/tags/v2-28/mh/bin/mh
Perl | 1646 lines | 1232 code | 207 blank | 207 comment | 223 complexity | 5a4fb72d689b6c38cb01b810a358cb26 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0, GPL-3.0
- #!/usr/bin/perl
- # -*- Perl -*-
- # Last change Time-stamp: <2000-09-09 16:00:57 winter>
- #---------------------------------------------------------------------------
- # File:
- # mh
- # Description:
- # A perl script that does home control functions
- # Author:
- # Bruce Winter bruce@misterhouse.net
- # Latest version:
- # http://misterhouse.net
- #
- # Change log:
- # - 03/07/98 Created from house_menu.
- # - The rest of the change log is at the bottom of this file.
- #
- # Documentation is in mh/docs/mh.html (from mh.pod) and mh/docs/install.html
- #
- # This free software is licensed under the terms of the GNU public license.
- # Copyright 1998-2000 Bruce Winter
- #
- #---------------------------------------------------------------------------
-
- use strict;
- my ($Pgm_Name, $Revision, $usage);
- # So we can get at it from other packages
- use vars qw(%config_parms %config_parms_startup $Pgm_Path $Version $Version_date);
- BEGIN {
- ($Version) = q$Revision: 107 $ =~ /: (\S+)/; # Auto-updated by CVS
- $0 = $ENV{sourceExe} if $ENV{sourceExe}; # perl2exe fills this in
- ($Pgm_Path, $Pgm_Name) = $0 =~ /^(.*)[\\\/]([^.]+)/i;
- ($Pgm_Name) = $0 =~ /([^.]+)/i unless $Pgm_Name;
- $Pgm_Name = 'mh' if $ENV{sourceExe}; # Since we sometimes rename mh.exe
- unless ($Pgm_Path) {
- use Cwd;
- $Pgm_Path = cwd();
- # When we do system calls in Dos, we need \, not /
- $Pgm_Path =~ tr!\/!\\! if $^O eq "MSWin32";
- }
- $usage =<<eof;
- Description:
- $Pgm_Name is a perl program for time, event, web, and voice based home control
- functions. Configuration is controled in the \\mh\\bin\\$Pgm_Name.ini file.
- See the \\mh\\docs\\$Pgm_Name.html for more info.
- Usage:
- $Pgm_Name [options] [files]
- Where options can be any of the parms listed in the \\mh\\bin\\$Pgm_Name.ini file
- Examples usage:
- $Pgm_Name
- $Pgm_Name -help
- $Pgm_Name -tk 0 -code_dir c:\\mh\\code\\test
- $Pgm_Name -log_file test1.log -debug 1 test1.pl
- eof
- }
- # Use var instead of my so we can get these in the http_server.pl scripts
- use vars qw($Time_Start_time $Time_Stop_time $Time_Increment $Time_Startup $Time_Startup_time $Time_Boot_time $Time_Uptime_Seconds);
- use vars qw($Time_Sunrise $Time_Sunset %Moon $Time_Now $Time_Date $Date_Now $Date_Now_Speakable $Year_Month_Now);
- use vars qw($Time $Second $Minute $Hour $Mday $Wday $Day $Month $Year);
- use vars qw($New_Second $New_Minute $New_Hour $New_Day $New_Week $New_Month $New_Year);
- use vars qw($Season $Weekday $Weekend $Holiday $Time_Of_Day);
- use vars qw($Startup $Reload $Reread $Loop_Count $Last_Response $Category);
- use vars qw($Version_tk);
- my ($Pgm_PathU);
- my (@Loop_Speeds, $Loop_Sleep_Time, $Loop_Tk_Passes);
- my ($Loop_Speed);
- my (@Requested_Files, @Print_Log, @Display_Log, @Speak_Log);
- my ($exit_flag, $xcmd_file, %file_code_times, %file_code_times2, %file_change_times);
- my (%User_Code, @Loop_Code, @Sub_Code, %Run_Members, @Item_Code, @Item_Code_Objects);
- my ($user_code, $user_code_last_good);
- my (%objects_by_object_name, %file_by_object_name, %files_by_webname);
- my (%object_names_by_file, %object_names_by_type, %object_names_by_webname, $pause_mode);
- my (%prev_serial_event, @Generic_Serial_Ports, @Server_Ports, , %Local_Addresses, @Local_Addresses, @Password_Allow_Clients);
- my ($CON_IN, $CON_OUT);
- #use vars '$CON_IN', '$CON_OUT';
- my($state, $temp); # Some generic useful vars
- use vars '%Tk_objects', '%Tk_results', '@Tk_widgets', '@Object_Types'; # So we can use in http_server
- use vars '$MW'; # So that programs that we 'do' can use the top window
- use vars '%Serial_Ports'; # So we can get at it from the Serial_Item package.
- use vars '%Socket_Ports';
- use vars '%Save';
- use vars '%Info', '$OS_win';
- use vars '%Password_Allow'; # So we can see check it from http_server.pl
- use vars '$Pgm_Root'; # So we can see it in eval var subs in read_parms
- use vars '$DNS_resolver';
- # Pre-declare these so we don't fail on non-windows platforms
- sub Win32::GetOSVersion;
- sub Win32::FsType;
- sub Win32::GetCwd;
- sub Win32::LoginName;
- sub Win32::NodeName;
- sub Win32::IsWinNT;
- sub Win32::IsWin95;
- sub Win32::GetTickCount;
- sub Win32::DriveInfo::DrivesInUse;
- &setup;
- &read_code; # Load all menus
- &monitor_commands;
- BEGIN {
- &check_for_run_cmd;
- &print_version;
- &check_usage;
- &setup_INC;
- &read_parms;
- &use_conditional_modules;
- print "Loading other modules\n";
- sub check_for_run_cmd {
- # This lets us use mh as a perl interpreter for running arbitrary perl code
- if ($ARGV[0] and $ARGV[0] eq '-run') {
- # @ARGV = split(/[, ]/, $config_parms{run_parms});
- shift @ARGV;
- my $pgm = shift @ARGV;
- my $pgm_path = $pgm;
- # Best to change to the mh bin dir, so their Paths are correct.
- # $pgm_path = "$Pgm_Path/$pgm" unless -e $pgm_path;
- chdir $Pgm_Path unless -e $pgm_path;
- unless (-e $pgm_path) {
- print "\nCan not find -run pgm: $pgm\n\n";
- exit;
- }
- print "\nRunning: $pgm_path @ARGV\n";
- $0 = $pgm; # Reset program name from mh to $pgm
- do "$pgm_path";
- print "Error with $pgm: $@\n" if $@;
- print "\nDone running: $pgm\n";
- exit;
- }
- }
- sub print_version {
-
- $Version_date= localtime((stat $0)[9]);
-
- # perl2exe sets this var
- if ($ENV{sourceExe}) {
- $Version_date= localtime((stat $ENV{sourceExe})[9]);
- $Version .= " (compiled)" unless $Version =~ /compiled/;
- }
-
- ($Pgm_PathU = $Pgm_Path) =~ tr/\\/\//;
- $Pgm_Root = "$Pgm_PathU/..";
-
- $OS_win = ($^O eq "MSWin32") ? 1 : 0;
- # Win95: MSWin32 Win95 B 4 0 67306684 1 FAT32
- # Win98: MSWin32 Win95 4 10 67766222 1 FAT
- if ($OS_win) {
- $Info{OS_version} = join(' ', Win32::GetOSVersion);
- $Info{OS_name} = 'NT' if Win32::IsWinNT;
- $Info{OS_name} = 'Win95' if Win32::IsWin95;
- $Info{OS_filesystem} = Win32::FsType;
- $Info{User} = Win32::LoginName;
- $Info{Machine} = Win32::NodeName;
- }
- else {
- $Info{OS_name} = $^O;
- $Info{User} = $ENV{USER};
- $Info{Machine} = $ENV{HOSTNAME};
- }
-
- print "\nCommand: $Pgm_Name @ARGV\n";
- print "Pgm path : $Pgm_Path\n";
- print "Pgm version: $Version Last updated: $Version_date\n";
- $Info{Perl_version} = $];
- # BuildNumber doesn't work with perl2exe compile :(
- $Info{Perl_version} .= " Build " . &Win32::BuildNumber() if $OS_win and !$ENV{sourceExe};
- print "Perl version: $Info{Perl_version}\n";
- print "OS version: $^O $Info{OS_name} $Info{OS_version} $Info{OS_filesystem}\n";
- print "Other : user=$Info{User} pid=$$ box=$Info{Machine} cpu=$ENV{PROCESSOR_ARCHITECTURE}-$ENV{PROCESSOR_LEVEL}\n";
- print "\n";
- }
- sub check_usage {
- # Get legal options from .ini file
- # my $parmfile = $Pgm_PathU . "/$Pgm_Name.ini";
- my $parmfile = $Pgm_PathU . "/mh.ini";
- open (PARMS, $parmfile) or die "Error, could not open parmfile $parmfile: $!\n";
- my @parms;
- while (<PARMS>) {
- push(@parms, "$1=s") if /^([^\s\#]+) *=/;
- }
- close PARMS;
- # print "db parms=@parms\n";
- use Getopt::Long;
- if (!&GetOptions(\%config_parms_startup, "h", "help", "run=s", "run_parms=s", @parms) or
- ($config_parms_startup{h} or $config_parms_startup{help})) {
- print $usage;
- exit;
- }
- }
- sub setup_INC {
- print "Setting up INC path ...";
- # Note, use lib messes up perl2exe, but eval use lib does not. Either use
- # eval use lib (only once, because it is slow in perl2exe) or comment out use lib
- # when compiling and use perl5lib env. Yuck.
- # - can not seem to get perl2exe to honor this. Guess we have to make sure
- # everything is compile by adding it to lib/mh_perl2exe_list.pl
- # eval "use lib '$Pgm_PathU/../lib', '$Pgm_PathU/../lib/site', '$Pgm_PathU', '../lib', '../lib/site', '.'";
- # eval "use lib '$Pgm_PathU/../lib', '$Pgm_PathU/../lib/site', '$Pgm_PathU'";
- # Use a push instead of a use lib, so we make sure the site perl libs come first, not last
- # - We need to support perl 5.005 and 5.6 at the same time. 5.005 win32 binaries
- # are distributed with mh (so user does not have to install them).
- # 5.6 users will be required to install them
- push (@INC, "$Pgm_PathU/../lib", "$Pgm_PathU/../lib/site", "$Pgm_PathU");
- # print "Error in use lib: $@\n" if $@; # Dang .. this error check messes up the compiled version!?? Gives 'can not find lib.pm' message
- print " done\n";
- require 'handy_utilities.pl'; # For misc. functions (e.g. time/date stamp routines)
- }
- sub read_parms {
- my $debug = 1 if $config_parms_startup{debug} and $config_parms_startup{debug} eq 'startup';
- &main::read_mh_opts(\%config_parms, $Pgm_PathU, $debug);
- # We need to honor starup parms, but a total reset messes up the tk debug button interface
- # %config_parms = (%config_parms, %config_parms_startup); # Last one (startup parms) wins
- for my $parm (keys %config_parms_startup) {
- $config_parms{$parm} = $config_parms_startup{$parm};
- }
- print "Code Directory: $config_parms{code_dir}\n";
- }
- sub use_conditional_modules {
- if ($config_parms{diagnostics} or $config_parms{w}) {
- print "Perl diaganotics module (perl -w) has been turned on\n";
- eval 'use diagnostics' if $config_parms{diagnostics};
- }
- # disable diagnostics;
- # This must be in a BEGIN in order for the 'use' to be conditional
- if ($OS_win) {
- print "Loading Windows modules\n";
-
- # Must use 'my_use' (evals) so unix doesn't croak on missing modules
- # Not sure what we gain/loose with ole lite
- # &my_use("Win32::DUN"); # Interface to rasdial
- &my_use("Win32::DriveInfo"); # For disk space free/total
- eval "use Win32::Console";
- print "\nError in loading module=Win32::Console:\n $@\n" if $@;
- &my_use("Win32::OLE");
- # &my_use("Win32::OLE qw(EVENTS)"); # EVENTS forces single-threaded apartment, so outlook.pl MAPI works
- # &my_use("Win32::OLE::lite");
- &my_use("Win32::Process");
- &my_use("Win32::Registry");
- # Note: Must use eval, not my_use, or exported pgms are not seen :(
- # - setupsup is not yet available for perl 5.6
- # - BuildNumber doesn't work with perl2exe compile
- # - Loaded from: http://jenda.krynicky.cz/perl/
- eval "use Win32::Setupsup qw(WaitForAnyWindow SendKeys)" if $ENV{sourceExe} or &Win32::BuildNumber() < 600;
- print "\nError in loading module=Win32::Setupsup:\n $@\n" if $@;
- eval "use Win32::Sound";
- print "\nError in loading module=Win32::Sound:\n $@\n" if $@;
- &my_use("Win32::SerialPort");
- &my_use("Win32::SoundEx"); # For Volume control
- &my_use("File::DosGlob 'glob'"); # Allow for globbing without perlglob.exe
- }
- else { # load the mutually-exclusive non-Windows modules
- &my_use("Device::SerialPort"); # Unix Posix verion of Win32 SerialPort
- }
- if ($config_parms{tk}) {
- print "Loading Tk modules ";
- eval "use Tk";
- # eval "use Tk qw/DoOneEvent DONT_WAIT ALL_EVENTS/";
- $Version_tk = $Tk::VERSION;
- print "Version $Tk::VERSION\n";
-
- if ($@) {
- print "\nError, perl Tk module is not installed.\nTk windows will be disabled with the -tk 0 option. Error:$@\n\n";
- $config_parms{tk} = 0;
- }
- else {
- &my_use("Display");
- }
- }
- }
- } # End BEGIN
-
- sub setup {
- print "Starting setup\n";
- $| = 1; # Turn on command buffering (e.g. flush on every print)
- my $logfile = $config_parms{log_file};
- $config_parms{log}++ if $logfile;
- $config_parms{log_file} = $Pgm_PathU . "/../mh.log" unless $config_parms{log_file};
- my $print_log = $Pgm_PathU . "/../mh.print.log";
- rename $print_log, $print_log . ".old";
- open PRINTLOG, ">$print_log" or die "Error, could not open print lotfile $print_log: $!\n";
- if ($config_parms{log}) {
- print "Output will be logged into $logfile\n";
- open STDOUT, ">$logfile" or die "Error, could not open logfile $logfile: $!\n";
- &print_version;
- }
- use File::Copy; # So we copy files
- use File::Basename;
- # use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
- # use Date::Parse; # For str2time
- use Time::Local; # For timelocal
- use LWP::Simple; # For pgms like set_clock that need to grab data from urls
- use Net::FTP; # For uploading stuff
- # use Data::Dumper qw(Dumper DumperX);
- 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";
- }
- use IO::Socket;
- &my_use("DB_File"); # Need by get_tv_grid
- use Fcntl; # To enable O_RDWR|O_CREAT
- # use MIME::Base64; # Needed for uudecode/uuencode in http_server and mhsend_server
- use Timer; # This needs to be first, as it is used in Voice_Cmd (and elsewhere?)
- use File_Item;
- use Generic_Item;
- use Group;
- use IR_Item;
- # &my_use("Serial_Item"); # So we can add debug to Serial_Item.pm when running mh.exe
- use Serial_Item;
- use X10_Items;
- use iButton;
- use Hardware::iButton::Connection;
- use Socket_Item;
- use Process_Item;
- use Voice_Cmd;
- use Voice_Text;
- use Caller_ID;
- use Astro::MoonPhase;
- use Astro::SunTime;
- use Text::Wrap;
- use constant; # To keep perl2exe happy
- use constant ON => 'on';
- use constant OFF => 'off';
- use constant STATUS => 'status';
- use constant OPEN => 'open';
- use constant CLOSE => 'close';
- use constant OPENED => 'opened';
- use constant CLOSED => 'closed';
- require 'handy_net_utilities.pl'; # For misc. net functions (e.g. net_mail_read)
- require 'console_utils.pl';
- require 'http_server.pl';
- if ($OS_win) {
- # These are the modules that perl2exe can not find on its own
- # Note: tk windows starts faster in mh.exe if we run this,
- # even though they are included with the perl2exe_include!
- # require 'mh_perl2exe_list.pl';
- #perl2exe_include mh_perl2exe_list.pl
- no strict 'subs'; # For non-win OS
- if (1) {
- $CON_IN = new Win32::Console STD_INPUT_HANDLE;
- $CON_OUT= new Win32::Console STD_OUTPUT_HANDLE;
- $CON_OUT->Title("Mister House");
- # use vars '$FG_WHITE', '$BG_CYAN';
- # &explodeAttr($CON_OUT, $FG_WHITE | $BG_CYAN);
- # $CON_OUT->Attr($FG_WHITE | $BG_CYAN);
- }
- }
-
- $SIG{INT} = \&sig_handler; # Exit cleanly with CTL-C
- $SIG{BREAK} = \&sig_handler if $OS_win; # Exit cleanly with BREAK
- $SIG{KILL} = \&sig_handler; # Exit cleanly with a kill signal
- $SIG{HUP} = \&read_code if !$OS_win; # Reload code (alias mhreload per info in mh.ini file)
- $SIG{PIPE} = \&sig_handler_pipe; # Web browsers can shut down sockets while we are sending data
- $SIG{CHLD} = 'IGNORE'; # So we don't create zombies when forking
-
- $config_parms{code_dir} = $Pgm_PathU . "/../code" unless $config_parms{code_dir};
- # Make various directories, if missing
- mkdir ("$config_parms{data_dir}/logs", 0777) unless -d "$config_parms{data_dir}/logs";
- mkdir ("$config_parms{data_dir}/web", 0777) unless -d "$config_parms{data_dir}/web";
- mkdir ("$config_parms{html_dir}/tv", 0777) unless -d "$config_parms{html_dir}/tv";
- mkdir ("$config_parms{html_dir}/tv/clicktv", 0777) unless -d "$config_parms{html_dir}/tv/clicktv";
- open(ERROR_LOG, ">>$config_parms{code_dir}/mh_temp.error_log") or
- print "Error, could not open error log $config_parms{code_dir}/-error_log-: $!\n";
- &add_hook_code;
- # print "parms=", join(":", %config_parms), "\n";
- if ($config_parms{voice_cmd}) {
- &Voice_Cmd::init;
- }
- if ($config_parms{voice_text}) {
- &Voice_Text::init;
- }
- # Find all defined socket and serial ports
- for my $parm (keys %config_parms) {
- next unless $config_parms{$parm}; # Ingore blank parms
- push(@Server_Ports, $1) if $parm =~ /(http)_port/;
- push(@Server_Ports, $1) if $parm =~ /(server\S+)_port/;
- push(@Generic_Serial_Ports, $1) if $parm =~ /(serial\S+)_port/;
- }
- # print "Server ports defined: @Server_Ports\n" if @Server_Ports;
- # print "Generic serial ports defined: @Generic_Serial_Ports\n" if @Generic_Serial_Ports;
- # print "Creating socket server ports: @Server_Ports\n" if @Server_Ports;
- print "Creating socket and serial objects\n";
- for my $port_name (@Server_Ports) {
- my $port = $config_parms{$port_name . "_port"};
- my $proto = $config_parms{$port_name . "_protocol"};
- my $datatype = $config_parms{$port_name . "_datatype"};
- $proto = 'tcp' unless $proto;
- $datatype = 'buffered' if $port_name eq 'http';
- $datatype = 'buffered' if $config_parms{$port_name . "_buffer"}; # Grandfathered syntax
- $datatype = '' unless $datatype;
- printf " - creating %-15s on %3s %5s %s\n", $port_name, $proto, $port, $datatype;
- $Socket_Ports{$port_name}{protocol} = $proto;
- $Socket_Ports{$port_name}{datatype} = $datatype;
- if ($proto eq 'tcp') {
- $Socket_Ports{$port_name}{sock} = new IO::Socket::INET->new(LocalPort => $port, Proto => 'tcp', Reuse => 1, Listen => 10) or
- die "Couldn't start a tcp server on $port_name $port: $@\nTo get mh to run, blank out or change the ${port}_port in mh.ini\n";
- } elsif ($proto eq 'udp') {
- $Socket_Ports{$port_name}{sock} = new IO::Socket::INET->new(LocalPort => $port, Proto => 'udp') or
- die "Couldn't start a udp server on $port_name $port: $@\n";
- $Socket_Ports{$port_name}{socka} = $Socket_Ports{$port_name}{sock}; # UDP ports are always "active"
- } else {
- die "Unknown protocol for $port_name \n";
- }
- }
-
- for my $port_name (@Generic_Serial_Ports) {
- &serial_port_create($port_name, $config_parms{$port_name . "_port"},
- $config_parms{$port_name . "_baudrate"},
- $config_parms{$port_name . "_handshake"},
- $config_parms{$port_name . "_datatype"});
- }
- # Create managed serial and server ports
- # This makes it easy to add new modules
- # for new serial/socket devices.
- # Manager must be available in lib directory
- # (e.g. Compool.pm)
- for my $parm (keys %config_parms) {
- next unless $config_parms{$parm};
- if ($parm =~ /^(\S+)_(serial|server)_port/) {
- if (-e "$Pgm_PathU/../lib/$1.pm") {
- print "Found managed $2 port=$1\nMH will now require $1.pm and call $1::$2_startup($parm)\n"
- if $config_parms{debug} eq 'startup';
- require "$1.pm";
- eval "&$1::$2_startup('$parm')";
- print "Startup errror on &$1::$2_startup('$parm'): $@\n" if $@;
- }
- else {
- print "No $1.pm file found for $parm\n";
- }
- }
- }
- if ($config_parms{weeder_port}) {
- $config_parms{weeder_baudrate} = 1200 unless $config_parms{weeder_baudrate};
- &serial_port_create('weeder', $config_parms{weeder_port}, $config_parms{weeder_baudrate}, 'dtr');
- $Serial_Ports{weeder}{process_data} = 1;
- }
- if ($config_parms{cm11_port}) {
- require 'ControlX10/CM11.pm';
- &serial_port_create('cm11', $config_parms{cm11_port}, 4800, 'none');
- }
- if ($config_parms{Homevision_port}) {
- require 'Homevision.pm';
- my($speed) = $config_parms{Homevision_baudrate} || 9600;
- if (&serial_port_create('Homevision', $config_parms{Homevision_port}, $speed, 'none')) {
- &Homevision::init($Serial_Ports{Homevision}{object}); # Turn on Echo mode
- }
- }
- if ($config_parms{Marrick_port}) {
- require 'Marrick.pm';
- my($speed) = $config_parms{Marrick_baudrate} || 9600;
- if (&serial_port_create('Marrick', $config_parms{Marrick_port}, $speed, 'none')) {
- &Marrick::init($Serial_Ports{Marrick}{object});
- }
- }
- if ($config_parms{HomeBase_port}) {
- require 'HomeBase.pm';
- my($speed) = $config_parms{HomeBase_baudrate} || 9600;
- if (&serial_port_create('HomeBase', $config_parms{HomeBase_port}, $speed, 'none')) {
- &HomeBase::init($Serial_Ports{HomeBase}{object}); # Turn on Echo mode
- }
- }
- if ($config_parms{ncpuxa_port}) {
- require 'ncpuxa_mh.pm';
- &ncpuxa_mh::init($config_parms{ncpuxa_port}); # Create socket connection
- }
- if ($config_parms{ibutton_port}) {
- &my_use("Hardware::iButton::Connection;");
- &iButton::connect($config_parms{ibutton_port});
- }
- # Do this one last, as it can share a serial port.
- if ($config_parms{cm17_port}) {
- require 'ControlX10/CM17.pm';
- &serial_port_create('cm17', $config_parms{cm17_port});
- }
- if($config_parms{weather_sblog_file} or
- $config_parms{weather_vwlog_file} or
- $config_parms{serial_wx200}) {
- require 'Weather.pm';
- &Weather_Data::Init();
- }
- if ($OS_win) {
- $Time_Boot_time = 0; # Gettickcount starts at computer boot
- }
- elsif ($^O eq 'linux') {
- # Linux output:
- # uptime: 2 hours 10:38pm up 2:10, 6 users, load average: 0.83, 0.45, 0.18
- # /proc/stat: cpu 10339 0
- # /proc/pid/stat: 732 (ghx2) S 565 732 376 1025 561 256 529 0 1194 0 142 35 0 0 0 0 0 0 499881 6688768 905 2147483647 134512640 134754096 3221224640 3221223956 1075917534 0 0 69632 17479 3222448608 0 0 17
- # Not sure if 1st number
- open(UPTIME, "/proc/uptime") or print "\nError: can't open /proc/uptime ($!)\n";
- my ($uptime, $idletime) = (<UPTIME> =~ /(\S+) (\S+)/);
- close UPTIME;
- $Time_Boot_time = time - $uptime;
- }
- $exit_flag = 0;
- $config_parms{sleep_time} = 50 unless defined $config_parms{sleep_time};
- $Loop_Sleep_Time = $config_parms{sleep_time};
- $config_parms{tk_passes} = 10 unless $config_parms{tk_passes};
- $config_parms{tk_font} = 'Times 10 bold' unless $config_parms{tk_font};
- $config_parms{tk_font_fixed} = 'Courier 10 bold' unless $config_parms{tk_font_fixed};
- $Loop_Tk_Passes = $config_parms{tk_passes};
- $Time = time;
- ($Second, $Minute, $Hour, $Mday, $Month, $Year) = localtime $Time; # Needed in my_str2time;
- $Time_Date = &time_date_stamp($config_parms{time_format_log} , $Time); # Needed by print_log
- $Month++;
- # Configure 'fast test mode' parms
- $Time_Increment = ($config_parms{time_increment}) ? $config_parms{time_increment} : 60;
- if ($config_parms{time_start} =~ /\S/) {
- $Loop_Sleep_Time = 0;
- $Loop_Tk_Passes = 1;
- $Time_Start_time = &my_str2time($config_parms{time_start});
- $Time = $Time_Start_time - $Time_Increment; # Cause we start the loop with an increment
- print "time_start=$config_parms{time_start} -> $Time_Start_time \n";
- }
- if ($config_parms{time_stop} =~ /\S/) {
- $Loop_Sleep_Time = 0;
- $Loop_Tk_Passes = 1;
- $Time_Stop_time = &my_str2time($config_parms{time_stop});
- $Time_Stop_time += 3600*24 if $Time_Stop_time < $Time_Start_time;
- print "time_stop =$config_parms{time_stop} -> $Time_Stop_time \n";
- }
- $Time_Startup_time = $Time;
- $Time_Startup = &time_date_stamp(9, $Time_Startup_time);
- $Startup = 1;
- if ($config_parms{pid_file}) {
- print "Process id $$ written to $config_parms{pid_file}\n";
- &file_write($config_parms{pid_file}, $$);
- }
- if ($config_parms{tk}) {
- &tk_setup_windows;
- }
- # $xcmd_file = "$config_parms{temp_dir}/house_cmd.cmd" if $config_parms{xcmd_file};
- # print "X command file: $config_parms{xcmd_file}\n" if $config_parms{xcmd_file};
- # Use eval to change $ENV{temp} to the real value ... this is done in read_opts now
- # eval "\$config_parms{xcmd_file} = qq[$config_parms{xcmd_file}]";
- print "External command file (xcmd_file): $config_parms{xcmd_file}\n" if $config_parms{xcmd_file};
- $config_parms{html_dir} = $config_parms{html_root} if $config_parms{html_root}; # Grandfather in the old name for this parm
- print "HTML file : $config_parms{html_dir}/$config_parms{html_file}\n";
- print "\nError, HTML file not found: $config_parms{html_dir}/$config_parms{html_file}\n\n" unless -e "$config_parms{html_dir}/$config_parms{html_file}";
- @Requested_Files = @ARGV;
-
- &password_read;
- srand(time() ^ ($$ + ($$ << 15)) ); # Set the randum number seed, used in time_random;
- $config_parms{max_log_entries} = 50 unless defined $config_parms{max_log_entries};
- $config_parms{max_state_log_entries} = 10 unless defined $config_parms{max_state_log_entries};
- $config_parms{time_format_log} = 12 unless $config_parms{time_format_log};
- print "Done with setup\n\n";
- }
- # The remaining subroutines are in alphabetical order
- # This code allows us to add dynamic user code hooks at various places.
- my (%hook_pointers, %hook_pointers_persistent, %hook_locations);
- sub add_hook_code {
- %hook_locations = ( MainLoop_pre => 1, MainLoop_post => 1,
- Serial_match => 1,
- Play_pre => 1, Play_post => 1,
- Speak_pre => 1, Speak_post => 1
- );
- for my $location (keys %hook_locations){
- my($accessors) = "
- sub ${location}_add_hook { return add_hook_ ( '$location', \@_ ) }
- sub ${location}_drop_hook { return drop_hook_( '$location', \@_ ) }
- sub ${location}_get_hooks { return get_hooks_( '$location' ) }
- sub ${location}_hooks { return run_hooks_( '$location', \@_ ) }
- ";
- eval $accessors;
- die "Eval error $@\n" if $@;
- }
- sub add_hook_ {
- my($location, $hook, $persistent) = @_;
-
- unless( defined( $hook_locations{$location} ) ){
- warn "Invalid hook location $location\n";
- return 0;
- }
-
- unless( ref $hook eq 'CODE' ){
- warn "Hook must be a code reference\n";
- return 0;
- }
-
- $hook_pointers{$location} = [] unless defined ($hook_pointers{$location});
-
- push( @{$hook_pointers{$location}}, $hook );
- push( @{$hook_pointers_persistent{$location}}, $hook ) if $persistent;
-
- return 1;
- }
- sub drop_hook_ {
- my($location, $hook ) = @_;
-
- unless( defined( $hook_locations{$location} ) ){
- warn "Invalid hook location $location\n";
- return 0;
- }
-
- if( defined ($hook_pointers{$location}) ){
- my($h)=$hook_pointers{$location};
- my($i)=-1;
-
- for ( $i=$#{$h}; $i >= 0; $i-- ) {
- last if ($hook == $h->[$i] );
- }
- # delete if the index returned is in range
- if ($i >=0 and $i <= $#{$h} ){
- splice( @{$h}, $i, 1 );
- return 1;
- }
- }
-
- warn "specified hook not found: $location\n";
- return 0;
- }
- sub get_hooks_ {
- my($location) = @_;
- return defined $hook_pointers{$location} ? @{$hook_pointers{$location}} : ();
- }
- # call all hooks with user specified args, if any
- sub run_hooks_ {
- # my($location) = @_;
- my $location = shift @_;
- for my $hook (&get_hooks_($location)){
- &$hook(@_); # Pass parms to hook
- }
- }
- # This will keep hook code defined with the persistent
- # flag (e.g. module code that is defined on startup).
- # All other user code is undefed.
- sub reset_hook_code {
- for my $location (keys %hook_locations) {
- if ($hook_pointers_persistent{$location}) {
- @{$hook_pointers{$location}} = @{$hook_pointers_persistent{$location}};
- }
- else {
- delete $hook_pointers{$location};
- }
- }
- }
- }
- sub browser {
- my ($file) = @_;
- # Don't need this ... run look at search path
- # unless (-f $config_parms{browser} or lc($config_parms{browser}) eq 'explorer') {
- # &print_log("Could not find html browser file: $config_parms{browser}");
- # return;
- # }
- # Translate unix/perl / to dos \
- $file =~ s|/|\\|g if $OS_win and $file !~ /^http/i;
- run "$config_parms{browser} $file";
- }
- my ($loop_tickcount1, $loop_tickcount_total);
- sub check_for_action {
- &exit_pgm if $exit_flag;
- my $loop_tickcount1 = &get_tickcount;
- # Do window loop here, to check for pause mode exit
- if ($MW) {
- $Loop_Tk_Passes = 100 if $Loop_Tk_Passes >100; # Make sure we don't have too many passes
- $Loop_Tk_Passes = 1 if $Loop_Tk_Passes < 1; # Make sure we make at least one pass
- for (1 .. $Loop_Tk_Passes) {
- my $tk_activity;
- $tk_activity = DoOneEvent(0xFF); # Avoid Constants ... we get compile errors if -tk 0
- # $tk_activity = DoOneEvent(DONT_WAIT | ALL_EVENTS);
- # $tk_activity = DoOneEvent(0x1E);
- # $tk_activity = DoOneEvent(0x02);
- }
- }
- &check_for_keyboard_input;
- return if $pause_mode;
- &set_global_vars;
- &Process_Item::harvest; # Check for done processes
- &Generic_Item::reset_states; # Reset states for all objects that are 'ISA Item' objects
- &Voice_Cmd::check_for_voice_cmd; # Do this even if VR is not installed, so we can do web and manual run_voice_cmd
- &check_for_serial_data if %Serial_Ports;
- &check_for_socket_data if %Socket_Ports;
- &check_for_timer_actions;
- &check_for_external_command_file;
- &MainLoop_pre_hooks(); # Created by &add_hooks
- # Use eval to catch minor errors without abending
- # - about 10% slower (170 -> 150)
- &eval_user_code_loop;
- # &loop_code;
- &MainLoop_post_hooks(); # Created by &add_hooks
- # Do the tk_setup_cascade_menus AFTER the first eval code, so we can test Tk widget objects
- if ($MW) {
- &tk_setup_cascade_menus if $Reload;
- &tk_setup_geometry if $Reread;
- }
- $loop_tickcount_total += &get_tickcount - $loop_tickcount1;
- if ($Reread) {
- $Startup = 0; $Reload = 0; $Reread = 0;
- }
- }
- sub check_for_cm11_data {
- my $data = &ControlX10::CM11::read($Serial_Ports{cm11}{object}, 1);
- return unless $data;
- my $data_d = unpack('C', $data); # Convert from string to decimal
- # Check for the official 0x5a=90 string and 0xa5=165 (I have seen this!)
- print "mh CM11 data=$data data_d=$data_d\n" if $config_parms{debug} eq 'X10' and $data;
- # if ($data_d == 0x5a) {
- if ($data_d == 0x5a or $data_d == 0xa5) {
- if ($data = &ControlX10::CM11::receive_buffer($Serial_Ports{cm11}{object})) {
- # Process status requests
- if ($data =~ /STATUS/) {
- my ($house, $device, $state) = $data =~ /(\S)(\S)STATUS_(\S+)/;
- $state = 'J' if $state eq 'ON';
- $state = 'K' if $state eq 'OFF';
- my $event_data = 'X' . $house . $device . $house . $state;
- if (my @refs = &Serial_Item::serial_items_by_id($event_data)) {
- for my $ref (@refs) {
- if ($state = $$ref{state_by_id}{$event_data}) {
- # set_receive $ref $state;
- $ref->{state} = $state;
- print "CM11 Status results: data=$data event_data=$event_data state=$state\n"
- if $config_parms{debug} eq 'X10';
- }
- }
- }
- else {
- &print_log("Status request on undefined state: data=$data event_data=$event_data");
- }
- }
- else {
- &process_serial_data("X" . $data);
- }
- }
- }
- }
- sub check_for_external_command_file {
- my ($cmd, $cmd_num, $ref, $said);
- my $xcmd_file = $config_parms{xcmd_file};
- # Checking for a file is pretty slow ...
- return unless $New_Second;
- # Note: Check for non-zero size, not -e. Zero length files cause a loop!
- if ($xcmd_file and -s $xcmd_file) {
- &print_log("External command file found: $xcmd_file");
- unless (open(XCMD, $xcmd_file)) {
- print "\nWarning, can not open file $xcmd_file: $!\n";
- return;
- }
- $cmd = <XCMD>;
- chomp($cmd);
- close XCMD;
- next unless $cmd;
- unlink $xcmd_file;
- &process_external_command($cmd, 1);
- }
- }
- sub check_for_generic_serial_data {
- my ($port_name) = @_;
- my $data;
- unless ($data = $Serial_Ports{$port_name}{object}->input) {
- # If we do not do this, we may get endless error messages.
- $Serial_Ports{$port_name}{object}->reset_error;
- }
- $Serial_Ports{$port_name}{data} .= $data if $data;
- print " serial name=$port_name type=$Serial_Ports{$port_name}{datatype} data2=$Serial_Ports{$port_name}{data}...\n"
- if $data and ($config_parms{debug} eq 'serial' or $config_parms{debug} eq $port_name);
- # Check to see if we have a carrage return yet
- if ($Serial_Ports{$port_name}{data} and
- (!defined $Serial_Ports{$port_name}{datatype} or $Serial_Ports{$port_name}{datatype} ne 'raw')) {
- while (my($record, $remainder) = $Serial_Ports{$port_name}{data} =~ /(.+?)[\r\n]+(.*)/s) {
- &print_log("Data from $port_name: $record. remainder=$remainder.") if $config_parms{debug} eq 'serial';
- $Serial_Ports{$port_name}{data_record} = $record;
- $Serial_Ports{$port_name}{data} = $remainder;
- if ($Serial_Ports{$port_name}{process_data}) {
- &process_serial_data($record);
- }
- else {
- last; # Only process one data_record per user_code loop
- }
- }
- }
- }
- sub check_for_Homevision_data {
- my $data = &Homevision::read($Serial_Ports{Homevision}{object});
- if ($data) {
- print "Homevision data=$data\n" if $config_parms{debug} =~ /homevision|serial/i;
- &process_serial_data($data);
- }
- }
- sub check_for_HomeBase_data {
- my $data = &HomeBase::read($Serial_Ports{HomeBase}{object});
- if ($data) {
- print "HomeBase x10 data=$data\n" if $config_parms{debug} eq 'homebase';
- &process_serial_data("X" . $data);
- }
- }
- sub check_for_keyboard_input {
- my $key;
- # return; # Console off for now.
- # Need to find a way to do this in Linux
- return unless $OS_win;
- for(0..$CON_IN->GetEvents()-1) {
- # Event data: 1, keyup_down, key_repeat_count, id1, id2, id3, id4
- # id1 seems to cover all the keys (e.g. 112 is F1, a=65, A=65)
- # id2 seems to be keyboard positional (e.g. a=30, s=31)
- # id3 seems to be ascii (a=97, A=65)
- my @event = $CON_IN->Input();
- $key = $event[3] if $event[1];
- }
- return unless $key;
- my %keymap = ('F1: Reload' => 'F1', 'F2: Pause' => 'F2', 'F3: Exit' => 'F3',
- 'F4: Debug' => 'F4', 'F5: Logging' => 'F5',
- 112 => 'F1', 113 => 'F2', 114 => 'F3',
- 115 => 'F4', 116 => 'F5');
- if ($key == 13) { # Enter Key -> display simple menu
- my ($oldX, $oldY, $oldS, $oldV) = $CON_OUT->Cursor();
- my $oldmode = $CON_IN->Mode();
- my $choice = &choose_menu($CON_IN, $CON_OUT,
- "F1: Reload", "F2: Pause", "F3: Exit",
- "F4: Debug", "F5: Logging");
- $CON_IN->Mode($oldmode);
- $CON_OUT->Cursor($oldX, $oldY, $oldS, $oldV);
- $key = $keymap{$choice};
- print "action=$choice key=$key\n";
- }
- else {
- $key = $keymap{$key} if $keymap{$key};
- }
-
- if ($key eq 'F1') {
- print "Key F1 pressed. Reloading code\n";
- read_code();
- }
- elsif ($key eq 'F2') {
- print "Key F2 pressed.\n";
- &pause;
- }
- elsif ($key eq 'F3') {
- print "Key F3 pressed. Exiting\n";
- &exit_pgm;
- }
- elsif ($key eq 'F4') {
- &toggle_debug;
- }
- elsif ($key eq 'F5') {
- &toggle_log;
- }
- elsif ($key) {
- print "key press: $key\n" if $config_parms{debug} eq 'misc';
- }
- }
- sub toggle_debug {
- $config_parms{debug} = ($config_parms{debug}) ? 0 : 1;
- my $state = ($config_parms{debug}) ? 'on' : 'off';
- print "Key F4 pressed. Debug turned $state.\n";
- }
- sub toggle_log {
- $config_parms{log} = ($config_parms{log}) ? 0 : 1;
- my ($state, $logfile);
- if ($config_parms{log}) {
- $state = 'on';
- $logfile = $config_parms{log_file};
- $logfile = 'mh_log.txt' unless $logfile;
- print "Key F5 pressed. Output will be logged into $logfile\n";
- open(OLDOUT, ">&STDOUT"); # Copy old handle
- open(OLDERR, ">&STDERR"); # Copy old handle
- open STDOUT, ">>$logfile" or print "\nError, could not open logfile $logfile: $!\n";
- $| = 1; # Turn on command buffering (e.g. flush on every print)
- open(STDERR, ">&STDOUT");
- }
- else {
- $state = 'off';
- print "Key F5 pressed. Output will no longer be logged to $logfile\n";
- close STDOUT;
- open(STDERR, ">&OLDERR");
- open(STDOUT, ">&OLDOUT");
- close OLDOUT;
- close OLDERR;
- print "STDOUT has been restored\n";
- }
- }
- my @serial_data_buffer;
- sub check_for_serial_data {
- # Process remaining serial items from previous pass
- if (my $data = shift @serial_data_buffer) {
- print "Running serial_data_buffer string: $data\n" if $config_parms{debug} eq 'X10';
- &process_serial_data($data, 1);
- return;
- }
- &check_for_cm11_data if $Serial_Ports{cm11}{object};
- &check_for_Homevision_data if $Serial_Ports{Homevision}{object};
- &check_for_HomeBase_data if $Serial_Ports{HomeBase}{object};
- &check_for_generic_serial_data('weeder') if $Serial_Ports{weeder}{object};
- for my $port_name (@Generic_Serial_Ports) {
- &check_for_generic_serial_data($port_name) if $Serial_Ports{$port_name}{object};
- }
- # Leave this under user control?
- # &iButton::monitor if $config_parms{ibutton_port} and if $New_Second;
- }
- my ($leave_socket_open_passes, $leave_socket_open_action);
- sub check_for_socket_data {
- # Time to finish the http GET from 2 passes ago with a list of spoken data
- if ($leave_socket_open_passes and --$leave_socket_open_passes == 0 and my $sock = $Socket_Ports{http}{socka}) {
- print "closing http port with action: $leave_socket_open_action\n" if $config_parms{debug} eq 'http';
- my $html = &html_page("", eval($leave_socket_open_action));
- print "Error in http lso action: $@\n" if $@;
- print $sock $html;
- &socket_close('http');
- }
- my (@ports_with_data, @active_ports);
- # See which ports are active
- # - could probably use a smarter select check here, rather than loop for each port
- for my $port_name (keys %Socket_Ports) {
- next unless my $sock = $Socket_Ports{$port_name}{sock};
- $Socket_Ports{$port_name}{inactive_this_pass} = 0;
- if ($Socket_Ports{$port_name}{socka}) {
- push(@active_ports, $port_name);
- $Socket_Ports{$port_name}{active_this_pass} = 0;
- }
- else {
- if (my $nfound = &socket_has_data($sock)) {
- my $new_sock = $sock->accept();
- next unless $new_sock; # Can be undef it socket was killed
- $new_sock->autoflush(1); # Not sure if this does anything?
- $Socket_Ports{$port_name}{socka} = $new_sock;
- $Socket_Ports{$port_name}{active_this_pass} = 1;
- delete $Socket_Ports{$port_name}{data}; # Delete data from previous session
- push(@active_ports, $port_name);
- # Log the address of the client
- my $peer = $new_sock->peername;
- my ($port, $iaddr) = unpack_sockaddr_in($peer) if $peer;
- my $client_ip_address = inet_ntoa($iaddr) if $iaddr;
- $Socket_Ports{$port_name}{client_ip_address} = $client_ip_address;
- logit("$config_parms{data_dir}/logs/server.$Year_Month_Now.log", "$port_name $client_ip_address");
- print "\n$port_name active sock=$new_sock client=$client_ip_address.\n" if $config_parms{debug} eq $port_name;
- }
- }
- }
- # See if any active ports have data ... this could be rolled into previous loop
- for my $port_name (@active_ports) {
- my $sock = $Socket_Ports{$port_name}{socka};
- if (my $nfound = &socket_has_data($sock)) {
- print "\n$port_name nfound=$nfound\n" if $config_parms{debug} eq $port_name;
- if ($nfound < 0) {
- # Note, must do a shutdown here ... a close does not close handles
- # from &run (system start) processes !?! ... maybe IO sockets do not need this?
- # Not sure how to shutdown IO handles ... this gives 'bad symbol on filehandle' error
- # shutdown($sock->fileno(), 2); # "how": 0=no more receives, 1=sends, 2=both
- print "1 closing socket port $port_name\n" if $config_parms{debug} eq $port_name;
- &socket_close($port_name);
- }
- else {
- push(@ports_with_data, $port_name);
- }
- }
- }
- # Get data from active ports
- for my $port_name (@ports_with_data) {
- my $sock = $Socket_Ports{$port_name}{socka};
-
- my $data;
- # Buffered mode means only read one line per pass
- # - This allows user code the option of reading port with <>
- # - Assumes clients will send a line at a time, so will not block
- if ($Socket_Ports{$port_name}{datatype} and $Socket_Ports{$port_name}{datatype} eq 'buffered') {
- $data = <$sock>;
- }
- else {
- # 1500 is ethernet packet size
- my $from_saddr = recv($sock, $data, 1500, 0);
- # Store udp from_* data
- if ($Socket_Ports{$port_name}{protocol} and $Socket_Ports{$port_name}{protocol} eq 'udp') {
- (my $from_port, my $from_ip) = sockaddr_in($from_saddr);
- $Socket_Ports{$port_name}{from_port} = $from_port;
- $Socket_Ports{$port_name}{from_ip} = $from_ip;
- }
- }
- print "\n sock=$sock lso=$leave_socket_open_passes data=$data.\n" if $config_parms{debug} eq $port_name;
- # Need to do this or the socket never closes!
- # For some reason, nfound = 1 (instead of -1) unless we do this.
- # In other words, a telnet disconnect will leave nfound=1, but no data.
- # When telnet closes, byte IS defined, but is empty, so check on ''
- if (!defined $data or $data eq '') {
- print "closing socket port $port_name\n" if $config_parms{debug} eq $port_name;
- &socket_close($port_name);
- }
- # If raw mode, return data as is
- if ($Socket_Ports{$port_name}{datatype} and $Socket_Ports{$port_name}{datatype} eq 'raw') {
- $Socket_Ports{$port_name}{data_record} = $data; # No not break data on newlines
- next;
- }
- if (my $echo = $config_parms{"${port_name}_echo"}) {
- # Need to loop thru $data here, one byte at a time
- my $byte = $data;
- # bs = 8, del=127
- my $char = unpack('C', $byte);
- # Allow us to pick our echo character (e.g. '*')
- $byte = $echo unless $echo == 1 or $char eq 8;
- next if $char eq 8;
- print $sock $byte unless $char eq 13 or $char eq 10;
- }
- $Socket_Ports{$port_name}{data} .= $data if defined $data;
- print "$port_name data=$Socket_Ports{$port_name}{data}..\n" if $config_parms{debug} eq $port_name;
-
- # Break data on newlines
- next unless $Socket_Ports{$port_name}{data};
- while (my($record, $remainder) = $Socket_Ports{$port_name}{data} =~ /(.+?)[\r\n]+(.*)/) {
- if ($config_parms{debug} eq $port_name) {
- print "$port_name record=$record. hex=", unpack('H*', $record), "\n";
- print "$port_name remainder=$remainder. hex=", unpack('H*', $remainder), "\n";
- }
- $Socket_Ports{$port_name}{data_record} = $record;
- $Socket_Ports{$port_name}{data} = $remainder;
-
- if ($port_name eq 'http') {
- if ($record =~ /^ *GET /) {
- ($leave_socket_open_passes, $leave_socket_open_action) = &process_http_request($sock, $record);
- print "db lso=$leave_socket_open_passes sock=$sock.\n" if $config_parms{debug} eq $port_name;
- unless ($leave_socket_open_passes) {
- print "4 closing socket port $port_name\n" if $config_parms{debug} eq $port_name;
- # We must sleep here for a bit, or else Netscape sometimes
- # says 'Document contains no data'.
- select undef, undef, undef, .010;
- &socket_close($port_name);
- }
- }
- else {
- # Do nothing with non-GET http requests
- # print $sock ">$record";
- }
- }
- else {
- # 10/99 Comment out \r\n print ... what needed this?? Messed up viavoice server
- # print $sock "\r\n";
- # print $sock "You said: $record\n";
- # non-raw, non-http socket data is usually read by 'said' Socket_Item methods
- # - only 1 per pass, since 'said' only reads one data_record per pass
- last;
- }
- }
- }
- }
- # This is called by mh/lib/Generic_Item.pm
- # - it fires tied items/events
- sub check_for_tied_events {
- my @objects = @_;
- for my $object1 (@objects) {
- # my $state1 = lc $object1 -> state;
- my $state1 = $object1 -> state;
- print "Object link: starting enumeration for object=$object1 state=$state1\n" if $config_parms{debug} eq '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}) {
- my ($object2, $state2) = @{$$object1{tied_objects}{$key}{$state_key}};
- $state2 = $state1 unless defined $state2;
- print "Object link: Setting $object2 to $state2\n" if $config_parms{debug} eq 'events';
- if ($object2->can('set')) {
- $object2->set($state2);
- # $object2->{changed_by} = $object1->{object_name};
- $object2->{changed_by} = $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 ($$object1{tied_events}{$event}{$state_key}) {
- print "Event link: eval event=$event\n" if $config_parms{debug} eq 'events';
- my $state = $state1; # So eval can substitue $state
- my $object=$object1;
- eval $event;
- print "tie_events eval error: $@" if $@;
- }
- }
- }
- }
- sub check_for_timer_actions {
- my ($ref);
- for $ref (&Timer::expired_timers_with_actions) {
- # Use this method avoids problems with Timer is called from X10_Items
- &Timer::run_action($ref);
- # run_action $ref;
- }
- }
- sub convert_k2f { # Convert degrees Kelvin to Farenheight
- sprintf("%3.1f", 32 + (9/5)*($_[0] - 273.15));
- }
- sub convert_c2f { # Convert degrees Kelvin to Farenheight
- sprintf("%3.1f", 32 + (9/5)*($_[0]));
- }
- sub convert_direction {
- my ($dir) = @_;
- if ($dir < 30 or $dir >= 330) {
- return "north";
- }
- elsif ($dir < 60) {
- return "north east";
- }
- elsif ($dir < 120) {
- return "east";
- }
- elsif ($dir < 150) {
- return "south east";
- }
- elsif ($dir < 210) {
- return "south";
- }
- elsif ($dir < 240) {
- return "south west";
- }
- elsif ($dir < 300) {
- return "west";
- }
- elsif ($dir < 330) {
- return "north west";
- }
- else {
- return "outer space";
- }
- }
- sub display {
- # If it is a file, read it
- my $text = $_[0];
- if ($text =~ /^\S+$/ 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};
- # Assume we were waiting for this and reset http server counter so almost 0
- $Last_Response = 'display';
- $leave_socket_open_passes= 2 if $leave_socket_open_passes;
- # Unless this was called from the web, display it with tk
- if ($config_parms{tk}) {
- $_[3] = $config_parms{tk_font} unless $_[3];
- new Display(@_) unless $leave_socket_open_passes;
- }
- else {
- # &print_log(@_);
- print "display call with -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("Evaluating 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_Now Opps1: $_[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:\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
- 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 to loop on accidental exit
- }
- }
- my $usercode_error_flag;
- sub eval_user_code_loop {
- # Dis-regard -w uninitialzed value warnings.
- local $SIG{__WARN__} = sub {
- return if $_[0] =~ /uninitialized value/ or $_[0] =~ /redefined at/;
- print "\n$Time_Now Opps2: $_[0]\n";
- # play('file' => $config_parms{sound_error});
- };
- eval "&loop_code";
- if ($@) {
- # Display usercode errors only once
- if ($usercode_error_flag) {
- print "Error in user code: $@";
- }
- else {
- $usercode_error_flag++;
- my $error = &eval_user_code_error($@, $user_code);
- print $error;
- &display($error, 0) unless !$config_parms{tk};
- &speak("Error found in user code. Check the error log.");
- # Log these errors for review
- print ERROR_LOG (&time_date_stamp(1), $Time)[0], ":\n $error\n";
- print "Error logged to: $config_parms{code_dir}/mh_temp.error_log\n";
- }
- }
- }
- 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
- &Serial_Item::reset; # So we can check for duplicate items
- &Voice_Cmd::reset; # So we can check for duplicate voice commands.
- &reset_hook_code; # This frees up old user code hooks
- }
- sub exit_pgm {
- print "Exiting program\n";
- &Voice_Cmd::remove_voice_cmds if $config_parms{voice_cmd};
- &run_kill_processes; # From handy_utilities ... kills anybody that isn't done yet
- &Process_Item::stop;
- &object_states_save;
- print "Bye bye\n";
- # Use exit code 1 to mean we exited on purpose ... anything else
- exit 1; # we can use in mh_loop to mean accidental exit, 'better restart'
- }
- sub file_changed {
- my ($file) = @_;
- my ($file_time);
- $file_time = (stat($file))[9];
- 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";
- # 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 $config_parms{debug} eq 'misc';
- return 1;
- }
- 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");
- }
- 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 :(
- # use Sys::Hostname;
- # $hostname = hostname() unless $hostname;
- 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 $config_parms{debug} eq '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) = @_;
- return $objects_by_object_name{$object_name};
- }
- sub help {
- &browser("$Pgm_Path/../docs/mh.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;
- }
- sub list_code_files {
- return sort {lc($a) cmp lc($b)} keys %object_names_by_file; # Case insensitive sort
- }
- sub list_code_webnames {
- my @a = keys %object_names_by_webname;
- return sort {lc($a) cmp lc($b)} keys %object_names_by_webname; # Case insensitive sort
- }
- 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_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_webname {
- 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);
- }
- }
- sub monitor_commands {
- print "Starting monitor commands loop\n\n";
- while (1) {
- # print '-' if $config_parms{debug};
- &check_for_action;
- next unless $Loop_Sleep_Time; # Avoid -w uninialized errors
- $Loop_Sleep_Time = 1000 if $Loop_Sleep_Time > 1000; # Don't go over a second
- select undef, undef, undef, $Loop_Sleep_Time / 1000;
- }
- }
- # use our own str2time here so we can do arithmitic offsets
- sub my_str2time {
- my($time_date_arg) = @_;
- return 0 unless defined $time_date_arg;
- my ($monthf, $mdayf, $yearf, $time_date_time, $hourf, $minf, $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
- ($monthf, $mdayf, $yearf, $time_date_time) = $time_date =~ /(\S+)\/(\S+)\/(\S+) +(.+)/;
- ($monthf, $mdayf, $time_date_time) = $time_date =~ /(\S+)\/(\S+) +(.+)/ unless $time_date_time; # Year is optional
- $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, $am_pm) = $time_date =~ /(\d+):?(\d*) *([AaPp]?[Mm]?)/;
- $minf = 0 unless $minf;
- unless (defined $ho