#!/usr/bin/perl
# Added by Debian package rules script
push @INC, ("/usr/lib/perl5/misterhouse","/usr/share/perl5/misterhouse");
# -*- Perl -*-
#
# $Date: 2007-08-31 10:32:53 -0400 (Fri, 31 Aug 2007) $
# $Revision: 1178 $
#
#---------------------------------------------------------------------------
#  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-2005 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 %Info);

BEGIN {
    $Info{Perl_compiled} = 'perl2exe' unless $^X =~ /perl/i;  # If built with perl2exe
    $Info{Perl_compiled} = "perlapp $PerlApp::BUILD" if $PerlApp::BUILD;     # If built with perlapp
    $Info{Perl_compiled} = "PAR $PAR::VERSION" if $PAR::VERSION;       # If built with PAR

            # $0=path to mh/bin, $^X=path to perl, unless perl2exe compiled mh.exe
    ($Pgm_Path, $Pgm_Name) = $0  =~ /^(.*)[\\\/]([^.]+)/;
    ($Pgm_Path, $Pgm_Name) = $^X =~ /^(.*)[\\\/]([^.]+)/ if $Info{Perl_compiled};

		my $shortened = ($config_parms{program_files_abbreviation})?$config_parms{$config_parms{program_files_abbreviation}}:'progra~1';

		$Pgm_Path =~ s/program files/$shortened/i;

                               # $0=mh if we run from mh/bin
    unless ($Pgm_Path) {
        ($Pgm_Name) = $0 =~ /([^.]+)/i;
        use Cwd;
        $Pgm_Path = cwd();
                                # When we do system calls in Dos, we need \, not /
        $Pgm_Path =~ tr!\/!\\! if $^O eq "MSWin32";
    }
    chdir $Pgm_Path;            # Base everything from the mh dir.

	# Are we running from within a subversion repository?
	my $entries='../.svn/entries';
	my $revision=undef;
	if (-r $entries) {
		open (ENTRIES, $entries);
		my $line1=<ENTRIES>;
		# $entries can be either XML (svn < 1.4) or just text (svn >= 1.4)
		if ($line1 =~ /xml/) {
			while (<ENTRIES>) {
				next unless /revision="(\d+)"/;
		    	$revision=$1;
				last;
			}
		} else  {
			# the revision number is the 11th line.  We have already read 1 line
			for (1..10) {
				$revision=<ENTRIES>;
			}
			chomp $revision;
		}
		close (ENTRIES);
    }

	$Version = "mh 2.104";
	if ($revision) {
		$Version.=" R${revision}";
	}
	$Version .= " (compiler: $Info{Perl_compiled})" if $Info{Perl_compiled};

#   $Pgm_Path = '.';

    $usage = <<"eof";

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

Usage:
   mh [options] [files]

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

Examples usage:
    mh
    mh -help
    mh -tk 0 -code_dir c:\\mh\\code\\test
    mh -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_Msecond_500 $New_Msecond_250 $New_Msecond_100 $New_Minute $New_Hour $New_Day $New_Week $New_Month $New_Year);
use vars qw($Season $Weekday $Weekend $Dark $Holiday $Time_Of_Day);
use vars qw($Startup $Reload $Reread $Loop_Count $Loop_Count_Reload $Last_Response $Category $Respond_Target $Set_By $Invalidate_Window);
use vars qw($Version_tk $DelayOccured %Debug $Authorized);
use vars qw(%User_Code @Code_Dirs @Generic_Serial_Ports %Misc);

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

my ($exit_flag, $xcmd_file, %file_code_times, %file_code_times2, %file_change_times);
my (@Loop_Code, @Sub_Code, %Sub_Code, %Run_Members, %Benchmark_Members, @Item_Code, @Item_Code_Objects);
my %custom_child_windows; #subs by window_name, display sub checks and calls sub to create window
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 (@Server_Ports, @Generic_Devices, %Local_Addresses, @Local_Addresses, %Passwords, @Password_Allow_Clients);
my (%proxy_servers, %app_parms);
my ($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 '%Generic_Devices';
use vars '%Socket_Ports';
use vars '%Save', '%Flags';
use vars '%Persistent';         # Uses Dumper for dynamic objects e.g. timers.pl
use vars '$OS_win';
use vars '%Password_Allow';     # So we can see check it from http_server.pl
use vars '%Disabled_Commands';  # So we can access fro Voice_Cmd.pm
use vars '$Pgm_Root';           # So we can see it in eval var subs in read_parms
use vars '$DNS_resolver';
use vars '%cm11_objects';
use vars '%ti103_objects';


                                # 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;
                                # Pre-declare these in case RRDs is not installed
sub RRDs::update;
sub RRDs::error;

sub ReadMode {};                # In case Readkey is not installed
sub ReadKey  {};

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

    sub setup_INC {
                                # For some weird reason, we get a startup abend this is evaled after we change INC with perl2exe :(
        eval "use Win32::Setupsup qw(WaitForAnyWindow SendKeys EnumChildWindows SetFocus SetWindowText GetWindowText)"
            if $Info{Perl_compiled};

                                # Pick local mh modules first, over any site install ones
        unshift (@INC, '/usr/share/perl5/misterhouse', '/usr/share/perl5/misterhouse/site', '/usr/lib/perl5/misterhouse', "${Pgm_Path}/../lib", "${Pgm_Path}/../lib/site", '.');
#       my $pwd=cwd(); print "pwd=$pwd inc=@INC\n";
#       push (@INC, './../lib', './../lib/site', '.');
#       push (@INC, './../lib');
        if ($^O eq 'MSWin32') {
            my $build = &Win32::BuildNumber;
            if ($build < 600) {
                push @INC, "${Pgm_Path}/../lib/site_win50";
            }
            elsif ($build < 800) {
                push @INC, "${Pgm_Path}/../lib/site_win56";
            }
            else {
                push @INC, "${Pgm_Path}/../lib/site_win58";
            }
        }
        require 'handy_utilities.pl';       # For misc. functions (e.g. time/date stamp routines)
    }


    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;
            unless (-e $pgm) {
                print "\nCan not find -run pgm: $pgm\n\n";
                exit;
            }
            print "\nRunning: $pgm @ARGV\n";
            my ($pgm_name) = $pgm =~ /([^\.\/\\]+)$/;
            $0 = $pgm_name;          # Reset program name from mh to $pgm
            do "$pgm";
            print "Error with $pgm: $@\n" if $@;
            print "\nDone running: $pgm\n";
            exit;
        }

    }

    sub print_version {

        $Version_date = localtime((stat $0)[9]);
        $Version_date = localtime((stat "$Pgm_Path/bin/$0.exe")[9]) if $PerlApp::BUILD;
        $Version_date = localtime((stat $ENV{sourceExe})[9]) if $ENV{sourceExe}; # Older 3.x perl2exe

        $Pgm_PathU = '.';       # Since we now chdir, this is obsolete, but still used in some user code :(
        $Pgm_Root  = './..';

        $OS_win = ($^O eq "MSWin32") ? 1 : 0;

# Win95:  MSWin32 Win95  B 4 0 67306684 1 FAT32
# Win98:  MSWin32 Win95    4 10 67766222 1 FAT
# WinME:  MSWin32 Win95    4 90 67766222 1 FAT
# 2K:     MSWin32 NT Service Pack 1,5,0,2195,2 NTFS
# XP:     MSWin32 NT ,5,1,2600,2 NTFS


        if ($OS_win) {
            $Info{OS_version} = join(',', Win32::GetOSVersion);
            $Info{OS_name} = 'Win95' if Win32::IsWin95 ;
            $Info{OS_name} = 'Win98' if Win32::IsWin95 and (Win32::GetOSVersion)[2] > 0;
            $Info{OS_name} = 'WinMe' if Win32::IsWin95 and (Win32::GetOSVersion)[2] > 10;
            $Info{OS_name} = 'NT'    if Win32::IsWinNT;
            $Info{OS_name} = 'XP'    if Win32::IsWinNT and (Win32::GetOSVersion)[2] > 0;
            $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} = $];
                                # Use eval to avoid problems with earlier version (e.g. build 502)
        $Info{Perl_version} .= " Build " . eval "&Win32::BuildNumber()" if $OS_win;
        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 print_license {
    print << 'EOF';
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

EOF
    }

                                # Get legal options from .ini file
    sub check_usage {
        my (@dirs, @parms1, @parms2);
        @dirs = split ',', $ENV{mh_parms} if $ENV{mh_parms};
        for my $dir ('./mh.ini', @dirs) {
            push @parms1, &file_read($dir);
        }
        for (@parms1) {
            push(@parms2, "$1=s") if /^([^\s\#\=]+)\s*=/;
        }
        use Getopt::Long;
        if (!&GetOptions(\%config_parms_startup, "h", "help", "run=s", "run_parms=s", @parms2) or
            ($config_parms_startup{h} or $config_parms_startup{help})) {
            print $usage;
            exit;
       }
                                # If -log_file used, start logging right away
        if (my $logfile = $config_parms_startup{log_file}) {
                                # Avoid an odd problem with Win32::Process ... it restarts the main process!
            if ($^O eq "MSWin32" and $PAR::VERSION) {
                print "\nWarning:  -log_file causes problems with Windows mhe.exe.\n";
                print "Instead, use redirection like: mh > debug.log\n\n";
            }
            else {
                print "Output will be logged into $logfile\n";
                open STDOUT, ">$logfile" or die "Error, could not open logfile $logfile: $!\n";
                &print_version;
            }
        }

    }

    sub read_parms {

        $config_parms{debug_old} = $config_parms{debug};
        my $debug = 1 if $config_parms_startup{debug} and $config_parms_startup{debug} eq 'startup';
        $debug = 1 if $Debug{parms};
        my @files = &main::read_mh_opts(\%config_parms, '.', $debug);
        print "Read parameter files: @files\n";
        if ($config_parms{code_dir} eq "$Pgm_Root/code/test") {
        	print "\n".'*' x 80 . "\n";
        	print "Warning, you should create your own code directory outside of the main\n";
        	print "distribution directory and point code_dir to it.  Otherwise, you may lose\n";
        	print "your customizations on upgrades.\n";
        	print '*' x 80 . "\n\n";
       	}
        if ($config_parms{data_dir} eq "$Pgm_Root/data") {
        	print "\n".'*' x 80 . "\n";
        	print "Warning, you should create your own data directory outside of the main\n";
        	print "distribution directory and point data_dir to it.  Otherwise, you may lose\n";
        	print "your customizations on upgrades.  The best way to accomplish this is to copy\n";
        	print "the entire contents of the standard data directory into a new directory.\n";
        	print '*' x 80 . "\n\n";
       	}

                                # Read in speak parms per application
        &main::read_parm_hash(\%{$app_parms{speak}},   $main::config_parms{speak_apps_default});
        &main::read_parm_hash(\%{$app_parms{speak}},   $main::config_parms{speak_apps});
        &main::read_parm_hash(\%{$app_parms{display}}, $main::config_parms{display_apps_default});
        &main::read_parm_hash(\%{$app_parms{display}}, $main::config_parms{display_apps});

                                # 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};
        }

        $config_parms{debug} = $config_parms{debug_old} if defined $config_parms{debug_old};
        &set_debug_data;                        # Populate %Debug

    }

    sub set_debug_data {
        if (defined $config_parms{debug}) {
            if (!defined $Debug{debug_previous} or $config_parms{debug} ne $Debug{debug_previous}) {
                undef %Debug;
                $Debug{debug_previous} = $config_parms{debug};
                                   # Allow for multiple debugs like serial;x10
                for my $debug (split ';', lc $config_parms{debug}) {
                                   # Allow for debug level like: x10:4
                    next unless $debug;
                    if ($debug =~ /(.+):(.+)/) {
                        $Debug{$1} = $2;
                        print "Debug for $1 set to $2\n";
                    }
                    else {
                        $Debug{$debug} = 1;
                        print "Debugging for $debug turned on\n";
                    }
                }
            }
        }
    }

    sub use_conditional_modules {

        $ENV{DISPLAY} = $config_parms{display} if $config_parms{display};

                                 # Find local code dirs, so we can add to INC path
        $config_parms{code_dir}        = "./../code"        unless $config_parms{code_dir};
        $config_parms{code_dir_common} = "./../code_common" unless $config_parms{code_dir_common};
        @Code_Dirs = split ',', $config_parms{code_dir};
        push @Code_Dirs, $config_parms{code_dir_common};
        for (@Code_Dirs) { s/^\s*//; s/\s*$//; }; # Drop leading and trailing blanks
        print "Code Directories:\n - ", join("\n - ", @Code_Dirs), "\n";;
                                 # If first time, add default selected modules
        use File::Copy;
                                  # Grandfather old style file
        move "$config_parms{data_dir}/select_code.txt", "$config_parms{data_dir}/code_select.txt" unless
            -e "$config_parms{data_dir}/code_select.txt";
        move "$config_parms{data_dir}/select_code2.txt", "$config_parms{data_dir}/code_unselect.txt" unless
            -e "$config_parms{data_dir}/code_unselect.txt";

                                  # Get default files from the distro if needed
        copy "$Pgm_Root/data/$config_parms{code_select}", $config_parms{data_dir} unless
            -e "$config_parms{data_dir}/$config_parms{code_select}";
        copy "$Pgm_Root/data/$config_parms{code_unselect}", $config_parms{data_dir} unless
            -e "$config_parms{data_dir}/$config_parms{code_unselect}";

        unshift @INC, @Code_Dirs; # So we can add/override .pm modules locally
                                  # So we can add/override .pl modules locally
        if($config_parms{lib_dir}){
            print "User   Lib  Directory: $config_parms{lib_dir}\n";
            unshift @INC, split(',', $config_parms{lib_dir});
#           print "new liblist:",join(':',@INC),"\n";
        }

        if ($config_parms{diagnostics} or $config_parms{w}) {
            $config_parms{diagnostics}++;
            $config_parms{w}++;
            print "Perl diaganotics module (perl -w) has been turned on\n";
            eval 'use diagnostics';
# Dang, 5.0 does not have warnings.pm, so we can not use it in 5.6/5.8 :(
#           no warnings 'uninitialized';   # These seem to always show up ... lets turn them off
#           eval 'use warnings';
#           eval "no warnings 'uninitialized'"; # Does not work :(
#           $SIG{__WARN__} = sub { print "my warn: $_[0].\n"; }; # Does not filter out first verbose warning
#           my $j; print "j=$j\n";
#           my $l; my %k; print $k{$l};
#           exit;
        }
#       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/lose with ole lite
#           &my_use("Win32::DUN");          # Interface to rasdial
#           use Win32::API 0.01;            # Used in DriveInfo, SerialPort, etc
            &my_use("Win32::DriveInfo");    # For disk space free/total
            eval "use Win32::Console";
            print "\nError in loading module=Win32::Console:\n  $@\n" if $@;

                                            # EVENTS forces single-threaded apartment, so outlook.pl MAPI works
                                            # We don't need " anymore, but we do need EVENTS for various
                                            # automation code (e.g. MS 5.1 VR and MSN messanger events)
                                            # Hmmm, EVENTS causes slow exits
            &my_use("Win32::OLE");
#           &my_use("Win32::OLE qw(in with EVENTS)");
#           use Win32::OLE qw(in with EVENTS);
#           &my_use("Win32::OLE::lite");
            &my_use("Win32::Process");
            &my_use("Win32::PerfLib"); # Used in &memory_used
            &my_use("Win32::Registry");
            &my_use("Win32::MemMap") if $config_parms{http_fork} eq 'memmap';
                                # Note: Must use eval, not my_use, or exported pgms are not seen :(
                                #  - Loaded from: http://jenda.krynicky.cz/perl/
                                #  - For some reason, perl2exe binary abends here, so we evaled it earlier
            eval "use Win32::Setupsup qw(WaitForAnyWindow SendKeys EnumChildWindows SetFocus SetWindowText GetWindowText)"
                unless $Info{Perl_compiled};
            print "\nError in loading module=Win32::Setupsup:\n  $@\n" if $@; #  and &Win32::BuildNumber < 580;

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

            &my_use("Win32::SerialPort");

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

                                # Older Win32 perls do not have this
            eval "Win32::Sound::Volume";
            if ($@) {
                print "\nWin32::Sound::Volume not installed ... volume control is disabled\n\n";
            }
            else {
                $Info{Volume_Control} = 'Win32::Sound';
            }

        }
        else {                              # load the mutually-exclusive non-Windows modules
            &my_use("Device::SerialPort");  # Unix Posix verion of Win32 SerialPort
                                # Used for $Keyboard.  Messes up background mh, so is optional
                                #  - no way to detect if we are in the foreground??
            eval "use Term::ReadKey" if $config_parms{term} eq 'readkey';
            print "\nTerm::ReadKey not installed ... keyboard monitoring disabled\n\n" if $@;
            eval "use Time::HiRes('gettimeofday')";   # Used for gettimeofday for sub-second timing
            if ($@) {
                print "\nTime::HiRes not installed ... benchmark timing is disabled\n\n";
                $Info{HiRes} = 0;
            }
            else {
                $Info{HiRes} = 1;
            }
            if ($main::Info{OS_name} eq "linux") {
                eval "use Audio::Mixer"; # Used in mh/code/common/mh_sound.pl volume control
                if ($@) {
                    print "\nAudio::Mixer not installed ... volume control is disabled\n\n";
                }
                else {
                    $Info{Volume_Control} = 'Audio::Mixer';
                }
            }

        }
                                          # Use GD for http server, if it is installed and has newFrom methods
        $Info{module_GD} = 0;
        if ($config_parms{gd}) {
            eval "use GD";
            if ($@) {
                print "Error in use GD: $@\n\nTo disable this error, set mh.ini parm gd=0\n\n";
            }
            elsif ($GD::VERSION and $GD::VERSION < 1.19) {
                print "GD version needs to be > 1.18. Version=$GD::VERSION\n";
            }
            else {
                $Info{module_GD} = 1;
            }
        }

        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");
            }
	    eval "use Tk::ToolBar";
	    eval "use Tk::BrowseEntry";
	    eval "use Tk::ProgressBar";
	    eval "use Tk::Tree";
	    eval "use Tk::Balloon"; # for new status bar labels
		eval "use Tk::PNG";
        }

                                # Allow for Round Robin database logs
        if ($config_parms{rrd_dir}) {
            eval "use RRDs";
            if ($@) {
                print "\nError, perl RRDs.pm is not installed.\n  - Either install or unset the rrd_dir mh.ini parm\n\n";
                $config_parms{rrd_dir} = '';
            }
        }


    }

}                               # End BEGIN


                                # Declare all subs, then run code at the bottom

sub setup {

    print "Starting setup\n";

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

    &add_hook_code;

    use Astro::MoonPhase;
#   use Astro::SunTime; The cpan one is downlevel (no twilight, and -time_zone 0 bug)
    use SunTime_mh;
#   use Barcode;
    use File::Basename;
#   use File::Copy;             # So we copy files
    use Fcntl;                  # To enable O_RDWR|O_CREAT

#   use HTTP::Date qw(time2str str2time);
    use HTTP::Date qw(time2str);
    use Date::Parse qw(str2time); # This str2time is more robust than the HTTP::Date one

#   use Data::Dumper qw(Dumper DumperX);
    use Data::Dumper;
#   use Date::Manip;            # This modules takes .5 second to load and uses 3 meg!
#   use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
    use IO::Handle;
    use IO::Socket;
#   use IO::Socket::INET;       # Gives us the INADDR constants, used in xAP.pm ... not in 5.0 :(
    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;

	eval "use Lingua::Num2Word"; # converts numbers to text for multiple languages
    print "Eval error on Error in use: $@\n" if $@;

                                # These Text modules are used in &phrase_match
    use Text::PhraseDistance qw(pdistance);
                                # This fancy distance function allows for non-exact word matching,
                                # but the non-XS version is too slow.  Use the XS version if installed,
                                # otherwise we use a simple but fast exact word match distance function.
    {
        local $SIG{__WARN__} = sub { };  # Disable 5.8 "Can't locate auto/..." message
        eval 'use Text::LevenshteinXS qw(distance)';
        eval 'print " - using simple Text distance function\n"; sub distance { return $_[0] ne $_[1] }' if $@;
    }
    use Time::Local;            # For timelocal
    use Time::DaysInMonth;      # For days_in (and is_leap?)

                                # Date::Manip needs it in ISO 8601 form: +-HHMM
                                # Hmmm, this messes up str2time from Date::Parse
                                # used by net_mail_summary :(
#   $ENV{TZ} = (($config_parms{time_zone} < 0) ? '-' : '+' ) . sprintf("%02d00", abs $config_parms{time_zone});

    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
#    exit;

    use Timer;                  # This needs to be first, as it is used in Voice_Cmd (and elsewhere?)
    use File_Item;
    use Generic_Item;
    use Device_Item;
    use Group;
    use IR_Item;
    use RF_Item;
#   &my_use("Serial_Item");  # So we can add debug to Serial_Item.pm when running mh.exe
    use Serial_Item;
    use vars '%Weather';
    use Weather_Item;   &Weather_Item::Init();
    use X10_Items;
    use iButton;
    use LCD;
    use xAP_Items;
    use xAP_Items;
    use EIB_Items;
    use EIB_Device;
    eval "use BSC";

                                # Base_Items
    use Base_Item;
    use Door_Item;
    use Light_Item;
    use Motion_Item;
    use Photocell_Item;

    use Socket_Item;
    use Process_Item;
    use Text_Cmd;
    use Voice_Cmd;
    use Voice_Text;

    use Caller_ID;              # Old module ... keep for a while for backward compatability
#    use Telephony_Item;
#    use CID_Lookup;
#    use CID_Log;
#    use CID_Announce;


    use constant;               # To keep perl2exe happy
    use constant ON      => 'on';
    use constant OFF     => 'off';
    use constant DIM     => 'dim';
    use constant BRIGHTEN=> 'brighten';
    use constant TOGGLE  => 'toggle';
    use constant STATUS  => 'status';
    use constant OPEN    => 'open';
    use constant CLOSE   => 'close';
    use constant OPENED  => 'opened';
    use constant CLOSED  => 'closed';
    use constant MOTION  => 'motion';
    use constant STILL   => 'still';

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

    if ($OS_win) {
        no strict 'subs';   # For non-win OS
        $CON_IN = new Win32::Console STD_INPUT_HANDLE;
        $CON_OUT= new Win32::Console STD_OUTPUT_HANDLE;
        $CON_OUT->Title($config_parms{title});
#       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} = \&exit_pgm    if  $OS_win;  # Exit less 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

                                              # Return codes (e.g. from run) are (were?) bad on freebsd with SIG{CHLD},
                                              # but without this we get many zombies.   We choose to be zombie free.
#   $SIG{CHLD} = \&sig_child_death unless $^O eq 'freebsd';
    $SIG{CHLD} = \&sig_child_death;

#   $SIG{TTIN} = 'IGNORE';                    # This does not help ReadKey in cbreak mode :(


    $Info{IPAddress_local}    = (&get_ip_address(''))[0];
    $Info{IPAddress_local}    = $config_parms{ipaddress_local}    if $config_parms{ipaddress_local};
    $Info{IPAddress_external} = $config_parms{ipaddress_external} if $config_parms{ipaddress_external};
    $Info{IPAddress_external} = $Info{IPAddress_local} unless $Info{IPAddress_external};

    $config_parms{log_file}   = "$config_parms{data_dir}/mh.log"  unless $config_parms{log_file};

                                # 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{data_dir}/cache", 0777)        unless -d "$config_parms{data_dir}/cache";
    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";

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

    &open_logs;

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

    # This was taken from lib/trigger_code.pl so that libraries involved with serial ports
    # and sockets could create new triggers.  See lib/Weather_daviswm2.pm for an example of
    # why this is a good idea.
    &triggers_read;

                                # Find all defined socket and serial ports
    for my $parm (sort keys %config_parms) {
        next unless $config_parms{$parm}; # Ingore blank parms
        next if $parm =~ /_MHINTERNAL_/;
        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/;
        push(@Generic_Devices, $1)      if $parm =~ /^(.+?)_device$/;
    }
#   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"};
        my $address  = $config_parms{$port_name . "_address"};
        $address  = '' unless $address;
#        my $break    = $config_parms{$port_name . "_break"};

        $proto    = 'tcp'      unless $proto;
        $datatype = 'buffered' if $port_name eq 'http';
        $datatype = 'buffered' if $config_parms{$port_name . "_buffer"}; # Grandfathered syntax
        $datatype = '' unless $datatype;
#       $break = "[\r\n]+" unless $break;
#       eval qq[\$break = "$break"];

	my $pretty_port_name = $port_name;
	$pretty_port_name =~ s/_/\x20/g; # a slight improvement

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

        $Socket_Ports{$port_name}{port}     = $port;
        $Socket_Ports{$port_name}{protocol} = lc $proto;
        $Socket_Ports{$port_name}{datatype} = $datatype;
        $Socket_Ports{$port_name}{address}  = $address if $address;
#       $Socket_Ports{$port_name}{break}    = $break;

        &socket_open($port_name);
    }

    &xAP::startup;              # Start the xAP/xPL sockets, in lib/xAP_Items.pm
    &EIB_Device::startup;       # Start the EIB device, in lib/EIB_Device.pm


    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"},
                            $config_parms{$port_name . "_prefix"},
                            $config_parms{$port_name . "_parity"});
        $Serial_Ports{$port_name}{process_data} = 1 if $config_parms{$port_name . "_process_data"};
    }
    foreach my $device_name (@Generic_Devices) {
    	&generic_device_create($device_name);
    }

                                # Grandfather in old ibutton parms
    $config_parms{iButton_serial_port} = $config_parms{ibutton_port} if $config_parms{ibutton_port};
    $config_parms{iButton_tweak}       = $config_parms{ibutton_tweak};

                                # Look for user specified modules
                                # This makes it easy to add new modules
                                # for new serial/socket devices.
                                # Manager must be available in lib directory
    for my $parm (keys %config_parms) {
                                # Check for serial and server ports modules (e.g. Compool.pm)
                                #  Allow for:   DSC_Alarm_serial_port = COMx
                                #             DSC_Alarm:1_serial_port = COMx
                                #               iButton_1_serial_port = COMx

        next unless $config_parms{$parm};
        next if $parm =~ /_MHINTERNAL_/;
#       if ($parm =~ /^(.+?)([:_]?\d*)_(serial|server)_port/) {
        if (my ($instance, $type) = $parm =~ /^(.+)_(serial|server)_port/) {
            my $module = $instance;
            $module =~ s/[:_]\d+$//;        # Drop instance suffix
#           print "\n\ndb i=$instance m=$module p=$parm\n";
           if (-e "./../lib/$module.pm" or
               -e "$config_parms{lib_dir}/$module.pm" or
               -e "$Code_Dirs[0]/$module.pm") {
#              -e "$config_parms{code_dir}/$module.pm") {
                print "Found managed $type port=$instance\nMH will now require $module.pm and call ${module}::${type}_startup($instance)\n"
                    if $Debug{startup};
                require "$module.pm";
                eval "&${module}::${type}_startup('$instance')";
                print "Startup error on &${module}::${type}_startup('$instance'): $@\n" if $@;
            }
            else {
#  No need for warning errata, in case we have arbitrary _port ini parms
#               print "No $1.pm file found for $parm\n";
            }
        }

                                # Check for other mh.ini specified modules (e.g. Weather_vw.pm)
                                # weather_vwlog_module=Weather_vw
        if ($parm =~ /^(\S+?)_module/) {
            my $module = "$config_parms{$parm}.pm";
            if (-e "./../lib/$module" or
                -e "$config_parms{lib_dir}/$module" or
                -e "$Code_Dirs[0]/$module") {
#               -e "$config_parms{code_dir}/$module") {
                my $startup = "&$config_parms{$parm}" . '::startup';
                print "Found managed $module module\nMH will now require $module and call $startup\n"
                    if $Debug{startup};
                require $module;
                eval    $startup;
                print "Startup error on $startup: $@\n" if $@;
                               # Startup function is optional (e.g. some modules only have serial_startup
#               print "Startup error on $startup: $@\n" if $@;

#               require "$1.pm";
#               eval "$1::startup()";
#               print "Startup error on $1::startup(): $@\n" if $@;
            }
            else {
                print "Warning, mh.ini module not found: $module\n";
            }
        }

                                # Start up sockets on proxy ports
        if (my ($interface) = $parm =~ /(\S+)_port$/ and $config_parms{$parm} =~ /^proxy +(\S+)/i) {
            my $address = $1;
            printf " - creating %-15s proxy on %s\n", $interface, $address;
            next if $proxy_servers{$address}; # Only need/want one
            $proxy_servers{$address} = new Socket_Item(undef, undef, $address, undef, undef, undef, "\035");
            $proxy_servers{$address}->start;
        }
    }

    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 the user has configured a backup CM11 without a main CM11 then switch them ...
    #   ... and tell the user what we've done
    if ($config_parms{cm11_bak_port} && !$config_parms{cm11_port}) {
        $config_parms{cm11_port} = $config_parms{cm11_bak_port};
        undef $config_parms{cm11_bak_port};
        print "Warning: a backup CM11 was configured without a main CM11. The backup will be used as the main unit\n";
    }

    if ($config_parms{cm11_port}) {
        require 'ControlX10/CM11.pm';
        if (&serial_port_create('cm11', $config_parms{cm11_port}, 4800, 'none')) {
                                # Reset the CM11 so we don't get old X10 incoming data
                                # This will also set the cm11 $POWER_RESET flag that
                                # that mh_control $Power_Supply will look for to detect power fails
                                # Also reset the clock for the heck of it ... doesn't take long
            &ControlX10::CM11::read($Serial_Ports{cm11}{object}, 1);
            &ControlX10::CM11::setClock($Serial_Ports{cm11}{object});
            $cm11_objects{timer} = new Timer;
            $cm11_objects{active} = new Generic_Item;
        }
    }

    # Initialise the backup CM11 if we have one
    if ($config_parms{cm11_bak_port}) {
        if (&serial_port_create('cm11_bak', $config_parms{cm11_bak_port}, 4800, 'none')) {
            &ControlX10::CM11::read($Serial_Ports{cm11_bak}{object}, 1);
            &ControlX10::CM11::setClock($Serial_Ports{cm11_bak}{object});
            $cm11_objects{bak_timer} = new Timer;
            $cm11_objects{bak_active} = new Generic_Item;
        }
    }

    if ($config_parms{ti103_port}) {
        require 'TI103.pm';
        if (&serial_port_create('ti103', $config_parms{ti103_port}, 19200, 'none')) {
            &ControlX10::TI103::read($Serial_Ports{ti103}{object}, 1);
            $ti103_objects{timer} = new Timer;
            $ti103_objects{active} = new Generic_Item;
        }
    }


    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{use_wish} && $^O eq 'linux' && -d '/dev/x10/') {
#        require 'X10_Wish.pm';
#        $Serial_Ports{'wish'}{object} = 'wish';
        my $instance = 'wish';
        my $module = 'X10_Wish';
        require "$module.pm";
        $Serial_Ports{$instance}{object} = $instance;
        eval "&${module}::startup('$instance')";
        print "Startup error on &${module}::startup('$instance'): $@\n" if $@;
    }


                                # 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});
    }

                                 # I guess there is not really much to do here
    if ($config_parms{iplcs_port}) {
        require 'iplcs.pm';
        if (&serial_port_create('iplcs', $config_parms{iplcs_port}, 4800, 'none')) {
            #$iplcs_objects{timer} = new Timer;
            #$iplcs_objects{active} = new Generic_Item;
        }
    }


                                # Store boot time in seconds since epoc
    if ($OS_win) {
        $Time_Boot_time = time - &get_tickcount/1000;    # 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;
    }
    elsif ($^O eq 'freebsd') {
        open(SYSCTL,"/sbin/sysctl -a |") or print "\nError: can't open /sbin/sysctl -a: $!";;
        while (<SYSCTL>) {last if (/boottime/)}
        $Time_Boot_time = $1 if (/ sec[ =]+(\d+)/);
        close(SYSCTL);
    }
    elsif ($^O eq 'darwin') {
#    In Darwin, open(SYSCTL) is "/usr/sbin/sysctl"  - whm 4 Dec 2004
#         -a yields a string: "kern.boottime = Fri Nov 26 13:11:16 2004"
#         -n yields secs since epoc
        use vars qw($sysctl);
        $sysctl = '/usr/sbin/sysctl';
        $Time_Boot_time = `$sysctl -n kern.boottime`;
    }


    $exit_flag = 0;
    $config_parms{sleep_time}    = 50 unless defined $config_parms{sleep_time};
    $config_parms{sleep_count}   =  2 unless defined $config_parms{sleep_count};
    $config_parms{tk_passes}     = 10 unless $config_parms{tk_passes};

    # NOTE: on Windows, default is best left empty for tk_font (inherits font from OS display scheme)

    $config_parms{tk_font}       = 'Times 10'   unless $config_parms{tk_font} or $OS_win;
    $config_parms{tk_font_fixed} = 'Courier 10' unless $config_parms{tk_font_fixed};

    $Loop_Tk_Passes  = $config_parms{tk_passes};
    $Loop_Sleep_Time = $config_parms{sleep_time};

    $Time = time;

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

    $Month++;

    &persistent_restore();      # Populate %Save
    &setup_DBI();               # Create optional $DBI database interface

    use vars '$Catchup_Mode';
    $Catchup_Mode = new Generic_Item;

                                # Configure 'fast test mode' parms
    $Time_Increment = ($config_parms{time_increment}) ? $config_parms{time_increment} : 60;
    my $time_start = $config_parms{time_start};
    $time_start = $Save{Time_Saved} if $time_start and lc $time_start eq 'resume';
    if ($time_start) {
        $Loop_Sleep_Time = 0;
#       $Loop_Tk_Passes  = 1;
        $Time_Start_time = &my_str2time($time_start);
        set $Catchup_Mode 'startup';
        $Time  = $Time_Start_time - $Time_Increment; # Cause we start the loop with an increment
        print "time_start=$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;
    $Save{mode}   = 'normal' unless $Save{mode};

    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;
    }

    speak('app=system System restarted');

    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(1);  ## force initial read

                                # Perl 5.004+ will self-randomize
#   srand(time() ^ ($$ + ($$ << 15)) ); # Set the random 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";

}

# Called from generic item *** and undo sub

sub open_logs {
    print " - reading previous log files\n";

                                # Setup and Read in previous logs
    my $print_log = "$config_parms{data_dir}/logs/print.log";
    my $speak_log = "$config_parms{data_dir}/logs/speak.log";
    my $error_log = "$config_parms{data_dir}/logs/error.log";

    my (@log);
    @log = &file_tail($print_log, $config_parms{max_log_entries});
    chomp @log;
    @Print_Log = reverse @log;
    unshift @Print_Log, "$Time_Date ---------- Restart ---------- ";

    @log = &file_tail($speak_log, $config_parms{max_log_entries});
    chomp @log;
    @Speak_Log = reverse @log;
#    unshift @Speak_Log, "$Time_Date ---------- Restart ---------- ";

    @log = &file_tail($error_log, $config_parms{max_log_entries});
    chomp @log;
    @Error_Log = reverse @log;
    unshift @Error_Log, "$Time_Date ---------- Restart ---------- ";


    print " - archiving previous $config_parms{data_dir}/logs/*.log files .";

               # These files will get archived by mh/code/common/mh_control.pl
    file_cat $error_log, $error_log . ".old";  print ".";
    file_cat $print_log, $print_log . ".old";  print ".";
    file_cat $speak_log, $speak_log . ".old";  print ".\n";
    open PRINTLOG,  ">$print_log" or die "Error, could not open print logfile $print_log: $!\n";
    open SPEAKLOG,  ">$speak_log" or die "Error, could not open speak logfile $speak_log: $!\n";
    open ERRORLOG,  ">$error_log" or die "Error, could not open error logfile $error_log: $!\n";

                                # So we can monitor these files
    PRINTLOG->autoflush(1);
    SPEAKLOG->autoflush(1);
    ERRORLOG->autoflush(1);

    print PRINTLOG (join "\n", reverse @Print_Log), "\n";
    print SPEAKLOG (join "\n", reverse @Speak_Log), "\n";
    print ERRORLOG (join "\n", reverse @Error_Log), "\n";
}

