/tags/v2-32/mh/bin/mh

Large files files are truncated, but you can click here to view the full file

#!/usr/bin/perl
# -*- Perl -*-
#  Last change Time-stamp: <2000-10-21 21:24:07 winter>
#---------------------------------------------------------------------------
#  File:
#      mh
#  Description:
#      A perl script that does home control functions
#  Author:
#      Bruce Winter bruce@misterhouse.net
#  Latest version:
#      http://misterhouse.net
#
#  Change log:
#    - 03/07/98  Created from house_menu.
#    - The rest of the change log is at the bottom of this file.
#
#  Documentation is in mh/docs/mh.html (from mh.pod) and mh/docs/install.html
#
#  This free software is licensed under the terms of the GNU public license. 
#  Copyright 1998-2000 Bruce Winter
#
#---------------------------------------------------------------------------
 
use strict;

my ($Pgm_Name, $Revision, $usage);
				# So we can get at it from other packages
use vars qw(%config_parms %config_parms_startup $Pgm_Path $Version $Version_date);

BEGIN {

    ($Version) = q$Revision: 128 $ =~ /: (\S+)/; # Auto-updated by CVS

    $0 = $ENV{sourceExe} if $ENV{sourceExe}; # perl2exe fills this in
    ($Pgm_Path, $Pgm_Name) = $0 =~ /^(.*)[\\\/]([^.]+)/i;
    ($Pgm_Name) = $0 =~ /([^.]+)/i unless $Pgm_Name;
    $Pgm_Name = 'mh' if $ENV{sourceExe}; # Since we sometimes rename mh.exe

    unless ($Pgm_Path) {
        use Cwd;
        $Pgm_Path = cwd();
                                # When we do system calls in Dos, we need \, not /
        $Pgm_Path =~ tr!\/!\\! if $^O eq "MSWin32";
    }


    $usage =<<eof;

Description:
   $Pgm_Name is a perl program for time, event, web, and voice based home control
   functions.  Configuration is controled in the \\mh\\bin\\$Pgm_Name.ini file.
   See the \\mh\\docs\\$Pgm_Name.html for more info.

Usage:
   $Pgm_Name [options] [files]

   Where options can be any of the parms listed in the \\mh\\bin\\$Pgm_Name.ini file

Examples usage:
    $Pgm_Name
    $Pgm_Name -help
    $Pgm_Name -tk 0 -code_dir c:\\mh\\code\\test
    $Pgm_Name -log_file test1.log -debug 1 test1.pl

eof

}
                                # Use var instead of my so we can get these in the http_server.pl scripts
use vars qw($Time_Start_time $Time_Stop_time $Time_Increment $Time_Startup $Time_Startup_time $Time_Boot_time $Time_Uptime_Seconds);
use vars qw($Time_Sunrise $Time_Sunrise_Twilight $Time_Sunset $Time_Sunset_Twilight %Moon $Time_Now $Time_Date $Date_Now $Date_Now_Speakable $Year_Month_Now);
use vars qw($Time $Second $Minute $Hour $Mday $Wday $Day $Month $Year);
use vars qw($New_Second $New_Minute $New_Hour $New_Day $New_Week $New_Month $New_Year);
use vars qw($Season $Weekday $Weekend $Holiday $Time_Of_Day);
use vars qw($Startup $Reload $Reread $Loop_Count $Last_Response $Category);
use vars qw($Version_tk $Password);

my ($Pgm_PathU);
my ($Loop_Speed, @Loop_Speeds, $Loop_Sleep_Time, $Loop_Tk_Passes);
my (@Requested_Files, @Print_Log, @Display_Log, @Speak_Log);

my ($exit_flag, $xcmd_file, %file_code_times, %file_code_times2, %file_change_times);
my (%User_Code, @Loop_Code, @Sub_Code, %Run_Members, @Item_Code, @Item_Code_Objects);
my ($user_code, $user_code_last_good);
my (%objects_by_object_name, %file_by_object_name, %files_by_webname);
my (%object_names_by_file, %object_names_by_type, %object_names_by_webname, $pause_mode);
my (%prev_serial_event, @Generic_Serial_Ports, @Server_Ports, , %Local_Addresses, @Local_Addresses, @Password_Allow_Clients);
my ($CON_IN, $CON_OUT);
#use vars '$CON_IN', '$CON_OUT';

my($state, $temp);              # Some generic useful vars

use vars '%Tk_objects', '%Tk_results', '@Tk_widgets', '@Object_Types'; # So we can use in http_server
use vars '$MW';                 # So that programs that we 'do' can use the top window
use vars '%Serial_Ports';       # So we can get at it from the Serial_Item package.
use vars '%Socket_Ports';
use vars '%Save';
use vars '%Info', '$OS_win';
use vars '%Password_Allow';     # So we can see check it from http_server.pl
use vars '$Pgm_Root';           # So we can see it in eval var subs in read_parms
use vars '$DNS_resolver';

                                # Pre-declare these so we don't fail on non-windows platforms
sub Win32::GetOSVersion;
sub Win32::FsType;
sub Win32::GetCwd;
sub Win32::LoginName;
sub Win32::NodeName;
sub Win32::IsWinNT;
sub Win32::IsWin95;
sub Win32::GetTickCount;
sub Win32::DriveInfo::DrivesInUse;


&setup;
&read_code;                     # Load all menus
&monitor_commands;