sub set_by_to_target {
    my ($set_by, $no_strip) = @_;

    $no_strip = 0 unless $no_strip;

    $set_by = undef if (!$set_by or $set_by =~ /time/i or $set_by =~ /^unknown/i or $set_by =~ /^usercode/i or $set_by eq 'status');

    # *** WTF?!  This got called over and over by something (couldn't have been in while loop because it wasn't locked up)
    # *** Check if timer object (?)

    my @objectList=();
    while (ref $set_by and $set_by->can('get_set_by')) {
        if (grep($set_by->{object_name} eq $_, @objectList)) {
            &print_log ("BUG! set_by loop detected with these objects: ".
                join (', ',@objectList));
            last;
        }
        push(@objectList, $set_by->{object_name});
        my $predecessor=$set_by->get_set_by();
        last if $predecessor and $predecessor eq $set_by; # comment this line out to detect self-setting objects
        $set_by = $predecessor;
    }

    if (!($no_strip)) {
        $set_by = $1 if ($set_by and $set_by =~ /(.*?) \[/); #web, email, im (and xap coming soon)
        $set_by = undef if ref $set_by;
    }
    return $set_by;
}

# Custom windows go at bottom of view menu, dialogs on tools

sub register_custom_window {
	my ($app, $window, $dialog, $menu, $title) = @_;

	return if !$config_parms{tk};

	$menu = 1 unless defined $menu; # default is to provide an activation menu

	my $label = ucfirst($app) . ' ' . ucfirst($window);
	$label = $title if $title;

	my $sub = eval("sub { &open_$app" . "_" . $window . "_window() }");
	if ($dialog) {
		$Tk_objects{"menu_tools_" . $app . "_" . $window} = $Tk_objects{menu_tools}->command(-label => "$label...", -command => $sub) unless $Tk_objects{"menu_tools_" . $app . "_" . $window};
	}
	else {
		$Tk_objects{"menu_view_" . $app . "_" . $window} = $Tk_objects{menu_view}->command(-label => $label, -command => $sub) unless $Tk_objects{"menu_view_" . $app . "_" . $window};
	}

	$custom_child_windows{"$app $window"} = (defined $custom_child_windows{"$app $window"})?$custom_child_windows{"$app $window"} + 1:1;
	warn 'Duplicate window registration' if $custom_child_windows{"$app $window"} > 1;
}

sub custom_window_registered {
	my ($app, $window) = @_;

	return $custom_child_windows{"$app $window"};
}



sub load_child_window {
	my %parms = @_;
	my $app = $parms{app};
	my $window = $parms{window_name};
	my $title = $parms{title};
	my $text = $parms{text};
	my $font = $parms{font};
	my $wait = $parms{wait}; # normally not passed
	my $buttons = $parms{buttons};
	my $help = $parms{help}; # just text for the moment

	$wait = 1 unless defined $wait; # Do not activate (window remains hidden on return)

	$title = ucfirst($app) unless $title;

	my %parms2 = qw//;
	$parms2{time} = 0;
	$parms2{wait} = $wait;
	$parms2{app} = $app; # was missing before!
	$parms2{window_name} = $window;
	$parms2{title} = $title;
	$parms2{text} = $text;
	$parms2{font} = $font;

	my $win = new Display(%parms2);

	if ($win and defined $buttons and !$win->{activated}) { # 1 = Close, 2 = OK/Cancel, 3=OK/Cancel/Apply
		$win->{MW}{bottom_frame}->configure(-borderwidth => 4);
		if ($help) {
			my $tk;
			my $fb = $win->{MW}{bottom_frame};
			my $sub = eval "sub { &display('app=help window_name=topic time=0 $help')}";
			$tk = $fb->Button(-text => 'Help', -command => $sub);
			$tk->pack(-side => 'right');
			&configure_element('button', \$tk);

		}
		if ($buttons == 1) {
			my $tk;
			my $sub = eval "sub { \$win->destroy() }";
			$tk = $win->{MW}{bottom_frame}->Button(-text => 'Close', -command => $sub)->pack(-side => 'right');
			&configure_element('button', \$tk);
		}
		elsif ($buttons == 2) {
			my $tk;
			my $sub = eval "sub { \$win->{canceled} = 1; \$win->destroy() }";
			$tk = $win->{MW}{bottom_frame}->Button(-text => 'Cancel', -command => $sub)->pack(-side => 'right');
			&configure_element('button', \$tk);
			$sub = "sub { \$win->destroy() unless &$parms{app}_$parms{window_name}_window_saving(\$win) }";
			$sub = eval($sub);
			$tk = $win->{MW}{bottom_frame}->Button(-text => 'OK', -command => $sub)->pack(-side => 'right');
			&configure_element('button', \$tk);
		}
		else {
			my $tk;
			my $sub = eval "sub { $win->destroy() unless &$parms{app}_$parms{window_name}_window_saving(\$win) }";
			$tk = $win->{MW}{bottom_frame}->Button(-text => 'OK', -command => $sub)->pack(-side => 'right');
			&configure_element('button', \$tk);
			$sub = eval "sub { $win->{canceled} = 1; $win->destroy() }";
			$tk = $win->{MW}{bottom_frame}->Button(-text => 'Cancel', -command => $sub)->pack(-side => 'right');
			&configure_element('button', \$tk);
			$sub = eval "sub { &$parms{app}_$parms{window_name}_window_saving() }";
			$tk = $win->{MW}{bottom_frame}->Button(-text => 'Apply', -command => $sub)->pack(-side => 'right')
			&configure_element('button', \$tk);

		}
	}

	return $win;

}




                                # The remaining subroutines are in alphabetical order


sub AUTOLOAD {
    use vars '$AUTOLOAD';
    &print_log("Undefined subroutine: $AUTOLOAD");
    return;
}
                                # This code allows us to add dynamic user code hooks at various places.
my (%hook_pointers, %hook_locations);
sub add_hook_code {

    my @hook_locations = qw( MainLoop_pre MainLoop_post
                             Serial_data  Serial_match X10_Interface::send_x10_data
                             State_change iButton_receive
                             Play_pre Play_post Play_parms Speak_pre Speak_post Speak_parms
                             Jabber_Message Jabber_IQ Jabber_Presence
                             AOLim_Message AOLim_Status AOLim_Disconnected ICQim_Message ICQim_Status ICQim_Disconnected MSNim_Message MSNim_Status
                             Reload_pre Reload_post Log Exit
                             );
    %hook_locations = map {$_, 1} @hook_locations;

    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, $type, @parms) = @_;
       $type = '0' unless $type;
       $type = 'persistent' if $type eq '1'; # Grandfathered syntax

       unless( defined( $hook_locations{$location} ) ){
           print "add_hook: Invalid hook location, loc=$location hook=$hook\n";
           return 0;
       }

       unless( ref $hook eq 'CODE' ){
           print "add_hook: Hook must be a code reference, loc=$location hook=$hook\n";
           return 0;
       }

       $hook_pointers{$location} = [] unless defined ($hook_pointers{$location});

       if ($type =~ /first/) {
           unshift( @{$hook_pointers{$location}}, [$hook, $type, @parms] );
       }
       else {
           push(    @{$hook_pointers{$location}}, [$hook, $type, @parms] );
       }

       return 1;
   }

   sub drop_hook_ {
       my($location, $hook ) = @_;

       unless( defined( $hook_locations{$location} ) ){
           print "drop_hook: Invalid hook location, loc=$location hook=$hook\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][0] );
           }

                                # delete if the index returned is in range
           if ($i >=0 and $i <= $#{$h} ){
               splice( @{$h}, $i, 1 );
               return 1;
           }
       }

       print "drop_hook: Specified hook not found, loc=$location hook=$hook\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 = shift @_;
       my $i = 0;
       for my $ptr (&get_hooks_($location)){
           my ($hook, $type, @parms) = @$ptr;
#          print "db hook l=$location p=$ptr h=$hook t=$type p=@parms.\n" unless $location eq 'MainLoop_pre';
                                # Allow for parms passed in mh, and parms specified
                                # with addhook.
           &$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) {
           my @hook_pointers_persistent;
           for my $ptr (&get_hooks_($location)){
               my ($hook, $type, @parms) = @$ptr;
               push @hook_pointers_persistent, $ptr if $type =~ /persistent/;
           }
           @{$hook_pointers{$location}} = @hook_pointers_persistent;
       }
   }
}

use vars '%Sounds';
sub add_sound {
    my ($key, $file, %parms) = @_;
    $Sounds{$key}{file} = $file;
    for my $parm (keys %parms) {
        $Sounds{$key}{$parm} = $parms{$parm};
    }
}

sub add_remove_modules {
	# *** For now jump to Web interface (should be a dialog!)
	&browser("http://localhost:$config_parms{http_port}/bin/code_select.pl");
}

sub add_remove_items {
	# *** For now jump to Web interface (should be a dialog!)
	&browser("http://localhost:$config_parms{http_port}/bin/items.pl");
}


sub browse_triggers {
	# *** For now jump to Web interface (should be a dialog!)
	&browser("http://localhost:$config_parms{http_port}/bin/triggers.pl");
}

sub set_password { # *** duplicated in mh_control!
    my $state = shift;
    @ARGV = (-user => $state);
    &print_log("Setting $state password with: @ARGV");
    do "set_password";
    &password_read;             # Re-read new password data
}

sub browser {
    my ($file) = @_;
                                # Don't need this ... run looks 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;

	# *** Should shellexecute in Windows!


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

my ($loop_tickcount1, $loop_tickcount2, $loop_tickcount3, $loop_tickcount4, $loop_tickcount_total);
my ($loop_sleep_total, $Disable);
sub check_for_action {
    &exit_pgm if $exit_flag;

                                # Avoid -w uninitialzed value warnings
    $loop_tickcount1 = $loop_tickcount2 = $loop_tickcount3 = $loop_tickcount4 = $loop_tickcount_total = 0 if $Startup;
    $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 <= 0;  # 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);
        }
    }
    $Disable = 0 unless $Disable; # Debug run times problems by turning off sections of code

    &check_for_keyboard_input        unless $Disable == 1;
    &check_for_nextpass_actions      unless $Disable == 2;
    return if $pause_mode;

    &set_global_vars                 unless $Disable == 3;
    &Process_Item::harvest           unless $Disable == 4;  # Check for done processes
    &Generic_Item::reset_states      unless $Disable == 5;  # Reset states for all objects that are 'ISA Item' objects
    &Voice_Cmd::check_for_voice_cmd  unless $Disable == 6;  # Do this even if VR is not installed, so we can do web and manual run_voice_cmd
    &check_for_proxy_data            unless $Disable == 7;
    &check_for_serial_data           unless $Disable == 8;
    &check_for_socket_data_http      unless $Disable == 9;
    &check_for_socket_data           unless $Disable == 10;
    &check_for_generic_device_data   unless $Disable == 11;
    &check_for_tied_times            unless $Disable == 12 and !$New_Minute;
    &Timer::check_for_timer_actions  unless $Disable == 13;
    &check_for_external_command_file unless $Disable == 14;

    my $tic1 = &get_tickcount;
    $Benchmark_Members{' OTHER'} += $tic1 - $loop_tickcount1 if $Benchmark_Members{on_off_flag};

                                # Use eval to catch minor errors without abending
                                #  - about 10% slower (170 -> 150)
    &MainLoop_pre_hooks()            unless $Disable == 15; # Created by &add_hooks

                                # Safegard from sleeping too much
    my $max_sleep = 500;
    $max_sleep = int $max_sleep / $config_parms{sleep_count} if $config_parms{sleep_count};
    $Loop_Sleep_Time = $max_sleep if $max_sleep < $Loop_Sleep_Time;

#   &loop_code;
    &eval_user_code_loop             unless $Disable == 16;
    &MainLoop_post_hooks()           unless $Disable == 17;  # Created by &add_hooks

                                # Substract out time spent sleeping
    my $tic2 = &get_tickcount - $loop_sleep_total;
    $Benchmark_Members{' USER'} += $tic2 - $tic1 if $Benchmark_Members{on_off_flag};
    $loop_tickcount_total       += $tic2 - $loop_tickcount1;

                                # 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;

	if ($Reload) {
	# Ditto for modules!

	    print "Creating Modules Menu\n";

	    $Tk_objects{menu_modules} = $Tk_objects{menu_bar}->Menubutton(-text => 'Modules', -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0) unless $Tk_objects{menu_modules};
	    $Tk_objects{menu_modules}->menu->delete(0, 'end'); # Delete old menus
	    &configure_element('window', \$Tk_objects{menu_modules});



	$Tk_objects{menu_modules}->command(-label => 'Add or Remove Modules...', -command => \&add_remove_modules);

	$Tk_objects{menu_modules}->separator();
	    my $i;

            for (sort keys %Run_Members) {
			$Tk_objects{menu_modules}->checkbutton(-label => $_, -variable => \$Run_Members{$_});
			last if $i++ > ((defined $config_parms{tk_module_menu_max} and $config_parms{tk_module_menu_max})?$config_parms{tk_module_menu_max}:50);
	    }


	my $tb_align = ($config_parms{tk_toolbar_align})?$config_parms{tk_toolbar_align}:'top';
	# *** Should validate before passing to tk lib

	print "Creating Toolbar\n";

	$Tk_objects{toolbar}->destroy() if $Tk_objects{toolbar};

	$Tk_objects{toolbar} = $MW->ToolBar('-movable', 1, '-side', "$tb_align",
                                 '-indicatorcolor', 'blue', '-sticky', 'nsew');

	my $tb = $Tk_objects{toolbar};

	&configure_element('toolbar', \$tb);

	&configure_element('toolbar', \$tb->{CONTAINER});


	#my @commands = ('navhome22','playpause22', 'playstop22', 'nav1rightarrow22', 'actundo22', 'actreload22', 'actrun22', 'actlock22', 'actunlock22', 'connectno22', 'connectyes22', 'connecting22');

	my %button = ('text' => 'Toggle house mode', 'image' => 'navhome22', 'command' => \&toggle_house_mode);

	tk_toolbar_add_button($tb, \%button);

	%button = ('text' => 'Toggle security mode', 'image' => 'actlock22', 'command' => \&toggle_security_mode);

	tk_toolbar_add_button($tb, \%button);

	%button = ('text' => 'Undo the last action', 'image' => 'actundo22', 'command' => \&undo_last_action);

	tk_toolbar_add_button($tb, \%button);

	%button = ('text' => 'Reload code', 'image' => 'actreload22', 'command' => \&read_code);

	tk_toolbar_add_button($tb, \%button);

	%button = ('text' => 'Pause', 'image' => 'playpause22', 'command' => \&toggle_pause);

	tk_toolbar_add_button($tb, \%button);


	if ($Run_Members{'internet_mail'}) { # ugly (20-line email scan belongs in lib or in here)

		my $sep = $tb->separator();
		#&configure_element('button', \$sep);

		# Calling voice command for this is absurd of course (see above)

		my %button = ('text' => 'Check email', 'image' => 'mailget22', 'command' => sub { run_voice_cmd('check for e mail', 0, 'tk')}); # *** Goofy vc name too

		tk_toolbar_add_button($tb, \%button);

		%button = ('text' => 'Email message', 'image' => 'mailsend22', 'command' => sub { &open_email_message_window() });

		tk_toolbar_add_button($tb, \%button);

	}




	    if ($Run_Members{'internet_dialup'}) {

		my $sep = $tb->separator();
		#&configure_element('button', \$sep);

		my %button = ('text' => 'Connect to Internet', 'image' => 'connectyes22', 'command' => \&ras_connect);

		tk_toolbar_add_button($tb, \%button);
		%button = ('text' => 'Disconnect from Internet', 'image' => 'connectno22', 'command' => \&ras_disconnect);

		tk_toolbar_add_button($tb, \%button);



	    }

	    if ($Run_Members{'mp3_winamp'} or $Run_Members{'mp3_slimserver'} or $Run_Members{'mp3_xmms'} or $Run_Members{'mp3_alsaplayer'}) { # all must create jukebox object!
		use vars '$jukebox'; # *** should just call subs!

		my $sep = $tb->separator();
		#&configure_element('button', \$sep);

		my %button = ('text' => 'Previous song', 'image' => 'playstart22', 'command' => sub {set $jukebox 'previous song', 'tk'});

		tk_toolbar_add_button($tb, \%button);

		%button = ('text' => 'Play', 'image' => 'nav1rightarrow22', 'command' => sub {set $jukebox 'play','tk'});

		tk_toolbar_add_button($tb, \%button);
		%button = ('text' => 'Pause', 'image' => 'playpause22', 'command' => sub {set $jukebox 'pause', 'tk'});

		tk_toolbar_add_button($tb, \%button);

		%button = ('text' => 'Stop', 'image' => 'playstop22', 'command' => sub {set $jukebox 'stop', 'tk'});

		tk_toolbar_add_button($tb, \%button);

		%button = ('text' => 'Next song', 'image' => 'playend22', 'command' => sub {set $jukebox 'next song', 'tk'});

		tk_toolbar_add_button($tb, \%button);

		%button = ('text' => 'Volume up', 'image' => 'nav1uparrow22', 'command' => sub {set $jukebox 'volume up','tk'});

		tk_toolbar_add_button($tb, \%button);

		%button = ('text' => 'Volume down', 'image' => 'nav1downarrow22', 'command' => sub {set $jukebox 'volume down','tk'});

		tk_toolbar_add_button($tb, \%button);




	    }


	$tb->separator();

	%button = ('text' => 'Help', 'image' => 'acthelp22', 'command' => \&help);

	$Tk_objects{toolbar_help_button} = tk_toolbar_add_button($tb, \%button);

	unless ($Tk_objects{menu_help}) {

	    $Tk_objects{menu_help} = $Tk_objects{menu_bar}->
        	Menubutton(-text => 'Help',
                   -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0);
	    &configure_element('window', \$Tk_objects{menu_help});

# Do the help menu here so it shows up last


	    $Tk_objects{menu_help}->command(-label => 'Contents', -underline => 0, -command => \&help);
	    $Tk_objects{menu_help}->command(-label => 'FAQ', -underline => 0, -command => sub { &help('faq') });
	    $Tk_objects{menu_help}->command(-label => 'Examples', -underline => 0, -command => sub { &help('examples')});
	    $Tk_objects{menu_help}->command(-label => 'User Documentation', -underline => 0, -command => sub { &help('wiki')});
	    $Tk_objects{menu_help}->command(-label => 'Neighborhood', -underline => 0, -command => sub { &help('neighborhood')});

	    $Tk_objects{menu_help}->separator;

	    my $title = ((($config_parms{title})?$config_parms{title}:"Misterhouse"));

	    $Tk_objects{menu_help}->command(-label => "About $title...", -underline => 0, -command => \&help_about);

	    &configure_element('window', \$Tk_objects{menu_help});

	}

	}



    }


    if ($Reread) {
        $Startup = 0; $Reload = 0; $Reread = 0;
                                # This will be reset to 'normal' on a normal exit
        $Save{mh_exit} = 'abend';
    }

}

sub check_for_ti103_data {
                # Standard 1-ti103 code

    if ($New_Second) {
        &ControlX10::TI103::send_buffer($Serial_Ports{ti103}{object});
    }

    my $data = &ControlX10::TI103::read($Serial_Ports{ti103}{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 TI103 data=$data data_d=$data_d\n" if $Debug{x10} and $data;
#       if ($data_d == 0x5a) {
    if ($data_d == 0x5a or $data_d == 0xa5) {
        if ($data = &ControlX10::TI103::receive_buffer($Serial_Ports{ti103}{object})) {
        &process_serial_data("X" . $data);
        }
    }
}


sub check_for_cm11_data {

                # Standard 1-cm11 code
    if (!$config_parms{cm11_bak_port}) {
    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 $Debug{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_serial_data("X" . $data);
        }
    }
    }
                # Dual cm11 code
    else {
    my $data     = &ControlX10::CM11::read($Serial_Ports{cm11}{object}, 1);
    my $data_bak = &ControlX10::CM11::read($Serial_Ports{cm11_bak}{object}, 1) if $config_parms{cm11_bak_port};

    my $heartbeat = $config_parms{cm11_heartbeat};
    $heartbeat = -1 unless $heartbeat;          # setting heartbeat to -1 disables the functionality

    # restart the timers if we've got data from them
    if ($data) {
        $cm11_objects{active}->set(ON);
        $cm11_objects{timer}->set($heartbeat,,1) if ($heartbeat != -1);
    }
    if ($data_bak) {
        $cm11_objects{bak_active}->set(ON);
        $cm11_objects{bak_timer}->set($heartbeat,,1) if ($heartbeat != -1);
    }

    if ($New_Second && $Debug{cm11}) {
        print "db CM11";
        print " main:" . $cm11_objects{active}->state();
        print ":" . $cm11_objects{timer}->seconds_remaining() if ($heartbeat != -1);
        if ($config_parms{cm11_bak_port}) {
        print " bak:" . $cm11_objects{bak_active}->state();
        print ":" . $cm11_objects{bak_timer}->seconds_remaining() if ($heartbeat != -1);
        }
        print "\n";
    }

    # Convert from string to decimal
    my $data_d = unpack('C', $data) if $data;
    my $data_d_bak = unpack('C', $data_bak) if ($data_bak && $config_parms{cm11_bak_port});

                                # 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 (($Debug{x10} || $Debug{cm11}) and $data);
    print "mh CM11 data_bak=$data_bak data_d_bak=$data_d_bak\n" if (($Debug{x10} || $Debug{cm11}) and $data_bak);

    $data = &ControlX10::CM11::receive_buffer($Serial_Ports{cm11}{object}) if ($data && ($data_d == 0x5a or $data_d == 0xa5));

    $data_bak = &ControlX10::CM11::receive_buffer($Serial_Ports{cm11_bak}{object}) if ($data_bak && ($data_d_bak == 0x5a or $data_d_bak == 0xa5));

    if ($heartbeat != -1) {
        if ($cm11_objects{timer}->inactive()) {
        print "db CM11 cm11_timer has expired... testing... " if $Debug{cm11};
        if (&ControlX10::CM11::ping_cm11($Serial_Ports{cm11}{object})) {
            $cm11_objects{active}->set(ON);
            print "alive\n" if $Debug{cm11};
        } else {
            $cm11_objects{active}->set(OFF);
            print "no response\n" if $Debug{cm11};
        }
        $cm11_objects{timer}->set($heartbeat,,1);
        }

        if (($cm11_objects{bak_timer}->inactive()) && ($config_parms{cm11_bak_port})) {
        print "db CM11 cm11_bak_timer has expired... testing... " if $Debug{cm11};
        if (&ControlX10::CM11::ping_cm11($Serial_Ports{cm11_bak}{object})) {
            $cm11_objects{bak_active}->set(ON);
            print "alive\n" if $Debug{cm11};
        } else {
            $cm11_objects{bak_active}->set(OFF);
            print "no response\n" if $Debug{cm11};
        }
        $cm11_objects{bak_timer}->set($heartbeat,,1);
        }
    }

    &process_serial_data("X" . $data) if ($data);
    &process_serial_data("X" . $data_bak) if (($data_bak) && ($data_bak != $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 $config_parms{no_log} =~ /xcmd/;
        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, 'xcmd');
    }
}

sub check_for_generic_serial_data {
    my ($port_name) = @_;
    my $data;

    return if $Serial_Ports{$port_name}{object} eq 'proxy';

    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;
    }
                                # SerialPort returns the empty string, which is defined.
                                # We need to allow for data=0, so need to use the defined test.
    undef $data if $data eq '';

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

    print "  serial name=$port_name type=$Serial_Ports{$port_name}{datatype} data2=\n$Serial_Ports{$port_name}{data}\n---\n"
        if defined $data and ($Debug{serial} or $Debug{$port_name});

                                # Check to see if we have a carrage return yet
    if (defined $Serial_Ports{$port_name}{data}) {
        if (defined($Serial_Ports{$port_name}{datatype}) and $Serial_Ports{$port_name}{datatype} eq 'raw') {
            &Serial_data_hooks($Serial_Ports{$port_name}{data}, $port_name);   # Created by &add_hooks
        }
        else {
            my $break = $config_parms{"${port_name}_break"};
            $break = "[\r\n]+" unless $break;
            while (my($record, $remainder) = $Serial_Ports{$port_name}{data} =~ /(.+?)$break(.*)/s) {
                print "Data from $port_name: $record.  remainder=$remainder.\n"
                    if $Debug{serial} or $Debug{$port_name};
                $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 {
                    &Serial_data_hooks($record, $port_name);   # Created by &add_hooks
                    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 $Debug{homevision} or $Debug{serial};
        &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 $Debug{ncpuxa} or $Debug{serial};
        &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 $Debug{homebase};
        &process_serial_data("X" . $data);
    }
}


use vars '$Keyboard';
sub check_for_keyboard_input {
                                # The F1->F5 data is now processed in mh/code/common/mh_control.pl
    undef $Keyboard;
    if ($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();
            $Keyboard = $event[3] if $event[1];
        }
        if ($Keyboard and ($Keyboard == 13 or $Keyboard == 32)) {       # Enter Key  -> display simple menu
            print "F1->Reload  F2->Pause  F3->Exit  F4->Debug  F5->Logging\n";
        }
#       if ($Keyboard and $Keyboard == 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);
#           my %keymap = ('F1: Reload' => 'F1', 'F2: Pause'   => 'F2', 'F3: Exit' => 'F3',
#                         'F4: Debug ' => 'F4', 'F5: Logging' => 'F5');
#           $Keyboard = $keymap{$choice};
#           print "action=$choice key=$Keyboard\n";
#       }
    }
    else {
        my ($key, $keystring);
                                # Allow for F1 -> F12, which are multi key strings
        ReadMode 'cbreak';
        while (defined($key = ReadKey(-1))) {
            $keystring .= sprintf('%2x', ord $key);
            $Keyboard = $key;
        }
        ReadMode 'normal';      # Or else we loose echo when mh exits.  Benchmark shows no slowdown.
        $Keyboard = $keystring if defined $keystring and length $keystring > 2;
    }

    return unless defined $Keyboard;

    my %keymap = (112 => 'F1',  113 => 'F2',  114 => 'F3',
                  115 => 'F4',  116 => 'F5',  117 => 'F6',
                  118 => 'F7',  119 => 'F8',  120 => 'F9',
                  121 => 'F10', 122 => 'F11', 123 => 'F12',
                  '1b4f50'     => 'F1',  '1b4f51'     => 'F2',  '1b4f52'     => 'F3',  '1b4f53'     => 'F4',
                  '1b5b31317e' => 'F1',  '1b5b31327e' => 'F2',  '1b5b31337e' => 'F3',  '1b5b31347e' => 'F4',
                  '1b5b31357e' => 'F5',  '1b5b31377e' => 'F6',  '1b5b31387e' => 'F7',  '1b5b31397e' => 'F8',
                  '1b5b32317e' => 'F10', '1b5b32337e' => 'F11', '1b5b32347e' => 'F12'
                  );
    $Keyboard = $keymap{$Keyboard} if defined $keymap{$Keyboard};

                                # This can not be called from mh_control when in paused mode
    if ($Keyboard eq 'F2' and $pause_mode) {
        &toggle_pause;
        undef $Keyboard;
    }

}

                                # Check for stuff that must be out of the user code loop (e.g. reload_code)
use vars '@Nextpass_Actions';
sub check_for_nextpass_actions {
    for my $ref (@Nextpass_Actions) {
        &$ref;
    }
    undef @Nextpass_Actions;
}

                                # This is pretty much defunct now
sub toggle_debug {
    $config_parms{debug} = ($config_parms{debug}) ? 0 : 1;
    my $state = ($config_parms{debug}) ? 'on' : 'off';
    print "Debugging for $state turned on.\n" unless $state eq 'off';
    print "Debugging turned off.\n" unless $state ne 'off';
}
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 = "$config_parms{data_dir}/mh_log.txt" unless $logfile;
        print     "Output will be logged to $logfile\n";
        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 "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("Logging turned off");
    }
}
sub toggle_pause {
    if ($pause_mode) {
        &print_log('Leaving pause mode');
        print "Leaving pause mode\n";
        $pause_mode = 0;
    }
    else {
        &print_log('Entering pause mode');
        print "Entering pause mode\n";
        $pause_mode = 1;
    }
#   display "Sorry, not implemented yet";
}


sub add_proxy {
    my $my_address = $_[0];
    &print_log("Adding proxy server: " . $_[0]);
    unless ($proxy_servers{$_[0]}) {
        $proxy_servers{$_[0]} = new Socket_Item(undef, undef, $_[0], undef, undef, undef, "\035");
        $proxy_servers{$_[0]}->start;
    }
}

sub drop_proxy {
    if (defined $proxy_servers{$_[0]}) {
        $proxy_servers{$_[0]}->stop;
        delete $proxy_servers{$_[0]};
        &print_log("Removed proxy server: " . $_[0]);
    }
}


sub check_for_proxy_data {

                   # Check if proxies are still alive.
                   # If one is down, a start attempt can be slow (1-2 seconds), so don't do it too often
    if (new_second(15)) {
        for my $address (keys %proxy_servers) {
            my $proxy = $proxy_servers{$address};
            if (!$proxy->active) {
                unless ($proxy->start) {
                    &print_log("Proxy is dead: $address");
#                   delete $proxy_by_room{$address};
                          # Drop only dynamic proxies, like those in common/proxy_client_server.pl.
                          # Leave static ones, so we can keep testing it so we can reconnect when proxy comes back
                    &drop_proxy($address) if $config_parms{mh_proxyreg_port};
                    $address =~ s/\:\d+$//; # Shorten up name for speaking
                    $address =~ s/.+\.(\d+)$/$1/;
                    &speak("proxy $address is dead") if &new_minute(2);
                    next;
                }
            }
        }
    }

    for my $address (keys %proxy_servers) {
        my $proxy = $proxy_servers{$address};
        if (my $data = $proxy->said) {
            my ($type, @data) = split $;, $data;
            print "server proxy data received address: $address, type: $type, data: @data.\n" if $Debug{proxy};
            return unless $type;
            if ($type eq 'serial') {
                    # If port was named, store in that hash, otherwise process
                if ($data[1]) {
#           if (defined($Serial_Ports{$data[1]}{object})   and $Serial_Ports{$data[1]}{object} eq 'proxy') {
            if (defined($Serial_Ports{$data[1]}{datatype}) and $Serial_Ports{$data[1]}{datatype} eq 'raw') {
            $Serial_Ports{$data[1]}{data} = $data[0];
            }
            else {
            $Serial_Ports{$data[1]}{data_record} = $data[0];
            }
                    if ($Serial_Ports{$data[1]}{process_data}) {
                        &process_serial_data($data[0]);
                    }
                    else {
                        &Serial_data_hooks($data[0], $data[1], 'proxy');   # Created by &add_hooks
                    }
                }
                else {
                    &process_serial_data($data[0]);
                }
            }
            elsif ($type eq 'set_receive') {
                eval "$data[0] -> set_receive('$data[1]')";
                print "proxy set_receive eval error: $@" if $@;
            }
            elsif ($type eq 'set') {
                eval "$data[0] -> set('$data[1]')";
                print "proxy set eval error: $@" if $@;
            }
            else {
                &print_log( "Error, unknown proxy data: $type.\n");
            }
        }
    }
}

my @serial_data_buffer;
sub check_for_serial_data {
    return unless %Serial_Ports;
                                # Process remaining serial items from previous pass
    if (my $data = shift @serial_data_buffer) {
        print "Running serial_data_buffer string: $data\n" if $Debug{x10};
        &process_serial_data($data, 1);
        return;
    }

    &check_for_ti103_data if $Serial_Ports{ti103}{object} and $Serial_Ports{ti103}{object} ne 'proxy';
    &check_for_cm11_data if $Serial_Ports{cm11}{object} and $Serial_Ports{cm11}{object} ne 'proxy';
    &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};
    }
}

my ($leave_socket_open_passes, $leave_socket_open_action, $leave_socket_open_check);
use vars '%socket_fork_data';

sub check_for_socket_data_http {

    return unless $config_parms{http_port};

                                # These must be closed only AFTER the 'forked' Win32 process is done
    if ($OS_win and $socket_fork_data{process} and $socket_fork_data{process}->Wait(0)) {
        print "http: closing http port after forked process s=$socket_fork_data{socket}\n" if $Debug{http};
        $socket_fork_data{socket}->close if $socket_fork_data{socket};
    if ($config_parms{http_fork} eq 'memmap') {
        my $ret = $socket_fork_data{forkmem}->Close if $socket_fork_data{forkmem};
        print "http:************  $ret, UNDEFINED!!!!!\n" if (!defined $ret );
    }
                                # Do the next one, if in the que
        if ($socket_fork_data{next} and my $ptr = shift @{$socket_fork_data{next}}) {

            print "http: printing defered socket s=$$ptr[0]\n" if $Debug{http};
            &print_socket_fork_win(@{$ptr});
        }
        else {
            undef $socket_fork_data{process};
            undef $socket_fork_data{socket};
        }
    }

                                # 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}) {
    if ($leave_socket_open_action and
        (--$leave_socket_open_passes <= 0) or
        ($leave_socket_open_check and eval($leave_socket_open_check))) {
        my $sock = $Socket_Ports{http}{socka};
        print "http: closing http port with action: s=$sock a=$leave_socket_open_action\n" if $Debug{http};
        my @data = eval($leave_socket_open_action);
        print "Error in http lso action: $@\n" if $@;
        my $html = &html_page("", @data);
        print $sock $html if $sock;
        &socket_close('http');
        $leave_socket_open_passes = 0;
        $leave_socket_open_action = '';
        $leave_socket_open_check  = '';
    }

#   return if $leave_socket_open_passes; # Wait for previous request to finish
    return if $leave_socket_open_action; # Wait for previous request to finish

    my $loop_count = 0;
    my $time_check = time;
    while (1) {
                                # See if there is a http request
        my $nfound = &socket_has_data($Socket_Ports{http}{sock});
        last unless $nfound;
        my $sock = $Socket_Ports{http}{sock}->accept();
        last unless $sock; # Can be undef it socket was killed
        $sock->autoflush(1); # Not sure if this does anything?
        $Socket_Ports{http}{socka} = $sock;

        ($leave_socket_open_passes, $leave_socket_open_action) = &http_process_request($sock);

        my $time_diff = time - $time_check;
        print "http: c=$loop_count td=$time_diff sop=$leave_socket_open_passes soa=$leave_socket_open_action.\n" if $Debug{http};

        if ($leave_socket_open_action) {
            last;               # Wait for socket action to finish before we process the next request
        }
        else {
                                # forked socket needs no closing, and can not have a open_action
            if ($leave_socket_open_passes and $leave_socket_open_passes < 0) {
                $leave_socket_open_passes = 0;
            }
            else {
                                # We must sleep here for a bit, or else Netscape sometimes
                                # says 'Document contains no data'.  Guess we don't need this anymore :)
#               select undef, undef, undef, .010;
                &socket_close('http');
            }
        }

                                # Process more requests if present, for a faster server,
                                # but let mh do other things periodically
#      last if $loop_count++ > 100;
       last if $loop_count++ > 100 or $time_diff > 1;
    }
}