BEGIN {

    &check_for_run_cmd;
    &print_version;
    &check_usage;
    &setup_INC;
    &read_parms;
    &use_conditional_modules;
    print "Loading other modules\n";

    sub check_for_run_cmd {
                                # This lets us use mh as a perl interpreter for running arbitrary perl code
        if ($ARGV[0] and $ARGV[0] eq '-run') {
#           @ARGV = split(/[, ]/, $config_parms{run_parms});
            shift @ARGV;
            my $pgm = shift @ARGV;
            my $pgm_path = $pgm;
                                # Best to change to the mh bin dir, so their Paths are correct.
#           $pgm_path = "$Pgm_Path/$pgm" unless -e $pgm_path;
            chdir $Pgm_Path unless -e $pgm_path;
            unless (-e $pgm_path) {
                print "\nCan not find -run pgm: $pgm\n\n";
                exit;
            }
            print "\nRunning: $pgm_path @ARGV\n";
            $0 = $pgm;          # Reset program name from mh to $pgm
            do "$pgm_path";
            print "Error with $pgm: $@\n" if $@;
            print "\nDone running: $pgm\n";
            exit;
        }

    }

    sub print_version {
        
        $Version_date= localtime((stat $0)[9]);
        
                                # perl2exe sets this var
        if ($ENV{sourceExe}) {
            $Version_date= localtime((stat $ENV{sourceExe})[9]);
            $Version .= " (compiled)" unless $Version =~ /compiled/;
        }
        
        ($Pgm_PathU = $Pgm_Path) =~ tr/\\/\//;
        $Pgm_Root = "$Pgm_PathU/..";
       
        $OS_win = ($^O eq "MSWin32") ? 1 : 0;

# Win95:  MSWin32 Win95  B 4 0 67306684 1 FAT32
# Win98:  MSWin32 Win95    4 10 67766222 1 FAT

        if ($OS_win) {
            $Info{OS_version} = join(' ', Win32::GetOSVersion);
            $Info{OS_name} = 'NT' if Win32::IsWinNT;
            $Info{OS_name} = 'Win95' if Win32::IsWin95;
            $Info{OS_filesystem} = Win32::FsType;
            $Info{User} = Win32::LoginName;
            $Info{Machine} = Win32::NodeName;
        }
        else {
            $Info{OS_name} = $^O;
            $Info{User} = $ENV{USER};
            $Info{Machine} = $ENV{HOSTNAME};
        }

        
        print "\nCommand: $Pgm_Name @ARGV\n";
        print "Pgm  path   : $Pgm_Path\n";
        print "Pgm  version: $Version      Last updated: $Version_date\n";
        $Info{Perl_version} = $];
                                # BuildNumber doesn't work with perl2exe compile :(
                                #  - use eval to avoid problems with earlier version (e.g. build 502)
        $Info{Perl_version} .= " Build " . eval "&Win32::BuildNumber()" if $OS_win and !$ENV{sourceExe};
        print "Perl version: $Info{Perl_version}\n";
        print "OS   version: $^O $Info{OS_name} $Info{OS_version} $Info{OS_filesystem}\n";
        print "Other       : user=$Info{User} pid=$$ box=$Info{Machine} cpu=$ENV{PROCESSOR_ARCHITECTURE}-$ENV{PROCESSOR_LEVEL}\n";
        print "\n";

    }

    sub check_usage {

                                # Get legal options from .ini file
#       my $parmfile = $Pgm_PathU . "/$Pgm_Name.ini";
        my $parmfile = $Pgm_PathU . "/mh.ini";
        open (PARMS, $parmfile) or die "Error, could not open parmfile $parmfile: $!\n";
        my @parms;
        while (<PARMS>) {
            push(@parms, "$1=s") if /^([^\s\#]+) *=/;
        }
        close PARMS;

        use Getopt::Long;
        if (!&GetOptions(\%config_parms_startup, "h", "help", "run=s", "run_parms=s", @parms) or
            ($config_parms_startup{h} or $config_parms_startup{help})) {
            print $usage;
            exit;
       }
    }

    sub setup_INC {
        print "Setting up INC path ...";
                                # Note, use lib messes up perl2exe, but eval use lib does not.  Either use 
                                #  eval use lib (only once, because it is slow in perl2exe) or comment out use lib
                                #  when compiling and use perl5lib env.  Yuck.
                                #  - can not seem to get perl2exe to honor this.  Guess we have to make sure
                                #    everything is compile by adding it to lib/mh_perl2exe_list.pl
#       eval "use lib '$Pgm_PathU/../lib', '$Pgm_PathU/../lib/site', '$Pgm_PathU', '../lib', '../lib/site', '.'";
#       eval "use lib '$Pgm_PathU/../lib', '$Pgm_PathU/../lib/site', '$Pgm_PathU'";
                                # Use a push instead of a use lib, so we make sure the site perl libs come first, not last
                                #  - We need to support perl 5.005 and 5.6 at the same time.  5.005 win32 binaries
                                #    are distributed with mh (so user does not have to install them).
                                #    5.6 users will be required to install them
        push    (@INC, "$Pgm_PathU/../lib", "$Pgm_PathU/../lib/site", "$Pgm_PathU");
#       unshift (@INC, "$Pgm_PathU/../lib", "$Pgm_PathU/../lib/site", "$Pgm_PathU");
#       print "Error in use lib: $@\n" if $@;   # Dang .. this error check messes up the compiled version!??  Gives 'can not find lib.pm' message
        print " done\n";
        require 'handy_utilities.pl';       # For misc. functions (e.g. time/date stamp routines)
    }

    sub read_parms {

        my $debug = 1 if $config_parms_startup{debug} and $config_parms_startup{debug} eq 'startup';
        &main::read_mh_opts(\%config_parms, $Pgm_PathU, $debug);

                                # We need to honor starup parms, but a total reset messes up the tk debug button interface

#       %config_parms = (%config_parms, %config_parms_startup); # Last one (startup parms) wins
        for my $parm (keys %config_parms_startup) {
            $config_parms{$parm} = $config_parms_startup{$parm};
        }

        print "User   Code Directory: $config_parms{code_dir}\n";
        print "System Code Directory: $config_parms{code_dir_common}\n" if $config_parms{code_dir_common};
    }

    sub use_conditional_modules {

        if ($config_parms{diagnostics} or $config_parms{w}) {
            print "Perl diaganotics module (perl -w) has been turned on\n";
            eval 'use diagnostics' if $config_parms{diagnostics};
        }
#       disable diagnostics;

                                # This must be in a BEGIN in order for the 'use' to be conditional
        if ($OS_win) {
            print "Loading Windows modules\n";
            
                                # Must use 'my_use' (evals) so unix doesn't croak on missing modules

                                # Not sure what we gain/loose with ole lite
#           &my_use("Win32::DUN");          # Interface to rasdial
            &my_use("Win32::DriveInfo");    # For disk space free/total
            eval "use Win32::Console";
            print "\nError in loading module=Win32::Console:\n  $@\n" if $@;

            &my_use("Win32::OLE");
#           &my_use("Win32::OLE qw(EVENTS)"); # EVENTS forces single-threaded apartment, so outlook.pl MAPI works

#           &my_use("Win32::OLE::lite");
            &my_use("Win32::Process");
            &my_use("Win32::PerfLib"); # Used in &memory_used

            &my_use("Win32::Registry");
                                # Note: Must use eval, not my_use, or exported pgms are not seen :(
                                #  - setupsup is not yet available for perl 5.6
                                #  - BuildNumber doesn't work with perl2exe compile 
                                #  - Loaded from: http://jenda.krynicky.cz/perl/
            eval "use Win32::Setupsup qw(WaitForAnyWindow SendKeys)" if $ENV{sourceExe} or &Win32::BuildNumber() < 600;
            print "\nError in loading module=Win32::Setupsup:\n  $@\n" if $@;

            eval "use Win32::Sound";
            print "\nError in loading module=Win32::Sound:\n  $@\n" if $@;

            &my_use("Win32::SerialPort");

#           &my_use("Win32::SoundEx");      # For Volume control

            &my_use("File::DosGlob 'glob'"); # Allow for globbing without perlglob.exe

        }
        else {                              # load the mutually-exclusive non-Windows modules
            &my_use("Device::SerialPort");  # Unix Posix verion of Win32 SerialPort
        }

        if ($config_parms{tk}) {
            print "Loading Tk modules ";
            eval "use Tk";
#           eval "use Tk qw/DoOneEvent DONT_WAIT ALL_EVENTS/";
            $Version_tk = $Tk::VERSION;
            print  "Version $Tk::VERSION\n";
            
            if ($@) {
                print "\nError, perl Tk module is not installed.\nTk windows will be disabled with the -tk 0 option. Error:$@\n\n";
                $config_parms{tk} = 0;
            }
            else {
                &my_use("Display");
            }
        }
    }

}                               # End BEGIN
 

sub setup {

    print "Starting setup\n";

    $| = 1;        # Turn on command buffering (e.g. flush on every print)

    my $logfile = $config_parms{log_file};
    $config_parms{log}++ if $logfile;
    $config_parms{log_file} = $Pgm_PathU . "/../mh.log" unless $config_parms{log_file};
    my $print_log = $Pgm_PathU . "/../mh.print.log";
    rename $print_log, $print_log . ".old";
    open PRINTLOG, ">$print_log" or die "Error, could not open print lotfile $print_log: $!\n";
    if ($config_parms{log}) {
        print "Output will be logged into $logfile\n";
        open STDOUT, ">$logfile" or die "Error, could not open logfile $logfile: $!\n";
        &print_version;
    }

    use Astro::MoonPhase;
    use Astro::SunTime;
#   use Barcode;
    use File::Basename;
    use File::Copy;             # So we copy files
    use Fcntl;                  # To enable O_RDWR|O_CREAT
#   use Date::Parse;            # For str2time
#   use Data::Dumper qw(Dumper DumperX);
#   use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
    use IO::Socket;
    use LWP::Simple;            # For pgms like set_clock that need to grab data from urls
#   use MIME::Base64;           # Needed for uudecode/uuencode in http_server and mhsend_server
    use Net::FTP;               # For uploading stuff
    use Text::Wrap;
    use Time::Local;            # For timelocal

    if ($config_parms{DNS_server}) {
        print "Loading DNS code ...";
        &my_use("Net::DNS::Resolver"); # for doing reverse DNS search
        $DNS_resolver = new Net::DNS::Resolver;
        $DNS_resolver->nameservers(split(',', $config_parms{DNS_server}));
        print " DNS set to $config_parms{DNS_server}\n";
    }
    &my_use("DB_File");         # Need by get_tv_grid

    use Timer;                  # This needs to be first, as it is used in Voice_Cmd (and elsewhere?)
    use File_Item;
    use Generic_Item;
    use Group;
    use IR_Item;
#   &my_use("Serial_Item");  # So we can add debug to Serial_Item.pm when running mh.exe
    use Serial_Item;
    use X10_Items;
    use iButton;
    use Hardware::iButton::Connection;

    use Socket_Item;
    use Process_Item;
    use Voice_Cmd;
    use Voice_Text;
    use Caller_ID;

    use constant;               # To keep perl2exe happy
    use constant ON  => 'on';
    use constant OFF => 'off';
    use constant STATUS => 'status';
    use constant OPEN  => 'open';
    use constant CLOSE => 'close';
    use constant OPENED  => 'opened';
    use constant CLOSED  => 'closed';

    require 'handy_net_utilities.pl';   # For misc. net functions (e.g. net_mail_read)
    require 'console_utils.pl';
    require 'http_server.pl';

    if ($OS_win) {

                                            # These are the modules that perl2exe can not find on its own
                                            #   Note: tk windows starts faster in mh.exe if we run this,
                                            #         even though they are included with the perl2exe_include!
#       require  'mh_perl2exe_list.pl';
#perl2exe_include mh_perl2exe_list.pl


        no strict 'subs';   # For non-win OS
        if (1) {
            $CON_IN = new Win32::Console STD_INPUT_HANDLE;
            $CON_OUT= new Win32::Console STD_OUTPUT_HANDLE; 
            $CON_OUT->Title("Mister House");
#           use vars '$FG_WHITE', '$BG_CYAN';
#           &explodeAttr($CON_OUT, $FG_WHITE | $BG_CYAN);
#           $CON_OUT->Attr($FG_WHITE | $BG_CYAN);
        }
    }
    
    $SIG{INT}   = \&sig_handler;              # Exit cleanly with CTL-C
    $SIG{BREAK} = \&sig_handler if  $OS_win;  # Exit cleanly with BREAK
    $SIG{KILL}  = \&sig_handler;              # Exit cleanly with a kill signal
    $SIG{HUP}   = \&read_code   if !$OS_win;  # Reload code (alias mhreload per info in mh.ini file)
    $SIG{PIPE}  = \&sig_handler_pipe;         # Web browsers can shut down sockets while we are sending data 
    $SIG{CHLD}  = 'IGNORE';                   # So we don't create zombies when forking
    
    $config_parms{code_dir}         = $Pgm_PathU . "/../code"        unless $config_parms{code_dir};
    $config_parms{code_dir_common } = $Pgm_PathU . "/../code_system" unless $config_parms{code_dir_common};

                                # Make various directories, if missing
    mkdir ("$config_parms{data_dir}/logs", 0777) unless -d "$config_parms{data_dir}/logs";
    mkdir ("$config_parms{data_dir}/web", 0777)  unless -d "$config_parms{data_dir}/web";
    mkdir ("$config_parms{html_dir}/tv", 0777)   unless -d "$config_parms{html_dir}/tv";
    mkdir ("$config_parms{html_dir}/tv/clicktv", 0777)   unless -d "$config_parms{html_dir}/tv/clicktv";

    open(ERROR_LOG, ">>$config_parms{code_dir}/mh_temp.error_log") or 
        print "Error, could not open error log $config_parms{code_dir}/-error_log-: $!\n";

    &add_hook_code;

#   print "parms=", join(":", %config_parms), "\n";
    if ($config_parms{voice_cmd}) {
        &Voice_Cmd::init;
    }
    if ($config_parms{voice_text}) {
        &Voice_Text::init;
    }

                                # Find all defined socket and serial ports
    for my $parm (keys %config_parms) {
        next unless $config_parms{$parm}; # Ingore blank parms
        push(@Server_Ports, $1)         if $parm =~ /(http)_port/;
        push(@Server_Ports, $1)         if $parm =~ /(server\S+)_port/;
        push(@Generic_Serial_Ports, $1) if $parm =~ /(serial\S+)_port/;
    }
#   print "Server         ports defined: @Server_Ports\n" if @Server_Ports;
#   print "Generic serial ports defined: @Generic_Serial_Ports\n" if @Generic_Serial_Ports;
#   print "Creating socket server ports: @Server_Ports\n" if @Server_Ports;
    print "Creating socket and serial objects\n";
    for my $port_name (@Server_Ports) {
        my $port     = $config_parms{$port_name . "_port"};
        my $proto    = $config_parms{$port_name . "_protocol"};
        my $datatype = $config_parms{$port_name . "_datatype"};

        $proto    = 'tcp'      unless $proto;
        $datatype = 'buffered' if $port_name eq 'http';
        $datatype = 'buffered' if $config_parms{$port_name . "_buffer"}; # Grandfathered syntax
        $datatype = '' unless $datatype;

        printf " - creating %-15s on %3s %5s %s\n", $port_name, $proto, $port, $datatype;

        $Socket_Ports{$port_name}{protocol} = $proto;
        $Socket_Ports{$port_name}{datatype} = $datatype;

        if ($proto eq 'tcp') {
           $Socket_Ports{$port_name}{sock} = new IO::Socket::INET->new(LocalPort => $port, Proto => 'tcp', Reuse => 1, Listen => 10) or 
               die "Couldn't start a tcp server on $port_name $port: $@\nTo get mh to run, blank out or change the ${port}_port in mh.ini\n";
        } elsif ($proto eq 'udp') {
           $Socket_Ports{$port_name}{sock} = new IO::Socket::INET->new(LocalPort => $port, Proto => 'udp') or 
               die "Couldn't start a udp server on $port_name $port: $@\n";
           $Socket_Ports{$port_name}{socka} = $Socket_Ports{$port_name}{sock}; # UDP ports are always "active"
        } else {
            die "Unknown protocol for $port_name \n";
        }
    }
    
    for my $port_name (@Generic_Serial_Ports) {
        &serial_port_create($port_name, $config_parms{$port_name . "_port"},
                            $config_parms{$port_name . "_baudrate"},
                            $config_parms{$port_name . "_handshake"},
                            $config_parms{$port_name . "_datatype"});
    }

                                # Create managed serial and server ports 
                                # This makes it easy to add new modules
                                # for new serial/socket devices.  
                                # Manager must be available in lib directory
                                #  (e.g. Compool.pm)
    for my $parm (keys %config_parms) {
        next unless $config_parms{$parm};
        if ($parm =~ /^(\S+?)(:?\d*)_(serial|server)_port/) {
            if (-e "$Pgm_PathU/../lib/$1.pm") {
                print "Found managed $3 port=$1$2\nMH will now require $1.pm and call $1::$3_startup($1$2)\n" 
                    if $config_parms{debug} eq 'startup';
                require "$1.pm";
                eval "&$1::$3_startup('$1$2')";
                print "Startup errror on &$1::$3_startup('$1$2'): $@\n" if $@;
            }
            else {
                print "No $1.pm file found for $parm\n";
            }
        }
    }

    if ($config_parms{weeder_port}) {
        $config_parms{weeder_baudrate} = 1200 unless $config_parms{weeder_baudrate};
        &serial_port_create('weeder', $config_parms{weeder_port}, $config_parms{weeder_baudrate}, 'dtr');
        $Serial_Ports{weeder}{process_data} = 1;
    }

    if ($config_parms{cm11_port}) {
        require 'ControlX10/CM11.pm';
        &serial_port_create('cm11', $config_parms{cm11_port}, 4800, 'none');
    }
    if ($config_parms{Homevision_port}) {
        require 'Homevision.pm';
        my($speed) = $config_parms{Homevision_baudrate} || 9600;
        if (&serial_port_create('Homevision', $config_parms{Homevision_port}, $speed, 'none')) {
            &Homevision::init($Serial_Ports{Homevision}{object}); # Turn on Echo mode
        }
    }
    if ($config_parms{Marrick_port}) {
        require 'Marrick.pm';
        my($speed) = $config_parms{Marrick_baudrate} || 9600;
        if (&serial_port_create('Marrick', $config_parms{Marrick_port}, $speed, 'none')) {
            &Marrick::init($Serial_Ports{Marrick}{object}); 
        }
    }
    if ($config_parms{HomeBase_port}) {
        require 'HomeBase.pm';
        my($speed) = $config_parms{HomeBase_baudrate} || 9600;
        if (&serial_port_create('HomeBase', $config_parms{HomeBase_port}, $speed, 'none')) {
            &HomeBase::init($Serial_Ports{HomeBase}{object}); # Turn on Echo mode
        }
    }
    if ($config_parms{ncpuxa_port}) {
        require 'ncpuxa_mh.pm';
        &ncpuxa_mh::init($config_parms{ncpuxa_port}); # Create socket connection
    }

    if ($config_parms{ibutton_port}) {
        &my_use("Hardware::iButton::Connection;");
        &iButton::connect($config_parms{ibutton_port});
    }
                                # Do this one last, as it can share a serial port.
    if ($config_parms{cm17_port}) {
        require 'ControlX10/CM17.pm';
        &serial_port_create('cm17', $config_parms{cm17_port});
    }

    if($config_parms{weather_sblog_file} or
       $config_parms{weather_vwlog_file} or
       $config_parms{serial_wx200}) {
        require 'Weather.pm';
        &Weather_Data::Init();
    }


    if ($OS_win) {
        $Time_Boot_time = 0;    # Gettickcount starts at computer boot
    }
    elsif ($^O eq 'linux') {

# Linux output:
# uptime: 2 hours 10:38pm  up  2:10,  6 users,  load average: 0.83, 0.45, 0.18
# /proc/stat: cpu  10339 0
# /proc/pid/stat: 732 (ghx2) S 565 732 376 1025 561 256 529 0 1194 0 142 35 0 0 0 0 0 0 499881 6688768 905 2147483647 134512640 134754096 3221224640 3221223956 1075917534 0 0 69632 17479 3222448608 0 0 17
                                # Not sure if 1st number
        open(UPTIME, "/proc/uptime") or print "\nError: can't open /proc/uptime ($!)\n";
        my ($uptime, $idletime) = (<UPTIME> =~ /(\S+) (\S+)/);
        close UPTIME;
        $Time_Boot_time = time - $uptime; 
    }

    $exit_flag = 0;
    $config_parms{sleep_time} = 50 unless defined $config_parms{sleep_time};
    $Loop_Sleep_Time = $config_parms{sleep_time};
    $config_parms{tk_passes} = 10 unless $config_parms{tk_passes};
    $config_parms{tk_font}       = 'Times 10 bold'   unless $config_parms{tk_font};
    $config_parms{tk_font_fixed} = 'Courier 10 bold' unless $config_parms{tk_font_fixed};
    $Loop_Tk_Passes = $config_parms{tk_passes};

    $Time = time;

    ($Second, $Minute, $Hour, $Mday, $Month, $Year) = localtime $Time; # Needed in my_str2time;

    $Time_Date = &time_date_stamp($config_parms{time_format_log} , $Time);  # Needed by print_log

    $Month++;

                                # Configure 'fast test mode' parms
    $Time_Increment = ($config_parms{time_increment}) ? $config_parms{time_increment} : 60;
    if ($config_parms{time_start} =~ /\S/) {
        $Loop_Sleep_Time = 0;
        $Loop_Tk_Passes = 1;
        $Time_Start_time = &my_str2time($config_parms{time_start});
        $Time  = $Time_Start_time - $Time_Increment; # Cause we start the loop with an increment
        print "time_start=$config_parms{time_start} -> $Time_Start_time \n";
    }
    if ($config_parms{time_stop} =~ /\S/) {
        $Loop_Sleep_Time = 0;
        $Loop_Tk_Passes = 1;
        $Time_Stop_time  = &my_str2time($config_parms{time_stop});
        $Time_Stop_time += 3600*24 if $Time_Stop_time < $Time_Start_time;
        print "time_stop =$config_parms{time_stop} -> $Time_Stop_time \n";
    }

    $Time_Startup_time = $Time;
    $Time_Startup = &time_date_stamp(9, $Time_Startup_time);
    $Startup = 1;

    if ($config_parms{pid_file}) {
        print "Process id $$ written to $config_parms{pid_file}\n";
        &file_write($config_parms{pid_file}, $$);
    }

    if ($config_parms{tk}) {
        &tk_setup_windows;
    }

#   $xcmd_file = "$config_parms{temp_dir}/house_cmd.cmd" if $config_parms{xcmd_file};
#   print "X command file: $config_parms{xcmd_file}\n" if $config_parms{xcmd_file};
                                # Use eval to change $ENV{temp} to the real value ... this is done in read_opts now
#    eval "\$config_parms{xcmd_file} = qq[$config_parms{xcmd_file}]";

    print "External command file (xcmd_file): $config_parms{xcmd_file}\n" if $config_parms{xcmd_file};

    $config_parms{html_dir} = $config_parms{html_root} if $config_parms{html_root}; # Grandfather in the old name for this parm
    print "HTML file     : $config_parms{html_dir}/$config_parms{html_file}\n";
    print "\nError, HTML file not found: $config_parms{html_dir}/$config_parms{html_file}\n\n" unless -e "$config_parms{html_dir}/$config_parms{html_file}";

    @Requested_Files = @ARGV;
    
    &password_read;

    srand(time() ^ ($$ + ($$ << 15)) ); # Set the randum number seed, used in time_random;

    $config_parms{max_log_entries} = 50 unless defined $config_parms{max_log_entries};
    $config_parms{max_state_log_entries} = 10 unless defined $config_parms{max_state_log_entries};
    $config_parms{time_format_log} = 12 unless $config_parms{time_format_log};

    print "Done with setup\n\n";

}


                                # The remaining subroutines are in alphabetical order



                                # This code allows us to add dynamic user code hooks at various places.
my (%hook_pointers, %hook_pointers_persistent, %hook_locations, %hook_parms);
sub add_hook_code {

    %hook_locations = ( MainLoop_pre => 1, MainLoop_post => 1,
                        Serial_match => 1,
                        Reload_pre   => 1, Reload_post  => 1,
                        Play_pre => 1,     Play_post => 1,
                        Speak_pre => 1,    Speak_post => 1
                        );

    for my $location (keys %hook_locations){
        my($accessors) = "
sub ${location}_add_hook  { return add_hook_ ( '$location', \@_ ) }
sub ${location}_drop_hook { return drop_hook_( '$location', \@_ ) }
sub ${location}_get_hooks { return get_hooks_( '$location' ) }
sub ${location}_hooks     { return run_hooks_( '$location', \@_ ) }
";
      eval $accessors;
      die "Eval error $@\n" if $@;
  }

   sub add_hook_ {
       my($location, $hook, $persistent, @parms) = @_;
    
       unless( defined( $hook_locations{$location} ) ){
           warn "Invalid hook location $location\n";
           return 0;
       }
       
       unless( ref $hook eq 'CODE' ){
           warn "Hook must be a code reference: hook=$hook\n";
           return 0;
       }
       
       $hook_pointers{$location} = [] unless defined ($hook_pointers{$location});
       
       push( @{$hook_pointers{$location}}, $hook );
       push( @{$hook_pointers_persistent{$location}}, $hook ) if $persistent;
       @{$hook_parms{$hook}} = @parms;

       return 1;
   }

   sub drop_hook_ {
       my($location, $hook ) = @_;
      
       unless( defined( $hook_locations{$location} ) ){
           warn "Invalid hook location $location\n";
           return 0;
       }
       
       if( defined ($hook_pointers{$location}) ){
           my($h)=$hook_pointers{$location};
           my($i)=-1;
           
           for ( $i=$#{$h}; $i >= 0; $i-- ) {
               last if ($hook == $h->[$i] );
           }

                                # delete if the index returned is in range
           if ($i >=0 and $i <= $#{$h} ){
               splice( @{$h}, $i, 1 );
               return 1;
           }
       }
       
       warn "specified hook not found: $location\n";
       return 0;
   }

   sub get_hooks_ {
       my($location) = @_;
       return defined $hook_pointers{$location} ? @{$hook_pointers{$location}} : ();
   }

                                # call all hooks with user specified args, if any
   sub run_hooks_ {
#      my($location) = @_;
       my $location = shift @_;
       for my $hook (&get_hooks_($location)){
                                # Allow for parms passed in mh, and parms specified
                                # with addhook.
           my @parms = (@_, @{$hook_parms{$hook}});
           &$hook(@parms); 
       }
   }

                                # This will keep hook code defined with the persistent
                                # flag (e.g. module code that is defined on startup).
                                # All other user code is undefed.
   sub reset_hook_code {
       for my $location (keys %hook_locations) {
           if ($hook_pointers_persistent{$location}) {
               @{$hook_pointers{$location}} = @{$hook_pointers_persistent{$location}};
           }
           else {
               delete $hook_pointers{$location};
           }
       }
   }
}


sub browser {
    my ($file) = @_;
                                # Don't need this ... run look at search path
#    unless (-f $config_parms{browser} or lc($config_parms{browser}) eq 'explorer') {
#        &print_log("Could not find html browser file: $config_parms{browser}");
#        return;
#    }
                                # Translate unix/perl / to dos \
    $file =~ s|/|\\|g if $OS_win and $file !~ /^http/i;

    run qq[$config_parms{browser} "$file"];
}

my ($loop_tickcount1, $loop_tickcount_total);
sub check_for_action {

    &exit_pgm if $exit_flag;
    my $loop_tickcount1 = &get_tickcount;

                                # Do window loop here, to check for pause mode exit
    if ($MW) {
        $Loop_Tk_Passes = 100 if $Loop_Tk_Passes >100; # Make sure we don't have too many passes
        $Loop_Tk_Passes = 1   if $Loop_Tk_Passes < 1;  # Make sure we make at least one pass
        for (1 .. $Loop_Tk_Passes) {
            my $tk_activity;
            $tk_activity = DoOneEvent(0xFF); # Avoid Constants ... we get compile errors if -tk 0
#           $tk_activity = DoOneEvent(DONT_WAIT | ALL_EVENTS);
#           $tk_activity = DoOneEvent(0x1E); 
#           $tk_activity = DoOneEvent(0x02); 
        }
    }
    &check_for_keyboard_input;
    return if $pause_mode;

    &set_global_vars;
    &Process_Item::harvest;          # Check for done processes
    &Generic_Item::reset_states;     # Reset states for all objects that are 'ISA Item' objects
    &Voice_Cmd::check_for_voice_cmd; # Do this even if VR is not installed, so we can do web and manual run_voice_cmd
    &check_for_serial_data if %Serial_Ports;
    &check_for_socket_data if %Socket_Ports;
    &check_for_timer_actions;
    &check_for_external_command_file;

    &MainLoop_pre_hooks();      # Created by &add_hooks

                                # Use eval to catch minor errors without abending
                                #  - about 10% slower (170 -> 150)
    &eval_user_code_loop;
#   &loop_code;

    &MainLoop_post_hooks();     # Created by &add_hooks

                                # Do the tk_setup_cascade_menus AFTER the first eval code, so we can test Tk widget objects
    if ($MW) {
        &tk_setup_cascade_menus if $Reload;
        &tk_setup_geometry      if $Reread;
    }

    $loop_tickcount_total += &get_tickcount - $loop_tickcount1;

    if ($Reread) {
        $Startup = 0; $Reload = 0; $Reread = 0;
    }

}

sub check_for_cm11_data {

    my $data = &ControlX10::CM11::read($Serial_Ports{cm11}{object}, 1);
    return unless $data;
    my $data_d = unpack('C', $data);    # Convert from string to decimal

                                # Check for the official 0x5a=90 string and 0xa5=165 (I have seen this!)
    print "mh CM11 data=$data data_d=$data_d\n" if $config_parms{debug} eq 'X10' and $data;
#   if ($data_d == 0x5a) {
    if ($data_d == 0x5a or $data_d == 0xa5) {
        if ($data = &ControlX10::CM11::receive_buffer($Serial_Ports{cm11}{object})) {

                                # Process status requests
            if ($data =~ /STATUS/) {
                my ($house, $device, $state) = $data =~ /(\S)(\S)STATUS_(\S+)/;
                $state = 'J' if $state eq 'ON';
                $state = 'K' if $state eq 'OFF';
                my $event_data = 'X' . $house . $device . $house . $state;
                if (my @refs = &Serial_Item::serial_items_by_id($event_data)) {
                    for my $ref (@refs) {
                        if ($state = $$ref{state_by_id}{$event_data}) {
#                           set_receive $ref $state;
                            $ref->{state} = $state;
                            print "CM11 Status results: data=$data event_data=$event_data state=$state\n" 
                                if $config_parms{debug} eq 'X10';
                        }
                    }
                }
                else {
                    &print_log("Status request on undefined state: data=$data event_data=$event_data");
                }
            }
            else {
                &process_serial_data("X" . $data);
            }
        }
    }
}

sub check_for_external_command_file {
    my ($cmd, $cmd_num, $ref, $said);
    my $xcmd_file = $config_parms{xcmd_file};
                                # Checking for a file is pretty slow ... 
    return unless $New_Second;
                                # Note: Check for non-zero size, not -e.  Zero length files cause a loop!
    if ($xcmd_file and -s $xcmd_file) {
        &print_log("External command file found: $xcmd_file");
        unless (open(XCMD, $xcmd_file)) {
            print "\nWarning, can not open file $xcmd_file: $!\n";
            return;
        }
        $cmd = <XCMD>;
        chomp($cmd);
        close XCMD;
        next unless $cmd;
        unlink $xcmd_file;
        &process_external_command($cmd, 1);
    }
}

sub check_for_generic_serial_data {
    my ($port_name) = @_;
    my $data;
    unless ($data = $Serial_Ports{$port_name}{object}->input) {
                                # If we do not do this, we may get endless error messages.
        $Serial_Ports{$port_name}{object}->reset_error;
    }

    $Serial_Ports{$port_name}{data} .= $data if $data;

    print "  serial name=$port_name type=$Serial_Ports{$port_name}{datatype} data2=$Serial_Ports{$port_name}{data}...\n" 
        if $data and ($config_parms{debug} eq 'serial' or $config_parms{debug} eq $port_name);

                                # Check to see if we have a carrage return yet
    if ($Serial_Ports{$port_name}{data} and
        (!defined $Serial_Ports{$port_name}{datatype} or $Serial_Ports{$port_name}{datatype} ne 'raw')) {
        while (my($record, $remainder) = $Serial_Ports{$port_name}{data} =~ /(.+?)[\r\n]+(.*)/s) {
            &print_log("Data from $port_name: $record.  remainder=$remainder.") if $config_parms{debug} eq 'serial';
            $Serial_Ports{$port_name}{data_record} = $record;
            $Serial_Ports{$port_name}{data} = $remainder;
            if ($Serial_Ports{$port_name}{process_data}) {
                &process_serial_data($record);
            }
            else {
                last;           # Only process one data_record per user_code loop
            }
        }
    }
}

sub check_for_Homevision_data {
    my $data = &Homevision::read($Serial_Ports{Homevision}{object});
    if ($data) {
        print "Homevision data=$data\n" if $config_parms{debug} =~ /homevision|serial/i;
        &process_serial_data($data);
    }
}

sub check_for_ncpuxa_data {
    my $data = &ncpuxa_mh::read($config_parms{ncpuxa_port});
    if ($data) {
        print "ncpuxa data=$data\n" if $config_parms{debug} =~ /ncpuxa|serial/i;
        &process_serial_data($data);
    }
}

sub check_for_HomeBase_data {
    my $data = &HomeBase::read($Serial_Ports{HomeBase}{object});
    if ($data) {
        print "HomeBase x10 data=$data\n" if $config_parms{debug} eq 'homebase';
        &process_serial_data("X" . $data);
    }
}

sub check_for_keyboard_input {
    my $key;

#   return;                     # Console off for now.

                                # Need to find a way to do this in Linux
    return unless $OS_win;

    for(0..$CON_IN->GetEvents()-1) {
# Event data:  1, keyup_down, key_repeat_count, id1, id2, id3, id4
#  id1 seems to cover all the keys (e.g. 112 is F1, a=65, A=65)
#  id2 seems to be keyboard positional (e.g. a=30, s=31)
#  id3 seems to be ascii (a=97, A=65)
        my @event = $CON_IN->Input();
        $key = $event[3] if $event[1];
    }
    return unless $key;

    my %keymap = ('F1: Reload' => 'F1', 'F2: Pause' => 'F2', 'F3: Exit' => 'F3',
                  'F4: Debug' => 'F4',  'F5: Logging' => 'F5',
                  112  => 'F1',        113  => 'F2',       114  => 'F3',
                  115  => 'F4',        116  => 'F5');


    if ($key == 13) {       # Enter Key  -> display simple menu
        my ($oldX, $oldY, $oldS, $oldV) = $CON_OUT->Cursor(); 
        my $oldmode = $CON_IN->Mode();
        my $choice = &choose_menu($CON_IN, $CON_OUT, 
                                  "F1: Reload", "F2: Pause", "F3: Exit",
                                  "F4: Debug", "F5: Logging");
        $CON_IN->Mode($oldmode);
        $CON_OUT->Cursor($oldX, $oldY, $oldS, $oldV);
        $key = $keymap{$choice};
        print "action=$choice key=$key\n";
    }
    else {
        $key = $keymap{$key} if $keymap{$key};
    }
    
    if ($key eq 'F1') {
        print "Key F1 pressed.  Reloading code\n";
        read_code();
    }
    elsif ($key eq 'F2') {
        print "Key F2 pressed.\n";
        &pause;
    }
    elsif ($key eq 'F3') {
        print "Key F3 pressed.  Exiting\n";
        &exit_pgm;
    }
    elsif ($key eq 'F4') {
        &toggle_debug;
    }
    elsif ($key eq 'F5') {
        &toggle_log;
    }
    elsif ($key) {
        print "key press: $key\n" if $config_parms{debug} eq 'misc';
    }
}

sub toggle_debug {
    $config_parms{debug} = ($config_parms{debug}) ? 0 : 1;
    my $state = ($config_parms{debug}) ? 'on' : 'off';
    print "Key F4 pressed.  Debug turned $state.\n";
}
sub toggle_log {
    $config_parms{log} = ($config_parms{log}) ? 0 : 1;
    my ($state, $logfile);
    if ($config_parms{log}) {
        $state = 'on';
        $logfile = $config_parms{log_file};
        $logfile = 'mh_log.txt' unless $logfile;
        print     "Key F5 pressed.  Output will be logged into $logfile\n";
        &print_log("Key F5 pressed.  Output will be logged into $logfile");
        open(OLDOUT, ">&STDOUT"); # Copy old handle
        open(OLDERR, ">&STDERR"); # Copy old handle
        open STDOUT, ">>$logfile" or print "\nError, could not open logfile $logfile: $!\n";
        $| = 1;        # Turn on command buffering (e.g. flush on every print)
        open(STDERR, ">&STDOUT");
    }
    else {
        $state = 'off';
        print "Key F5 pressed.  Output will no longer be logged to $logfile\n";
        close STDOUT;
        open(STDERR, ">&OLDERR");
        open(STDOUT, ">&OLDOUT");
        close OLDOUT;
        close OLDERR;
        print     "STDOUT has been restored\n";
        &print_log("STDOUT has been restored");
    }
}

my @serial_data_buffer;
sub check_for_serial_data {
                                # Process remaining serial items from previous pass
    if (my $data = shift @serial_data_buffer) {
        print "Running serial_data_buffer string: $data\n" if $config_parms{debug} eq 'X10';
        &process_serial_data($data, 1);
        return;
    }

    &check_for_cm11_data if $Serial_Ports{cm11}{object};
    &check_for_Homevision_data if $Serial_Ports{Homevision}{object};
    &check_for_HomeBase_data if $Serial_Ports{HomeBase}{object};
    &check_for_ncpuxa_data if $config_parms{ncpuxa_port};
    &check_for_generic_serial_data('weeder') if $Serial_Ports{weeder}{object};
    for my $port_name (@Generic_Serial_Ports) {
        &check_for_generic_serial_data($port_name) if $Serial_Ports{$port_name}{object};
    }
                                # Leave this under user control?
#   &iButton::monitor if $config_parms{ibutton_port} and if $New_Second;
}

my ($leave_socket_open_passes, $leave_socket_open_action);
sub check_for_socket_data {

                                # Time to finish the http GET from 2 passes ago with a list of spoken data
    if ($leave_socket_open_passes and --$leave_socket_open_passes == 0 and my $sock = $Socket_Ports{http}{socka}) {
        print "closing http port with action: $leave_socket_open_action\n" if $config_parms{debug} eq 'http';
        my @data = eval($leave_socket_open_action);
        print "Error in http lso action: $@\n" if $@;
        my $html = &html_page("", @data);
        print $sock $html;
        &socket_close('http');
    }

    my (@ports_with_data, @active_ports);

                                # See which ports are active
                                #  - could probably use a smarter select check here, rather than loop for each port
    for my $port_name (keys %Socket_Ports) {
        next unless my $sock = $Socket_Ports{$port_name}{sock};
        $Socket_Ports{$port_name}{inactive_this_pass} = 0;
        if ($Socket_Ports{$port_name}{socka}) {
            push(@active_ports, $port_name);
            $Socket_Ports{$port_name}{active_this_pass} = 0;
        }
        else {
            if (my $nfound = &socket_has_data($sock)) {
                my $new_sock = $sock->accept();
                next unless $new_sock; # Can be undef it socket was killed
                $new_sock->autoflush(1); # Not sure if this does anything?
                $Socket_Ports{$port_name}{socka} = $new_sock;
                $Socket_Ports{$port_name}{active_this_pass} = 1;
                delete $Socket_Ports{$port_name}{data}; # Delete data from previous session
                push(@active_ports, $port_name);
                                # Log the address of the client
                my $peer = $new_sock->peername;
                my ($port, $iaddr) = unpack_sockaddr_in($peer) if $peer;
                my $client_ip_address = inet_ntoa($iaddr) if $iaddr;
                $Socket_Ports{$port_name}{client_ip_address} = $client_ip_address;
                logit("$config_parms{data_dir}/logs/server.$Year_Month_Now.log",  "$port_name $client_ip_address");
                print "\n$port_name active sock=$new_sock client=$client_ip_address.\n" if $config_parms{debug} eq $port_name;
            }
        }
    }

                                # See if any active ports have data ... this could be rolled into previous loop
    for my $port_name (@active_ports) {
        my $sock = $Socket_Ports{$port_name}{socka};
        if (my $nfound = &socket_has_data($sock)) {
            print "\n$port_name nfound=$nfound\n" if $config_parms{debug} eq $port_name;
            if ($nfound < 0) {
                                # Note, must do a shutdown here ... a close does not close handles
                                #   from &run (system start) processes !?! ... maybe IO sockets do not need this?
                                # Not sure how to shutdown IO handles ... this gives 'bad symbol on filehandle' error
#               shutdown($sock->fileno(), 2);   # "how":  0=no more receives, 1=sends, 2=both
                print "1 closing socket port $port_name\n" if $config_parms{debug} eq $port_name;
                &socket_close($port_name);
            }
            else {
                push(@ports_with_data, $port_name);
            }
        }
    }
                                # Get data from active ports
    for my $port_name (@ports_with_data) {
        my $sock = $Socket_Ports{$port_name}{socka};
 
        my $data;

                                # Buffered mode means only read one line per pass
                                #  - This allows user code the option of reading port with <>
                                #  - Assumes clients will send a line at a time, so will not block 
        if ($Socket_Ports{$port_name}{datatype} and $Socket_Ports{$port_name}{datatype} eq 'buffered') {
            $data = <$sock>;
        }
        else {
                                # 1500 is ethernet packet size
            my $from_saddr = recv($sock, $data, 1500, 0); 

                                # Store udp from_* data
            if ($Socket_Ports{$port_name}{protocol} and $Socket_Ports{$port_name}{protocol} eq 'udp') {
                (my $from_port, my $from_ip) = sockaddr_in($from_saddr);
                $Socket_Ports{$port_name}{from_port} = $from_port;
                $Socket_Ports{$port_name}{from_ip}   = $from_ip;
            }
        }

        print "\n sock=$sock lso=$leave_socket_open_passes data=$data.\n"  if $config_parms{debug} eq $port_name;

                                # Need to do this or the socket never closes!
                                # For some reason, nfound = 1 (instead of -1) unless we do this.
                                # In other words, a telnet disconnect will leave nfound=1, but no data.
                                # When telnet closes, byte IS defined, but is empty, so check on ''
        if (!defined $data or $data eq '') {
            print "closing socket port $port_name\n" if $config_parms{debug} eq $port_name;
            &socket_close($port_name);
        }

        $Socket_Ports{$port_name}{data} .= $data if defined $data;
        print "$port_name data=$Socket_Ports{$port_name}{data}..\n" if $config_parms{debug} eq $port_name;

                                # If raw mode, return data as is
        if ($Socket_Ports{$port_name}{datatype} and $Socket_Ports{$port_name}{datatype} eq 'raw') {
#           $Socket_Ports{$port_name}{data_record} = $data;  # No not break data on newlines
            next;
        }

        if (my $echo = $config_parms{"${port_name}_echo"}) {
                                # Need to loop thru $data here, one byte at a time
            my $byte = $data;
                                # bs = 8, del=127
            my $char = unpack('C', $byte);
                                # Allow us to pick our echo character (e.g. '*')
            $byte = $echo unless $echo == 1 or $char eq 8;
            next if $char eq 8;
            print $sock $byte unless $char eq 13 or $char eq 10;
        }

     
                                # Break data on newlines
        next unless $Socket_Ports{$port_name}{data};
        while (my($record, $remainder) = $Socket_Ports{$port_name}{data} =~ /(.+?)[\r\n]+(.*)/) {
            if ($config_parms{debug} eq $port_name) {
                print "$port_name record=$record.  hex=", unpack('H*', $record), "\n";
                print "$port_name remainder=$remainder.  hex=", unpack('H*', $remainder), "\n";
            }
            $Socket_Ports{$port_name}{data_record} = $record;
            $Socket_Ports{$port_name}{data}        = $remainder;
            

            if ($port_name eq 'http') {
                if ($record =~ /^ *GET /) {
                    ($leave_socket_open_passes, $leave_socket_open_action) = &process_http_request($sock, $record);
                    print "db lso=$leave_socket_open_passes sock=$sock.\n" if $config_parms{debug} eq $port_name;
                    unless ($leave_socket_open_passes) {
                        print "4 closing socket port $port_name\n" if $config_parms{debug} eq $port_name;
                                # We must sleep here for a bit, or else Netscape sometimes
                                # says 'Document contains no data'.
                        select undef, undef, undef, .010;
                        &socket_close($port_name);
                    }
            …