sub check_for_socket_data {

    my (@active_ports, @ports_with_data);

                                # 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 if $port_name eq 'http'; # Deal with this elsewhere
                                # Need to use _flag var so active/inactive_this_pass is valid for 1 full pass.
        $Socket_Ports{$port_name}{active_this_pass} = 0;
        $Socket_Ports{$port_name}{active_this_pass} = 1   if $Socket_Ports{$port_name}{active_this_pass_flag};
        $Socket_Ports{$port_name}{inactive_this_pass} = 0;
        $Socket_Ports{$port_name}{inactive_this_pass} = 1 if $Socket_Ports{$port_name}{inactive_this_pass_flag};
        $Socket_Ports{$port_name}{active_this_pass_flag}   = 0;
        $Socket_Ports{$port_name}{inactive_this_pass_flag} = 0;
        next unless my $sock = $Socket_Ports{$port_name}{sock};

                                # Check to see if any already open client sockets are active
        my $server_active = 0;
        if ($Socket_Ports{$port_name}{clients}) {
            my $client_number = 0;
            for my $ptr (@{$Socket_Ports{$port_name}{clients}}) {
                my ($socka, $client_ip_address, $client_port, $data) = @{$ptr};
                next unless $socka;
                if (my $nfound = &socket_has_data($socka)) {
                                # Set default to active socket
                    $Socket_Ports{$port_name}{socka}             = $socka;
                    $Socket_Ports{$port_name}{client_number}     = $client_number;
                    $Socket_Ports{$port_name}{data}              = $data;
                    $Socket_Ports{$port_name}{client_ip_address} = $client_ip_address;
                    $Socket_Ports{$port_name}{client_port}       = $client_port;
                    print "socket: $port_name nfound=$nfound client=$client_number" if $Debug{$port_name};
                    $server_active = 1;
                    last;
                }
                $client_number++;
            }
        }
        unless ($server_active) {
                                 # Check for sockets where mh is a client, not a server (only one active socket possible)
            if (!$Socket_Ports{$port_name}{port} or $Socket_Ports{$port_name}{protocol} eq 'udp') {
                $server_active = 1 if $Socket_Ports{$port_name}{socka};
            }
                                 # Else look for new clients
            elsif (my $nfound = &socket_has_data($sock) and my $new_sock = $sock->accept()) {
                $new_sock->autoflush(1); # Not sure if this does anything?
                                               # Log the address of the client
                my $peer = $new_sock->peername;
                my ($client_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;
                $Socket_Ports{$port_name}{client_port} = $client_port;
                $Socket_Ports{$port_name}{socka} = $new_sock;
                $Socket_Ports{$port_name}{active_this_pass_flag} = 1;

                push @{$Socket_Ports{$port_name}{clients}}, [$new_sock, $client_ip_address, $client_port, undef];
                delete $Socket_Ports{$port_name}{data}; # Delete data from previous session
                $Socket_Ports{$port_name}{client_number} = @{$Socket_Ports{$port_name}{clients}} - 1;

                logit "$config_parms{data_dir}/logs/server.$Year_Month_Now.log",  "$port_name $client_ip_address";
                print "\nsocket: $port_name active sock=$new_sock client=$client_ip_address.\n" if $Debug{$port_name};

                $server_active = 1;
            }
        }
        push(@active_ports, $port_name) if $server_active;
    }

                                           # See if any active ports have data
    for my $port_name (@active_ports) {
        my $sock = $Socket_Ports{$port_name}{socka};
        if (my $nfound = &socket_has_data($sock)) {
#           print "socket: $port_name nfound=$nfound " if $Debug{$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
                if ($!{EINTR}) {
                                # It is safe to ignore EINTR on socket selects (as socket_has_data does)
                    print "socket: $port_name encountered EINTR and ignoring\n" if $Debug{'socket'};
                } else {
                	print "socket: closing socket port $port_name due to error on select\n" if $Debug{'socket'};
                	&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) if $from_saddr;
                $Socket_Ports{$port_name}{from_port} = $from_port;
                $Socket_Ports{$port_name}{from_ip}   = $from_ip;
            }
        }
        print "socket data: port=$port_name data=$data.\n" if $Debug{$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 "socket: closing socket port $port_name\n" if $Debug{$port_name};
            &socket_close($port_name);
        }
        else {
            $Socket_Ports{$port_name}{data} .= $data if defined $data;
            print "socket: port=$port_name data=$data.\n" if $Debug{$port_name};

            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;
            }
        }
    }

                                # Look for 'records' based on break separator
                                #  - this data may have been read from a previous pass
    for my $port_name (keys %Socket_Ports) {
        next if $port_name eq 'http'; # Deal with this elsewhere
        next unless $Socket_Ports{$port_name}{data};

                                # If raw mode, return data as is
        if ($Socket_Ports{$port_name}{datatype} and $Socket_Ports{$port_name}{datatype} eq 'raw') {
            next;
        }

                                # Look for data separator (default is newline)
        my $break = $config_parms{"${port_name}_break"};
        $break = $Socket_Ports{$port_name}{break} if $Socket_Ports{$port_name}{break};
        $break = "[\r\n]+" unless $break;
#        $break = "[\r\n]+";

        if ( my($record, $remainder) = $Socket_Ports{$port_name}{data} =~ /(.+?)$break(.*)/s) {
            $Socket_Ports{$port_name}{data_record} = $record;
            $Socket_Ports{$port_name}{data}        = $remainder;
            if ($Debug{$port_name}) {
                print "socket: port=$port_name record=$record, r=$remainder.\n";
#               print "socket: $port_name record=$record.  hex=", unpack('H*', $record), "\n";
#               print "socket: $port_name remainder=$remainder.  hex=", unpack('H*', $remainder), "\n";
            }
        }
                                # Store away Client data
        my $client_number = $Socket_Ports{$port_name}{client_number};
        $Socket_Ports{$port_name}{clients}[$client_number][3] = $Socket_Ports{$port_name}{data} if defined $client_number;

                                # 10/99 Comment out \r\n print ... what needed this?? Messed up viavoice server
#       print $sock "\r\n";
#       print $sock "You said: $record\n";

    }

}

                                # These tied subs are called by mh/lib/Generic_Item.pm
                                # They are called in main mh so evals work ok
sub check_for_tied_events {
    my @objects = @_;
    for my $object1 (@objects) {
        next unless  $object1 -> isa('Generic_Item'); # Safeguard ... should not need this
        my $state1 = $object1 -> state;
        $state1 = $object1->{state} unless defined $state1;  # In case default_getstate fails for whatever reason

        &State_change_hooks($object1, $state1); # Created by &add_hooks

        print "Object link: starting enumeration for object=$object1->{object_name} state=$state1\n" if $Debug{events};

        for my $key (keys %{$$object1{tied_objects}}) {

                                # If the tied object is not tied to that state,
                                # see if it is tied to all_states
            my $state_key = $state1;
            $state_key = 'all_states' unless $$object1{tied_objects}{$key}{$state_key};

            if ($$object1{tied_objects}{$key}{$state_key}) {
                for my $state2 (sort keys %{$$object1{tied_objects}{$key}{$state_key}}) {
                    my ($object2, $log_msg) = @{$$object1{tied_objects}{$key}{$state_key}{$state2}};
                    &print_log($log_msg) unless $log_msg eq '1';
#                   $state2 = $state1 unless defined $state2;
                    $state2 = $state1 if $state2 eq 'all_states';
                    if ($object2->can('set')) {
                                # Make sure we don't get into a loop with cross-tied objects
                        unless ($object1->{set_by} and
                                ($object1->{set_by} eq $object2 or
                                 $object1->{set_by} eq $$object2{object_name} ) ) {
#                           $object2->{set_by} = $object1->{object_name};
#                           $object2->{set_by} = $object1;
		            my $Set_By = $object1->{set_by};
                            $Respond_Target = $object1->get_target(); # Pass target along
			    $Respond_Target = $Set_By unless $Respond_Target or ref $Set_By; # Just for legacy code (speak chimes)
                            $object2->set($state2, $object1);
                        }
                    }
                    else {
                        print "tie_items object can not set: $object2\n";
                    }
                }
            }
        }

        for my $event (keys %{$$object1{tied_events}}) {
            my $state_key = $state1;
            $state_key = 'all_states' unless $$object1{tied_events}{$event}{$state_key};

            if (my $log_msg = $$object1{tied_events}{$event}{$state_key}) {
                &print_log($log_msg) unless $log_msg eq '1';
                print "Event link: eval event=$event\n" if $Debug{events};
                my $state = $state1; # So eval can substitute $state
                my $object=$object1;
                $Set_By = $object1->{set_by};        # Checked in Generic_Item set method (not usually at this time)

                $Respond_Target = $object1->get_target() if defined $object1->get_target(); # Pass target along (IF it exists, else we overwrite good value!)
		$Respond_Target = $Set_By unless $Respond_Target or ref $Set_By; # Just for legacy code (speak chimes)
                eval $event;
                $Set_By = '';
                print "tie_events eval error: $@" if $@;
            }
        }

    }
}

sub check_for_tied_filters {
    my ($self, $state, $set_by) = @_;

    if ($$self{tied_filters}) {
        my $searchstate = $state;
        $searchstate = lc($searchstate) unless defined $self->{states_casesensitive};
        for my $filter (keys %{$$self{tied_filters}}) {
            my $log_msg;
            if ($log_msg = $$self{tied_filters}{$filter}{$searchstate} or
                $log_msg = $$self{tied_filters}{$filter}{all_states}) {
                print "Item tie_fiter test for $self->{object_name} filter: $filter  state:$searchstate\n"  if $Debug{filters};
                if (eval $filter) {
                    print "Item tie_filter triggered for $self->{object_name} $filter\n" if $Debug{filters};
                    &print_log($log_msg) unless $log_msg eq '1';
                    return 1;
                }
            }
        }
    }

    # Check for stacked multi-states.   Here are some examples of the ~ and ; tied together.
    #
    # State: 'on~10~random:on;repeat:on;play'
    #     We should wind up calling set_with_timer with 'on,10,;random:on;repeat:on;play'.
    #     This will assure that the additonal processing occurs after the timeout.
    #
    # State: 'repeat:on;play~3600~stop'
    #     We should wind up calling set on repeat:on and then set with timer on play~3600~stop
    #
    # State: 'repeat:on;play~3600~stop;repeat:off'
    #     We should wind up calling set on repeat:on and then set with timer on play~3600~stop;repeat:off
    #
    # Find first ;

    # Is this a state string with multiple sets in it?  If so we take over and call set on each state found.
    # If not, we are already in a set call, so don't do any additional processing.

#   print "dbx1 o=$self->{object_name} ms=$self->{states_nomultistate} s=$state\n";
    unless ($self->{states_nomultistate}) {
        if($state =~ /;/) {
            print "Multiple states entry state=$state\n" if $Debug{state};
            while ( my ($currentstate, $remainingstate) = split(/;/, $state, 2) ) {
                print "Multiple states split into state=$currentstate remainder=$remainingstate\n" if $Debug{state};
                $state = $remainingstate;

            # Check for states with a embedded set_with_timer directive
                return 1 if check_for_embedded_commands($self, $currentstate, $remainingstate);

            # Set the object to the currentstate, we will then loop and repeat
            #print ">>>>>set state=$currentstate\n";
                $self->set($currentstate);
            }
            return 1;
        }
        else {
        # Check for states with a embeded set_with_timer directive
            return check_for_embedded_commands($self, $state);
        }
    }
    return 0;
}

sub check_for_embedded_commands {
    my ($self, $state, $remainingstates) = @_;

                                # Allow for embeded objects (e.g.: $Pool;on)
    if($state =~ /^\$.*/) {
        my $ref = eval "ref $state";
        print "check_for_embedded_commands found $state->set('$remainingstates') ref=$ref\n"  if $Debug{state};
        if ($ref) {
            eval "$state->set('$remainingstates');";
            print "generic_item set invalid multistate $state->set('$remainingstates'); (:$@)\n" if $@;
            return 1;
        }
    }

    # Check for states with a embeded set_with_timer directive
    if (my ($s1, $time, $s2) = $state =~ /(.*?)~(.+?)~(.*)/ and
        $self->can('set_with_timer')) {
        print "Multiple states set with timer state=$s1 time=$time afterstate=$s2\n" if $Debug{state};
        $self->set_with_timer($s1, $time, $s2, $remainingstates);
        print "Embeded set_with_timer state found for $self->{object_name}: s1=$s1, time=$time, s2=$s2\n"  if $Debug{filters};
        return 1;
    }
}

sub check_for_tied_times {
                                # time_* calls are minute based (except for idle:XX seconds)
    return unless $New_Second;

    for my $ref (@Generic_Item::items_with_tied_times) {
        for my $time (keys %{$$ref{tied_times}}) {
            for my $state (keys %{$$ref{tied_times}{$time}}) {
                my $triggered = 0;
                print "Item tie_time test for $ref->{object_name} time: $time  state:$state\n"  if $Debug{tied_times};
                                # Look for time_idle specs like:
                                #  'time_idle 10 minutes', 'time_idle 2 seconds', 'time_idle 24 hours',
                                #  'time_idle 7 days', 'time_idle 1 hour on'
                if (my ($idle_time) = $time =~ /time_idle (.+)/) {
                                # Should we do this check for the other triggers??
                                #  We also need it to verify the state is not equal to the requested state,
                                #  to avoid resetting the idle timeout by setting an object to the state it already is?
                    if ($state ne $ref->state()) {
                        print "Item tie_item found idle_time=$idle_time\n" if $Debug{tied_times};
                        $triggered = 1 if $ref->time_idle($idle_time);
                    }
                }
                elsif ($New_Minute) {
                                                  # Check for time_cron format, else default to time_now
                    my @a = split ' ',$time;
                    if (5 == @a) {
                        $triggered = 1 if &time_cron($time);
                    }
                    else {
                        $triggered = 1 if &time_now($time);
                    }
                }
                if ($triggered) {
                    print "Item tie_time triggered for $ref->{object_name} $time\n" if $Debug{tied_times};
                    my $log_msg = $$ref{tied_times}{$time}{$state};
                    &print_log($log_msg) unless $log_msg eq '1';
                    if ($ref->can('set')) {
#                       $ref->{set_by} = 'tied_time';
                        $ref->set($state, 'tied_time');
                    }
                    else {
                        print "tie_items object can not set: $ref->{object_name}\n";
                    }
                }
            }
        }
    }
}


sub convert_k2f {       # Convert degrees Kelvin to Farenheight
    sprintf("%3.1f", 32 + (9/5)*($_[0] - 273.15));
}
sub convert_c2f {       # Convert degrees Celsius to Farenheight
    sprintf("%3.1f", 32 + (9/5)*($_[0]));
}
sub convert_f2c {       # Convert degrees fahrenheit to celsius
     sprintf("%3.1f", (5/9)*($_[0] - 32));
}
sub convert_f2k {       # Convert degrees fahrenheit to kelvin
     sprintf("%3.1f", (5/9)*($_[0] - 32) + 273.15);
}
sub convert_mb2in {     # Convert millibars to inches of mercury
     sprintf("%4.2f", $_[0] * 0.029529987508);
}
sub convert_in2mb {     # Convert to inches of mercury to millibars
     sprintf("%4.2f", $_[0] / 0.029529987508);
}
sub convert_km2mile {   # convert kilometers (per hour) to miles (per hour)
     sprintf("%5.2f", $_[0] / 1.609344);
}
sub convert_mile2km {   # convert miles (per hour) to kilometers (per hour)
     sprintf("%5.2f", $_[0] * 1.609344);
}
sub convert_mps2mph {   # convert meters per second to miles per hour
    sprintf("%5.2f", $_[0] * 2.23693632);
}
sub convert_mph2mps {   # convert miles per hour to meters per second
    sprintf("%5.2f", $_[0] / 2.23693632);
}
sub convert_mps2kph {   # convert meters per second to kilometers per hour
    sprintf("%5.2f", $_[0] * 3.6);
}
sub convert_kph2mps {   # convert kilometers per hour to meters per second
    sprintf("%5.2f", $_[0] / 3.6);
}
sub convert_nm2mile { # convert nautical miles (knots) to miles (per hour)
	sprintf("%5.2f", $_[0] * 1.150779448);
}
sub convert_mile2nm { # convert miles (per hour) to nautical miles (knots)
	sprintf("%5.2f", $_[0] / 1.150779448);
}
sub convert_nm2km { # convert nautical miles (knots) to kilometers (per hour)
	sprintf("%5.2f", $_[0] * 1.85198849217);
}
sub convert_km2nm { # convert kilometers (per hour) to nautical miles (knots)
	sprintf("%5.2f", $_[0] / 1.85198849217);
}
sub convert_knots2mps { # convert knots to meters per second
	sprintf("%5.2f", $_[0] * 6.66715857181);
}
sub convert_mps2knots { # convert meters per second to knots
	sprintf("%5.2f", $_[0] / 6.66715857181);
}
sub convert_mm2in { # convert millimeters (per hour) to inches (per hour)
     sprintf("%5.2f", $_[0] * 0.0393700787402);
}
sub convert_in2mm { # convert inches (per hour) to millimeters (per hour)
     sprintf("%5.2f", $_[0] / 0.0393700787402);
}

sub convert_direction {
    my ($dir) = @_;
    return 'unknown'    if $dir !~ /^[\d \.]+$/;
    return 'north'      if $dir <  30 or $dir >= 330;
    return 'north east' if $dir <  60;
    return 'east'       if $dir < 120;
    return 'south east' if $dir < 150;
    return 'south'      if $dir < 210;
    return 'south west' if $dir < 240;
    return 'west'       if $dir < 300;
    return 'north west' if $dir < 330;
    return 'outer space';
}

sub display {
    my %parms = &parse_func_parms(@_);

    unless (defined $parms{text} and $parms{text} ne '') {
        ($parms{text}, $parms{time}, $parms{title}, $parms{font},
         $parms{window_name}, $parms{append}) = @_;
    }
    else {
	&set_app_parms(\%parms, 'display');     # Set parms according to an optional app parm
    }

    print "db display t=$parms{text} d=$parms{device} p=@_\n" if $Debug{display};

    my $text = $parms{text};
    return unless $text;        # No data


                                # If it is a TXT file, read it
    if ($text =~ /^\S+\.txt$/ and -e $text) {
        open IN, $text or print "Error in sub display, could not open file $text:$!\n";
        local $/ = undef;       # Slurp the whole file at once
        $text = <IN>;
        close IN;
    }

    unshift (@Display_Log, $text);
    pop @Display_Log if @Display_Log >  $config_parms{max_log_entries};
    &Log_hooks('display', $text, %parms);   # Created by &add_hooks

                                # Allow for display_device functions (e.g. lib/Display_Alpha.pm display_alpha)
    if ($parms{device}) {
        my $use_tk = 0;
        my (@display_devices) = split(/[,;|]/, $parms{device});
        for my $device (@display_devices) {
            if ($device eq 'tk') {
               $use_tk = 1;
            } else {
               my $func = "display_$device";
               if ($main::{$func}) {
                  no strict 'refs';
                  eval &$func(%parms);
               }
            }
        }
        return unless $use_tk;
    } elsif ($parms{display_rooms}) {
        return unless &route_display_rooms(%parms);
    }

                                # Assume we were waiting for this and reset http server counter. Speak has precedence. (?)

	# *** Could this be any less clear?  Global $Last_Response should be deprecated.

    $Last_Response = 'display' unless $Last_Response eq 'speak';
    $leave_socket_open_passes = 1 if $leave_socket_open_passes;

    return if ($leave_socket_open_passes and !defined $parms{time} and defined $parms{target} and $parms{target} =~ /^web/);
	# *** For legacy modules (what is left of them)

    return if (!$parms{target} and $Respond_Target =~ /^web/);


                                # Unless this was called from the web, display it with tk
    if ($config_parms{tk}) {
        $parms{title} = ucfirst($parms{app}) || $Time_Now unless $parms{title}; # Default Title
	# Logic is in configure_element
#        $parms{font}  = $config_parms{tk_font} unless $parms{font};
                                # Do not display if from web, unless display time is requested
	my $return_object;



	if (defined($parms{window_name}) and $custom_child_windows{"$parms{app} $parms{window_name}"}) {
		# Try to create custom window
		eval "\$return_object = &open_$parms{app}_$parms{window_name}_window()";
	}
	$return_object = new Display(%parms) unless $return_object;
	return ((ref $return_object)?$return_object:0);
    }
    else {
        print "Display call with tk disabled (-tk 0).  Text=@_\n";
    }

}

sub display_log_last {
                                # Return the last how_many displayed phrases
    my ($how_many) = @_;
    my $count = @Display_Log;
    if ($how_many >= $count) {
        return @Display_Log;
    }
    else {
        return (@Display_Log[0 .. ($how_many-1)]);
    }
}

sub eval_user_code_load {
    &print_log((($Startup)?'E':'Ree') . "valuating user code");

                                # Certain errors (e.g. 'Global symbol $xyz requires ...') do not
                                # show up in $@, but we can trap them with the WARN signal.
                                # Skip Subroutine xyz redfined warnings, as we do this a lot on reload
    local $SIG{__WARN__} = sub {
        return if $_[0] =~ /redefined at/;
        $@ = "\n$Time_Date Oops1: $_[0]";
        print "$@\n";
#       play('file' => $config_parms{sound_error});
    };


    eval $user_code;
    if ($@) {
        my $old_error = $@;

                                # This attempt on trying to find which file has the error does not
                                # work well if there is noloop directives.  That causes the items
                                # code to refer to subroutines that are in other members, so doing
                                # and eval on just the item code causes 'undefined sub' errors.
                                # Also, this error analysis is pretty slow.
        if ($config_parms{error_by_file}) {
                                # See if the error is in the item code;
            print "Coding error found ...\n";
            print " - checking item code\n";
            my $item_code = join '', @Item_Code;
            &eval_user_code_reset;
            eval $item_code;

            if ($@) {
                my $error = "\nError in item/global_var code:\n  " . &eval_user_code_error($@, $item_code);
                print $error;
                &display($error, 60) unless $Startup or !$config_parms{tk};
                undef $old_error;
            }

                                # Try each code member, one at a time, till we find the error
                                #  - must include item code or global my vars cause errors :(
            else {
                for my $sub_code (@Sub_Code) {
                    my ($member) = $sub_code =~ /sub (\S+)_loopcode /;
                    print " - checking loop code for $member\n";
                    my $temp_code = $item_code . $sub_code;
                    &eval_user_code_reset;
                    eval $temp_code;
                    if ($@) {
                        my $error = "\nError in file $member:\n  " . &eval_user_code_error($@, $temp_code);
                        print $error;
                        &display($error, 60) unless $Startup or !$config_parms{tk};
                        undef $old_error;
                        last;
                    }
                }
            }
        }

        if ($old_error) {
            my $error = "\nError in user code file $config_parms{data_dir}/mh_temp.user_code\n\n  " .
                &eval_user_code_error($old_error, $user_code);
            print $error;
            &display($error, 60) unless $Startup or !$config_parms{tk};
        }

        exit 1 if !$user_code_last_good;

        print "\nLoading in previous user code\n";
        $user_code = $user_code_last_good;
        &eval_user_code_reset;
        eval $user_code;
        &object_states_restore; # Put vars back to their last know state
        &Reload_post_hooks();   # Created by &add_hooks (after object states have been restored)

        print "Activate voice menu\n";
        &Voice_Cmd::activate;
        play('file' => $config_parms{sound_error});
    }
    else {
        print "\nGood code saved\n";
        $user_code_last_good = $user_code;
        play('file' => $config_parms{sound_reload});
#       &file_write('mh.started', $$); # Used in mh.bat and mhl to loop on accidental exit
        unlink 'mh.startup';           # Used in mh.bat and mhl to loop on accidental exit
    }
}

my $usercode_error_flag;
sub eval_user_code_loop {

                                # Dis-regard -w uninitialzed value warnings.
                                #  - also seems to save a lot of cpu time in loop_code
    local $SIG{__WARN__} = sub {
        return if $_[0] =~ /uninitialized value/ or $_[0] =~ /redefined at/;
        print "\n$Time_Date Oops2: $_[0]\n";
#       play('file' => $config_parms{sound_error});
    };
#    local $SIG{__DIE__} = sub {
#        print "\n$Time_Date Dieing: $_[0]\n";
#        exit 1;
#    };
#   &loop_code;
    eval "&loop_code";          # Not too much slower ... catches more errors
    if ($@) {
                                # Display usercode errors only once
        if ($usercode_error_flag) {
            print "Error in user code: $@";
        }
        else {
            $usercode_error_flag++;
            my $error = "Error found in user code file: $config_parms{data_dir}/mh_temp.user_code\n\n";
            $error .= &eval_user_code_error($@, $user_code);
            print $error;

	    # *** what is the logic of this line?  Display if tk disabled?

            &display($error, 0) unless $config_parms{tk};
            &speak("app=error Error found in user code.  Check the error log.") unless $config_parms{no_speak_errors} =~ /error/i;

                                # Log these errors for review
            print ERRORLOG (&time_date_stamp(1), $Time)[0], ":\n  $error\n";
            print "Error logged to: $config_parms{data_dir}/error.log\n";
        }
    }

    $Respond_Target  = undef;  # This is only valid during the user code loop
}

sub eval_user_code_error {
    my ($error, $code) = @_;
                                # Example errors:
                                #  Can't call method "state_now" without a package or object reference at (eval 55) line 2, <CODE> ch
                                #  Variable "$i_tempx_outside" is not imported at (eval 58) line 187, <CODE> chunk 13.
                                #  Undefined subroutine &main::abc called at (eval 39) line 59.
                                #  Global symbol "$a1" requires explicit package name at (eval 39) line 60.
    my ($line1, $line2) = $error =~ /at\s+\(eval\s+(\d+)\)\s+line\s+(\d+)/;
    $error =~ s/\seval .+//s;     # Drop listing of eval-ed code (shown if -diagnostics 1)
    my @code = split("\n", $code);
    if (defined $line2) {
        $line2 -= 6;
        $line2  = 0 if $line2 < 0;
        my $i   = 0;
        while ($i++ < 11) {
            last if $line2++ > $#code;
            $error.="Line $line2:  ". $code[$line2-1]. "\n";
        }
    }
    return "$Time_Date: " . $error;
}

sub eval_user_code_reset {
    &Socket_Item::reset;        # So we can check for duplicate items
    &Device_Item::reset;        # So we can check for duplicate items
    &Voice_Cmd::reset;          # So we can check for duplicate voice commands.
    &X10_Item::reset;           # Reset some list arrays
    &EIB_Item::reset;           # Reset some list arrays
    &reset_hook_code;           # This frees up old user code hooks

                                # Since we created new objects, lets de-reference all the old ones
    &Timer::delete_old_timers;
    &Generic_Item::delete_old_tied_times;
     # Weather_Item.pm keeps an array containing all Weather objects
     # It must be cleared on resets, otherwise old copies of Weather objects are kept around
     # This is a memory leak and can cause multiple tied_{object/events}
    &Weather_Item::clear_weather_item_list;
}

sub eval_with_timer {
    my ($action, $time)= @_;
    print "eval_with_timer: time=$time action=$action\n" if $Debug{timer};
    return unless $time;
    my $timer = &Timer::new();
    &Timer::set($timer, $time, $action);
}

sub exit_pgm {
    my ($restart) = @_;
    $Save{mh_exit} = ($restart) ? 'restart' : 'normal';
    if ($restart) {
	print "Restarting\n";
    }
    else {
	print "Exiting\n";
    }


    if ($main::Info{OS_name}=~ /darwin/i) {  # Should go into Voice::Text?
      Dispose_Speech_Channel();
    }
    &Voice_Cmd::remove_voice_cmds if $config_parms{voice_cmd};
    &Exit_hooks();              # Allow user code exits
    &run_kill_processes;        # From handy_utilities ... kills anybody that isn't done yet
    &Process_Item::stop();

                                # Used in mh/code/common/mh_control to
                                # display a auto-restarted window
    &object_states_save;

                                # Close all ports to be safe
    for my $port (keys %Serial_Ports) {
        my $object = $Serial_Ports{$port}{object};
#        $object->close() if $object and $object ne 'proxy';
        $object->close() if $object and $object ne 'proxy' and $object ne 'wish';
    }
    for my $port (keys %Socket_Ports) {
        my $sock = $Socket_Ports{$port}{sock};
        $sock->close() if $sock;
    }
                                # Use exit code 1 to mean we exited on purpose ... anything else
                                # we can use in mh_loop to mean accidental exit, 'better restart'
    if ($restart) {
        &print_log("Restarting mh");
#       exit 99;
        POSIX::_exit(99);       # MUCH faster ... but no DESTROY or END called.
    }
    else {
        print "Bye Bye\n";
#       exit 1;
        POSIX::_exit(1);        # MUCH faster ... but no DESTROY or END called.
    }
}

END {
#   print "Exiting mh\n";       # Will not see this (or DESTROY) with fast POSIX::_exit
}



sub file_changed {
    my ($file) = @_;
    my ($file_time);
                                # Trigger a file_changed if the file is added, deleted, or changed
    if (-e $file) {
        $file_time = (stat($file))[9];
    }
    else {
        $file_time = 0;
    }

#    print "Warning, file_change file does not exist: $file\n" unless -e $file;
    print "db file_change file=$file time=$file_time time_old=$file_change_times{$file}\n" if $Debug{file};
                                # 1st time we look at a file, return 'unknown' (-1)
    unless (defined $file_change_times{$file}) {
        $file_change_times{$file} = $file_time;
        return undef;
    }
    return 0 if $file_time == $file_change_times{$file}; # File has not changed since last call
    $file_change_times{$file} = $file_time;              # Reset time
    print "File changed: time=$file_time file=$file\n" if $Debug{file};
    return 1;
}

sub file_size {
    return (stat($_[0]))[7];
}

sub file_unchanged {
    my ($file) = @_;
    my $flag = &file_changed($file);
    if (defined $flag) {
        return !$flag;
    }
    else {
        return undef;
    }
}
                                # Grandfatherd old name
sub file_change {
    return &file_changed(@_);
}

sub file_diff {
    my($file1, $file2) = @_;
    open (FILE1, $file1) or print "Warning, could not open file $file1\n", return 1;
    open (FILE2, $file2) or print "Warning, could not open file $file2\n", return 1;
    my(@data1) = <FILE1>;
    my(@data2) = <FILE2>;
    close FILE1;
    close FILE2;
    return !("@data1" eq "@data2");
}


                               # Look for the calling program
                               # Used by Generic_Item set_by
sub get_calling_sub {
    my $x=1;   ## don't need to check [0] (self)
#   print "loopcode_search: ",scalar(localtime(time())),"\n";
    while(my($pkg, $filename, $line, $subroutine) = caller($x++)) {
#       print "loopcode_search: $x [$pkg] [$filename][$subroutine]\n";
        if($subroutine =~ s/^main::(.*)_loopcode$/UserCode [$1.pl]/){
#           print "loopcode_search: set_by=$subroutine\n";
            return $subroutine;
        }
    }
    return undef;
}

sub get_ip_address {
    my ($hostname) = @_;

                                # gethostbyname will default to the local box if left blank
                                #  - Sys::Hostname will add ISP name onto local box name :(
                                #  - hmmm, gethostbyname does not work on some linux boxes with bank arg.
   use Sys::Hostname;
   $hostname = hostname() unless $hostname and !$OS_win;

    my @host_data = gethostbyname($hostname);
    my @ip_addresses = map {inet_ntoa($_)} @host_data[4 .. $#host_data];
    print "IP addresses for $hostname are @ip_addresses\n" if $Debug{misc};
    return wantarray ? @ip_addresses : $ip_addresses[-1]; # Assume last one is most interesting ... usually IP address
}

sub get_object_by_name {
    my ($object_name) = @_;
    $object_name = '$' . $object_name unless $object_name =~ /^\$/;
    return $objects_by_object_name{$object_name};
}

sub help {
    my $topic = shift;
    if ($topic eq 'neighborhood') {
	&browser("http://www.frappr.com/misterhouse");
    }
    elsif ($topic eq 'wiki') {
	&browser("http://misterhouse.wikispaces.com");
    }
    elsif ($topic eq 'faq') {
	&browser("$Pgm_Path/../docs/faq.html");
    }
    elsif ($topic eq 'examples') {
	&browser("$Pgm_Path/../docs/examples.html");
    }
    else {
        &browser("$Pgm_Path/../docs/index.html");
    }
}

sub is_local_address {
    my ($address) = @_;
                                # Default to the web client
    $address = $Socket_Ports{http}{client_ip_address} unless $address;
#   return grep $address =~ /$_/, @Local_Addresses;
    return (grep $address =~ /$_/, @Local_Addresses) ? 1 : 0;
}

sub last_response {
    $Last_Response = '' unless $Last_Response;
    my $last_response;
    if ($Last_Response eq 'speak') {
        ($last_response) = &speak_log_last(1);
        $last_response =~ s/\n/  /g;         # Remove line breaks
        $last_response =~ s/^.+?: //s;       # Remove time/date/status portion of log entry
    }
    elsif ($Last_Response eq 'display') {
        ($last_response) = &display_log_last(1);
    }
    elsif ($Last_Response eq 'print_log') {
        ($last_response) = &print_log_last(1);
    }
    $Last_Response = '';
#   print "db LR=$Last_Response lr=$last_response\n";
    return $last_response;
}

sub list_code_files {
    return sort {lc($a) cmp lc($b)} keys %object_names_by_file;    # Case insensitive sort
}
sub list_code_webnames {
    my ($type) = @_;
    my @a = keys %object_names_by_webname;

                                # If object type was requested, return only categores that had that type
    if ($type) {
        my %categories;
        for my $category (@a) {
            for my $object_name (&list_objects_by_webname($category)) {
                my $object = &get_object_by_name($object_name);
                next unless $object and $object->isa($type);
                $categories{$category} = 1;
            }
        }
        @a = keys %categories;
    }

    return sort {lc($a) cmp lc($b)} @a;
}
sub list_files_by_webname {
    my ($webname) = @_;
    $webname =~ s/_/ /;         # Take out _ put in by http_server.pl

                                # If there are no files listed, then it must be
                                # a file without a category, to return webname.
    return ($files_by_webname{$webname}) ? @{$files_by_webname{$webname}} : $webname;
}

sub list_groups_by_object {
    my ($object) = @_;
    my @groups;
    for my $group_name (&list_objects_by_type('Group')) {
      my $group = &get_object_by_name($group_name);
#     print "testing group=$group_name -> $group\n";
      for my $object2 (list $group) {
    push @groups, $group if $object eq $object2;
      }
    }
    return @groups;
}

sub list_objects_by_file {
    return @{$object_names_by_file{$_[0]}};
}
sub list_objects_by_type {
    my ($object_type) = @_;
    return unless $object_names_by_type{$object_type};
    return @{$object_names_by_type{$object_type}};
}
sub list_objects_by_type2 {
    my ($object_type) = @_;
    my @object_list = &list_objects_by_type($object_type);
    return map{&get_object_by_name($_)} @object_list;
}


sub list_objects_by_group {
    my ($group_name) = @_;
    $group_name = '$' . $group_name unless $group_name =~ /^\$/;
    if (my $object = &get_object_by_name($group_name)) {
        my @objects = list $object;
        return (map {$_->{object_name}} @objects);
    }
}

sub list_objects_by_webname {
    return unless $_[0];
    return @{$object_names_by_webname{$_[0]}} if $object_names_by_webname{$_[0]};
}
sub list_object_types {
    return sort keys %object_names_by_type;
}
sub list_voice_cmds {
    my ($vocab) = @_;
    return &Voice_Cmd::voice_items($vocab);
}
sub list_voice_cmds_match {
    my ($cmd, $vocab) = @_;
                                # Not sure why grep // returns empty list, so lets avoid it
    if ($cmd) {
        $cmd = quotemeta $cmd;      # Avoid regex errors:  e.g. $cmd='+20'
        return grep /$cmd/, &list_voice_cmds($vocab);
    }
    else {
        return &list_voice_cmds($vocab);
    }
}

                                 # These functions can be used to change .mht entries
sub mht_item_copy {
    my ($file, $pos) = @_;
    my @file_data = &file_read($file);
    my $pos2 = @file_data;
    $file_data[$pos2] = $file_data[$pos];
#   print "db copy $pos to $pos2: $file_data[$pos2]\n";
}

sub mht_item_delete {
    my ($file, $pos) = @_;
    my @file_data = &file_read($file);
    my $pos2 = @file_data;
    $file_data[$pos] = '';
    &mht_item_file_write($file, \@file_data);
}

sub mht_item_add {
    my ($file, @parms) = @_;
    return unless @parms;
    my @file_data = &file_read($file);
    my $record;
    for my $p (@parms) {
        $record .= "$p,  ";
    }
    $file_data[@file_data] = $record;
    &mht_item_file_write($file, @file_data);
}


sub mht_item_file_write {
    my ($file, $data_ptr) = @_;
    print "Writing out to mht file $file\n";
    &file_backup($file);
    &file_write($file, join("\n", @$data_ptr));
}

sub monitor_commands {
    print "Starting monitor commands loop\n\n";
    while (1) {
        &check_for_action;
    }
}


                                # use our own str2time here so we can do arithmitic offsets
my %table_month = qw(jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 sep 9 oct 10 nov 11 dec 12
                  january 1 february 2 march 3 april 4 may 5 june 6
                  july 7 august 8 september 9 october 10 november 11 december 12);
sub my_str2time {
    my($time_date_arg) = @_;
    return 0 if !defined $time_date_arg or $time_date_arg eq 'none';
    my ($monthf, $mdayf, $yearf, $time_date_time, $hourf, $minf, $secf, $am_pm);
    my ($op, $offset, $sec_offset, $hour_offset, $min_offset);
    my $time_date = eval(qq["$time_date_arg"]);   # Use eval for on-the-fly variable substitution
    print "Error in my_str2time: time=$time_date_arg  error=$@\n" if $@;

                                # Date specification is optional.  Allow for:
                                #  12/25/00 7:00 pm
                                #  12/25    7:00 pm
                                #  Dec/25   7:00 pm (Dec 25 7:00 pm would be tricky)
    ($monthf, $mdayf, $yearf, $time_date_time) = $time_date =~ /(\S+)\/(\S+)\/(\S+)\s+(.+)/;
    ($monthf, $mdayf, $time_date_time) = $time_date =~ /(\S+)\/(\S+)\s+(.+)/ unless $time_date_time; # Year is optional

                # Allow for Date only specs
    unless ($time_date_time) {
    $time_date_time = '12 pm' if ($monthf, $mdayf, $yearf) = $time_date =~ /^ *(\S+?)\/(\S+?)\/?(\S*) *$/;
    }

                                # Allow for dd/mm format
    ($mdayf, $monthf) = ($monthf, $mdayf) if $config_parms{date_format} =~ /ddmm/;

    $monthf = $table_month{lc $monthf} if $monthf and $monthf !~ /\d+/;
    $monthf = $Month unless $monthf;
    $mdayf  = $Mday  unless $mdayf;
    $yearf  = $Year  unless $yearf;
    $monthf--;          # Jan = 0;

    $time_date = $time_date_time if $time_date_time;
    ($hourf, $minf, $secf, $am_pm) = $time_date =~ /(\d+):?(\d*):?(\d*)\s*([AaPp]?[Mm]?)/;
    $minf = 0 unless $minf;
    $secf = 0 unless $secf;
    unless (defined $hourf) {
        my @caller = caller;    # This is not useful in user_code eval :(
        print_log("Warning, bad time record: time=$time_date_arg time_date=$time_date caller=@caller.");
        return 0;
    }
                                # Allow for time offsets
    ($op, $offset) = $time_date =~ /([\+\-])\s*(\S+)/;

    $sec_offset = 0;
    if ($op) {
        ($hour_offset, $min_offset) = split(":", $offset);
        if ($op eq '+') {
            $sec_offset += $hour_offset * 3600 if $hour_offset;
            $sec_offset += $min_offset  * 60   if $min_offset;
        }
        elsif ($op eq '-') {
            $sec_offset -= $hour_offset * 3600 if $hour_offset;
            $sec_offset -= $min_offset  * 60   if $min_offset;
        }
        else {
            print "Error in my_str2time.  Bad operator=$op time=$time_date\n";
        }
    }

                                # Adjust to am/pm to 24 hour time
                                # Allow for 24 hour time with pm (e.g. 16:00pm)
    $hourf -= 12 if $am_pm and $hourf > 12;
    $am_pm = uc $am_pm;
    if ($hourf == 12) {
        $sec_offset -= 12 * 3600 if $am_pm eq "AM";
    }
    else {
        $sec_offset += 12 * 3600 if $am_pm eq "PM";
    }
#   print "db td=$time_date offset=$sec_offset hour=$hourf:$minf $am_pm\n";

                                # Adjust to unix convention
    if (defined $yearf) {
        $yearf -= 1900 if length($yearf) == 4;
        $yearf += 100 if $yearf < 70;
    }

                                # Silly timelocal dies with bad times, and we can not trap
                                # a $SIG{_DIE_} without exiting, so check for valid times :(
    if ($secf > 59 or $minf > 59 or $hourf > 23 or $mdayf > 31 or $monthf > 11 or $yearf > 2037 or
        $secf <  0 or $minf <  0 or $hourf <  0 or $mdayf <  0 or $monthf <  0 or $yearf <    0 ) {
        my @caller = caller;    # This is not useful in user_code eval :(
        print "Bad time format:  $time_date   caller=@caller\n";
        print "db mday=$Mday mdayf=$mdayf min=$Minute minf=$minf secf=$secf " .
            "hour=$Hour hourf=$hourf ap=$am_pm m=$Month mf=$monthf y=$Year yf=$yearf\n";
        return;
    }
    return ($sec_offset + timelocal($secf, $minf, $hourf, $mdayf, $monthf, $yearf));
}

sub new_second {
    return unless $New_Second;
    return 1 unless $_[0];
    return !($Time % $_[0]);
#   return !($Second % $_[0]);
}

sub new_minute {
    return unless $New_Minute;
    return 1 unless $_[0];
    my $minute = int ($Time / 60);
    return !($minute % $_[0]);
#   return !($Minute % $_[0]);
}

sub new_hour {
    return unless $New_Hour;
    return 1 unless $_[0];
    return !($Hour % $_[0]);
}

sub object_states_restore {

    my $restore_state_file = "$config_parms{data_dir}/mh_temp.saved_states";

# Read in the normal file, and a file of saved states unused from a previous call
#  - for example, maybe you just ran on a test module on the previous pass
    open  SAVE, $restore_state_file;
    my @states = <SAVE>;
    open SAVE,  "$restore_state_file.unused" and push @states, <SAVE>;
    open SAVE, ">$restore_state_file.unused";

#   &speak("Error, Mr. Bruce, restoring an empty state file!") if !@states and $Info{User} eq 'winter';

    print "Restoring object states\n";

    # Set unused stats first, so they can get overwritten by a more recent state
    no strict 'vars';       # Do this so eval doesn't choke ... we do defined checks in the $state code
    while (my $state = pop @states) {
        print "restoring state: $state" if $Debug{save};
        my $rc = eval $state;
        if ($@) {
            print " Error in save: eval $state\n   $@";
        }
        elsif ($rc eq 'var not used') {
            print SAVE $state;  # These are unused for this call of mh
            print " - Save stated not used:\n rc=$rc  state=$state\n" if $Debug{save};
        }
    }
    use strict 'vars';
    close SAVE;

    &Timer::resort_timers_with_actions;

    print "Object states restored\n";

    &persistent_restore();
}

sub object_states_save {
    my ($object_type, $var, $expire_time, $state);

    print "$Time_Date: Saving object states ..." unless $config_parms{no_log} =~ /save_state/;
    $Save{Time_Saved} = $Time_Date;
    my ($restore_state, $restore_string);

#    for $var (keys %Save) {
#        no strict 'refs';
#        if (defined $Save{$var}) {
#            $restore_state .= &object_states_save_check("\$Save{q~$var~} = q~$Save{$var}~;") . "\n";
#        }
#        print "Saving state for Save{$var} = $state\n" if $Debug{save};
#    }
                                # Save states of all objects
    for $object_type (@Object_Types) {
        for $var (keys %{$file_by_object_name{$object_type}}) {
            print "Saving state for $object_type $var\n" if $Debug{save};
            my $ref = $objects_by_object_name{$var};
            if ($ref and $ref->can('restore_string')) {
                $restore_string =  &object_states_save_check($ref->restore_string);
                $restore_state .= "if (defined $var) {$restore_string} else {'var not used'}\n" if $restore_string;
            }
        }
    }
                                 # Do not write file on startup ($restore_state should be empty)
    my $restore_state_file = "$config_parms{data_dir}/mh_temp.saved_states";
    if ($restore_state) {
        return unless $restore_state;

        open  SAVE, ">$restore_state_file" or print "Can not open saved_states file $restore_state_file: $!\n";
        print SAVE $restore_state;
        close SAVE;
        print_log("Object states saved") if $Debug{save};
#       print "Save object states:  restore_state=\n$restore_state\n" if $Debug{save};
    }

                                # Save Persistent data
# Not sure why this does not work ... only the first gets saved??
#   file_write "$restore_state_file.persistent", Data::Dumper->Dump([\%Persistent, \%Save], [qw(*Persistent *Save)]);
    file_write "$restore_state_file.persistent",
       Data::Dumper->Dump([\%Persistent], [qw(*Persistent)]) .
       Data::Dumper->Dump([\%Save],       [qw(*Save)]);

    print " done\n" unless $config_parms{no_log} =~ /save_state/;

}


sub object_states_save_check {
    my ($save_string) = @_;
    return unless $save_string;

                                # These are old tests
#    if ($state =~ /\~/) {
#                print "\n\nWARNING, \$Save{$var} was not saved because it contained a ~ character: $state\n\n";
#     }
                                # Check for state values with bad data that we can not restore
#   elsif ($state =~ /\x20-\x7e/ ) {
#   elsif ($state =~ /^[^\W\d_]+$/) {

                                # This is an effective test
                                #  - no, this is a bad think.  evaling a timer $save_string
                                #    will reset the timer!  Lets skip this check.
#    eval $save_string;
#    if ($@) {
#        print "\n\nWARNING, Can not save this wierd state: $save_string. \n - Error: $@\n\n"
#            if $Debug{misc};
#        return;
#    }
                                # Can not restore stuff with carrage returns (for now).
                                #  - we pop/eval off of a list array

    $save_string =~ s/\n/ /g;

    return $save_string;
}

sub persistent_restore {
                                # Restore Persistent data
    $Persistent{timers} = [];   # In case we don't read in any
    my $restore_state_file = "$config_parms{data_dir}/mh_temp.saved_states";
    if (-e  "$restore_state_file.persistent") {
        my $persistent_data = file_read "$restore_state_file.persistent";
        eval $persistent_data;
        print "Error in Persistent data restore: $@\n" if $@;

                                # Must resart each timer
        for my $timer (@{$Persistent{timers}}) {
            $timer->restore_self_set;
        }
    }
}

###########################################################
##  password_read will populate password related data.
##    it was originally called once during mh initialization,
##    but is now called during EVERY password_check().
##
##  if we're requested by force_read to re-process the pw files,
##    we will.  normally, we'll only re-process the file(s) if
##    they've changed since last time we read them.
##
###########################################################
sub password_read {
    my($force_read)=@_;   ## allow caller to force re-read (on startup)

    my $pw_file = $config_parms{password_file};
    $pw_file = "$config_parms{data_dir}/.password" unless $pw_file;
    if($force_read || &file_changed($pw_file)){
        %Passwords=();  ## reset to allow deletion of users
        if (-e $pw_file){
        print "Reading password from $pw_file\n" if $Debug{password};
        if (open (PASSWD, $pw_file)) {
            while (<PASSWD>) {
            if (/User: (\S+) (.+)/) {
                $Passwords{$1} = $2;
            }
            else {
                $Passwords{family} = $_;  # Grandfathter old single-user file
            }
            }
        }
        close PASSWD;
        }
        else {
        print "\nWarning:  password_file $pw_file not found.  Run mh/bin/set_password\n\n";
        }
    }

                                # This disables password protection for the specified commands/items
    $pw_file = $config_parms{password_allow_file};
    if ($pw_file and ($force_read or &file_changed($pw_file)) ) {
        %Password_Allow=();
        my @records = grep !(/^\#/ or /^\s*$/), &file_read($pw_file);
        print "Read in ", scalar @records, " items from $pw_file\n" if $Debug{password};
#       %Password_Allow = map {$_, 1} @records;
        for my $cmd (@records) {
            my $user = 'anyone';
            if ($cmd =~ /(.+?) *authority *= *(\S+)/i) {
                $cmd  = $1;
                $user = $2;
            }
            $cmd =~ s/\s*$//;   # Drop trailing whitespace
            $Password_Allow{$cmd} = $user;
        }
    }

                                # This allows for disabling commands without modifing code
                                # - for example, 'reboot the computer' in mh/code/common/mh_control.pl
    $pw_file = $config_parms{disabled_commands};
    if ($pw_file and ($force_read or &file_changed($pw_file) )) {
        %Disabled_Commands=();
        my @records = grep !(/^\#/ or /^\s*$/), &file_read($pw_file);
        print "Read in ", scalar @records, " commands from from $pw_file\n" if $Debug{password};
        %Disabled_Commands = map {lc $_, 1} @records;
    }
}


sub authority_check {
    my ($user_required) = @_;
    return 1 if defined($user_required) and $user_required eq 'anyone';
    return 0 if !$Authorized;
    return 1 if !$user_required;
    return 1 if  $Authorized eq 'admin';    # Allow any command for admin
    return 1 if  $Authorized eq $user_required;
    return 1 if  $user_required eq 'guest';  # Allow any login for guest commands
    return 0;
}

                                # Returns userid that matches the password
sub password_check {
    my ($password, $port, $type) = @_;

#   return 0;  # disable remote access

    &password_read(0);   ## reload if anything changed

    if (%Passwords) {
        if ($password) {
# each requires a reset to start at the begining :(
#           while (my($user, $passwordc) = each %Passwords) {
            for my $user (sort keys %Passwords) {
                my $passwordc = $Passwords{$user};
                print "testing $password for user=$user pw=$passwordc.\n" if $Debug{password};

                                # Simple string check if already crypted (e.g. html password cookie check)
                if ($type eq 'crypted') {
                    return $user if $passwordc eq $password;
                }
                                # Check encrypted password
                elsif (crypt($password, $passwordc) eq $passwordc) {
                    return $user;
                }
            }
            print "No match found for $password.\n" if $Debug{password};
            return 0;
        }
                                # Bypass password protection on select clients
        else {
            my $client = $Socket_Ports{$port}{client_ip_address} if $port;
#           return 'family' if $client and -1 < index $config_parms{password_allow_clients}, $client;
            my $a = ($client and grep $client =~ /^$_$/, @Password_Allow_Clients) ? 'family' : 0;
            print "db p=$port client=$client pa=@Password_Allow_Clients a=$a\n" if $Debug{password};
            return $a;
        }
    }
    else {
        return 'admin';         # No password required if the file does not exist
    }
}

                                # If valid, return the crypted password
sub password_check2 {
    my ($password) = @_;

    &password_read(0);   ## reload if anything changed

    if (%Passwords and $password) {
        for my $user (sort keys %Passwords) {
            my $passwordc = $Passwords{$user};
            if (crypt($password, $passwordc) eq $passwordc) {
                return ($user, $passwordc);
            }
        }
    }
    return undef;
}


sub phrase_match {
    my ($phrase) = @_;
                                # Look for Voice_Cmd matches
    my (%list1, %list2);
    my $d_min1 = 999;
    my $set1 = 'abcdefghijklmnopqrstuvwxyz0123456789';
    print "phrase_match for: $phrase.\n" if $Debug{phrase};
#   for my $phrase2 (('when will the sun set', 'new moon')) {
                                 # Do a fast less accurate search on all phrases
    for my $phrase2 (&Voice_Cmd::voice_items('mh', 'no_category')) {
        my $d = pdistance($phrase, $phrase2, $set1, \&distance, {-cost => [1,0,3], -mode => 'set'});
        print " - d1=$d phrase=$phrase2.\n" if $Debug{phrase};
        push @{$list1{$d}}, $phrase2 if $d <= $d_min1;
        $d_min1 = $d if $d < $d_min1;
    }

    return @{$list1{$d_min1}};   # Skip the rest for now.

                                 # Now do a slow search to narrow in from the above list
                                 #  ... hmmm, seems to create too small a subset
    my $d_min2 = 999;
    my $set2 = 'abcdefghijklmnopqrstuvwxyz0123456789+-%';
    for my $phrase2 (@{$list1{$d_min1}}) {
        my $d = pdistance($phrase, $phrase2, $set2, \&distance, {-cost => [1,0,3], -mode => 'set'});
        print " - d2=$d phrase=$phrase2.\n" if $Debug{phrase};
        push @{$list2{$d}}, $phrase2 if $d <= $d_min2;
        $d_min2 = $d if $d < $d_min2;
    }

    return @{$list2{$d_min2}};
}

sub play {
    my %parms;

    if (@_ == 1) {              # Simple way ... no parms
        $parms{file} = $_[0];
    }
    else {
        %parms = @_;
    }

    &set_app_parms(\%parms, 'speak');     # Set parms according to an optional app parm

    $parms{mode} = '' unless $parms{mode};
    $parms{retry} = 5 unless $parms{retry};
    $parms{retry}--;

                                # Allow for add_sound %Sounds keys ... if not specified in play call
    my $sound_key = $parms{file};
    if ($Sounds{$sound_key}) {
        for my $parm (keys %{$Sounds{$sound_key}}) {
            $parms{$parm} = $Sounds{$sound_key}{$parm} unless $parms{$parm} and $parm ne 'file';
        }
    }

    return if $parms{file} eq 'none';

    my $mode = $parms{mode} || $Save{mode};

                                # Do not log System our sound_ files (these are played frequently)
    &print_speaklog($mode . ": (" . basename($parms{file}) . ")")  unless
        $parms{file} =~ /sound_/ or $parms{file} =~/^System/ or $parms{nolog};


    print "Playing wave file $parms{file}\n" if $Debug{play};

    &Log_hooks('play', $parms{file}, %parms);   # Created by &add_hooks

    return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $mode !~ /unmute/i;

    my $play_parm = $parms{mode};
    $play_parm = 'wait' if !$play_parm and $config_parms{play_mode} eq 'wait';

    $parms{time} = 5 unless $parms{time};

    $parms{rooms} = $parms{room} if $parms{room}; # Allow for room or rooms

#   &write_socket("play", "$rooms", $file);

    no strict 'subs';       # For non-win OS
    if (lc($play_parm) eq 'stop') {
        &Win32::Sound::Stop();
    }
    elsif (lc($play_parm) eq 'loop') {
        $play_parm = SND_LOOP | SND_ASYNC;
    }
    elsif (lc($play_parm) eq 'wait') {
                                # If we want to wait (e.g. so we can turn speakers off), maybe we should fork
        $play_parm = 0;         # Or can we test to see if we are still playing??
    }
    else {
        $play_parm = SND_ASYNC; # Do not wait.
    }


#   &set_volume($parms{volume});
    &Play_parms_hooks(\%parms);# Created by &add_hooks
    &Play_pre_hooks(%parms);# Created by &add_hooks


                               # Do not speak locally if this parm is specified and does not
                               # match the rooms parm or it is a non-standard card
    if ($config_parms{speak_mh_room} && $parms{rooms} and !$parms{card}) {
        my $mh_room = $config_parms{speak_mh_room};
        return unless $parms{rooms} =~ /^$mh_room|\,$mh_room|^all/;
    }

    my @files = split(/[, ]/, $parms{file});
#   $play_parm = 0 if @files > 1; # If more than one file, wait.
    for my $file (@files) {
                                # Check for SystemXYZ or //server or \file or c:\file
        unless ($file =~ /^System/ or $file =~ /^[\\\/]/ or $file =~ /^\S\:/) {

            if (-e $file) {
            }
                                # Use from common dir only if it is not in the user sound_dir
                                #  - Can not test for -e in user sound_dir if we have a *.wav spec
            elsif ( -e "$config_parms{sound_dir_common}/$file" and
                   !-e "$config_parms{sound_dir}/$file") {
                $file = "$config_parms{sound_dir_common}/$file";
            }
            else {
                $file = "$config_parms{sound_dir}/$file";
            }

                                # If wildcarded file, build an array of all files and pick one
            if (!-e $file and $file =~ /\*/) {
                my @files_to_pick = glob $file;
                my $file_cnt = @files_to_pick;
                if ($file_cnt > 1) {
                    $file = @files_to_pick[int(rand $file_cnt)];
                    print "Play picked file $file\n";
                }
                else {
                    $file = $files_to_pick[0];
                }
            }
        }
        print "playing file=$file parm=$play_parm\n" if $Debug{play};

#       system($config_parms{sound_program_prescript}) if $config_parms{sound_program_prescript};

        my $i;

#       while ($i++ < 3) {
#           no strict 'subs';   # For non-win OS
        my $played_ok;

                                # Let the speak code push the wav file
                                # For speak (TTS), this gets done in Voice_Text.pm
        if ($parms{address}) {
            copy $file, "$config_parms{data_dir}/cache/speak_address.$Second.wav";
            for my $address (split ',', $parms{address}) {
                my $address_code = $config_parms{voice_text_address_code};
                $address_code =~ s|\$address|$address|;
                $address_code =~ s|\$url|http://$Info{IPAddress_local}:$config_parms{http_port}/cache/speak_address.$Second.wav|;
                print "play running address code: $address_code\n" if $Debug{play};
                eval $address_code;
            }
            last;
        }

        if (!$OS_win) {
            next if $file =~ /^System/;
            if ($config_parms{sound_program} =~ /vv_tts/i) {    # use vv_tts for play also
                speak(play=>"$file", nolog=>1, %parms);
                last;
            }
            last unless $config_parms{sound_program};
            my $sound_program = $config_parms{sound_program};
            if ($config_parms{mp3_program}) {
                $sound_program = $config_parms{mp3_program} if ($file =~ /.mp3/);
            }
            if ($parms{sound_program} ) {
                $sound_program = $parms{sound_program};
            }
            print "running: $sound_program $file\n";

                                # Greg Satz had problems with MAC OS X zombies with system call here
                                # Some linux guys had problems with problems with rc being mis-set
                                # with the fork, so default to system calls

            if (($main::Info{OS_name} eq "OSX") or  $config_parms{sound_fork} = "fork") {
                print_log ("Playing sound file $file with $sound_program") if $Debug{play};
                my $kid = fork;
                warn "Cannot fork in &play: $!" unless defined $kid;
                if ($kid) {
                    print_log ("Skipping sound file") if $Debug{play};
                    # 2006-12-10, commenting out the following line as
                    # we don't want mh to wait during fork sounds.
                    # If people start to experience problems with forked sound,
                    # the lack of the following line is a likely culprit.
                    # waitpid($kid,0);
                    $played_ok = 1;
                }
                else {
                    print_log ("executing sound file") if $Debug{play};
                    exec qq[$sound_program $file];
                    die "can't exec sound_program: $sound_program";
                    exit(0);
                }
                print_log ("$file has played") if $Debug{play};
            }
            else {
                if ($sound_program =~ /play$/) {
                    if (defined $parms{volume}) {
                        my $pervol = $parms{volume} / 100;
                        $sound_program .= " -v $pervol";
                    }
                }
                                # Perl 5.8 did was setting $? to -1, so use system $rc instead
                my $rc = system("$sound_program $file &");
                $played_ok = 1 if 0 == $rc;
            }
        }
        else {
            $played_ok = 1 if 1 == Win32::Sound::Play($file, $play_parm | SND_NOSTOP);
        }
                                # If no success, try again later
        unless ($played_ok) {
            if ($parms{retry} > 0) {
                my $play_timer = new Timer;
                my $replay_parms = '';
                for my $key (sort keys %parms) {
                    my $value = $parms{$key};
                    $value = $file if $key eq 'file'; # Just the current file
                    $replay_parms .= qq['$key' => '$value', ];
                }
                set $play_timer 1, "&play($replay_parms)";
#               print "Waiting to play sound file, pass $parms{retry}, &play{$replay_parms}\n";
                print "Waiting to play sound file, pass=$parms{retry} file=$file\n";
            }
            else {
                print "Gave up trying to play sound file: $file\n";

            }
        }

        $parms{fileplayed} = $file if $played_ok; # For play_post_hooks to use

#        print "Waiting to play sound file, pass $i, file=$file\n";
#        sleep 1;
#        }

#       system($config_parms{sound_program_postscript}) if $config_parms{sound_program_postscript};

    }

    &Play_post_hooks(%parms); # Created by &add_hooks

}

sub print_log {
#   my ($data) = @_;
    my $data = "@_";
    my $logfile;
    if ($data =~ /^log=(\S+) /i) {
        $logfile = "$config_parms{data_dir}/$1";
        $data =~ s/^log=\S+//i;
    }
    &Log_hooks('print_log', $data);   # Created by &add_hooks



    if ($Tk_objects{log_window}) {
                                # Most recent at top ... if we put it on the bottom, we have to constantly
                                # move to the bottom, messing up any manual scrolling
        $Tk_objects{log_window}->insert('0.0', "$Time_Date $data\n");
#       $Tk_objects{log_window}->insert('end', "$Time_Date $data\n");
#       $Tk_objects{log_window}->yview('moveto', 30);
    }
    else {
	if (!$config_parms{tk_console_timestamps} and $MW) {
	        print "$data\n";
	}
	else {
	        print "$Time_Date $data\n";
	}
    }
    $data = "$Time_Date $data";
    unshift (@Print_Log, $data);
    pop @Print_Log if @Print_Log > $config_parms{max_log_entries};

    $Last_Response = 'print_log' unless $Last_Response;


    if ($logfile) {
        logit $logfile, $data . "\n", 0;
    }
    else {
        print PRINTLOG $data . "\n";
    }
    return;
}

sub print_log_last {
                                # Return the last how_many print_log phrases
    my ($how_many) = @_;
    my $count = @Print_Log;
    if ($how_many == 1) {
        return $Print_Log[0];
    }
    elsif ($how_many >= $count) {
        return @Print_Log;
    }
    else {
        return (@Print_Log[0 .. ($how_many-1)]);
    }
}

sub error_log_last {
                                # Return the last how_many error_log phrases
    my ($how_many) = @_;
    my $count = @Error_Log;
    if ($how_many == 1) {
        return $Error_Log[0];
    }
    elsif ($how_many >= $count) {
        return @Error_Log;
    }
    else {
        return (@Error_Log[0 .. ($how_many-1)]);
    }
}

sub print_msg {
#   my ($data) = @_;
    my $data = "@_";
    my $time = &time_date_stamp(13, $Time);
    if ($Tk_objects{msg_window}) {
        $Tk_objects{msg_window}->insert('0.0', "$time $data\n");
#       $Tk_objects{msg_window}->insert('0.0', "$Time_Date $data\n");
    }
    else {
        print "$time $data\n";
    }
    $Last_Response = 'print_msg';
}

sub print_speaklog {
#   my ($data) = @_;
    my $data = "@_";

#   unshift (@Speak_Log, "$Time_Now $data");
    unshift (@Speak_Log, "$Time_Date $data");
    pop @Speak_Log if @Speak_Log > $config_parms{max_log_entries};

    $data =~ s/<\/?voice.*?>//g;  # Drop XML speech tags
    $data =~ s/\n *$//;           # Drop trailing cr

    if ($Tk_objects{speak_window}) {
                                # Most recent at top ... if we put it on the bottom, we have to constantly
                                # move to the bottom, messing up any manual scrolling
        $Tk_objects{speak_window}->insert('0.0', "$Time_Date $data\n");
    }
    else {
        print "$data\n" unless $config_parms{no_log} =~ /speak/ or $Startup; # On startup no print needed as it is just the "System Restarted" message (or an error with its own debug info)
    }
    print SPEAKLOG "$Time_Date $data\n";
}

sub process_external_command {
    my ($cmd, $warning_flag, $set_by, $respond_target) = @_;
    $cmd =~ s/^\s+//;           # Deletes leading blanks
    $cmd =~ s/\s+$//;           # Deletes trailing blanks

    print "Running external command: $cmd set by $set_by\n" unless $config_parms{no_log} =~ /xcmd/;

    if (&run_voice_cmd(lc($cmd), undef, $set_by, 0, $respond_target)) {
	$set_by =~ s/ +\[(.*)$//;

        print_log "Ran $set_by command: $cmd" unless $config_parms{no_log} =~ /xcmd/ or $set_by eq 'tk'; # tk is not appropriate here (command listbox doesn't call this.)
    }
                                # Limit syntax to protect from dangerous hacks
    elsif ($cmd =~ /^set +(\$[\_a-z0-9]+) * [\'\" \_a-z0-9]+ *$/i and eval "ref $1") {
        print_log "Running set command: $cmd" unless $config_parms{no_log} =~ /xcmd/;
        eval $cmd;
        print_log "\nError in running external set command: cmd=$cmd\n error: $@\n" if $@;
    }
    elsif ($cmd =~ /^speaki?t? (.+)/i) {
                                 # So speak hooks can react right (eg common/speak_chime.pl)
				 # *** Deprecated as they don't always get the right target
        $Respond_Target = $respond_target;
        $Respond_Target = &set_by_to_target($set_by) unless defined($Respond_Target);
        speak($1);
    }
    elsif ($cmd =~ /^display (.+)/i) {
        display($1);
    }
                                # Allow for simulated serial data
#   elsif ($cmd =~ /[A-Z0-9]+$/ and &process_serial_data($cmd)) {
    elsif ($cmd =~ /[A-Z0-9]+$/ and my @refs = &Device_Item::items_by_id($cmd)) {
        for my $ref (@refs) {
            if (my $state = $$ref{state_by_id}{$cmd}) {
#               set_receive $ref $state;
                set         $ref $state, $set_by;
                print "Serial event=$cmd state=$state\n" if $Debug{serial};
            }
            else {
                set         $ref $cmd, $set_by;
            }
        }
        print_log "Found a matching event for xcmd=$cmd";
    }
#   elsif ($cmd =~ /[a-zA-Z0-9]+$/) {
#       $cmd = uc $cmd;
#       print "Writing xcmd serial data:$cmd.\n";
#       print "serial results: ", $Serial_Ports{weeder}{object}->write($cmd . "\r"), ".\n" if $Serial_Ports{weeder}{object};
#   }
    else {
        print_log "Warning, command from $set_by not recognized:$cmd." if $warning_flag;
        return 0;
    }
    return 1;
}

my (@prev_x10_events, %prev_x10_units, $prev_x10_units_reset);
sub process_serial_data {
    my ($event_data, $prev_pass, $source) = @_;

    $source = 'serial' unless $source;

    return unless $event_data;

                                # Allow for other processing.  Ignore if this is data munged
                # in the crazy X10 serial_data_buffer munging (don't want the proxy to see it)
    &Serial_data_hooks($event_data, undef, $source) unless $prev_pass;   # Created by &add_hooks

    my ($event_type, $event_data1) = $event_data =~ /^(\S)(\S*)/;

    print "Serial data: event_type=$event_type, event_data=$event_data\n"
        if $Debug{serial} or ($Debug{x10} and $event_type eq 'X');

    my ($state, $ref, @refs, $matched);
    if ($event_type eq 'X') {

                                # Process CM11 status requests
# C2STATUS_ONC2
# C3C3STATUS_OFFC3C3STATUS_OFF
# J5J7STATUS_ON OR  J5J2STATUS_OFF ...  Leviton DHC examples give strange extra 2 characters before STATUS string

        if ($event_data1 =~ /POLL/) {
     #***should check for mismatch of house and house2!
            my ($house, $device, $house2, $level) = $event_data1 =~ /(\S)(\S)(\S)POLL/;

            my $event_data = 'X' . $house . $device;
            if (my @refs = &Device_Item::items_by_id($event_data)) {
                for my $ref (@refs) {
                    if ($ref->{x10_id}) {
                        &print_log($ref->{x10_id} . $house . "POLL: " . substr($ref->{object_name},1) . " polled");
                    }
                }
            }

            return;
        }
        elsif ($event_data1 =~ /&P/) {
            my ($house, $device, $house2, $level) = $event_data1 =~ /(\S)(\S)(\S)&P(.*)/;
            $level -= 128 if ($level > 128); #***move this to cm11 module
            my $level1 = (($level/63) * 100);
            $level1 = int ( $level1 + 0.5 );

    #***Turn on if off and level <> 0
    #***Don't return, see below how status preserves additional commands!

                                                              #set level here;
            my $event_data = 'X' . $house . $device;
            if (my @refs = &Device_Item::items_by_id($event_data)) {
                for my $ref (@refs) {
                    if ($ref->{x10_id}) {
                #   print "FROM LEVEL:" . $ref->{level} . "\n";
                #   print "TO LEVEL:" . $level1 . "\n";
                        &print_log("$ref->{x10_id}&P" . $level . ": " . substr($ref->{object_name},1) . " " . (($level1 > $ref->{level})?"brightened":"dimmed") . " to " . $level1 . '%') if ($ref->{level} != $level1);
                        $ref->{level} = $level1 if ($ref->{level} != $level1);
                    }
                }
            }
            return;
        }
        elsif ($event_data1 =~ /STATUS/) {
#           &print_log("ed1:" . $event_data1);
#           my ($house, $device, $state) = $event_data1 =~ /(\S)(\S)STATUS_(\S+)/;
            my ($house, $device, $state) = $event_data1 =~ /(\S)(\S)\S{0,2}STATUS_(\S+)/;

            $event_data1 =~ s/\S\SSTATUS_$state//g;
            $event_data = "X" . $event_data1;

            $state = 'J' if $state eq 'ON';
            $state = 'K' if $state eq 'OFF';
            my $event_data = 'X' . $house . $device . $house . $state;
            if (my @refs = &Device_Item::items_by_id($event_data)) {
                for my $ref (@refs) {
                    if ($state = $$ref{state_by_id}{$event_data}) {
#                       $ref->{state} = $state;
#                       set_receive $ref $state, 'status' if $state ne $ref->{state};
                        if (lc($state) ne lc($ref->{state}) and ((lc($ref->{state}) eq "on") or  (lc($ref->{state}) eq "off") or
                                                                 (lc($ref->{state}) eq "status") or (lc($ref->{state}) eq "manual") )) {
                            if ((lc($state) eq "on") or (lc($state) eq "off") ) {
                                &print_log($ref->{x10_id} . ": " . substr($ref->{object_name},1) . " reported new status: $state") if ((lc($ref->{state}) ne 'status') and (lc($ref->{state}) ne 'manual'));
                                set_receive $ref $state, 'status';
                            }
                        }

                        print "CM11 Status results: data=$event_data1 event_data=$event_data state=$state\n"
                            if $Debug{x10};
                    }
                }
            }
            else {
                &print_log("Status request on undefined state: data=$event_data1 event_data=$event_data");
            }
            return unless $event_data1;
        }

                                # Track previous X10 data

                                # Ignore duplicate X10 entries
                                #  - We might have a CM11 and a MR26 both receiving the same data
        unless ($config_parms{x10_data_allow_dups}) {
            for my $i (0 .. 4) {
                my $time_diff = $loop_tickcount1 - $prev_x10_events[$i]{time} if $prev_x10_events[$i]{time};
                last unless defined($time_diff) and $time_diff < $config_parms{x10_multireceive_delay};
#               print "db $event_data1 eq $prev_x10_events[$i]{data}\n";
                if ($event_data1 eq $prev_x10_events[$i]{data}) {
                    print_log "X10: Duplicate data ignored data=$event_data time=$time_diff"
                        if $config_parms{x10_errata} >= 3;
                    return;
                }
            }
        }
        unless ($prev_pass or $source eq 'rf') {
            pop  @prev_x10_events if @prev_x10_events > 4;
            unshift @prev_x10_events, {time => $loop_tickcount1, data => $event_data1};
        }

    }

                                # Look for a direct match
    if (@refs = &Device_Item::items_by_id($event_data)) {
        $matched = 1;
        for $ref (@refs) {
#           print "db et=$event_type ed=$event_data o=$ref->{object_name}\n";
            if ($state = $$ref{state_by_id}{$event_data}) {
                set_receive $ref $state, $source;
                print "Serial event=$event_data state=$state\n" if $Debug{serial};
            }
            else {
                set_receive $ref $event_data, $source;
            }
                                # Allow for other processing
            &Serial_match_hooks($ref, $state, $event_data);   # Created by &add_hooks
        }
    }
                                # Check for string type items (e.g. caller ID or analog data)
    elsif ($event_type ne 'X' and @refs = &Device_Item::items_by_id($event_type)) {
        $matched = 1;
        for $ref (@refs) {
#           print "db et=$event_type ed=$event_data o=$ref->{object_name}\n";
            set_receive $ref $event_data, $source;
        }
    }

                                # Check for merged or broken X10 data
    if ($event_type eq 'X') {

        print_log "X10: Incoming data=$event_data" if $config_parms{x10_errata} >= 4;

                                # Track last selected items list (reset if a non-unit code string is found)
                                #  - For example:  XA1A2ALxx would set both units A1 and A2 to dim level xx
                                #    Not yet used for on/off codes: XA1A2AJ would set A1 to manual, and A2 to off
                                #    To handle on/off codes, it looks like this would be a bit messy, as these are set
                                #    above or in x10_chunks.  Maybe better to re-write all this code?? 07/2002
        my $length = length $event_data;
        my $pos = 1;
        while ($pos < $length) {
       last if $event_data =~ /PRESET_DIM/;  # The DIM1 and DIM2 strings would get parsed as M1 and M2
       my $unit = substr($event_data, $pos, 2);
            if ($unit =~ /([A-P][1-9A-G])/) {
                undef %prev_x10_units if $prev_x10_units_reset;
                $prev_x10_units_reset = 0;
                $prev_x10_units{$unit} = 1;
            }
            else {
                $prev_x10_units_reset = 1;
                undef %prev_x10_units if $unit =~ /[A-P][OP]/; # Reset list if we see a all on/off
                last if $unit =~ /[A-P][LM]/; # The rest of the string is bright/dim codes
            }
            $pos += 2;
        }
        print "X10: Previous units=", keys %prev_x10_units, " reset_flag=$prev_x10_units_reset\n" if $Debug{x10};


                                # Check for codes All-on All-off
        if ($event_data =~ /^X(\S)([OP])$/) {
            print_log "X10: House code $1 set to $2" if $Debug{x10} or $config_parms{x10_errata} >= 3;
            my $state = ($2 eq 'O') ? ON : OFF;
            &X10_Item::set_by_housecode($1, $state);
            return 1;
        }

                                # Do special X10 data processing on longer X10 strings
        if (!$matched and 3 < (my $length = length($event_data))) {

            my $f_code = substr($event_data, 2, 1);

                                #  Trap X10 Bright/Dim button hold times.  The 2 characters after
                                #  a bright/dim reflect how long the bright/dim button was held down for
            if ($length == 5 and ($f_code eq 'M' or $f_code eq 'L')) {
                                # hmmm, this may not be a good idea for non-cm11 users, but
                                # I don't think non-cm11 interfaces will generate this??
#               my $dim_level = &ControlX10::CM11::dim_level_decode(substr($event_data, 3)) if $config_parms{cm11_port};
#               return 1 unless $dim_level;
                my $dim_level = &x10_dim_level_decode(substr($event_data, 3));
                $dim_level = ($f_code eq 'M') ? '+' . $dim_level : '-' . $dim_level;
#               $dim_level = ($f_code eq 'M') ? '+' . $dim_level : '-'  $dim_level;
                print_log "X10: Dim/bright level=$dim_level event=$event_data " if $config_parms{x10_errata} >= 3;

                                # Code incoming bright/dim with the same syntax as outgoing:  e.g XA+20 XB-30
                                #  - Process for house code: e.g. new X10_Item('A');
                                #  - Process for all previously selected unit codes.
                undef @prev_x10_events; # Disable merging with raw data
#               print "db pxd=$prev_x10_events[1]{data} dim=$dim_level ed=$event_data\n";
                my $hc = substr($event_data, 1, 1);
                for my $unit ('', keys %prev_x10_units) {
                    &process_serial_data('X' . $unit . $hc . $dim_level);
                }
                return 1;
            }
                                # Check to see if X10 strings got run together (XA1A2 ->  XA1 XA2)
            else {
                return 1 if &process_x10_chunks($event_data);
            }

        }

                                # Check for multi-key X10 commands (e.g. XA1 XAJ -> XA1AJ)
                                # Optional, to allow for external code to take care of this

        my $prev_x10_event = '';
        unless ($config_parms{x10_data_no_merge}) {
            for my $i (1 .. 4) {
                my $prev_x10_time = $prev_x10_events[$i]{time};
                last unless $prev_x10_time and $prev_x10_time > ($loop_tickcount1 - $config_parms{x10_multikey_delay});
                $prev_x10_event = $prev_x10_events[$i]{data} . $prev_x10_event;
            }
        }
        if ($prev_x10_event) {
            my $event_data2 = 'X' . $prev_x10_event . substr($event_data, 1);
            print_log "X10: Merged string data=$event_data2" if $Debug{x10} or $config_parms{x10_errata} >= 3;
                                # See if it matches as one string
            if (&Device_Item::items_by_id($event_data2)) {
                print_log "X10: Event found for merged data=$event_data2" if $config_parms{x10_errata} >= 3;
                push(@serial_data_buffer, $event_data2);
                return 1;
            }
                                # See if the merge string matches as smaller strings ... IF we have not matched yet
            elsif (!$matched) {
                return 1 if &process_x10_chunks($event_data2, $event_type)
            }
        }

        print_log "X10: Unmatched incoming data=$event_data" if !$matched and $config_parms{x10_errata} >= 2;
    }
    else {
        print_log "Unmatched incoming serial data=$event_data" unless $matched or $config_parms{no_log} =~ /serial_unmatch/;
    }

    return $matched;
}

                                # This is called by mh/lib/Serial_Item.pm
sub proxy_send {
    my ($interface, $function, @data) = @_;

    my $address;
    if ($function eq 'speak' or $function eq 'play' or $function eq 'ibutton') {
        $address = $interface;
    }
    else {
                # Some interfaces (bx24) are case mixed
    my $ref = $Serial_Ports{$interface} || $Serial_Ports{uc $interface} || $Serial_Ports{lc $interface};
    print "proxy_send test: int=$interface r=$ref p=$$ref{object}\n" if $Debug{proxy};
    return 0 unless $$ref{object} eq 'proxy';
        $address = $config_parms{   $interface . '_port'};
        $address = $config_parms{lc($interface) . '_port'} unless $address;
        $address = $config_parms{uc($interface) . '_port'} unless $address;
    }
    $address =~ s/proxy +//;

    my $proxy = $proxy_servers{$address};
    unless ($proxy) {
        print "\nError in proxy_send:  no proxy server found for function=$function int=$interface address=$address data=@data\n";
        return 0;
    }

    print "proxy data sent: int=$interface f=$function a=$address p=$proxy d=@data\n" if $Debug{proxy};
    $proxy->start unless $proxy->active;
    if ($proxy->active) {
        $proxy->set(join $;, $interface, $function, @data);
    }
    else {
        print_log "Error in proxy_send: proxy port not active for function=$function int=$interface address=$address data=@data";
#       return 0;  If we return 0, send_serial_data will try to send.
    }
    return 1;
}

                                # This is called by mh/lib/iButton.pm
sub proxy_receive {
    my ($address) = @_;
    $address =~ s/proxy +//;
    my $proxy = $proxy_servers{$address};
    my $data = $proxy->said_next;
                                # Receive again because have both \r and \n on a
                                # Socket_Item set, and both will trigger <>
#   $proxy->said_next;
    return split $;, $data;
}


sub process_x10_chunks {
    my ($event_data, $event_type) = @_;
    return 0 if $event_data =~ /PRESET_DIM/ or $event_data =~ /STATUS/ or $event_data =~ /&P/;

    my $length = length($event_data);
    my $pos = 1;
    my $flag_found = 0;
    my $event_data_chunk;
    while ($pos < $length) {
        print "X10 db: try breaking $event_data into 4 and 2 character chunks:\n" if $Debug{x10};
                                # Look for 4 character match
                                #  - also match raw bright/dim commands (XaBcd is a match if B=L or M)
        if ($event_data_chunk = 'X' . substr($event_data, $pos, 4) and
            (&Device_Item::items_by_id($event_data_chunk)) or
            ($event_data_chunk =~ /^X\S[ML]\S\S/)) {
#           (substr($event_data, $pos) =~ /^\S[ML]/)) {
            print "  Found match: $event_data_chunk\n" if $Debug{x10};
                                # Process this data one pass at a time (e.g. multi keypad entries)
            push(@serial_data_buffer, $event_data_chunk);
            $flag_found = 1;
            $pos += 4;
        }
                                # Ignore processed bright/dim commands (Xa+dd)
        elsif (substr($event_data, $pos) =~ /^\S[\+\-]/) {
            $flag_found = 1;
            $pos += 4;
        }
                                # Look for 2 character match
        elsif ($event_data_chunk = 'X' . substr($event_data, $pos, 2) and
               &Device_Item::items_by_id($event_data_chunk)) {
            print "  Found match: $event_data_chunk\n" if $Debug{x10};
            push(@serial_data_buffer, $event_data_chunk);
            $flag_found = 1;
            $pos += 2;
        }
                                # Look for a 8 character match, like for a Stanley garage door transmitters
        elsif ($event_data_chunk = 'X' . substr($event_data, $pos, 8) and
               &Device_Item::items_by_id($event_data_chunk)) {
            print "  Found match: $event_data_chunk\n" if $Debug{x10};
            push(@serial_data_buffer, $event_data_chunk);
            $flag_found = 1;
            $pos += 8;
        }
        else {
            print "  No match found: $event_data_chunk\n" if $Debug{x10};
            my($hc, $fc) = $event_data_chunk =~ /X(\S)(\S)/;
            $fc = 'ON'      if $fc eq 'J';
            $fc = 'OFF'     if $fc eq 'K';
            $fc = 'ALL_ON'  if $fc eq 'O';
            $fc = 'ALL_OFF' if $fc eq 'P';
            &print_log("X10: Unmatched incoming data_chunk=$event_data_chunk ($hc $fc)") if $config_parms{x10_errata} >= 2;
            $pos += 2;
        }
    }
    if ($flag_found and $event_type) {
        undef @prev_x10_events;
    }
    return $flag_found;
}

sub read_code_forced {
    &read_code('forced');
}

sub read_code {
    my ($reload_mode) = @_;
    my (@files, $file, $file_dir, $file_path, @files_read, @files_changed, @files_changed2, $file_time, %noload_files);

    $Reread = 1;

    print_log ((($Startup)?'R':'Re-r') . "eading " . (($ENV{mh_parms})?$ENV{mh_parms}:'mh.private.ini') . " and mh.ini");

    read_parms unless $Startup; # Re-read .ini parms, in case they changed

    &read_misc_parms();         # Reread misc files/parms

                                # These parms might be twiddled with, so re-set them.
                                #  - %Local_Addresses is for backward compatibility ... maybe drop it some day
    %Local_Addresses = map{$_, 1} split(',', $config_parms{local_addresses});
    @Local_Addresses = split ',', $config_parms{local_addresses};
    @Password_Allow_Clients = split /[, ]+/, $config_parms{password_allow_clients};

    &read_table_files();           # Re-create table code file, if any table file changed

    print "Reading code_dirs: @Code_Dirs\n";
    if (@Requested_Files or $config_parms{only_load}) {
        @files_read = @Requested_Files;
        push @files_read, split ',', $config_parms{only_load};
    }
    else {
        for my $file_dir (@Code_Dirs) {
            opendir(DIR, $file_dir) or print  "\n\nError, can not open directory $file_dir.\n\n";
            push @files_read, readdir(DIR) unless $file_dir eq $config_parms{code_dir_common};
            close DIR;
        }
                                  # Add selected members from code_dir_common
        push @files_read, &file_read("$config_parms{data_dir}/$config_parms{code_select}", 2);

        @files_read = grep(/^[a-z0-9].*\.(pl|mhp)$/i, @files_read); # Must start with alphanumeric ... emacs edited checkpoints can start with #


    }
    @files_read = map {lc} @files_read if $OS_win;  # So we catch duplicate members with different cases
    @files_read = uniqify  @files_read;  # Uniq-ify the list

#   print "           files: @files_read\n";
    my $count = @files_read;
    print_log((($Startup)?'R':'Re-r') . "eading $count code files");
    die "\n\nError, no code files found in Code_Dirs: @Code_Dirs\n\n" unless @files_read;


                                # Read changed files
    undef @files_changed;
    undef @files_changed2;
    my %files_deleted = %file_code_times;
    %noload_files = map {lc($_), 1} (split(',', $config_parms{no_load}),
                                 &file_read("$config_parms{data_dir}/$config_parms{code_unselect}", 2))
    if -e "$config_parms{data_dir}/$config_parms{code_unselect}";

    my %files_seen;
    for $file (@files_read) {
        next if $file =~ /^read_table/; # Ignore table file readers in the user dir
        (print "File skipped due to -noload: $file\n"), next if $noload_files{lc($file)};

        undef $file_path;
        for my $code_dir (@Code_Dirs) {
            next unless -e "$code_dir/$file";
            if ($file_path) {
                print "Duplicate file.\n -    Used: $file_path\n - Skipped: $code_dir/$file\n\n";
            }
            else {
                $file_path = "$code_dir/$file";
            }
        }
        unless ($file_path) {
            print "\nError, could not find file in Code_Dirs: $file\n\n";
            next;
        }

        delete $files_deleted{$file_path};

        unless (-e $file_path) {
            print "\n\nError, can not find file $file_path\n\n";
            next;
        }
        $file_time = (stat($file_path))[9];
                                # File has not changed since last call
        next if $file_code_times{$file_path} and $file_time == $file_code_times{$file_path};
        delete $User_Code{$file_path};
        push(@files_changed, $file_path);
        push(@files_changed2, $file);
    }
                                # Delete any old files that were deleted
    my $files_deleted = 0;
    for $file_path (keys %files_deleted) {
        delete $User_Code{$file_path};
        delete $file_code_times{$file_path};
        $files_deleted++;
    }
    my $msg;
    $msg = "   $files_deleted file" . (($files_deleted == 1)?'':'s') . ' deleted, ' . ($#files_changed2 + 1) . ' file' . (($#files_changed2 == 0)?'':'s') . ' changed';

    $msg .= ": @files_changed2" if $#files_changed != -1;

    &print_log($msg) unless $Startup;
    &read_user_code(@files_changed) if @files_changed or $files_deleted or $reload_mode eq 'forced';
#   speak(@files_changed+0 . " files were read.");

    die "\n\nError, no user code found\n\n" unless @Loop_Code;

#   &tk_setup_cascade_menus if $MW;

}

sub read_misc_parms {

    &http_read_parms;           # Refresh lib/http_server.pl stuff
    &Voice_Text::read_parms();

    &Caller_ID::read_areacode_list('local_area_code' => $config_parms{local_area_code},
                                   'area_code_file'  => $config_parms{area_code_file})
        if file_change($config_parms{area_code_file}) or $Startup;

    &Caller_ID::read_callerid_list($config_parms{caller_id_file}, $config_parms{caller_id_reject_file})
        if file_change($config_parms{caller_id_file}) or file_change($config_parms{caller_id_reject_file}) or $Startup;

}


###################################
## convert_table_files is intended to provide a transition from the
##   current "table_A" *.mht files to the xml item definition files.
###################################
sub convert_table_files {
                                # Find files
    my %file_paths = &file_read_dir(@Code_Dirs);
    my @files_read = sort keys %file_paths;

    @files_read = grep(/^[a-z0-9].*\.mht$/i, @files_read);

                                # See if we are supposed to skip any files
    my %noload_files = map {lc($_), 1} (split(',', $config_parms{no_load}),
                                    &file_read("$config_parms{data_dir}/$config_parms{code_unselect}", 2))
    if -e "$config_parms{data_dir}/$config_parms{code_unselect}";

    ## attempt to convert all *.mht files to xml
    require "table_A2XML.pm";
    foreach my $mht_file (@files_read){
        (print "File skipped due to -noload: $mht_file\n"), next if $noload_files{lc($mht_file)};
        my $mht_path=$file_paths{$mht_file};  ##
        my $xml_path=$mht_path;
        if( $xml_path =~s/(.*)\.mht/${1}.xml/){
            print "converting [$mht_path] to [$xml_path]\n";
            &table_A2XML::convert($mht_path,$xml_path);
        }
        else{
            die "couldn't infer output from [$ARGV]\n";
        }
    }
}

                                # Read optional, table formated definitions of mh objects and events
sub read_table_files {

                # Allow for newer xml formated tables
    my $table_type = ($config_parms{table_type} =~ /xml/i) ? 'xml' : 'mht';

    if ($table_type eq 'xml') {
        require "read_table_xml.pl";
        &convert_table_files; ## convert any *.mht files that exist.
    }

                                # Find files
    my %file_paths = &file_read_dir(@Code_Dirs);
    my @files_read = sort keys %file_paths;


#   return unless @files_read = grep(/^[a-z0-9].*\.mht$/i, @files_read);
    return unless @files_read = grep(/^[a-z0-9].*\.$table_type$/i, @files_read);

    my $count = @files_read;
   print_log "Reading $count .mht table files: @files_read";

                                # See if we are supposed to skip any files
    my %noload_files = map {lc($_), 1} (split(',', $config_parms{no_load}),
                                    &file_read("$config_parms{data_dir}/$config_parms{code_unselect}", 2))
    if -e "$config_parms{data_dir}/$config_parms{code_unselect}";

                                # See if any of the files have changed
    my ($changed);
    for my $file (@files_read) {
        (print "File skipped due to -noload: $file\n"), next if $noload_files{lc($file)};
        my $file_time = (stat($file_paths{$file}))[9];
        $changed++ if !$file_code_times2{$file} or $file_time > $file_code_times2{$file};
        $file_code_times2{$file} = $file_time;
    }
    return unless $changed;

                                # Process tables of various, user-defined formats
    for my $file (@files_read) {
        next if $noload_files{lc($file)};
#       (my $table_code_file = "$file_paths{$file}") =~ s/\.mht$/.mhp/i;
        (my $table_code_file = "$file_paths{$file}") =~ s/\.$table_type$/.mhp/i;
        print_log "Translating $file -> $table_code_file";
        open  TABLE_IN,  "$file_paths{$file}";
        open  TABLE_OUT, ">$table_code_file" or print_log "Error in writing to $table_code_file";
        print TABLE_OUT "#\n#@ Do NOT edit this file.  It was auto-generated from $file.\n#\n";
        print TABLE_OUT "# Category = Other\n\n";
        my $format;
        my %formats_seen;
    if ($table_type =~/xml/) { $/=undef;$format="xml"; }
#   print "read_table: table_type [$table_type] format [$format]\n";
        while (<TABLE_IN>) {
#       print "read_table: read data [$_]\n";
                  # only scan for the format tag/comments in mht files, not xml files
            if ($table_type eq "mht"){
        if( /Format\s*=\s*(\S+)/i) {
                    $format = $1;
                    next;
            }
                if (/^\s*#/) {      # comment line
                    print TABLE_OUT $_;
                    next;
                }
        }
            if ($format) {
                                # These code reading subroutines are in mh/lib/read_table.pl
                                # Run the Init function on Reload
                if(!$formats_seen{$format}++){
#           print "read_table: initializing for [$format]\n";
                    require "read_table_$format.pl" ;
                    my $results = eval "&read_table_init_$format(\$_)";
                    print TABLE_OUT "# Init results: $results $@\n";
                    print "Error in &read_table_$format: $@\n" if $@;
                }

                chomp;          # Drop newline
                s/\s*$//;       # Drop end of line blanks
                print TABLE_OUT eval "&read_table_$format(\$_)";
                print "Error in &read_table_$format: $@\n" if $@;
            }
        }
        close TABLE_IN;
        close TABLE_OUT;
        if ($format =~/xml/) { $/="\n"; }
        print_log "Table format not recognized: file=$file mhp_file=$table_code_file." unless $format;
    }

}

sub set_app_parms {
    my ($parms, $func) = @_;
    if (my $app = $$parms{app}) {
        if ($app_parms{$func}{$app}) {
            for my $temp (split ' ', $app_parms{$func}{$app}) {
                my ($key, $value) = $temp =~ /(\S+)=(\S*)/;
                $$parms{$key} = $value unless $$parms{$key};
                print "db app=$app t=$app_parms{$func}{$app} k=$key v=$value.\n" if $Debug{parms};
            }
        }
        else {
            print "app_parms: func=$func -app $app not listed in mh.ini ${func}_apps parms\n" if $Debug{parms};
        }
    }
}

sub setup_DBI {
    use vars '$DBI';
    return unless $config_parms{dbi_driver};

    my $db = "DBI:$main::config_parms{dbi_driver}:$main::config_parms{dbi_database}";
    $db .= ":$config_parms{dbi_server}" if $config_parms{dbi_server};
    $db .= ":$config_parms{dbi_port}"   if $config_parms{dbi_port};
    print "Enabling DBI database:  $db\n";

    unless (&my_use('DBI')) {       # So we don't fail if DBI is not installed
        return if $DBI = DBI->connect($db, $config_parms{dbi_user},$config_parms{dbi_password});
    }

    print " - Could not connect to database.\n";
    if ($config_parms{dbi_essential}) {
        print " - dbi_essential=1, so exiting.\n";
        exit(1);
    }
}


sub sort_user_code
{
    if($a =~ /.mhp/i)
    {
        if($b =~ /.mhp/i)
        {
            return lc($a) cmp lc($b);
        }
        else
        {
            return -1;
        }
    }
    elsif($b =~ /.mhp/i)
    {
        return 1;
    }
    else
    {
        return lc($a) cmp lc($b);
    }
}

sub read_user_code {
    my(@files) = @_;
    my ($file, $noloop_flag, $noloop_statement_flag, $pod_flag, $webname);

    $Reload = 1;
    $Loop_Count_Reload = 0;
    undef @Tk_widgets;

    for $file (@files) {
        open(CODE, $file) or die "Error, can not open file $file:$!\n";
        @{$User_Code{$file}} = <CODE>;
        close CODE;
        $file_code_times{$file} = (stat($file))[9];
    }

    &object_states_save unless $Startup;

                                # Create item and loop code strings from file data
    my ($record);
    undef @Loop_Code;
    undef @Sub_Code;
    undef %Sub_Code;
    undef @Item_Code;
    undef @Item_Code_Objects;
    undef %Run_Members;
    undef %Benchmark_Members;
    undef %file_by_object_name;
    undef %object_names_by_file;
    undef %object_names_by_webname;
    undef %objects_by_object_name;
    undef %object_names_by_type;
    undef %files_by_webname;

    my (%member_sort_order, %object_name_check);
    for $file (sort sort_user_code keys %User_Code) {
        print "Reading $file\n" if $Debug{misc};

                                # Allow for . in dir name (e.g. misterhouse-2.26)
                                # Add _table suffix, so we can have both items.pl and items.mht
        my ($member_name) = $file =~ /([^\\\/\.]+)\.[^\\\/\.]+$/i;
        $member_name .= '_table' if $file =~ /mhp$/;

        $webname = $member_name;
        $noloop_flag = $noloop_statement_flag = $pod_flag = 0;

#       push (@Item_Code, "my $item_file_name; # Used to see which files items came from \n");
        my ($code, $code_flag);
        for my $temp (@{$User_Code{$file}}) {
            $record = $temp;    # Do not want to modify stuff in User_Code
#           push(@Item_Code, "\$item_file_name = '$file';\n");

                                # Check for pod sections
            $pod_flag = 1 if $record =~ /^=for/ or $record =~ /^=begin/;
            $pod_flag = 0 if $record =~ /^=cut/ or $record =~ /^=end/;
            if ($pod_flag) {
                $code .= $record;
                next;
            }

                                # No need to keep subroutines out of the loop code ... no speed advantage ?!?
#           $subroutine_flag = 1 if $record =~ /^ *sub /; # Assume the rest of the file is subroutine!
            $noloop_flag = 1 if $record =~ /#\s*noloop=start/i;
            if ($record =~ /\#\s*category\s*=\s*(.+?)\s*[\r\n]/i) {
                $webname = $1;
                $record .= "\n\$Category = '$1';\n"; # Used in tk_widgets
                push @{$files_by_webname{$webname}}, $member_name;
            }
            $webname =~ tr/ /\_/;    # Blanks are not allowed in urls
            $member_sort_order{$member_name} = $1 if $record =~ /\#\s*position\s*=\s*(\S+)/i;

                                # Pull it out as an mh object IF:
                                #  - It has 0 to 3 blanks in front of it (no my, not indented more than 3 blanks)
                                #    Allow for new XYZ(stuff), new XYZ;, new XYZ qq|stuff|, etc
#           my ($object, $type) = $record =~ /^\s*(\$\S+)\s*=\s*new\s+(\S+?)\s*[\(\;]/;
#           my ($object, $type) = $record =~ /^\s{0,3}(\$\S+)\s*=\s*new\s+(\S+?)\s*[\(\"\'\;\n]/;

#           my ($object, $type) = $record =~ /^\s{0,3}(\$\S+)\s*=\s*new\s+([^\s\(\;]+)/; # <- Did not parse on RH 9.0 perl 5.8!  Ok without last \s
#           my ($object, $type) = $record =~ /^\s{0,3}(\$\S+)\s*=\s*new\s+([A-Za-z0-9\_\-]+)/;
            my ($object, $type) = $record =~ /^\s{0,3}(\$\S+)\s*=\s*new\s+([A-Za-z0-9:\_\-]+)/;


                                # Allow for type->new(..)
            ($object, $type) = $record =~ /^\s{0,3}(\$\S+)\s*=\s*(\S+?) *-> *new/ unless $type;

#           print "wn=$webname member=$member_name o=$object type=$type\n";

                                # Store a ref-to-name correlation hash
            if ($object) {
                                # Warn if a duplicate record, but only if it is different
                                #  That way we can define identical objects in different members.
                                #  First drop extra blanks, so records look more similar
                my $r_test = $record;
                $r_test =~ s/ +/ /g;
                if ($object_name_check{$object} and $object_name_check{$object}{record} ne $r_test) {
                    printf "\n\nWarning, duplicate object name: $object\n";
                    printf " - %-15s: %s - %-15s: %s\n", $member_name, $r_test,
                       $object_name_check{$object}{member}, $object_name_check{$object}{record};
                }
                $object_name_check{$object}{record} = $r_test;
                $object_name_check{$object}{member} = $member_name;

                push @Item_Code_Objects, &store_object_data($object, $type, $webname, $member_name);
            }

                                # Find global records
                                #  - only if has 0 to 3 blanks in front of it
                                #  - Methods can be of either form:
                                #     $object -> method (parms)
                                #     method $object parms
                                #     Can also do a return if $Reload in the method, and leave it in the loop

            if ($object or
                $record =~ / # *noloop *$/i or        # noloop record comment
                $record =~ /^my[\s\(]/ or             # Global 'my'
                $record =~ /^our[\s\(]/ or            # Global 'our'
                $record =~ /^use +vars\s/ or          # Global 'use vars'
                $record =~  /^\s*hidden\s/ or         # These only needs to be done on code load
                $record =~ /->\s*hidden/   or
                $record =~  /^\s*set_(authority|icon|info|order|fp_location)\s/ or
                $record =~ /->\s*set_(authority|icon|info|order|fp_location)/   or
                $record =~ /^\s{0,3}\S+\s*->\s*add[\s\(]/ or
                $record =~ /^\s{0,3}add\s/) {
                $noloop_statement_flag = 1 unless $pod_flag; # Allow for multi-record statements
            }

            if ($noloop_flag or
                $noloop_statement_flag) {
                push(@Item_Code, $record);
#               print "item rec=$record\n";
            }
            else {
                $code .= $record;
                $code_flag++ unless $record =~ /^\s*$/ or $record =~ /^\s*\#/;
            }

                                # Check for the end of a statment ... allow for end of line comments
            $noloop_statement_flag = 0 if $record =~ /\;\s*$/ or $record =~ /\;\s*#/;

            $noloop_flag = 0 if $record =~ /#\s*noloop=stop/i;

        }
                                # Only create subroutine if this file had event code
        if ($code_flag) {
            $Sub_Code{$member_name} = $code;
            $Run_Members{$member_name} = 1;
        }

                                # Default the order of user files after common files,
                                # so we can override functions if neede
        unless (defined $member_sort_order{$member_name}) {
            $member_sort_order{$member_name} = ($file =~ /$config_parms{code_dir_common}/) ? 8 : 9;
        }

#       ($webname =~ /startup/i) ?  unshift(@Loop_Code, $temp) : push(@Loop_Code, $temp);
    }

                                # Sort Loop_Code into desired order
    for my $member_name (sort {$member_sort_order{$a} <=> $member_sort_order{$b} or
                               $a cmp $b} keys %Run_Members) {

        next unless $Sub_Code{$member_name};

        my ($sub_name, $sub_code) = &read_user_code_loopcode($member_name, $Sub_Code{$member_name});
        push @Sub_Code, $sub_code;

        $temp = "    \$Run_Members{'$member_name'}++, $sub_name, \$Run_Members{'$member_name'}-- if \$Run_Members{'$member_name'};\n";
                                # Running eval on each member code is too ineffecient
                                #  - At sleep_time=1, my I went from 60 pps, 2% cpu, to 30 pps, 25% cpu
#       $temp = qq[   if (\$Run_Members{'$member_name'}) {eval '$sub_name'; &display_loopcode_error('$member_name') if \$@;}\n];
        ($webname =~ /startup/i) ?  unshift(@Loop_Code, $temp) : push(@Loop_Code, $temp);
    }

#   push(@Loop_Code, "\n   \$Startup = 0; \$Reload = 0; \$Reread = 0;\n}");


                                # 'use vars' allows us to keep use strict vars, but also
                                # entries in the symbol table (unlike 'my') so we can
                                # do the 'object_name' reference and do symbolic var manipulation
    for (sort keys %file_by_object_name) {
        my @list = sort keys %{$file_by_object_name{$_}};
    @list = grep !/\[/, @list;    # Do not 'use vars' objects that are members of pre-declared list arrays
        unshift @Item_Code, "use vars qw(@list);\n\n";
        unshift @Item_Code, "# List of $_ objects\n";
    }
    push(@Item_Code, @Item_Code_Objects); # These have to come after the objects have been defined

    &write_user_code;

    @Object_Types = sort keys %object_names_by_type;
}

sub store_object_data {
    my ($object, $type, $webname, $member_name) = @_;
    my $code;
                               # Store object data in various hashes
    $file_by_object_name{$type}{$object} = $member_name;
    push @{$object_names_by_file{$member_name}}, $object;
    push @{$object_names_by_webname{$webname}},  $object;
    push @{$object_names_by_type{$type}},        $object;

                               # Now generate code for on-they-fly stored data
                               # because we don't get object reference till code is evaluated
    $code  = qq[\$objects_by_object_name{'$object'} = $object;\n];
    $code .= $object . qq[->{category} = "$webname";\n];
    $code .= $object . qq[->{filename} = "$member_name";\n];
    $code .= $object . qq[->{object_name} = '$object';\n];
    return $code;
}

sub read_user_code_loopcode {
    my ($member_name, $code) = @_;
    my $sub_name = "${member_name}_loopcode";
    $sub_name =~ s/[- ]/_/g;   # Legalize sub name
    my $debug_print = '';
    $debug_print = "print '   $member_name' if \$Debug{user_code};\n";
    return ($sub_name, "#-------------------------------------------------\n\n" .
        "sub $sub_name {\n $debug_print" .
        "   if (\$Run_Members{'$member_name'} > 10) { # Check for too many eval errors\n" .
        "        display('Multiple eval errors in $member_name.  Code was disabled', 0);" .
        "   \$Run_Members{'$member_name'} = 0; return;\n   }\n" .
        "   my \$benchmark_tickcount = &get_tickcount if \$Benchmark_Members{on_off_flag};\n" .
#       " print \"db rl=\$Reload m=$member_name\n\" if \$Reload;\n" .
        $code .
        "   \$Benchmark_Members{'$member_name'} += &get_tickcount - \$benchmark_tickcount if \$benchmark_tickcount and \$Benchmark_Members{on_off_flag};\n" .
        "\n} # End of $member_name");
}

                                # This allows for a quick replacement of code that has no global items (e.g. tv_grid_program.pl)
                                # Much quicker than a read_code call.
                                # Like the 'do' function, except we add sub member_name {} around the code
sub do_user_file {
    my ($file) = @_;
    my ($member_name) = $file =~ /([^\\\/]+)\.(pl|mhp)$/i;
    $member_name .= '_table' if $file =~ /mhp$/;
    my ($sub_name, $code) = &read_user_code_loopcode($member_name, &file_read($file, 1));
    print_log "Evaluating code $member_name";
    print "\n\n\ndb user_file code:\n", $code, "\n\n" if $Debug{misc};
    eval $code;
                                 # If error, use previous code if we have it
    if ($@) {
        print_log "Error in do_user_file eval on $file";
        display   "Error in do_user_file eval on $file: \n error: $@\n";
        if ($Sub_Code{$member_name}) {
            print_log "Reading in older code for $member_name";
            $code = &read_user_code_loopcode($member_name, $Sub_Code{$member_name});
            eval $code;
            display   "Error in 2nd do_user_file eval $file: \n error: $@\n" if $@;
        }
    }
}

sub run_after_delay {
    my ($delay, $code_ref) = @_;
    my $timer = new Timer;
    set $timer $delay, $code_ref;
                                # Data Dumper will not dump anonymous subroutines
#   push @{$Persistent{timers}}, $timer;
}

sub run_voice_cmd {
    my ($cmd, $vocab, $set_by, $no_log, $respond_target) = @_;
    $vocab = 'mh' unless $vocab; # Default

                                 # Look for the first Voice_Cmd match
    my ($ref, $said, $vocab_cmd) = &Voice_Cmd::voice_item_by_text(lc($cmd));
    print "run_voice_cmd cmd=$cmd ref=$ref said=$said vocab=$vocab_cmd no_log=$no_log set_by=$set_by target=$respond_target\n"
        if $Debug{misc};
    if ($ref and $vocab eq $vocab_cmd) {
        set $ref $said, $set_by, $no_log, $respond_target;
#       return $ref;
    }
                                 # Also look for any Text_Cmd matches
                                 # ... maybe this should go under process_external_command?
                                 # ... if so, web RUN would not work.
    my $text_cmd_matches = &Text_Cmd::set_matches($cmd, $set_by, $no_log, $respond_target);

    return ($ref or $text_cmd_matches) ? 1 : 0;
}



sub sendkeys_find_window {
    my ($title, $program, $timeout) = @_;
    return unless $OS_win;

    $timeout = 2000 unless defined $timeout;
                                # Use this if we need to disable Setupsup ?
    if (0) {
        print "Starting $program\n" if $Debug{misc};
        run $program;
        print "Waiting for $title...\n" if $Debug{misc};
        select undef, undef, undef, .5; # Give it a chance to get going
    }
    else {
        my $window;
        unless (&WaitForAnyWindow($title, \$window, 100, 200) or !$program) {
            print "Starting $program\n" if $Debug{misc};
	    $program = "\"$program\"" if $program =~ /\x20/;
            run $program;
            print "Waiting for $title...\n" if $Debug{misc};
            &WaitForAnyWindow($title, \$window, $timeout, 200); # Wait for 2 seconds
            select undef, undef, undef, .5; # Give it a chance to get going
        }
        if ($window) {
            print "Found window $title: $window\n" if $Debug{misc};
            return $window;
        }
        else {
            print "Timed out waiting for $title window for $program\n" if $Debug{misc};
        }
    }
}


my ($loop_speed_cnt, $loop_unix_cnt, $prev_time, $prev_sec, $prev_min, $prev_hour, $prev_mday, $prev_month, $prev_year);
sub set_global_vars {

                                # Need to get smart and do this only every second/hour/etc.
    $loop_speed_cnt++;
    $Loop_Count++;
    $Loop_Count_Reload++;
    $New_Second      = 0;
    $New_Msecond_500 = 0;
    $New_Msecond_250 = 0;
    $New_Msecond_100 = 0;
    $New_Minute      = 0;
    $New_Hour        = 0;
    $New_Day         = 0;
    $New_Week        = 0;
    $New_Month       = 0;
    $New_Year        = 0;
    $DelayOccured    = 0;

    my $time_now = time;
    if ($Startup) {
        $prev_time = $Time - 1;
        $prev_min = $prev_hour = $prev_mday = $prev_month = $prev_year = '';
    }
                                # If mh got hung up doing something, lets go to catch up mode
    elsif (!$Time_Start_time and $prev_time < ($time_now - 2)) {
        $DelayOccured = $time_now - $prev_time;
        unless ($config_parms{no_log} =~ /pause/ or $Reload or $Loop_Count < 10
                or ($config_parms{time_pause_log} and $config_parms{time_pause_log} > $DelayOccured) ) {
            my $volume = int 100 * $DelayOccured / 30;
            if (-e ($Sounds{'mh_pause'}) ) {
                &play(file => 'mh_pause', volume => $volume); # Defined in event_sounds.pl
            }
            print_log "Paused for $DelayOccured seconds";
        }
        logit "$config_parms{data_dir}/logs/mh_pause.$Year_Month_Now.log",  "mh paused for $DelayOccured seconds";
        if ($DelayOccured > $config_parms{time_catchup_skip} and $config_parms{no_log} =~ /pause/) {
            print_log "Skipping catchup mode. Pause of $DelayOccured > $config_parms{time_catchup_skip} seconds";
        }
        else {
            $Time_Start_time = $prev_time;
            set $Catchup_Mode 'mh_pause';
            $Time_Increment  = 1;
            $config_parms{sleep_time} = $Loop_Sleep_Time; # In case we manually change it after startup
            $Loop_Sleep_Time = 0;   # Go to full throttle catchup mode
        }
    }

                                # Check for test mode, where we cycle one second per loop
    if ($Time_Start_time or $Time_Stop_time) {

                                # We are past Stop_time, exit mh
        if ($Time_Stop_time and $Time_Stop_time < $Time) {
            my $msg = "Exiting at specified stop time of $config_parms{time_stop}";
#           &speak($msg);
            print_log $msg;
            print $msg;
            &exit_pgm;
        }
                                # All caught up, go to normal mode
        if (!$Time_Stop_time and $Time_Start_time and ($Time + $Time_Increment) > time) {
            if ($$Catchup_Mode{state} eq 'startup') {
                my $msg = "Caught up from start time of $config_parms{time_start}";
                print_log $msg;
                &speak($msg) unless $config_parms{time_start} eq 'resume';
#               $Loop_Tk_Passes  = $config_parms{tk_passes};
            }
            set $Catchup_Mode 'done';
            $Loop_Sleep_Time = $config_parms{sleep_time};
            undef $Time_Start_time;
        }
        else {
            $Time += $Time_Increment;
                                # Reset these so the $New_Msecond_* is always true in catchup mode
            $loop_tickcount2 = $loop_tickcount3 = $loop_tickcount4 = 0;
        }
    }
    else {
        $Time = time;
    }

                                # If clock was reset to a past time, keep old time till we catch up.
                                # This way, we do not repeat time base events (like running set_clock.bat again)
    $Time = $prev_time if $prev_time > $Time;

                                # Check if we need to set the .1 second flag
    if ($loop_tickcount1 - $loop_tickcount2 > 100) {
        $loop_tickcount2 = $loop_tickcount1;
        $New_Msecond_100 = 1;
    }
    if ($loop_tickcount1 - $loop_tickcount3 > 250) {
        $loop_tickcount3 = $loop_tickcount1;
        $New_Msecond_250 = 1;
        if ($loop_tickcount1 - $loop_tickcount4 > 500) {
            $loop_tickcount4 = $loop_tickcount1;
            $New_Msecond_500 = 1;
        }
    }


    unless ($prev_time == $Time) {
                                # Synchronize milli-second flags
        $loop_tickcount2 = $loop_tickcount3 = $loop_tickcount4 = $loop_tickcount1;
        $New_Msecond_100 = $New_Msecond_250 = $New_Msecond_500 = 1;

        $Info{loop_speed} = $loop_speed_cnt;
        $Loop_Speed       = $loop_speed_cnt; # Grandfathered (in old benchmarks.pl)
        if (@Loop_Speeds) {
            unshift(@Loop_Speeds, $Info{loop_speed});
            pop(@Loop_Speeds);
        }
        else {
            @Loop_Speeds = ($Info{loop_speed}) x 20;
        }
#       print "Speeds1 = @Loop_Speeds\n";
        $loop_speed_cnt = 0;
        $prev_time = $Time;

        $New_Second = 1;
        my $year_unix;
        ($Second, $Minute, $Hour, $Mday, $Month, $year_unix, $Wday) = localtime($Time);
        $Month++;
        $Day = (qw(Sun Mon Tue Wed Thu Fri Sat))[$Wday];
        $prev_sec = $Second;

        $Time_Date = &time_date_stamp($config_parms{time_format_log}, $Time);

                                # Note: use eq instead of ==, so 0 does not eq ''
                                # This could happen if mh were started at midnight (hour=0)
        if ($prev_min ne $Minute) {
            $New_Minute = 1;
            $prev_min = $Minute;

            $Time_Now  = &time_date_stamp(5, $Time);
                                # Drop the : so 18:00 is pronounced 1800, not 18
                                #  - but then 20:00 is proununced 2 thousand, not 20 hundred :(
#           $Time_Now =~ s/\:// if $config_parms{time_format} == 24 and $Time_Now =~ /^\d+\:0\d$/;

            if ($prev_hour ne $Hour) {
                $New_Hour = 1;
                $prev_hour = $Hour;

                if (&time_less_than('5:00')) {
                    $Time_Of_Day = 'night';
                }
                elsif (&time_less_than('11:59')) {
                    $Time_Of_Day = 'morning';
                }
                elsif (&time_less_than('17:00')) {
                    $Time_Of_Day = 'afternoon';
                }
                elsif (&time_less_than('21:00')) {
                    $Time_Of_Day = 'evening';
                }
                else {
                    $Time_Of_Day = 'night';
                }

                if ($prev_mday ne $Mday) {
                    $New_Day = 1;
                    $prev_mday = $Mday;
                    if ($Wday == 0 or $Wday == 6) {
                        $Weekday = 0;
                        $Weekend = 1;
                    }
                    else {
                        $Weekday = 1;
                        $Weekend = 0;
                    }
                    if ($Wday == 0) {
                        $New_Week = 1;
                    }
                    $Date_Now           = &time_date_stamp(6, $Time);
                    $Date_Now_Speakable = &time_date_stamp(15, $Time);
                    $Year_Month_Now = &time_date_stamp(10, $Time);  # Useful for log files
                    $Year = $year_unix + 1900;
                    $Year += 100 if $Year < 1970;
                    &set_sun_time; # Get new sunrise/sunset times for the new day
                    &set_moon_data; # Get new sunrise/sunset times for the new day

                                # Calander info at: http://www.pip.dknet.dk/~pip10160/cal/calendar20.txt
                                # From a anoter web page (no other info though)
                                #  For March Equinox= 365.2421376Y+.0.0679190Y^2-0.0027879Y^3
                                #  For September Equinox=1721325.6978+365.2425055Y-0.1266890Y^2+0.0019401Y^3
                                # These season dates are averages

                    my @seasons = split(',', $config_parms{seasons});
                    my @season_starts = split(',', $config_parms{season_starts});

                    if ($Month < 3 or ($Month == 3 and $Mday < $season_starts[0]) or ($Month == 12 and $Mday > $season_starts[3])) {
                        $Season = $seasons[0];
                    }
                    elsif ($Month < 6 or ($Month == 6 and $Mday < $season_starts[1])) {
                        $Season = $seasons[1];
                    }
                    elsif ($Month < 9 or ($Month == 9 and $Mday < $season_starts[2])) {
                        $Season = $seasons[2];
                    }
                    else {
                        $Season = $seasons[3];
            }


                                # Check/Set the $Holiday var
                    if ($config_parms{holiday_dates}) {
#                       print "Checking holiday dates $config_parms{holiday_dates}\n";
                        undef $Holiday;
                        for my $date_des (split ',', $config_parms{holiday_dates}) {
                            my($month, $mday, $wday, $week, $year, $des);
                            if (($month, $wday, $week, $des) = $date_des =~ m|(\d+)/(\d+)\^(-?\d+)\s*(.*)|) {
                                my $week2 = ($week < 0) ?  int((days_in($Year, $Month) - $Mday + 7)/7) : int(($Mday + 6)/7);
#                               print "db0 m=$month wday=$wday week=$week week2=$week2 des=$des\n";
                                if ($month == $Month and $wday == $Wday) {
                                    if (($week > 0 and int(($Mday + 6)/7) == $week) or
                                        ($week < 0 and int((days_in($Year, $Month) - $Mday + 7)/7) == abs($week))){
                                        $des = 1 unless $des; # Description is optional
                                        $Holiday = $des;
                                    }
                                }
                            }
                            elsif (($month, $mday, $year, $des) = $date_des =~ m|(\d+)/(\d+)/?(\d*)\s*(.*)|) {
                    ($mday, $month) = ($month, $mday) if $config_parms{date_format} =~ /ddmm/;
#                               print "db1 m=$month y=$year des=$des\n";
                   # Allow for yy or 20yy
                next if $year and (($year % 100) != ($Year % 100));
                                if ($month == $Month and $mday == $Mday) {
                                    $des = 1 unless $des; # Description is optional
                                    $Holiday = $des;
                                }
                            }
                        }
            print "Holiday notice:  $Date_Now $Holiday\n" if $Holiday;

                    }

                    if ($prev_month ne $Month) {
                        $New_Month = 1;
                        $prev_month = $Month;
                        if ($prev_year ne $Year) {
                            $New_Year = 1;
                            $prev_year = $Year;
                        }
                    }
                }
            }
                                # This must be run AFTER startup sun_time call
            if (&time_less_than(  $Time_Sunrise_Twilight) or
                &time_greater_than($Time_Sunset_Twilight)) {
                $Dark = 1;
            }
            else {
                $Dark = 0;
            }
        }
        $New_Second = $New_Minute = $New_Hour = $New_Day = $New_Week = $New_Month = $New_Year = 0 if $Startup or $Reload;

                                # More $New_Second stuff ...
        $Info{cpu_used} = 0;
        if ($^O eq 'linux') {
            open(STAT, "/proc/$$/stat") or print "Error, Can not  open /proc/$$/stat: $!";
            my @a = split(/\s+/, <STAT>);
            close STAT;
                                # Add utime (user time) and ktime (kernal time).  These are in 1/100 second units
            my $cnt = $a[13] + $a[14];
            $Info{cpu_used} = ($cnt - $loop_unix_cnt) if $loop_unix_cnt;
            $Info{memory_virtual} = $a[22] / 1024000;
            $Info{memory_real}    = $a[23] * 4 / 1000;
            $loop_unix_cnt = $cnt;
        }
        else {
                                # This call takes .2 seconds, so only do it once a minute, and not in fast mode
            ($Info{memory_virtual}, $Info{memory_real}) = &memory_used if $Startup or
                ($New_Minute and !($Time_Start_time or $Time_Stop_time));

                                # Calculate a rolling average ... naw, per second good so we can match to taskman
#            @loop_tickcount_totals = 5 x $loop_tickcount_total unless @loop_tickcount_totals;
#            shift @loop_tickcount_totals;
#            push @loop_tickcount_totals, $loop_tickcount_total;
            $Info{cpu_used} = 100*$loop_tickcount_total/1000 if $loop_tickcount_total;
            $Info{cpu_used} /= 2; # Heuristic ... maybe due to un-accounted for sleeps in non-user code?
            $loop_tickcount_total = 0;
        }
        $Info{cpu_used} = 100 if $Info{cpu_used} > 100;

        $Tk_objects{label_time} = &time_date_stamp(14, $Time);

#        substr($Tk_objects{label_time}, 19, 0) = '  Time: ';

        $Time_Uptime_Seconds = $Time - $Time_Startup_time;
        my $uptime_days;
        if ($New_Minute and 48 < ($uptime_days = $Time_Uptime_Seconds / (24 * 3600000))) {
            print_log "Uptime: $uptime_days days.  Better re-start MisterHouse.  " .
                "It will mess up after 49.7 (2**32 mill-seconds) days of uptime";
            &speak("Please restart misterhouse.  Uptime is $uptime_days days.") if $New_Hour and $Hour > 9 and $Hour < 22;
        }

        $Tk_objects{label_uptime_cpu} = sprintf("CPU %s",
                                                &time_diff($Time_Boot_time, $Time, undef, 'numeric'));
#                                               &time_diff($Time_Boot_time, ($loop_tickcount1)/1000, undef, 'numeric'));
        $Tk_objects{label_uptime_mh}  = sprintf("MH %s",
                                                &time_diff($Time_Startup_time, $Time, undef, 'numeric'));
	my $cpu_used = $Info{cpu_used};
	if ($cpu_used == 100) {
		$cpu_used = ' 100%'; # Fixes jitter when system status bar visible and toolbar floating (or on side edge)
	}
	else {
		$cpu_used = sprintf("%3.1f%%", $cpu_used);
	}
        $Tk_objects{label_cpu_used}    = "CPU $cpu_used" . (($config_parms{tk_loop_speed})?sprintf(" Loops %3d", $Info{loop_speed}):'');
        $Tk_objects{label_memory_used} = sprintf("MB %3.1f/%3.1f",
                                                 $Info{memory_virtual}, $Info{memory_real}) if $Info{memory_virtual};
                                # This is grandfathered for old Tk menus
        $Tk_objects{label_cpu_loops}  = sprintf("Loops Per Second: %4d", $Info{loop_speed});

    }

    # Save object states every 5 minutes, in case mh is aborted without a proper shutdown
#   &object_states_save if $New_Minute and !($Minute % 5); $Time_Increment
    &object_states_save if $New_Minute and !($Time_Start_time or $Time_Stop_time); # Skip if in accelerated mode

    &set_debug_data if $New_Second;         # Populate %Debug if debug changed

}

sub generic_device_create {
	my ($name)=@_;


	my $location = $config_parms{$name.'_device'};
	my $datatype = $config_parms{$name.'_device_datatype'};
	my $break  = $config_parms{$name.'_device_break'};
	my $mode  = $config_parms{$name.'_device_mode'};

	unless ($location) {
		&print_log("can't create generic device $name without a location");
		return;
	}

	print(" - creating generic device $name on $location\n");

	$datatype = 'raw' unless $datatype;
	$break = "\r\n" unless $break;
	$mode = "rw" unless $mode;

	$Generic_Devices{$name}{location} = $location;
	$Generic_Devices{$name}{datatype} = $datatype;
	$Generic_Devices{$name}{break} = $break;
	$Generic_Devices{$name}{readable} = ($mode =~ /r/);
	$Generic_Devices{$name}{writeable} = ($mode =~ /w/);

	&generic_device_open($name);
}

sub generic_device_open {
	my ($name)=@_;

	my $flags= O_NONBLOCK;

	if ($Generic_Devices{$name}{readonly}) {
		$flags |= O_RDONLY;
	} else {
		$flags |= O_RDWR;
	}

	my $handle=new IO::File($Generic_Devices{$name}{location}, $flags);

	if (!defined $handle) {
		&print_log("Can't open generic device $name: ".$Generic_Devices{$name}{location}.": $!");
		return;
	}

	$Generic_Devices{$name}{handle}=$handle;
}

sub check_for_generic_device_data {
	return unless %Generic_Devices;

	foreach my $name (keys(%Generic_Devices)) {
		next unless $Generic_Devices{$name}{handle};
		next unless $Generic_Devices{$name}{readable};
		my $rin='';
		vec($rin,$Generic_Devices{$name}{handle}->fileno,1)=1;
		my $numFound=select($rin,undef,undef,0);
		if ($numFound) {
			read_from_generic_device($name);
		}
	}
}

sub read_from_generic_device {
	my ($name)=@_;

	my $buffer;

	while ($Generic_Devices{$name}{handle}->sysread($buffer,1024)) {
		# &print_log("read ".length($buffer)." bytes from generic device $name");
		# &print_log("buffer is $buffer");
		$Generic_Devices{$name}{data} .= $buffer;
	}
	if ($! and $! != 11) { # error 11 is "resource temporarily unavailable", we ignore it
		&print_log("Error reading from $name: $! ",int($!));
	}
	if ($Generic_Devices{$name}{datatype} ne 'raw') {
		my $break = $Generic_Devices{$name}{break};
		if (my ($record, $remainder) = $Generic_Devices{$name}{data} =~ /(.+?)$break(.*)/s) {
			$Generic_Devices{$name}{data_record}=$record;
			$Generic_Devices{$name}{data}=$remainder;
		}
	}
}

sub serial_port_create {
    my ($name, $port, $baudrate, $handshake, $datatype, $prefix, $parity, $databits, $stopbits) = @_;

	# *** This fixes COM ports on Win2K platforms, so INI documentation about this is unneeded.

    $port = '\\\\.\\' . $port if $Info{OS_name} =~ /(NT|XP)/ and $port =~ /^com\d{2}\z/i;


    my $pretty_name = $name;
    $pretty_name =~ s/_/\x20/g;

    unless ($name and $port) {
        print "\n\nError, serial port data missing: name=$name port=$port\n\n";
        return;
    }

    printf " - creating %s port on %s\n", $pretty_name, $port;

    $handshake = 'none' unless $handshake;
    $baudrate  = '1200' unless $baudrate;
    $parity    = 'none' unless $parity;

    $Serial_Ports{$name}{handshake} = $handshake;
    $Serial_Ports{$name}{baudrate}  = $baudrate;
    $Serial_Ports{$name}{port}      = $port;
    $Serial_Ports{$name}{datatype}  = $datatype;
    $Serial_Ports{$name}{parity}    = $parity;
    $Serial_Ports{$name}{prefix}    = $prefix;

    if ($port =~ /proxy/i) {
        $Serial_Ports{$name}{object} = 'proxy';
        return;
    }

    &serial_port_open($name, $databits, $stopbits);
#   &serial_port_open($name)  || delete $Serial_Ports{$name};
}

sub serial_port_open {
    my ($name, $databits, $stopbits) = @_;

    my $serial_port;
    my $port = $Serial_Ports{$name}{port};

    $databits = 8 unless $databits;
    $stopbits = 1 unless $stopbits;


    delete $Serial_Ports{$name}{object}; # Delete previous object, if any

                                # Re-use an opened port, if it exists already
    if ($serial_port = $Serial_Ports{object_by_port}{$port}) {
        print "   reusing serial object on port $port for $name\n";
        $Serial_Ports{$name}{object} = $serial_port;
        return;                 # First port gets to set baudrate etc
    }
    else {
                                # Must do a 'new', even if re-opening a recently closed port :(
        unless (( $OS_win and $serial_port = new Win32::SerialPort ($port))or
                (!$OS_win and $serial_port = new Device::SerialPort ($port))) {
            print "\n\nCan't open serial port $port: $^E\n\n";
            return;
        }
    }

    $Serial_Ports{$name}{object} = $serial_port;
    $Serial_Ports{object_by_port}{$port} = $serial_port;

#   $serial_port->{"_RBUF"} = " "x4096;
#   $serial_port->{"_RBUF"} = " "x16000;

#   my $serial_port = $Serial_Ports{$name}{object};
    $serial_port->error_msg(1);     # use built-in error messages
    $serial_port->user_msg(0);

    $serial_port->databits($databits) if $serial_port->can_databits;
    $serial_port->baudrate($Serial_Ports{$name}{baudrate});
    $serial_port->parity($Serial_Ports{$name}{parity});
    $serial_port->stopbits($stopbits);
#   $serial_port->dtr_active(1);
    $serial_port->handshake($Serial_Ports{$name}{handshake});
#   $serial_port->read_buf_max(4096);
#   $serial_port->write_buf_max(4096);

    return $serial_port->write_settings;

#   my @serial_parms = $serial_port->set_test_mode_active;
#   print "np=@serial_parms\n";
}


sub set_sun_time {
    my @parms = (latitude  =>  $config_parms{latitude}, longitude => $config_parms{longitude},
                 time_zone =>  $config_parms{time_zone});

    print "Latitude: $config_parms{latitude},  Longitude: $config_parms{longitude},  Time Zone: $config_parms{time_zone}\n";
    $Time_Sunrise = &sun_time(type => 'rise', @parms);
    $Time_Sunset  = &sun_time(type => 'set',  @parms);

    $Time_Sunrise_Twilight = &sun_time(type => 'rise', twilight => $config_parms{twilight}, @parms);
    $Time_Sunset_Twilight  = &sun_time(type => 'set',  twilight => $config_parms{twilight}, @parms);

    if ($config_parms{time_format} == 12) {
        $Time_Sunrise          = time_to_ampm $Time_Sunrise;
        $Time_Sunset           = time_to_ampm $Time_Sunset;
        $Time_Sunrise_Twilight = time_to_ampm $Time_Sunrise_Twilight;
        $Time_Sunset_Twilight  = time_to_ampm $Time_Sunset_Twilight;
    }

    print "sunrise=$Time_Sunrise sunset=$Time_Sunset\n";
    print "sunrise twilight=$Time_Sunrise_Twilight sunset twilight=$Time_Sunset_Twilight\n";
}

sub set_moon_data {
    my @phase = Astro::MoonPhase::phase($Time);
    $Moon{phase} = ('New',  'One-Quarter Waxing',   'Half Waxing', 'Three-Quarter Waxing',
                    'Full', 'Three-Quarter Waning', 'Half Waning', 'One-Quarter Waning', 'New')[int .5 + 8 * $phase[0]];
    $Moon{brightness} = int 100 * $phase[1];
    $Moon{age} = int $phase[2];
    print "The moon is $Moon{phase}, $Moon{brightness}% bright, and $Moon{age} days old\n";

    my @phases = Astro::MoonPhase::phasehunt($Time + 3600*24*30);
    my $month  = 3600 * 24 * 29.53058868;

    $Moon{time_new_prev }  = int $phases[0] - (($phases[0] > $Time) ? $month : 0);
    $Moon{time_new}        = int $phases[0] + (($phases[0] < $Time) ? $month : 0);
    $Moon{time_first_prev} = int $phases[1] - (($phases[1] > $Time) ? $month : 0);
    $Moon{time_first}      = int $phases[1] + (($phases[1] < $Time) ? $month : 0);
    $Moon{time_full_prev}  = int $phases[2] - (($phases[2] > $Time) ? $month : 0);
    $Moon{time_full}       = int $phases[2] + (($phases[2] < $Time) ? $month : 0);
    $Moon{time_last_prev}  = int $phases[3] - (($phases[3] > $Time) ? $month : 0);
    $Moon{time_last}       = int $phases[3] + (($phases[3] < $Time) ? $month : 0);

    $Moon{new_prev}   = &time_date_stamp(15, $Moon{time_new_prev});
    $Moon{first_prev} = &time_date_stamp(15, $Moon{time_first_prev});
    $Moon{full_prev}  = &time_date_stamp(15, $Moon{time_full_prev});
    $Moon{last_prev}  = &time_date_stamp(15, $Moon{time_last_prev});
    $Moon{new}        = &time_date_stamp(15, $Moon{time_new});
    $Moon{first}      = &time_date_stamp(15, $Moon{time_first});
    $Moon{full}       = &time_date_stamp(15, $Moon{time_full});
    $Moon{last}       = &time_date_stamp(15, $Moon{time_last});

    print "The next full moon is on $Moon{full}\n";
}

sub sig_handler {
    print "Exit flag set in sig_handler\n" if $Debug{exit};
    $exit_flag = 1;
}
sub sig_handler_pipe {
    print "\nBroken pipe\n";
}
sub sig_child_death {
#   my $pid = wait;
#   print "reaped $pid" . ($? ? " with exit $?" : '');
                                # Harvest potentially more than one dead child
    use POSIX ":sys_wait_h";
    my $pid;
    do {
        $pid = waitpid(-1,  WNOHANG);
    } until $pid <= 0;
#       $pid = waitpid(-1, &WNOHANG);
#   } until $pid == -1;
}

                                # This will close either client or server active socket
sub socket_close {
    my ($port_name) = @_;
    my $sock = $Socket_Ports{$port_name}{socka};
    print "Closing socket port $port_name\n" if $Debug{$port_name};
    unless ($sock) {
        print "Error, socket_close sock port undefined for port $port_name\n";
    }
    else {
        close $sock;
    }
    delete $Socket_Ports{$port_name}{socka};

                                # Drop client data from list of active clients
    my $client_number = $Socket_Ports{$port_name}{client_number};
    splice(@{$Socket_Ports{$port_name}{clients}}, $client_number, 1) if defined $client_number;

                                # See if we need to close the parent socket
    delete $Socket_Ports{$port_name}{sock} if
        $Socket_Ports{$port_name}{host_port} and
        $Socket_Ports{$port_name}{host_port} =~ /\:/; # Client, not server, socket

    $Socket_Ports{$port_name}{inactive_this_pass_flag} = 1;
    $Socket_Ports{$port_name}{active_this_pass_flag} = 0;
}

                                # This opens a server socket (client sockets are done in mh/lib/Socket_Item.pm)
sub socket_open {
    my ($port_name) = @_;
    my $proto   = $Socket_Ports{$port_name}{protocol};
    my $port    = $Socket_Ports{$port_name}{port};
    my $address = $Socket_Ports{$port_name}{address};
    print "Opening socket port $port_name on port $port\n" if $Debug{$port_name};
    unless ($port) {
        print "\nError, no port specified for ip server $port_name\n";
        return;
    }
    if ($proto eq 'tcp') {
        $Socket_Ports{$port_name}{sock} =
            new IO::Socket::INET->new(LocalPort => $port, LocalAddr => $address,
                                      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_name}_port in mh.ini\n";
    } elsif ($proto eq 'udp') {
        if ($address) {
            $Socket_Ports{$port_name}{sock} =
                new IO::Socket::INET->new(PeerPort => $port, Proto => 'udp',
                                          PeerAddr => $address, Broadcast => 1) or
                die "Couldn't start a udp peer server on $port_name $port: $@\n";
        }
        else {
            $Socket_Ports{$port_name}{sock} =
                new IO::Socket::INET->new(LocalPort => $port, Proto => 'udp', Broadcast => 1,
                                          LocalAddr => '0.0.0.0') or
#                                         LocalAddr => inet_ntoa(INADDR_ANY)) or
                die "Couldn't start a udp server on $port_name $port: $@\n";
# INADDR_ANY = 0.0.0.0 ... is in IO::Socket::INET, but that is not in perl 5.0 :(
        }
        $Socket_Ports{$port_name}{socka} = $Socket_Ports{$port_name}{sock}; # UDP ports are always "active"
    } else {
        print "\nUnknown protocol in socket_open for socket port $port_name: proto=$proto port=$port\n\n";
    }
}

                                # Restart a server socket
sub socket_restart {
    my ($port_name) = @_;
    my $sock = $Socket_Ports{$port_name}{sock};
    print "Restarting $port_name\n";
    print "Restarting socket port $port_name\n" if $Debug{$port_name};
    unless ($sock) {
        print "Warning, socket_restart sock port was not active: $port_name\n";
    }
    else {
        close $sock;
    }
    &socket_open($port_name);
}


                                # This could be made more efficient per pg. 200 of Advanced perl programing.
                                # and using $bit_out=$bit_in
sub socket_has_data {
    my($sock, $timeout) = @_;
#   return unless $sock;  # Should never happen
    $timeout = 0 unless $timeout;
    my $rbit = '';
    vec($rbit, $sock->fileno(), 1) = 1; # This had an unintilized var??
    my ($nfound) = select($rbit, undef, undef, $timeout);
    return $nfound;
}

                                # Used to parse arg call with "key1=value1 key2=value2 text) or standard parm passing
sub parse_func_parms {
    my ($text) = @_;            # Simple way ... no parms

    my %parms;

    if (@_ > 1) {               # Fancy way key=value way
        print "Odd number of parms in in parse_func_parms: @_.\n" if @_ % 2;
        %parms = @_;
        $text = $parms{text};
    }
                                # Allow for parms in text if done the simple way
    $text = '' unless $text;
    $text = &parse_func_parms2(\%parms, $text);
    $parms{text} = $text;

    return (%parms);
}

sub parse_func_parms2 {
    my ($ref, $text) = @_;
    while (my ($key, $value, $text_new) = $text =~ /^\s*(\S+?)=(\S*)\s*(.*)/s) {
        $text = $text_new;
                                 # If value has leading but not trailing quote, grab till next quote
        if ($value =~ /^[\'\"]([^\'\"]+)$/) {
            $value = $1;
            if ($text =~ /(.+?)[\'\"](.*)/) {
                $value .= " $1";
                $text = $2;
            }
        }
        $key = lc $key;
        $$ref{$key} = $value;
    }
    return $text;
}


sub respond {
    my (%parms) = &parse_func_parms(@_);

    if ($Debug{respond}) {
      my $parm;
      foreach $parm (keys(%parms)) {
        print "respond parm $parm is $parms{$parm}\n";
      }
    }

                                # Get respond from passed parm or global parm
    my $target = $parms{target};
    $target = $Respond_Target unless $target;
                                # Strip out optional key=value parms
    if ($target =~ /(\S+?) (.+)/) {
        $target = $1;
        &parse_func_parms2(\%parms, $2);
    }
    $target = 'default' if $target =~ /\$/; # Ignore goofy target=$object cases
#   $target =~ s/\$//g;     # Avoid errors from target=$object
#    my $p = join ',', %parms; print "db2 p=$p.\n";

                                # Call respond_xyz function
    $target = 'default' if $target !~ /\S/ or $target =~ /unknown/i or $target =~ /UserCode/i or $target =~ /time/i; # includes tie_time

    print "respond target=$target lr=$Last_Response RT=$Respond_Target lso=$leave_socket_open_passes lsa=leave_socket_open_action a=@_\n"
        if $Debug{respond};

    $leave_socket_open_passes = 1 if $leave_socket_open_passes > 0;

                                # If a file, read the contents (ONLY A TEXT FILE, COULD NOT SAY "Play" BEFORE!)
    $parms{text} = &file_read($parms{text}) if $parms{text} =~ /^\S+\.txt$/ and -e $parms{text};

                                # Allow for a , delimited list of targets
    for my $target1 (split ',', $target) {
        my $ref = eval '\&' . "respond_$target1";
        if ($@) {
            warn "Error in respond: respond=$target1 error=$@";
        }
        else {
            $ref->(%parms);
        }
    }
}
                                        # Called to tell web server to wait for respond results

					# *** Okay, so why is $Respond_Target checked?
					# *** One of the last meaningful (?) references to this var

sub respond_wait {
    $leave_socket_open_passes = 200 if $Respond_Target =~ /^web/;
}

sub respond_default {
    &speak(@_);
}
sub respond_display {
    &display(@_);
}
sub respond_email {
    &net_mail_send(@_);
#    &print_log(@_);
}
sub respond_im {
    &net_im_send(@_);
#    &print_log(@_);
}
sub respond_log {
    my %parms = &parse_func_parms(@_);
    &print_log($parms{text});
}
sub respond_speak {
    &speak(@_);
}
sub respond_serial {
    &respond_default(@_);
}
sub respond_rf {
    &respond_default(@_);
}
sub respond_tk {
    if ($config_parms{console_speech}) {
        &speak(@_);
    }
    else {
        &display(@_);
    }
}
sub respond_vr {
    &respond_default(@_);
}
sub respond_web {
    &respond_default(@_);
}
sub respond_xcmd {
    &respond_default(@_);
}
sub respond_unmuted {
    my %parms = @_;
    $parms{mode} = 'unmuted';
    &speak(%parms);
}

sub respond_telnet {
    my %parms = @_;
    my $text = $parms{raw_text};
    $text = $parms{text} unless $text;
    $text =~ s/\n/\n\r/g;
    my $to = $parms{to};
    if ($to) {
       $text = '[response] ' . $text;
    } else {
       $to = 'all' unless $to;
       $text = '[echo] ' . $text;
    }
    print "respond telnet: client=$parms{client} text=$text to=$parms{to}\n" if $Debug{respond};
    if ($to) {
       my $client_num = 0;
       for my $ptr (@{$main::Socket_Ports{server_telnet}{clients}}) {
          my ($socka, $client_ip_address, $client_port, $data) = @{$ptr};
          if (($to eq 'all') or ($client_ip_address eq $to)) {
              eval "\$telnet_server->set(q~$text~,$client_num)";
              if ($@) {
                 print "respond telnet eval error: client=$parms{client} text=$parms{text} error=$@\n";
              } else {
                 # send a cr
                 eval "\$telnet_server->set('cr',$client_num)";
              }
          }
          $client_num++;
       }
    } else {
       eval "\$telnet_server->set(q~$parms{text}~)";#, $parms{to})";
#    eval "\$telnet_server->set(q~$parms{text}~, $parms{arg1})";
       print "respond telnet eval error: client=$parms{client} text=$parms{text} error=$@\n" if $@;
    }
}

sub respond_object_set {
    my (%parms) = @_;
    $parms{name} = '$' . $parms{name} unless $parms{name} =~ /^\$/;
    print "respond object_set: $parms{name}->set(q~$parms{text}~, $parms{arg1}, $parms{arg2})\n" if $Debug{respond};
    eval "$parms{name}->set(q~$parms{text}~, $parms{arg1}, $parms{arg2})";
    print "respond object_set eval error: name=$parms{name}, arg1=$parms{arg1}, error=$@\n" if $@;
}

sub speak {
    my ($rooms, $display_time, $play);

    my %parms = &parse_func_parms(@_);
    &set_app_parms(\%parms, 'speak');     # Set parms according to an optional app parm

    my $phrase = $parms{text};


    print "Voice_Text: speak @_\n" if $Debug{voice};


    my @speak_parms = qw(engine address room rooms mode display play volume time voice pitch card to_file compression app length echo display_rooms);
                                # Not all TTS engines have all these options ... this is a superset
#   print "Warning, speak control not recognized: key=$key value=$value\n"
#            unless grep $key eq $_, @speak_parms;

    if ($main::Info{OS_name}=~ /darwin/i) {   # Should go into Voice::Text? (YES!! It should.)
      print "Trying to speak $phrase\n";
      speak_mac ($phrase);
      return;
    }

    $parms{mode}  = '' unless $parms{mode};
    $parms{rooms} = $parms{room}    if $parms{room}; # Allow for room or rooms
    $rooms        = $parms{rooms}   if $parms{rooms};
    $display_time = $parms{display} if $parms{display};
    $play         = $parms{play}    if $parms{play};


                                # Allow for defaults to be specified in parmfile
    for my $parm (@speak_parms) {
        my $value = $config_parms{"speak_$parm"};
        $parms{$parm} = $value if defined $value and !defined $parms{$parm};
    }

    if ($phrase =~ /\.wav$/) {
        &play('file' => $phrase, 'rooms' => $rooms);
        return;
    }

				# Avoid speaking long text
    if ($parms{length} and length $phrase > $parms{length}) {
        &display(@_);           # Display full text
	$phrase = substr($phrase, 0, $parms{length}) . '.  Speech truncated.'
    }
    else { # Not truncuated, but it is a text file, so display it too (?)
	    $display_time = 120 if !$display_time and $phrase !~ /\n/ and -f $phrase and ($phrase =~ /\.txt$/);
	    &display($phrase, $display_time) if $display_time;
    }

                                # If we are dealing with a file, slurp it up into one string
    if ($phrase !~ /\n/ and ($phrase =~ /\.txt$/)) {
        my $file = $phrase;
        $phrase = '';
        open(TEXT, $file) or print "Error, could not open file to speak $file: $!\n";
        while (<TEXT>) {
            $phrase .= ' ' . $_;
        }
        close TEXT;
    }

    my $mode = $parms{mode} || $Save{mode};


    if (!$parms{nolog}) {
        my $speaklog = '';
        $speaklog = $mode . ": " if $mode;
        $speaklog = "card=$parms{card}: " if $parms{card};
        $speaklog = "to_file: "           if $parms{to_file};
        $speaklog .= "(" . basename($play) . ") " if $play;     # put sound in () to show the sound played.
        $speaklog .= $phrase if $phrase;
        &print_speaklog($speaklog);
    }

    $Last_Response = 'speak';   # Queried by http_server and telnet_server

                                # Check if we want to speak web requested data
                                # If Respond_Target is set, let &respond_web handle it?
                                # If room or address, then let it go there rather then the web

    if ($leave_socket_open_passes and
        !($parms{room} or $parms{address})) {
        $leave_socket_open_passes = 1;

                                           # Intercept speak/log/print/last_response -> web wav
                                           #  - but not for wml response
        if ($leave_socket_open_action =~ /response/ and $leave_socket_open_action !~ /,'w'/) {
                                # Generate to_wave file unless webmute
            if (my $wav_file = &http_speak_to_wav_start($phrase, $parms{voice}, $parms{compression} )) {
                $leave_socket_open_action = "&http_speak_to_wav_finish(qq|$phrase|, qq|$wav_file|)";
                $leave_socket_open_check  = "!&Voice_Text::is_speaking_wav()";
                $leave_socket_open_passes = 999;
                                 # Skip local speak if speaking via remote wav
                return;
            }
        }

        if (($config_parms{internet_speak_flag} eq 'none') or
            ($config_parms{internet_speak_flag} eq 'local' and !&is_local_address())) {
            return;
        }
#       $parms{card} = 3;  # Redirect only to alternet card?
    }



    &Log_hooks('speak', $phrase, %parms);   # Created by &add_hooks

                                # Lowercase all uppercase text ...
                                #  if it > 4 characters (don't want to mess up acronyms)
    $parms{no_mod} = 1 if $phrase =~ /\<sable\>/i;
    $phrase =~ s/([A-Z]{4,})/ucfirst(lc($1))/eg unless $parms{no_mod};

                                # Ascii codes 030 -> 126 covers normal characters
                                #    anything between ! thru ~
                                # We do this check in case something (like serial_server)
                                # goes out of control ... we don't want to hear garbage!
                                # Updated:  French (and other languages) have characters above 126, so lets skip this check
#    my $count_non_ascii = $phrase =~ tr/\n\r\t !-~//c;
#    if ($phrase and $count_non_ascii > 10 and !$play) {
#        print "Data is unspeakable!  non_ascii=$count_non_ascii, phrase=$phrase\n";
#        print_log "Data is unspeakable!  non_ascii=$count_non_ascii, phrase=", substr($phrase, 0, 40), " ...\n";
#        return;
#    }

	# raw_text is a copy of the text before we process it to be
	# more suitable for TTS
	$parms{raw_text}=$parms{text};
	$parms{text} = &Voice_Text::force_pronounce($phrase, \%parms);

    # Allow for a comma delimited list of echo (devices)
    if ($parms{echo}) {
       my (@echo_conduits) = split(/[,;|]/,$parms{echo});
       for my $echo_conduit (@echo_conduits) {
            $echo_conduit = lc $echo_conduit;
            if ($echo_conduit eq 'im') {
                &net_im_send(%parms);
            } elsif ($echo_conduit eq 'email') {
                &net_mail_send(%parms);
            } elsif ($echo_conduit eq 'sms') {
                &net_mail_send(%parms);
            } elsif ($echo_conduit eq 'telnet') {
                &respond_telnet(%parms);
            } elsif (!(exists($parms{display_rooms}))) {
                my $func = "display_$echo_conduit";
                if ($main::{$func}) {
                    no strict 'refs';
                    &$func(%parms);
                }
            }
       }
       if (exists($parms{display_rooms})) {
          &main::route_display_rooms(%parms);
       }
    }

    &Speak_parms_hooks(\%parms); # Created by &add_hooks
    return if $parms{no_speak};  # In case hook decided not to speak

    &Speak_pre_hooks(%parms);   # Created by &add_hooks
#   &Speak_pre_hooks(\%parms);   # Created by &add_hooks

                               # Do not speak locally if this parm is specified and does not
                               # match the rooms parm or it is a non-standard card
    if ($config_parms{speak_mh_room} && $parms{rooms} and !$parms{card}) {
                # Do not speak locally if this parm is specified and does not match the rooms parm
        my $mh_room = $config_parms{speak_mh_room};
        return unless $parms{rooms} =~ /^$mh_room|\,$mh_room|^all/;
    }

                                # Do not speak muted or offline
    return if $mode and ($mode eq 'mute' or $mode eq 'offline') and !$parms{to_file};


                                # If we have a 1/2 duplex sound card, we want to wait a bit before speaking
                                # or else the speech will get qued.
                                # Maybe just turning off vr during speach would fix this?
    if (my $delay = $config_parms{delay_speak}) {
        $delay -= (&get_tickcount - &Voice_Cmd::get_last_cmd_time);
        if ($delay > 0) {
            print "Sleeping for $delay ms before speaking\n";
            select undef, undef, undef, $delay / 1000;
        }
    }
#   &set_volume($parms{volume});

                # Allow for a comma delimited list of cards
    if (my $cards = $parms{card}) {
       for my $card (split ',', $cards) {
         $parms{card} = $card;
     &Voice_Text::speak_text(%parms);
       }
    }
    else {
       &Voice_Text::speak_text(%parms);
    }

    &Speak_post_hooks(%parms);   # Created by &add_hooks

}

sub route_display_rooms {
    my (%parms) = @_;
    my (%targets, %display_rooms, %display_groups);
    &main::read_parm_hash(\%display_rooms, $main::config_parms{'display_rooms'});
    &main::read_parm_hash(\%display_groups, $main::config_parms{'display_groups'});
    for my $room (split(/[,;|]/,$parms{display_rooms})) {
       if (exists($display_groups{$room})) {
          # then expand the group
           my %groups = &parse_func_parms($display_groups{$room});
           for my $group_room (keys %groups) {
             if (!(exists($targets{$group_room}))) { # prevent duplicates on expansion
                my %room_parms = &parse_func_parms($display_rooms{$group_room});
                %{$targets{$group_room}} =%room_parms;
             }
          }
       } elsif ($room eq 'all') {
          # then expand into all rooms
          for my $all_room (keys %display_rooms) {
             if (!(exists($targets{$all_room}))) { # prevent duplicates on expansion
                my %room_parms = &parse_func_parms($display_rooms{$all_room});
                %{$targets{$all_room}} = %room_parms;
             }
          }
       } else {
          if (!(exists($targets{$room}))) { # prevent duplicates on expansion
             my %room_parms = &parse_func_parms($display_rooms{$room});
             %{$targets{$room}} = %room_parms;
          }
       }
    }
    # iterate over the targets and invoke the applicable function
    my $return_tk = 0;
    for my $target_room (keys %targets) {
       if ($targets{$target_room}{device} eq 'tk') {
          $return_tk = 1;
       } else {
          my $func = "display_$targets{$target_room}{device}";
          foreach my $key (keys %{$targets{$target_room}}) {
             $parms{$key} = $targets{$target_room}{$key} unless $key eq 'device' or $key eq 'text';
          }
          if ($main::{$func}) {
              no strict 'refs';
              eval &$func(%parms);
          }
       }
    }
    return $return_tk;
}

sub speak_log_last {
                                # Return the last how_many spoken phrases
    my ($how_many) = @_;
    my $count = @Speak_Log;
    if ($how_many >= $count) {
        return @Speak_Log;
    }
    else {
        return (@Speak_Log[0 .. ($how_many-1)]);
    }
}


sub time_cron {
    my ($time_date, $second) = @_;
                                # Only on minute boundarys unless $second parm is used
    if (defined $second) {
        return unless $second eq '*' or $New_Second and $second == $Second;
    }
    else {
        return unless $New_Minute;
    }

# This is not useful?
#   my $time_date2 = eval(qq["$time_date"]);   # Use eval for on-the-fly variable substitution
#   print "Error in time_cron: time=$time_date  error=$@\n" if $@;
#   my @cron = split(' ', $time_date2);
    my @cron = split(' ', $time_date);
    my (@cron_now, $field, $entry, $low, $high);

    unless (@cron == 5) {
        &print_log("Bad time_cron format (needs 5 fields): @cron\n");
        return;
    }

    @cron_now = ($Minute, $Hour, $Mday, $Month, $Wday);
  FIELD:
    for $field (0..4) {
        for $entry (split(',', $cron[$field])) {
            # Go to next field if this field matches the current time_date
            next FIELD if $entry eq '*';
            if (2 == (($low, $high) = split('-', $entry))) {
                next FIELD if $cron_now[$field] >= $low and
                    $cron_now[$field] <= $high;
            }
            else {
                next FIELD if $cron_now[$field] == $entry;
            }
        }
        return 0;   # None of the entries for this field qualified
    }
    return 1;

}

sub time_between {
    my ($time_date_1, $time_date_2) = @_;
    my $time1 = &my_str2time($time_date_1);
    my $time2;
    if (defined $time_date_2) {
    $time2 = &my_str2time($time_date_2);
    }
    else {
    return 0;  # 2nd parameter not provided;
    }
    return 0 if $time1 == 0;  # Time_date string invalid
    return 0 if $time2 == 0;  # Time_date string invalid
    if ($time2 < $time1) {    # This happens comparing across midnight
    if (($time1 - $Time) > 43200) { # If Time1 is more than 12 hours into the future
        $time1 = $time1 - 86400;   #    Subtract 24 hours from Time1
    }
    else {
        $time2 = $time2 + 86400;   #    Otherwise add 24 hours to Time2
    }
    }
    return (($Time >= $time1) && ($Time <= $time2));
}

sub time_now_diff {
    my ($time_date) = @_;
    return int((&my_str2time($time_date) - $Time)/60);
}

sub time_greater_than {
    my ($time_date) = @_;
    my $time2 = &my_str2time($time_date);
    return 0 if $time2 == 0;    # Time_date string was invalid
    return $Time > $time2;
}

sub time_less_than {
    my ($time_date) = @_;
    return $Time < &my_str2time($time_date);
}

sub time_greater_or_equal {
    my ($time_date) = @_;
    my $time2 = &my_str2time($time_date);
    return 0 if $time2 == 0;    # Time_date string was invalid
    return $Time >= $time2;
}

sub time_less_or_equal {
    my ($time_date) = @_;
    return $Time <= &my_str2time($time_date);
}

sub time_now {
    my ($time_date, $second) = @_;
                                # Only on minute boundarys unless $second parm is used
    if (defined $second) {
        return unless $second eq '*' or $New_Second and $second == $Second;
    }
    else {
        return unless $New_Minute;
    }

    return unless $time_date =~ /\S/;                 # Ignore empty entries
    return if     $time_date eq 'none';               # For use in bypassing timed events easily

                                # Allow time_now to match to the nearest minute, not the exact second
                                #  - if we add a 'catchup mode', we can go back to checking on the exact second
    my $time_now = &my_str2time($time_date);
    unless ($time_now) {
        my @caller = caller;    # This is not useful in user_code eval :(
        print "Bad time_now format:  $time_date  caller=@caller\n";
    }
#   print "db td=$time_date t=$Time tn=$time_now\n";
    return ($Time >= $time_now and $Time < $time_now+60);
}

my %random_offsets;
sub time_random_offset {
    my ($time_date, $offset) = @_;
                                # Only on secondboundarys
    return unless $New_Second;
    return unless $time_date =~ /\S/;                 # Ignore empty entries
    return if     $time_date eq 'none';               # For use in bypassing timed events easily

    my $time_now = &my_str2time($time_date);
    unless ($time_now) {
        my @caller = caller;    # This is not useful in user_code eval :(
        print "Bad time_now format:  $time_date  caller=@caller\n";
        return 0;
    }

    my $key = "$time_date$;$offset";

    if ($time_now == $Time) {
        my ($minutes, undef, $seconds) = $offset =~ /^(\d+)?(:(\d+))?$/;
        my $random = (defined $minutes or defined $seconds) ? ($minutes * 60 + $seconds) : 3600;
        $random = int(rand($random));
        $random_offsets{$key} = $Time + $random;
#       print "db td=$time_date t=$Time tn=$time_now o=$offset r=$random \n";
    }

    if ($random_offsets{$key} == $Time) {
        delete $random_offsets{$key} ;
        return 1;
    }
    else {
        return 0;
    }
}

sub time_random {
    return unless $New_Minute;  # Only on minute boundaries
    my ($time_cron, $time_freq) = @_;
    my $flag = &time_cron($time_cron);
    return 0 unless $flag;
#   my $r = rand $time_freq;
#   my $i = int $r;
#   print "db $Time_Now time_random freq=$time_freq r=$r i=$i\n";
#   return ($i == 0) ? 1 : 0;
    return (int(rand $time_freq) == 0) ? 1 : 0;
}

sub system_info {
	display "time=0 app=system window_name=info System Info"
}

# Temporarily use browser for this (should be a child window photo-viewer created by the rrd module.)
# bindings should be overridden there too!

sub display_weather_graph {
	my $type = shift;
	browser "http://localhost:$config_parms{http_port}/bin/weather_graph.pl?$type" if $Run_Members{'weather_rrd_update'};
}

# *** Is there even a forecast key in the current hash?
# *** Should be a custom window in weather monitor

sub display_weather_conditions {
	&display("app=weather window_name=forecast $Weather{forecast}") if $Weather{forecast};
}


sub help_about {
	my $title = ((($config_parms{title})?$config_parms{title}:"Misterhouse"));
	my $win = &load_child_window(title => "About $title", text => "$Pgm_Path/../docs/mh_logo.gif", wait => 1, app => 'help', window_name => 'about', buttons => 1, help => 'This is the about box. The System Info button displays OS and program status.');
	unless ($win->{activated}) {
		play 'about';
		my $tk;
		$tk = $win->{MW}{top_frame}->Label(-text => "$title $Version PID: $$")->pack(qw/-expand yes -fill both -side top/);
		&configure_element('label', \$tk);
		$tk = $win->{MW}{bottom_frame}->Button(-text => "System Info...", -command => \&system_info)->pack(qw/-side right/);
		&configure_element('button', \$tk);
		# easter egg (plays goofy WAV file)
		$win->{photo2}->bind('<Double-1>' => sub{ play 'fun/service.wav'});

		$win->activate();
	}
}

sub tk_setup_windows {
                                # See perl/bin/widget.bat for lots of examples
    print " - setting up main window\n";
    $MW = MainWindow->new;
    $MW->withdraw;              # Hide the window until we are all set up
				# doesn't quite work on XP :(

    #$MW->protocol('WM_DELETE_WINDOW', sub { &display("To exit, use the File->Exit pulldown\n", 5)}
    $MW->protocol('WM_DELETE_WINDOW', sub { &exit_pgm() } );

                                # Keep startup value so we resize only if it has changed since startup.
                                # and we don't mess with manual changes.
    $config_parms{tk_geometry_startup} = $config_parms{tk_geometry};

    $MW->iconname('Misterhouse'); # Loads tk icon resource
                                                                        # Older build gives 'bitmap not defined' error
    # $MW->iconbitmap($Pgm_Root . '/web/favicon.ico') unless $^O eq 'MSWin32' and &Win32::BuildNumber < 810;
    my $icon_image = $MW->Photo(
    	-file => "${Pgm_Root}/web/favicon.gif",
    	-format => 'gif');
    $MW->Icon(-image => $icon_image);
#   $MW->optionAdd('*font' => 'systemfixed');
#   $MW->optionAdd('*font' => $config_parms{tk_font_menus}) if $config_parms{tk_font_menus};
    &configure_element('window', \$MW);
                                # This doesn't work :( So let's not call it! :)
#    $MW->bind('Alt-Key-R'   => \&read_code);
#    $MW->bind('Alt-Key-X'   => \&sig_handler);

    $MW->title(($config_parms{title}) ? eval "'$config_parms{title}'" : "Misterhouse $Version PID: $$");

                                # Create menu bar and top-level menus
    $Tk_objects{menu_bar} = $MW->Frame->pack(-anchor => 'w', -side => 'top', -expand => 0, -fill => 'x');
    &configure_element('window', \$Tk_objects{menu_bar});

    $Tk_objects{menu_file} = $Tk_objects{menu_bar}->
        Menubutton(-text => 'File',
                   -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0);

    &configure_element('window', \$Tk_objects{menu_file});

    $Tk_objects{menu_view} = $Tk_objects{menu_bar}->
        Menubutton(-text => 'View',
                   -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0);

    &configure_element('window', \$Tk_objects{menu_view});

    $Tk_objects{menu_view}->command(-label => 'in Browser',  -command => sub { &browser("http://localhost:$config_parms{http_port}") });
    $Tk_objects{menu_view}->separator();

	# *** Move this (and debug options) to after loop code read (with groups, etc.)

	if ($config_parms{tk_schemes}) {
	    $Tk_objects{menu_view_schemes} = $Tk_objects{menu_view}->menu->Menu;
        &tk_cascade_entry('Schemes', $Tk_objects{menu_view}, $Tk_objects{menu_view_schemes});

        &configure_element('window', \$Tk_objects{menu_view_schemes});

	    my @scheme_options;
        @scheme_options = split ',', $config_parms{tk_schemes};
	    my $sub;

	    for (sort @scheme_options) {
	        $sub = "sub {\$Invalidate_Window = 1; my \%opts = (tk_scheme => '$_'); print 'SCHEME = $_\n';  &write_mh_opts(\\%opts,0,1); &read_code_forced()}";
            $sub = eval $sub;
            print "Error in tk_scheme eval: error=$@\n" if $@;
            $Tk_objects{menu_view_schemes}->radiobutton(-label => ucfirst($_), -underline => 0, -variable => \$config_parms{tk_scheme}, -value =>$_, -command => $sub);
	    }

	    $Tk_objects{menu_view}->separator();

	}



    if ($config_parms{tk_commands}) {
        $Tk_objects{menu_commands} = $Tk_objects{menu_bar}->
            Menubutton(-text => 'Commands',
                       -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0);

        &configure_element('window', \$Tk_objects{menu_commands});
    }

    $Tk_objects{menu_items} = $Tk_objects{menu_bar}->
        Menubutton(-text => 'Items',
                   -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0) if $config_parms{tk_items};

    &configure_element('window', \$Tk_objects{menu_items}) if $Tk_objects{menu_items};

    $Tk_objects{menu_tools} = $Tk_objects{menu_bar}->
        Menubutton(-text => 'Tools',
                   -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0);

    &configure_element('window', \$Tk_objects{menu_tools});



    $Tk_objects{menu_tools}->command(-label => 'Undo last action', -command => \&undo_last_action);

    $Tk_objects{menu_tools}->command(-label => 'Triggers...', -command => \&browse_triggers);

    $Tk_objects{menu_tools}->separator();





    $Tk_objects{menu_tools_set_password} = $Tk_objects{menu_tools}->menu->Menu;

    &configure_element('window', \$Tk_objects{menu_tools_set_password});


    &tk_cascade_entry('Set Password', $Tk_objects{menu_tools}, $Tk_objects{menu_tools_set_password});

    $Tk_objects{menu_tools_set_password}->command(-label => 'Guest', -underline => 0, -command => sub { &set_password('guest')});
    $Tk_objects{menu_tools_set_password}->command(-label => 'Family', -underline => 0, -command => sub { &set_password('family')});
    $Tk_objects{menu_tools_set_password}->command(-label => 'Administrator', -underline => 0, -command => sub { &set_password('admin')});


    $Tk_objects{menu_tools}->separator;








    $Tk_objects{menu_tools}->checkbutton(-label => 'Console Speech',  -variable => \$config_parms{console_speech});

    $Tk_objects{menu_tools_echoes} = $Tk_objects{menu_tools}->command(-label => 'Echo'); # This is a dynamic cascade...

    $Tk_objects{menu_tools}->separator;


    $Tk_objects{menu_file}->command(-label => 'Restart', -underline => 0, -command => sub {exit_pgm(999)});

    $Tk_objects{menu_file}->command(-label => 'Reload', -accelerator => 'F1', -underline => 0, -command => \&read_code);
    $Tk_objects{menu_file}->command(-label => 'Reload All', -underline => 0, -command => \&read_code_forced);
    $Tk_objects{menu_file}->command(-label => 'Pause', -accelerator => 'F2', -underline => 0, -command => \&toggle_pause);
    $Tk_objects{menu_file}->command(-label => 'Log', -accelerator => 'F5', -underline => 0, -command => \&toggle_log);
    $Tk_objects{menu_file}->separator();




    $Tk_objects{menu_file_debug} = $Tk_objects{menu_file}->menu->Menu;

    &configure_element('window', \$Tk_objects{menu_file_debug});

    &tk_cascade_entry('Debug', $Tk_objects{menu_file}, $Tk_objects{menu_file_debug});

	#Loop through debug options (should build dynamically like "list debug options"

    if ($config_parms{debug_options}) {

	my @debug_options;

        @debug_options = split ',', $config_parms{debug_options};


	for (sort @debug_options) {
		#my $cmd = "sub {\$config_parms{debug} = $_}";
		$Tk_objects{menu_file_debug}->checkbutton(-label => ucfirst($_), -underline => 0, -variable => \$Debug{$_}, -command => sub {$config_parms{debug} = undef}) if $_ !~ /^off$/i;
	}

    }


    $Tk_objects{menu_file}->separator();
    $Tk_objects{menu_file}->command(-label => 'Exit',   -accelerator => 'F3', -underline => 1, -command => \&sig_handler);

# *** Is an object toggle "shortcut" on the main tb now (doesn't really belong on file menu.)

#    $Tk_objects{menu_file}->radiobutton(-label => 'Mode: Normal',  -variable => \$Save{mode}, -value => 'normal');
#    $Tk_objects{menu_file}->radiobutton(-label => 'Mode: Mute',    -variable => \$Save{mode}, -value => 'mute');
#    $Tk_objects{menu_file}->radiobutton(-label => 'Mode: Offline', -variable => \$Save{mode}, -value => 'offline');


}

sub toggle_house_mode {
	use vars '$mode_mh'; # When would this object not exist?  Should be declared in here?

	if (ref $mode_mh) {

		my $state = $mode_mh->{state};

		if ($state eq 'offline') {
			$state = 'normal'
		}
		elsif ($state eq 'mute') {
			$state = 'offline';
		}
		else {
			$state = 'mute';
		}

		set $mode_mh $state, 'tk';
	}
}

sub toggle_security_mode {
	use vars '$mode_security'; # When would this object not exist?  Should be declared in here?

	if (ref $mode_security) {

		my $state = $mode_security->{state};

		if ($state eq 'armed') {
			$state = 'unarmed'
		}
		else {
			$state = 'armed';
		}

		set $mode_security $state, 'tk';
	}
}

sub ras_connect {

	if (defined $config_parms{net_connect_entry} and $config_parms{net_connect_entry}) {
        	print_log "Dialing the internet with $config_parms{net_connect_entry}";

		# *** This is awful (good thing most won't use it!)

		run qq[rasdial "$config_parms{net_connect_entry}" $config_parms{net_connect_name} $config_parms{net_connect_password}];
		return 1; # Worked as best we can tell at the moment.
	}
	else {
		warn 'Dial-up networking is not configured (net_connect_entry)';
	}
}

sub ras_disconnect {
       	print_log "Disconnecting from the Internet";
	run qq[rasdial /disconnect];
	return 1; # whatever
}



sub undo_last_action {
    my $msg;
    my $undid = 0;
    my $set_by = shift;
    $set_by = 'tk' unless $set_by;

    my $target = &set_by_to_target($set_by);

    my @refs = &Generic_Item::recently_changed;
    if ($#refs != -1) {

    while (my $ref = shift @refs) {

		# *** Need config parm to filter these

	my $ref_set_by = $ref->{set_by};

	while (ref $ref_set_by and $ref_set_by->can('get_set_by')) {
		$ref_set_by = $ref_set_by->get_set_by();
	}

	my $ref_type = ref $ref;

	my $automation = (!$ref_set_by or $ref_set_by =~ /usercode/i or $ref_set_by =~ /unknown/i or $ref_set_by =~ /time/i or $ref_set_by =~ /^xap$/i or $ref_set_by =~ /^status$/i); # includes tie_time

        if (($ref->isa('X10_Item') or $ref->isa('Serial_Item') or $ref->isa('Voice_Cmd') or $ref->isa('IR_Item') or $ref->isa('Generic_Item')) and !$automation) {
            my $name = &pretty_object_name($ref->{object_name});
	    if ($name !~ /undo/i) { 		# Don't undo the undo voice command!
   		    $msg = "Changing $name from $ref->{state} back to $ref->{state_prev}.";

		    if (ref $set_by and $set_by->can('respond')) {
		            $set_by->respond("app=control $msg");
		    }
                    else { # called by tk

			# No said or state_now called prior, so no RT, so no_chime=1
			respond "target=$target no_chime=1 app=control $msg";

		    }
        	    set $ref $ref->{state_prev}, $set_by;
		    $undid = 1;
	            last;
	    }
        }
    }

    }

respond "target=$target app=control no_chime=1 No recent actions can be undone." unless $undid;


}


sub tk_toolbar_add_button {
	my ($tb, $p_button) = @_;

	my $text = $p_button->{text};
	my $tip = $p_button->{tip};
	my $image = $p_button->{image};
	my $command = $p_button->{command};

	$tip = $text unless $tip;


        my $button = $tb->ToolButton(-text  => $text,
                          -tip   => $tip,
			  -image => $image,
                          -command => $command
			 );

	&configure_element('button', \$button);
	return $button;
}


sub tk_setup_geometry {
                                # Allow geometry resizing on reload, but only if it has changed,
                                # so we don't mess up manual changes.
    if ($config_parms{tk_geometry} and
        ($Startup or
         $config_parms{tk_geometry} ne $config_parms{tk_geometry_startup})) {
        print "Setting geometry to $config_parms{tk_geometry}\n";
        $MW->geometry($config_parms{tk_geometry});
        $config_parms{tk_geometry_startup} = $config_parms{tk_geometry};
    }
}

sub tk_setup_cascade_menus {

    if ($config_parms{tk_commands}) {




        print "Creating Command menu\n";
        $Tk_objects{menu_commands}->menu->delete(0, 'end'); # Delete old menus

        for my $category (&list_code_webnames('Voice_Cmd')) {

            next if $category =~ /^none$/;

                                # We must delete old ones first, otherwise we get a memory leak!
            $Tk_objects{menu_command_by_cat}{$category}->delete(0, 'end') if $Tk_objects{menu_command_by_cat}{$category};
            delete $Tk_objects{menu_command_by_cat}{$category};


            for my $cmd (&list_objects_by_webname($category)) {
                my $object = &get_object_by_name($cmd);
                my $text   = $object->{text};

                next unless $text;  # Only do voice items
                next if $$object{hidden};

                                # Create category menu ... now that we know it will have entries!
                unless ($Tk_objects{menu_command_by_cat}{$category}) {
                    $Tk_objects{menu_command_by_cat}{$category} = $Tk_objects{menu_commands}->menu->Menu;
                    &tk_cascade_entry($category, $Tk_objects{menu_commands}, $Tk_objects{menu_command_by_cat}{$category});
                }

#                $Tk_objects{menu_command_by_cat}{$category}->
#                    add('command', -label => 'state_log', command => sub{display join("\n", state_log $object)});

                my $filename = $object->{filename};
                                # Drop the {a,b,c} enumeration (pick the first one)
                $text = $1 . $2 . $3 if $text =~ /^(.*)\{(.*),.*\}(.*)/;

   	        $filename =~ s/_/\x20/g;
		$filename =~ ucfirst($filename);

                if (my ($prefix, $states, $suffix) = $text =~ /^(.*)\[(.+?)\](.*)$/) {
                    for my $state (split(',', $states)) {
                        my $text2 = "$prefix$state$suffix";
                        my $text3 = "$filename: $text2";
                        $Tk_objects{menu_command_by_cat}{$category}->
                            add('command', -label => $text3, -command => sub{&run_voice_cmd($text2, undef, 'tk')});
                    }
                }
                else {
                    my $text3 = "$filename: $text";
                    $Tk_objects{menu_command_by_cat}{$category}->
                        add('command', -label => $text3, -command => sub{&run_voice_cmd($text, undef, 'tk')});
                }
            }
        }
    }

    if ($config_parms{tk_items}) {
        print "Creating Items menu\n";

                                # Create/Reset Item cascade menu
        $Tk_objects{menu_items}->menu->delete(0, 'end'); # Delete old menus
	$Tk_objects{menu_items}->command(-label => 'Add or Remove Items...', -command => \&add_remove_items);

                                # Timers do not have @states (only state), so can not be included
#       for my $object_type ('Serial_Item', 'X10_Item', 'X10_Appliance', 'iButton', 'Compool_Item', 'Group') {
        for my $object_type (@Object_Types) {

            my @object_list = &list_objects_by_type($object_type);
            my @objects = map{&get_object_by_name($_)} @object_list;

                                # See if any of these objects have states ... if not skip menu entry
            my $flag = 0;
            for my $object (@objects) {
                if (&tk_object_states($object, 'menu_items')) {
                    $flag = 1;
                    last;
                }
            }
            next unless $flag;

                                # We must delete old ones first, otherwise we get a memory leak!
            $Tk_objects{menu_items_by_type}{$object_type}->delete(0, 'end')if $Tk_objects{menu_items_by_type}{$object_type};

            $Tk_objects{menu_items_by_type}{$object_type} = $Tk_objects{menu_items}->menu->Menu;

    	    &configure_element('window', \$Tk_objects{menu_items_by_type}{$object_type});
            &tk_cascade_entry($object_type, $Tk_objects{menu_items}, $Tk_objects{menu_items_by_type}{$object_type});

                                # Sort by filename first, then object name
            for my $object (sort {$a->{filename} cmp $b->{filename} or $a->{object_name} cmp $b->{object_name}} @objects) {

                next if $$object{hidden};

                                # We must delete old ones first, otherwise we get a memory leak!
                                #  - this one does not help!  Still leaks about .3 mb per reload with 40 or so items :(
		# *** How is this one special?

               $Tk_objects{menu_items_by_object}{$object}->delete(0, 'end') if $Tk_objects{menu_items_by_object}{$object};

                                # Only list items with NON-BLANK states
                if (my $menu = &tk_object_states($object, 'menu_items')) {
                    $Tk_objects{menu_items_by_object}{$object} = $menu;
                    my $filename = $object->{filename};
		    $filename =~ s/_/ /g;
		    $filename = ucfirst($filename);
			# *** This should be another cascade!
                    my $object_name  = "$filename: " . &pretty_object_name($object->{object_name});
                    &tk_cascade_entry($object_name, $Tk_objects{menu_items_by_type}{$object_type},
                                      $Tk_objects{menu_items_by_object}{$object});
                }
            }
        }
    }

                                # Create/Reset Group cascade menu
    if ($config_parms{tk_groups}) {
        print "Creating Groups menu\n";


	# Don't create if no groups!

	my @list = &list_objects_by_type('Group');

	if ($#list != -1) {

	    $Tk_objects{menu_groups} = $Tk_objects{menu_bar}-> Menubutton(-text => 'Groups',
                   -borderwidth => 2, -underline => 0)->pack(-side => 'left', -padx => 0) unless $Tk_objects{menu_groups};


        $Tk_objects{menu_groups}->menu->delete(0, 'end'); # Delete old menus

        for my $group_name (&list_objects_by_type('Group')) {
            my $group = &get_object_by_name($group_name);
            next unless $group;
            next if $$group{hidden};
            $group_name = &pretty_object_name($group_name);

            $Tk_objects{menu_groups_by_group}{$group} = $Tk_objects{menu_groups}->menu->Menu;

            &configure_element('window', \$Tk_objects{menu_groups_by_group}{$group});

            &tk_cascade_entry($group_name, $Tk_objects{menu_groups}, $Tk_objects{menu_groups_by_group}{$group});

                                # Add an entry for the group
            &tk_object_states($group, 'menu_groups', $Tk_objects{menu_groups_by_group}{$group});

                                # Sort by filename first, then object name
            for my $object (sort {$a->{filename} cmp $b->{filename} or $a->{object_name} cmp $b->{object_name}} list $group) {
                next if $$object{hidden};
                if (my $menu = &tk_object_states($object, 'menu_groups')) {
                    $Tk_objects{menu_items_by_object}{$object} = $menu;
                    my $filename = $object->{filename};
                    my $object_name  = "$filename: " . &pretty_object_name($object->{object_name});
                    &tk_cascade_entry($object_name, $Tk_objects{menu_groups_by_group}{$group}, $menu);
                }
            }
        }
    }

}
# Check for leaking memory on $Reload, where we re-build menus
#   my $mem = `ps -F \"%z\" -p $$ | tail -1`;
#   chomp $mem;
#   print "Memory used: $mem,  Memory delta:", $mem - $memory_prev, "\n";
#   $memory_prev = $mem;

}


sub tk_object_states {
    my ($object, $menu_parent, $menu) = @_;

    return unless $object; # *** Looks like a warning needed here (for calling code's developer)

                                # Already have this object's menu created
    return $Tk_objects{menu_items_by_object}{$object} if !$menu and $Tk_objects{menu_items_by_object}{$object}; # Already have this object's menu created

    return unless  $object->{states}; # Only create menus for objects with states
    my @states = @{$object->{states}};
    my $object_type = ref $object;

	# *** NO! Groups have dynamically aggregated states assigned on reload. &aggregate_states needs to be in this script! Where is it in the SVN version?

    @states = split ',', $config_parms{x10_menu_states} if $object_type eq 'X10_Item' or $object_type eq 'Group';
    return unless $states[0];

    $menu = $Tk_objects{$menu_parent}->menu->Menu unless $menu; # Create a new menu unless given
    $menu -> add('command', -label => 'Log', -command => sub{display join("\n", state_log $object)});
    for my $state (@states) {
        next if $state =~ /^[+-]\d+$/ and $state % 20;
        $menu -> add('command', -label => $state, -command => sub{set $object $state, 'tk'});
    }
    return $menu;
}

sub tk_cascade_entry {
    my ($label, $menu1, $menu2) = @_;

    $label =~ s/_/ /g;

    $menu1->cascade(-label => $label);
    $menu1->entryconfigure($label, -menu => $menu2);
}

                                # Create tk widget subroutines
sub tk_button {
    return unless $MW and $Reload and $Tk_objects{grid};
    my (@data) = @_;
    my @widgets;
    while (@data) {
        my $label = shift @data;
        my $pvar  = shift @data;
        $Tk_objects{button}{$pvar}->destroy if $Tk_objects{button}{$pvar} and Exists($Tk_objects{button}{$pvar});
        $Tk_objects{button}{$pvar} = $Tk_objects{grid}->Button(-text => $label, -command => $pvar);
        push(@widgets, $Tk_objects{button}{$pvar});
    }
    if (@widgets > 3) {
        $widgets[0]->grid(@widgets[1..$#widgets], -sticky => 'w');
    }
    elsif (@widgets > 1) {
        $widgets[0]->grid(@widgets[1..$#widgets], -columnspan => 2, -sticky => 'w');
    }
    else {
        $widgets[0]->grid(qw/-columnspan 5 -sticky w/);
    }
}

                                # Button for the menubar
sub tk_mbutton {
    return unless $MW and $Reload and $Tk_objects{grid};
    my ($label, $pvar) = @_;
    $Tk_objects{mbutton}{$pvar}->destroy if $Tk_objects{mbutton}{$pvar} and Exists($Tk_objects{mbutton}{$pvar});
    $Tk_objects{mbutton}{$pvar} = $Tk_objects{menu_bar}->Button(-text => $label, -command => $pvar)->
        pack(qw/-side right/);
}

sub tk_checkbutton {
    return unless $Reload;

                                # Allow web widgets, even with -no_tk
    push(@Tk_widgets, [$Category, 'checkbutton', @_]);

    return unless $MW and $Tk_objects{grid};
    my @data = @_;
    my @widgets;
    while (@data) {
        my $label = shift @data;
        my $pvar  = shift @data;
        $Tk_objects{checkbutton}{$pvar}->destroy if $Tk_objects{checkbutton}{$pvar} and Exists($Tk_objects{checkbutton}{$pvar});
        $Tk_objects{checkbutton}{$pvar} = $Tk_objects{grid}->Checkbutton(-text => $label,  -variable => $pvar);

        &configure_element('label', \$Tk_objects{checkbutton}{$pvar});
        push(@widgets, $Tk_objects{checkbutton}{$pvar});
    }
    if (@widgets > 3) {
        $widgets[0]->grid(@widgets[1..$#widgets], -sticky => 's');
    }
    elsif (@widgets > 1) {
        $widgets[0]->grid(@widgets[1..$#widgets], -columnspan => 2, -sticky => 's');
    }
    else {
        $widgets[0]->grid(qw/-columnspan 2 -sticky w/);
    }
}

sub tk_command_list {
    my ($parent) = @_;


	my $list = $parent->Scrolled( qw/Tree -separator : -exportselection 1 -scrollbars osoe / );
	&configure_element('edit', \$list);


                                # These 2 commands give a 'can not find delegate.pl' msg on tk 8.020 (ok on 8.015).
#   $list->Label(text => "Command or Search String")->pack(-side => 'top', -fill => 'x');
#   $Tk_objects{command} = $list->Entry(-width => 20, -borderwidth => 4)->pack(-side => 'top', -fill => 'both');

    my $f = $parent->Frame->pack(-side => 'top', -fill => 'x');
#    $f->Label(-text => "Command or Search:")->pack(-side => 'left', -fill => 'x');
    $Tk_objects{command} = $f->BrowseEntry(-width => 20)->pack(-side => 'left', -fill => 'x', -expand => 1);
#    $Tk_objects{command}->Subwidget('entry')->configure(-bg => 'white');

	# *** Need execute_tk_command sub (looks at textbox)

    $Tk_objects{command}->configure( -command => sub { print "testing browseentry @_"; } );

	my $entry = $Tk_objects{command}->Subwidget('entry');
	&configure_element('edit', \$entry);


# *** Errored (?!);

#	my $list = $Tk_objects{command}->Subwidget("slistbox")->Subwidget("listbox");
#	&configure_element('edit', \$list);



    #$list->insert(0, &list_voice_cmds_match($config_parms{tk_startup_cmd})); # Init with all commands *** Need to persist the last command search!

	my @cmds = &list_voice_cmds_match($config_parms{tk_startup_cmd});

	my $last_cat = '';

	for (@cmds) {
		my $cat = (split( /:/, $_ ))[0];
		if ($last_cat ne $cat) {
		    	$list->add( $cat, -text => $cat, -image => $list->Getimage("folder"));
			$last_cat = $cat;
		}
		my $text = (split( /:/, $_ ))[-1];
	    	$list->add( $_, -text => $text, -image => $list->Getimage("file"));
	}


		# *** Check if leaf node!

	$list->configure( -command => sub { my $cmd="@_"; if ($cmd =~ /^(.*?): /) { $cmd =~ s/^(.*?): //; $Tk_objects{command}->Subwidget('entry')->configure(-text => $cmd); &process_external_command($cmd, 0, 'tk') } } );

	$list->autosetmode();

    #$list->bind('<Double-1>' => sub{
    #   $list->selectionClear(0, 'end');
    #    my ($file, $cmd) = $_[0]->get('active') =~ /(.+)\: *(.+)/;
    #    &run_voice_cmd($cmd, undef, 'tk');
    #});

    $Tk_objects{command}->bind('<Return>', sub {
        my $cmd = $Tk_objects{command}->Subwidget('entry')->get();
        #my $cmd = $Tk_objects{command}->cget('-text');
        unless (&process_external_command($cmd, 0, 'tk')) {
                                # No exact match ... create a list of commands that kind of match
	    $last_cat = undef;
            $list->delete('all');
            my @cmds = &list_voice_cmds_match($cmd);
            print_log "No matching commands found for $cmd" unless @cmds;

	for (@cmds) {
		my $cat = (split( /:/, $_ ))[0];
		if ($last_cat ne $cat) {
		    	$list->add( $cat, -text => $cat, -image => $list->Getimage("folder"));
			$last_cat = $cat;
		}
		my $text = (split( /:/, $_ ))[-1];
	    	$list->add( $_, -text => $text, -image => $list->Getimage("file"));
	}

	$list->autosetmode();
        }
	$Tk_objects{command}->insert('end', $cmd); # add to MRU (*** check if there already, move to top)
    });
    return $list;
}

sub tk_scalebar {
  return unless $Reload and $Tk_objects{grid};  # a crutch for ailing code that creates widgets at the wrong time (better to let them break!)
  my $tk;
  my ($pvar, $col, $label, $from, $to, $row, $show_label) = @_;

  $from = 0 unless defined $from;
  $to = 100 unless defined $to;
  $row = 0 unless defined $row;
  $show_label = 1 unless defined $show_label;

  if (ref $pvar ne 'SCALAR') {

    $tk = $Tk_objects{grid} ->
      Scale(-from         => $from,
            -to           => $to,
            -label        => $label,
            -width        => '10',
            -length       => '80',
            -showvalue    => '1',
            -borderwidth    => '0',
            -relief        => 'sunken',
            -orient       => 'horizontal',
            -variable     => \$$pvar->{state},
	    -command      => sub { $Tk_results{$label} = $$pvar->{state}; $$pvar->set($$pvar->{state}, 'tk') });

  }
  else {



    $tk = $Tk_objects{grid} ->
      Scale(-from         => $from,
            -to           => $to,
            -label        => $label,
            -width        => '10',
            -length       => '80',
            -showvalue    => '1',
            -borderwidth    => '0',
            -relief        => 'sunken',
            -orient       => 'horizontal',
            -variable     => \$$pvar );




  }

    &configure_element('scale', \$tk);

    $tk -> grid(-row => $row, -column => $col);
    return $tk;
}



sub tk_entry {
    return unless $Reload;

                                # Allow web widgets, even with -no_tk
    push(@Tk_widgets, [$Category, 'entry', @_]);

    return unless $MW and $Tk_objects{grid};
    my @data = @_;
    my @widgets;
    for (@data) {
        my $label= shift @data;
        my $pvar = shift @data;
        $Tk_objects{entry}{$label}->destroy if $Tk_objects{entry}{$label} and Exists($Tk_objects{entry}{$label});
        $Tk_objects{entry}{$pvar} ->destroy if $Tk_objects{entry}{$pvar} and Exists($Tk_objects{entry}{$pvar});

        $Tk_objects{entry}{$label} = $Tk_objects{grid}->
            Label(-text => $label, -anchor => 'w');
#           Label(-relief => 'groove', -text => $label, -anchor => 'w',  -bg => 'white', -font => $config_parms{tk_font});

	&configure_element('label', \$Tk_objects{entry}{$label});


        if (ref $pvar ne 'SCALAR' and $pvar->can('set')) {
            $Tk_objects{entry}{$pvar}  = $Tk_objects{grid}->Entry(-textvariable => \$$pvar{state}, -width => 12);

            $Tk_objects{entry}{$pvar}->bind('<Return>', sub { $Tk_results{$label} = $$pvar{state}; $pvar->set($$pvar{state}, 'tk') } ) ;
        }
        else {
            $Tk_objects{entry}{$pvar}  = $Tk_objects{grid}->Entry(-textvariable => $pvar, -width => 12);
            $Tk_objects{entry}{$pvar}->bind('<Return>', sub { $Tk_results{$label} = $$pvar } );
        }

	&configure_element('edit', \$Tk_objects{entry}{$pvar});

        push(@widgets, $Tk_objects{entry}{$label});
        push(@widgets, $Tk_objects{entry}{$pvar});
    }

#   if (@widgets > 2) {
        $widgets[0]->grid(@widgets[1..$#widgets], -sticky => 'w');
#   }
#   else {
#       $widgets[0]->grid(@widgets[1..$#widgets], -columnspan => 2, -sticky => 'w');
#   }

}

# One at a time now, first param is status bar frame number (1 = original, 2=sb, 3=sb row 2)

sub tk_label_new {
    return unless $Reload;
    my $frame_number = shift;
    my @data = @_;
    my @widgets;


                                # Allow web widgets, even with -no_tk
    push(@Tk_widgets, [$Category, 'label', @_]);

    return unless $MW and $Tk_objects{"fb$frame_number"};
    for my $pvar (@data) {
        $Tk_objects{label}{$pvar}->destroy if $Tk_objects{label}{$pvar} and Exists($Tk_objects{label}{$pvar});

        $Tk_objects{label}{$pvar} = $Tk_objects{"fb$frame_number"}->
            Label(-relief => 'sunken', -textvariable => $pvar, -justify => 'center');

$Tk_objects{label}{$pvar}->pack( -fill => 'x', -expand => 1);

#           Label(-relief => 'sunken', -textvariable => $pvar, -anchor => 'w', -font => $font1);

        push(@widgets, $Tk_objects{label}{$pvar});
	&configure_element('label', \$Tk_objects{label}{$pvar});
    }
#    if (@widgets > 1) {
#       $widgets[0]->pack(qw/-side bottom -padx 5 -anchor n/);
#    }
#    else {
#        $widgets[0]->grid(qw/-sticky w/);
        $widgets[0]->pack(qw/-side left -padx 2 -anchor n/);
#    }
}

# *** Deprecated (labels populate status bar, not widget control pane.)

sub tk_label {
    return unless $Reload;

                                # Allow web widgets, even with -no_tk
    push(@Tk_widgets, [$Category, 'label', @_]);

    return unless $MW and $Tk_objects{grid};
    my @data = @_;
    my @widgets;
    for my $pvar (@data) {
        $Tk_objects{label}{$pvar}->destroy if $Tk_objects{label}{$pvar} and Exists($Tk_objects{label}{$pvar});
                                # Note: Use a fixed font, so label size does not change with changing letters.
        $Tk_objects{label}{$pvar} = $Tk_objects{grid}->
            Label(-relief => 'sunken', -textvariable => $pvar, -justify => 'left',
                  -anchor => 'w');
#           Label(-relief => 'sunken', -textvariable => $pvar, -anchor => 'w', -font => $font1);

	&configure_element('log', \$Tk_objects{label}{$pvar}); # these are log-like (need fixed-width font)

        push(@widgets, $Tk_objects{label}{$pvar});
    }
    if (@widgets > 1) {
        $widgets[0]->grid(@widgets[1..$#widgets], -sticky => 'w');
    }
    else {
        $widgets[0]->grid(qw/-columnspan 5 -sticky w/);
    }
}

sub configure_element {
	my $type = shift; # *** Check ref $$element for type of widget
	my $p_element = shift;
	my $flags = shift;
	my $font;
	my $bgcolor;
	my $color;
	my $colors;
	my $relief;
	my $border_width;

    unless ($$p_element) {
        print "configure_element error: type=$type\n";
        return;
    }

	if (defined $$p_element) {

		$font = &get_scheme_parameter($type, 'font');
		$color = &get_scheme_parameter($type, 'color');
		$colors = &get_scheme_parameter($type, 'colors'); #for multi-color progress bars
		$bgcolor = &get_scheme_parameter($type, 'bgcolor');
		$relief = &get_scheme_parameter($type, 'relief');
		$border_width = &get_scheme_parameter($type, 'borderwidth');

		if ($type eq 'window') {
			$$p_element->optionAdd('*font' => $font) if $font;
		}
		elsif ($type ne 'toolbar' and $type ne 'progress') {
# Get this error:  Can't set -font to `Times 10 bold' for Tk::Frame=HASH(0x73b0928): unknown option "-font" at C:/Perl/site/lib/Tk/Configure.pm line 46.
#			$$p_element->configure(-font => $font) if $font;
		}
		if ($type eq 'progress') {
			$$p_element->configure(-colors => [0, $color]) if $color;

			my @colors = split ',', $colors;

			$$p_element->configure(-colors => [0,$colors[0],12,$colors[0], 25, $colors[1],37,$colors[1],50,$colors[2],63,$colors[2], 75, $colors[3], 87,$colors[3]]) if defined $colors and defined $flags and $flags;
		}
		else {
			$$p_element->configure(-bg => $bgcolor) if $bgcolor;
		}
		if ($type ne 'frame' and $type ne 'window') {
			$$p_element->configure(-relief => $relief) if $relief;
			$$p_element->configure(-borderwidth => $border_width) if $border_width;
		}
	}
	else {
		warn "Undefined element passed to configure_element type=$type $p_element";
	}
}

sub get_scheme_parameter {
	my $type = shift; #window *** or menu, frame, edit, log, progress or toolbar
	my $parameter = shift; #borderwidth, relief, bgcolor or font

	# *** Validate

	my $key = "tk_$parameter";
	if ($parameter eq 'font') { # for backwards compatibility (tk_font_fixed, tk_font_menus, etc.)
	#	$key .= '_menus' if $type eq 'window' or $type eq 'frame';
		$key .= '_window' if $type eq 'window';
		$key .= '_fixed' if $type eq 'log';
		$key .= '_edit' if $type eq 'edit';
		$key .= '_label' if $type eq 'label'; # *** label widget sends this or log, depending on parameter passed to it
	}
	else {
		$key .= "_$type";
	}

	my $scheme_key = $key;
	$scheme_key .= "_$config_parms{tk_scheme}" if $config_parms{tk_scheme};

	if (exists $config_parms{$scheme_key}) {
		return $config_parms{$scheme_key};
	}
	else {
		return (exists $config_parms{$key})?$config_parms{$key}:'';
	}


}

                                # Label for the menubar (not used much.)
sub tk_mlabel {
    return unless $Reload;

    push(@Tk_widgets, [$Category, 'label', $_[0]]);

    return unless $MW and $Tk_objects{menu_bar};
    my ($pvar, $name) = @_;


                                                 # Allow for $name so we can reliably destroy on $Reload.
                                                 # $pvar may be %Save or an object that changes on reloads :( # *** Why the frown here?  Do these not work properly?  Other labels do.
    $name = $pvar unless $name;
                                                 # If an object, get its state
                                                 #  - As of 2.88 (Generic_Item Tie update), object pointers don't work.  Data is not updated.
    my $pvar2 = (ref $pvar ne 'SCALAR' and $pvar->can('set')) ? \$$pvar{state} : $pvar;
#   print "db2 testing mlabel pv=$pvar pv2=$pvar2 pv2v=$$pvar2  $Tk_objects{mlabel}{$pvar}\n";

    $Tk_objects{mlabel}{$name}->destroy() if $Tk_objects{mlabel}{$name} and Exists($Tk_objects{mlabel}{$name});
    $Tk_objects{mlabel}{$name} = $Tk_objects{menu_bar}->
    Label(-relief => 'sunken', -textvariable => $pvar2);


    &configure_element('edit', $Tk_objects{mlabel}{$name});

    $Tk_objects{mlabel}{$name}->pack(qw/-side right -anchor e/);
}


sub tk_radiobutton {
    return unless $Reload;

#   print "db5 Debug doing the radiobutton thing, l=@_, r=$Reload\n";

                                # Allow web widgets, even with -no_tk
    push(@Tk_widgets, [$Category, 'radiobutton', @_]);

    return unless $MW and $Tk_objects{grid};
    my ($label, $pvar, $pvalue, $ptext, $callback, $widget) = @_;
    $Tk_objects{radiobutton}{$pvar}->destroy if $Tk_objects{radiobutton}{$pvar} and Exists($Tk_objects{radiobutton}{$pvar});
    my @widgets;
    my @text = @$ptext if $ptext;      # Copy, so we can do shift and still have the origial $ptext array available for html widget
    for my $value (@$pvalue) {
        my $text = shift @text;
        $text = $value unless defined $text;

                                # Check to see if $pvar is an object with the set method
                                #  - use set if we can, so state_now works on tk changes
        if (ref $pvar ne 'SCALAR' and $pvar->can('set')) {
            $widget = $Tk_objects{grid}->Radiobutton(-text => $text, -variable => \$$pvar{state}, -value => $value,
                                                     -command => sub {$pvar->set($value) });
        }
        else {
            $widget = $Tk_objects{grid}->Radiobutton(-text => $text,  -variable => $pvar, -value => $value);
        }
        push(@widgets, $widget);
#       &configure_element('frame', $widget);
    }
    $Tk_objects{radiobutton}{$pvar} = $Tk_objects{grid}->Label(-text => $label)->grid(@widgets, -sticky => 'w');
#   $Tk_objects{radiobutton}{$pvar} = $Tk_objects{grid}->Label(-text => $label);
#   &configure_element('frame', $Tk_objects{radiobutton}{$pvar});
#   $Tk_objects{radiobutton}{$pvar}->grid(@widgets, -sticky => 'w');
}

                                # This sub sleeps, and times how long it slept
sub sleep_time {
    my ($sleep_time) = @_;
    return 0 unless $sleep_time;
    my $tic1 = &get_tickcount;
    select undef, undef, undef, $sleep_time / 1000;
    return &get_tickcount - $tic1;
}


sub write_user_code {

    undef $user_code;
#   $user_code  = "\nuse strict 'subs';\nuse strict 'refs';\nuse strict 'vars';\n";

                                 # Add sleeps 1/$i-th way through user code.
                                 # Improves cache usage for less %cpu than 1 big sleep.
    my $sleep_call = "   \$loop_sleep_total += &sleep_time(\$Loop_Sleep_Time);\n";
    my $j = int @Loop_Code / ($config_parms{sleep_count} - 1) if $config_parms{sleep_count} > 1;
    for my $k (0 .. $config_parms{sleep_count}-2) {
        my $pos = $k * $j;
        splice @Loop_Code, $pos+$k, 0, $sleep_call;;
    }
    push @Loop_Code, $sleep_call if $config_parms{sleep_count} > 0;

                                # join with '' so 'eof' markers are in col 1
    $user_code .= join('', @Item_Code, "\n", @Sub_Code,
                       "#-----------------------------------\n\n",
                       "sub loop_code { \n\n   \$loop_sleep_total = 0;\n",
                       @Loop_Code,  "\n}");
    my $user_code_file = "$config_parms{data_dir}/mh_temp.user_code";
    open(USERCODE, ">$user_code_file") or print "Can not open debug user code file $user_code_file: $!\n";
    print USERCODE $user_code;
    close USERCODE;

    &Reload_pre_hooks();        # Not sure if/when this would be used.

    &eval_user_code_reset;      # Re-initialize stuff
    &eval_user_code_load;       # Look for real bad errors, caught when defining subroutine
    &object_states_restore;     # Must be after Item_code variables have been defined

                                # Created by &add_hooks (after object states have been restored)
                                # Note:  I don't think this is useful, as user code loop has not been run yet to add any hooks!
    &Reload_post_hooks();       #        Except, it IS useful when called from module code on startup.

    print "Activating voice commands\n";
    &Voice_Cmd::activate;

    if ($config_parms{listen} and $config_parms{listen} ne '0') { # default listens, 0 starts up not listening
	    print "Turning on microphone\n";
	    &Voice_Cmd::mic('on');
    }


                               # Now set usage_name in each object, so they know what they are called.
#   my $var;
#   for $var (keys %main::) {
#       no strict 'refs';
#       my $ref = ${$var};

#   for (sort keys %file_by_object_name) {
#       for $var (keys %{$file_by_object_name{$_}}) {
#           my $ref = eval "\\$var";
#           $$ref->{usage_name} = $var;
#       }
#   }

}


my %table_hcodes = qw(A 0110  B 1110  C 0010  D 1010  E 0001  F 1001  G 0101  H 1101
                      I 0111  J 1111  K 0011  L 1011  M 0000  N 1000  O 0100  P 1100);
my %table_dcodes = qw(1 0110  2 1110  3 0010  4 1010  5 0001  6 1001  7 0101  8 1101
                      9 0111 10 1111 11 0011 12 1011 13 0000 14 1000 15 0100 16 1100
                      A 1111  B 0011  C 1011  D 0000  E 1000  F 0100  G 1100);
sub x10_dim_level_decode {
    my ($code) = @_;
                                # Convert bit string to decimal
    my $level_b = $table_hcodes{substr($code, 0, 1)} . $table_dcodes{substr($code, 1, 1)};
    my $level_d = unpack('C', pack('B8', $level_b));
                                # Varies from 36 to 201, by 11, then to 210 as a max.
                                # 16 different values.  Round to nearest 5%, max of 95.
    my $level_p = int(100 * $level_d / 211); # Do not allow 100% ... not a valid state?
    $level_p = $level_p - ($level_p % 5);
    print "CM11 debug: dim_code=$code leveld=$level_d level_p=$level_p\n" if $Debug{x10};
    return $level_p;
}

#---------------------------------------------------------------------------

                                # Lets do it.  Note, we put this at the bottom so
                                # we can delare global arrays like %table_hcodes and %table_month
&setup;
&read_code;                     # Load all menus
&monitor_commands;

#---------------------------------------------------------------------------


__END__


# $Date: 2007-08-31 10:32:53 -0400 (Fri, 31 Aug 2007) $
#
# $Log: mh,v $
# Revision 2.101  2006/01/29 20:23:40  winter
# *** empty log message ***
#
# Revision 2.100  2005/10/02 16:48:28  winter
# *** empty log message ***
#
# Revision 2.99  2005/05/22 18:02:28  winter
# *** empty log message ***
#
# Revision 2.98  2005/03/20 18:53:39  winter
# *** empty log message ***
#
# Revision 2.97  2005/01/23 23:07:10  winter
# *** empty log message ***
#
# Revision 2.96  2004/11/22 22:42:50  winter
# *** empty log message ***
#
# Revision 2.95  2004/09/25 19:40:18  winter
# *** empty log message ***
#
# Revision 2.94  2004/07/30 23:05:10  winter
# *** empty log message ***
#
# Revision 2.93  2004/07/18 22:09:43  winter
# *** empty log message ***
#
# Revision 2.92  2004/07/05 23:23:29  winter
# *** empty log message ***
#
# Revision 2.91  2004/06/06 21:29:28  winter
# *** empty log message ***
#
# Revision 2.90  2004/05/02 22:05:08  winter
# *** empty log message ***
#
# Revision 2.89  2004/04/25 17:21:46  winter
# *** empty log message ***
#
# Revision 2.88  2004/03/23 01:50:21  winter
# *** empty log message ***
#
# Revision 2.87  2004/02/01 19:24:18  winter
#  - 2.87 release
#
# Revision 2.86  2003/12/22 00:07:41  winter
#  - 2.86 release
#
# Revision 2.85  2003/12/01 03:05:33  winter
#  - 2.85 release
#
# Revision 2.84  2003/11/23 20:20:04  winter
# - 2.84 release
#
# Revision 2.83  2003/09/02 02:43:43  winter
#  - 2.83 release
#
# Revision 2.82  2003/07/06 17:49:41  winter
#  - 2.82 release
#
# Revision 2.81  2003/06/01 21:52:49  winter
#  - 2.81 release
#
# Revision 2.80  2003/04/20 21:43:57  winter
#  - 2.80 release
#
# Revision 2.79  2003/03/09 03:11:07  winter
# - 2.79 release
#
# Revision 2.78  2003/02/08 05:23:36  winter
#  - 2.78 release
#
# Revision 2.77  2003/01/18 03:28:11  winter
#  - 2.77 release
#
# Revision 2.76  2003/01/12 20:31:02  winter
#  - 2.76 release
#
# Revision 2.75  2002/12/24 02:58:10  winter
# - 2.75 release
#
# Revision 2.74  2002/12/02 04:47:14  winter
# - 2.74 release
#
# Revision 2.73  2002/11/10 01:54:05  winter
# - 2.73 release
#
# Revision 2.72  2002/10/13 01:59:42  winter
# - 2.72 release
#
# Revision 2.71  2002/09/22 01:30:54  winter
# - 2.71 release
#
# Revision 2.70  2002/08/22 04:27:33  winter
# - 2.70 release
#
# Revision 2.69  2002/07/01 22:20:49  winter
# - 2.69 release
#
# Revision 2.68  2002/05/28 13:02:16  winter
# - 2.68 release
#
# Revision 2.67  2002/05/04 06:55:55  winter
# - 2.67 release
#
# Revision 2.66  2002/03/31 18:48:55  winter
# - 2.66 release
#
# Revision 2.65  2002/03/02 02:32:59  winter
# - 2.65 release
#
# Revision 2.64  2002/01/23 01:46:17  winter
# - 2.64 release
#
# Revision 2.63  2002/01/19 20:59:19  winter
# - 2.63 release
#
# Revision 2.62  2001/12/16 21:44:09  winter
# - 2.62 release
#
# Revision 2.61  2001/11/18 22:46:31  winter
# - 2.61 release
#
# Revision 2.60  2001/10/21 01:08:38  winter
# - 2.60 release
#
# Revision 2.59  2001/09/23 19:26:53  winter
# - 2.59 release
#
# Revision 2.58  2001/08/22 03:04:31  winter
# - test release
#
# Revision 2.57  2001/08/12 04:02:57  winter
# - 2.57 update
#
# Revision 2.56  2001/07/19 03:48:08  winter
# - add http_fork
#
# Revision 2.55  2001/06/27 13:17:36  winter
# - 2.55 release
#
# Revision 2.54  2001/06/27 03:45:11  winter
# - 2.54 release
#
# Revision 2.53  2001/06/01 12:54:00  winter
# - test release
#
# Revision 2.52  2001/05/28 21:13:07  winter
# - 2.52 release
#
# Revision 2.51  2001/05/06 21:05:42  winter
# - 2.51 release
#
# Revision 2.50  2001/04/21 16:21:06  winter
# - add x10_mulitireceive_delay check
#
# Revision 2.49  2001/04/15 16:12:24  winter
# - 2.49 release
#
# Revision 2.48  2001/03/24 23:43:36  winter
# - add serial undef check with length == 0
#
# Revision 2.47  2001/03/24 17:58:33  winter
# - 2.47 release
#
# Revision 2.46  2001/02/27 01:45:33  winter
# - test release with faster http calls
#
# Revision 2.45  2001/02/24 23:18:05  winter
# - 2.45 release
#
# Revision 2.44  2001/02/12 14:50:06  winter
# - add Nextpass_Actions
#
# Revision 2.43  2001/02/04 20:27:26  winter
# - 2.43 release
#
# Revision 2.42  2001/01/23 13:32:29  winter
# - test release
#
# Revision 2.41  2001/01/20 17:46:19  winter
# - 2.41 release
#
# Revision 2.40  2001/01/16 01:48:31  winter
# - test release
#
# Revision 2.39  2000/12/21 18:54:14  winter
# - 2.38 release
#
# Revision 2.38  2000/12/21 18:49:01  winter
# - 2.38 release
#
# Revision 2.37  2000/12/08 02:13:35  winter
# *** empty log message ***
#
# Revision 2.36  2000/12/03 19:33:47  winter
# - 2.36 release
#
# Revision 2.35  2000/11/19 19:54:28  winter
# - added %Weather.  Fixed -time_stop accelerated time mode
#
# Revision 2.34  2000/11/12 21:01:02  winter
# - 2.34 release
#
# Revision 2.33  2000/10/28 21:33:38  winter
# - fix random and x10 string merging
#
# Revision 2.32  2000/10/22 16:44:57  winter
# - 2.32 release
#
# Revision 2.31  2000/10/13 19:47:57  danal
# DSC_Alarm.pm support via changes to managed serial startup calls
#
# Revision 2.30  2000/10/09 02:24:19  winter
# - post 2.29 release.  Add new members and sync up code/bruce
#
# Revision 2.29  2000/10/01 23:35:24  winter
# - 2.29 release
#
# Revision 2.28  2000/09/09 21:16:23  winter
# - 2.28 release
#
# Revision 2.27  2000/08/19 00:58:57  winter
# - 2.27 release.  Lots of small bug fixes.
#
# Revision 2.26  2000/08/11 00:47:46  danal
# Fix bug in "datatype=raw" socket ports
#
# Revision 2.25  2000/08/09 03:38:36  winter
# - fix $cpu test and improve my_str2time error msg
#
# Revision 2.24  2000/08/06 21:56:43  winter
# - See 2.24 release notes.
#
# Revision 2.23  2000/08/06 00:59:42  winter
# - added .gif, jgp support.  Added use diagnostics. Added &dir_index.
#   Improve error analysis.  Lots of other minor changes.
#
# Revision 2.22  2000/06/24 22:10:54  winter
# - 2.22 release.  Changes to read_table, tk_*, tie_* functions, and hook_ code
#
# Revision 2.21  2000/06/17 21:06:24  winter
# - add read_table_files, for reading optional .mht files
#
# Revision 2.20  2000/05/27 16:38:46  winter
# - Allow for regular expresions in local_address check.  Add internet_speak_flag.
#
# Revision 2.19  2000/05/21 22:08:56  winter
# - add &add_hooks, so we can have user defined callbacks
#
# Revision 2.18  2000/05/14 19:01:02  winter
# *** empty log message ***
#
# Revision 2.17  2000/05/14 16:15:58  winter
# - add Socket_Item datatype.  Switch from systread to recv on tcp reads
#
# Revision 2.16  2000/05/11 01:12:45  danal
# Added support for UDP sockets; must be defined in MH.INI
#
# Revision 2.15  2000/05/06 16:30:13  winter
# - allow for duplicate Serial_Item ids.  Add tk_font.
#
# Revision 2.14  2000/04/23 01:30:19  winter
# - enable unmuted in the Play function
#
# Revision 2.13  2000/04/09 17:37:23  winter
# - added IR_Item.  Numerous bug fixes.
#
# Revision 2.12  2000/03/22 14:03:47  winter
# -Fix CM11 delay.  Compile in Serial_Item
#
# Revision 2.11  2000/03/10 02:42:24  winter
# - Add Ibutton support and more web changes
#
# Revision 2.1  2000/02/20 04:47:54  winter
# -2.01 release
#
# Revision 2.00  2000/02/13 04:00:08  winter
# - change Version to 2.00
#
# Revision 1.100  2000/02/13 03:59:23  winter
# *** empty log message ***
#
# Revision 1.99  2000/02/13 03:57:26  winter
#  - 2.00 release.  New web server interface
#
# Revision 1.98  2000/02/12 04:24:36  winter
# - lots of web changes.
#
# Revision 1.97  2000/01/28 02:40:20  winter
# -add use Fcntl and X10 Garage_Door
#
# Revision 1.96  2000/01/27 13:28:04  winter
# - add time_random
#
# Revision 1.95  2000/01/26 14:32:38  winter
# - ignore empty $time_date spec, and add time_random
#
# Revision 1.94  2000/01/09 20:13:53  winter
# - Add $year_unix to $Year is always a correct 4 digit year
#
# Revision 1.93  2000/01/05 14:38:44  winter
# *** empty log message ***
#
# Revision 1.92  2000/01/02 23:31:12  winter
# - fix tk date bug, add Date_Now_Speakable, my_use DosGlob
#
# Revision 1.91  1999/12/15 13:46:25  winter
# - fix "12:xx AM" tests in my_str2time (called by time_now).   Force -time_stop > -time_start.
#
# Revision 1.90  1999/12/12 23:53:35  winter
# - Add http delay for Netscape.  Do not require () in Object definitions, $New_Week
#
# Revision 1.89  1999/11/21 02:50:11  winter
# - add config_parms{sound_program} option.  Fix add unless $Startup to read_parms.
#
# Revision 1.88  1999/11/17 05:35:14  winter
# - Add list of fixes from Dan W., add HomeBase_baudrate
#
# Revision 1.87  1999/11/08 02:23:54  winter
# - delete X10_Lamp
#
# Revision 1.86  1999/11/08 02:08:54  winter
# - add file_unchanged
#
# Revision 1.85  1999/11/03 02:53:35  winter
# - add $Reread, time_format, and move serial_port object_by_port data
#
# Revision 1.84  1999/10/27 01:43:37  winter
# - close IN on log
#
# Revision 1.83  1999/10/09 20:31:27  winter
# - change CM11, CM17 to ControlX10.  add max_log_entries
#
# Revision 1.82  1999/10/02 22:36:29  winter
# - return undef in file_changed if we don't know
#
# Revision 1.81  1999/10/01 01:32:33  winter
# - allow for port sharing in serial_port_create
#
# Revision 1.80  1999/09/30 13:24:34  winter
# - added interface to Serial_Item.pm
#
# Revision 1.79  1999/09/27 03:06:29  winter
# - add sendkeys_find_window and serial_data_buffer
#
# Revision 1.78  1999/09/18 03:20:00  winter
# - allow for config_parm sounds
#
# Revision 1.77  1999/09/17 02:59:47  winter
# - add SetupSup.  Move CM11.
#
# Revision 1.76  1999/09/16 12:54:25  winter
# - Change use cm17 to require cm17, so it compiles Ok
#
# Revision 1.75  1999/09/12 20:53:22  winter
# - fixed $Holiday bug
#
# Revision 1.74  1999/09/12 16:40:58  winter
# *** empty log message ***
#
# Revision 1.73  1999/09/12 16:06:20  winter
# - changed tk menus to improve (but not fix) the memory leak problem
#
# Revision 1.72  1999/08/30 00:01:57  winter
# *** empty log message ***
#
# Revision 1.71  1999/08/29 17:29:37  winter
# - pull out global 'use vars', like global 'by' out of loop code
#
# Revision 1.70  1999/08/21 03:38:10  winter
# - Restore STDOUT after done loggin.
#
# Revision 1.69  1999/08/02 01:50:13  winter
# - add CM11 Status processing
#
# Revision 1.68  1999/08/01 01:11:46  winter
# - enable Help, add Local_Address, add password_allow_file
#
# Revision 1.67  1999/07/29 13:31:41  winter
# - fix dos key problem
#
# Revision 1.66  1999/07/28 23:30:20  winter
# - add last_displayed support.
#
# Revision 1.65  1999/07/21 21:07:04  winter
# - add my_use.  Switch from Win32::Sleep to select (now enabled win windows perl)
#
# Revision 1.64  1999/07/18 23:13:22  winter
# - add state to voice_cmd.  Buffer socket data faster.
#
# Revision 1.63  1999/07/05 22:23:37  winter
# - added a simple &play mode.  Added %Tk_results
#
# Revision 1.62  1999/07/03 22:22:01  winter
# - make socket debug port specific
#
# Revision 1.61  1999/06/27 20:10:02  winter
# - Save X10_appliance on exit.  Add ENV{mh_parm} check
#
# Revision 1.60  1999/06/23 23:13:17  winter
# - close misc file handles.
#
# Revision 1.59  1999/06/22 00:41:26  winter
# - update http_server SET_VAR
#
# Revision 1.58  1999/06/20 22:26:49  winter
# - add do_user_file and dns_resolver code
#
# Revision 1.57  1999/06/19 20:00:32  winter
# - change Debug flag.  Add list ip address.  Fix uptime bugs.
#
# Revision 1.56  1999/05/30 21:06:24  winter
# - Store data into @Tk_widgets, for use by http_server.
#
# Revision 1.55  1999/05/12 03:48:46  winter
# - add $Time and check for $Time < $prev_time, so we don't re-fire events
#
# Revision 1.54  1999/04/28 13:50:29  winter
# - fix X10 bright/dim loop bug.  Add tk_checkbutton
#
# Revision 1.53  1999/04/15 12:54:29  winter
# - add server buffer option.  Take out dtr_active set.  Put in serial port reset_error.
#
# Revision 1.52  1999/04/08 01:56:31  winter
# - Add server log.  Flush STDOUT when logging.  Check for 4 character X10 strings.
#
# Revision 1.51  1999/03/28 02:49:13  winter
# - fixed bug in position= check
#
# Revision 1.50  1999/03/28 00:29:20  winter
# - add tk_ widgets
#
# Revision 1.49  1999/03/21 17:13:51  winter
# - fix time_now PM offset.  Do NOT exit 1 on -run stub
#
# Revision 1.48  1999/03/18 14:36:20  winter
# - add mh_start and exit 1 so we can check for unexpected exits
# - fix data_record processing in check_for_generic_serial_port
#
# Revision 1.47  1999/03/16 01:55:38  winter
# - re-write my_str2time.
#
# Revision 1.46  1999/03/12 04:22:36  winter
# - add 49 day bug check.
# - move reset_states into Serial_Item
# - check to nearest minute, not second, in time_now
#
# Revision 1.45  1999/03/10 14:44:54  winter
# - display error errata to tk window. Use older SerialPort
#
# Revision 1.44  1999/03/09 04:22:43  winter
# - Get smarter on X10 string.  Change serial_string to do better with multilines
#
# Revision 1.43  1999/03/07 20:54:24  winter
# - allow for > 2 generic serial ports.
# - fix window size on startup.
# - fix str2time bug and x10 loop bugs.
#
# Revision 1.42  1999/02/26 14:32:17  winter
# - fix the memory leak problem by testing on /s instead of ' ' in add object methods
#
# Revision 1.41  1999/02/25 14:26:28  winter
# - perl2exe_include SerialPort to guarentee it gets included in compiled mh
#
# Revision 1.40  1999/02/21 00:23:09  winter
# - Change $Pgm_Path from my to use var.
#
# Revision 1.39  1999/02/20 20:03:19  winter
# - add Process_Item, password_read, $Reload.
#
# Revision 1.38  1999/02/15 02:42:42  winter
# - add Tk Items, Groups
#
# Revision 1.37  1999/02/13 22:23:57  winter
# - add Group Item support.   Use call to play on non-windows box.
#
# Revision 1.36  1999/02/08 13:41:15  winter
# - add print to stdout, if tk & config_parms{debug}
#
# Revision 1.35  1999/02/08 03:44:03  winter
# - Fix serial port write error from ver 1.34.  add some homebase debug.
#
# Revision 1.34  1999/02/08 00:33:47  winter
# - add filename to tk menus. fix duplicate timer bug.
#
# Revision 1.33  1999/02/06 22:29:03  winter
# - add geometry.  reset cmd_list.
#
# Revision 1.32  1999/02/04 14:02:24  winter
# - added more Tk menus. Fixed http server paths.  Switch to new OLE calls.
#
# Revision 1.31  1999/02/02 14:37:37  winter
# - change ole call to Win32::Ole
#
# Revision 1.30  1999/02/01 00:05:20  winter
# - Fix the tk debug button.  Add SerialPort_Linux support
#
# Revision 1.29  1999/01/30 19:48:54  winter
# - Speed up compiled version by avoiding use lib.
# - allow mh.ini on reload
# - add state_now reset loop on generic_item
# - set frames into Tk_objects, so we can dynmically change tk window from user code
# - misc minor bug fixes.
#
# Revision 1.28  1999/01/28 00:55:21  winter
# - re-enable unix select sleep.  Disable raw serial output.  Use ~ in restore states file.
#
# Revision 1.27  1999/01/24 20:06:14  winter
# - Move pod docs. into mh.pod.  Untabify (again!)
#
# Revision 1.26  1999/01/23 16:23:17  winter
# - Change the structure of the Serial_Port object to match the Socket_Port object (no Serial_Data arrays)
#
# Revision 1.25  1999/01/22 02:40:25  winter
# - add linux support.  re-tabbify.   add password function.
# - allow for client port connections.  Add support for festival TTS
#
# Revision 1.23  1999/01/17 22:12:35  winter
# - resort subs into alphabetical order.
# - replace use module with eval "use module" so we can conditionaly load OS dependent modules
#
# Revision 1.22  1999/01/16 19:57:37  winter
# - allow '0' as a telnet input byte without closing.  Document regular expresions.
#
# Revision 1.21  1999/01/13 14:07:48  winter
# - re-write the socket interface, allowing for multiple socket ports that
#   can be controled from user code (see telnet.pl)
#
# Revision 1.20  1999/01/10 02:27:14  winter
# - allow for defered html_spoken, so we can get valid web page 'last spoken' updates
#
# Revision 1.19  1999/01/09 19:09:14  winter
# - allow for run_voice_cmd even if VR is not installed or working.
#   Add more error messages on Voise OLE errors.
#
# Revision 1.18  1999/01/08 14:23:19  winter
# - add perl pod documentation.  Fix run_voice_cmd to allow leading/trailing blanks
#
# Revision 1.17  1999/01/07 01:51:32  winter
# - Use my_strin2time in time_less_than and time_greater_than, so we can
#   do time aritmatic there.  Add dbmclose in logit_dbm.
#
# Revision 1.16  1998/12/10 14:37:24  winter
# - add new Web interface, so it is customizable.  Switch to latest version
#   of Tk and fix Tk focus problem.
#
# Revision 1.15  1998/12/07 14:31:49  winter
# - Allow for more flexable serial port output.  Add serial_port_examples.pl
#   Change cm11 code for faster execution.
#
# Revision 1.14  1998/11/30 14:34:41  winter
# - add loops per second max with and without tk loops
#
# Revision 1.13  1998/11/30 04:35:25  winter
# - Add more internet options (email send/receive/monitor, net html retrieve
#   and process options).  Add command line interface on Tk window.
#   Switch house.bat from perl to 'pure bat' so compiled users can use it
#
# Revision 1.12  1998/11/21 22:11:44  winter
# - Update tk gui.  Enable bright/dim for CM11 (e.g. +10..+90,-10..-90)
#
# Revision 1.11  1998/11/19 14:27:06  winter
# - Add triva, thoughts, and set_clock applications.  Restructure code dir.
#   Add cpu used to tk gui.
#
# Revision 1.10  1998/11/15 22:01:31  winter
# - Add print and speak logs to the gui.
#   Add Constans ON, OFF, OPEN, CLOSE, etc.
#   Add support for generic serial port events
#   Make the object save and restore scenerio more robust.
#   Add Display.pm, so we can display multiple objects at the same time
#
# Revision 1.9  1998/11/11 04:18:33  winter
# - lots of small changes and fixes.
#
# Revision 1.8  1998/09/19 20:38:41  winter
# - Start on a simple tk interface.  Change default so tk windows are enabled.
#   Fix web server port error.  Change how help text is involked.  Use tk
#   DoOneEvent instead of Mainloop.
#
# Revision 1.7  1998/09/16 13:02:50  winter
# - default to no_tk.  Warn, but do not die, if socket port fails.  Allow Loop_Sleep_Time
#   to come from the parm file.  Save states periodically.  Undef objects_by_object_name.
#
# Revision 1.6  1998/09/12 22:09:42  winter
# - add Homebase support.  Add http server support if server_port is specified.
#
# Revision 1.5  1998/08/30 14:32:23  winter
# - fix private.ini check.
#
# Revision 1.4  1998/08/30 00:08:03  winter
# *** empty log message ***
#
# Revision 1.3  1998/08/29 20:43:15  winter
# - re-write serial interface, so we can support mupltiple ports (e.g. cm11)
#
# Revision 1.2  1998/08/26 03:08:21  winter
# - add Revision to header
#
#
