From 4e8e805910d3993105894aa441b58804c64f1faf Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 8 Mar 2010 11:15:11 +0000 Subject: [PATCH 001/150] Copied remotely From 22b7344c9fd40bfede06d3d43987c68fab90ae78 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 8 Mar 2010 19:03:21 +0000 Subject: [PATCH 002/150] --- .../Insteon.pm | 382 +++- lib/Insteon/AllLinkDatabase.pm | 1360 ++++++++++++ lib/Insteon/BaseInsteon.pm | 1426 ++++++++++++ lib/Insteon/BaseInterface.pm | 339 +++ lib/Insteon/Controller.pm | 55 + lib/Insteon/Lighting.pm | 266 +++ lib/Insteon/Message.pm | 605 ++++++ lib/Insteon/Security.pm | 48 + lib/Insteon_Device.pm | 1903 ----------------- lib/Insteon_Irrigation.pm | 5 +- lib/Insteon_Link.pm | 429 ---- lib/Insteon_PLM.pm | 1566 +++----------- lib/Telephony_xAP.pm | 7 +- lib/Timer.pm | 22 +- lib/read_table_A.pl | 75 +- lib/site/DateTime/TimeZone.pm | 126 +- lib/site/HTTP/Date.pm | 1 - lib/site/HTTP/Headers.pm | 1 - lib/site/HTTP/Message.pm | 2 +- lib/site/HTTP/Request.pm | 1 - lib/site/HTTP/Response.pm | 1 - lib/site/HTTP/Status.pm | 2 +- 22 files changed, 4900 insertions(+), 3722 deletions(-) rename code/common/insteon_item_commands.pl => lib/Insteon.pm (50%) mode change 100644 => 100755 create mode 100755 lib/Insteon/AllLinkDatabase.pm create mode 100755 lib/Insteon/BaseInsteon.pm create mode 100755 lib/Insteon/BaseInterface.pm create mode 100755 lib/Insteon/Controller.pm create mode 100755 lib/Insteon/Lighting.pm create mode 100755 lib/Insteon/Message.pm create mode 100755 lib/Insteon/Security.pm delete mode 100644 lib/Insteon_Device.pm delete mode 100644 lib/Insteon_Link.pm diff --git a/code/common/insteon_item_commands.pl b/lib/Insteon.pm old mode 100644 new mode 100755 similarity index 50% rename from code/common/insteon_item_commands.pl rename to lib/Insteon.pm index 907f38fc3..cad6c9247 --- a/code/common/insteon_item_commands.pl +++ b/lib/Insteon.pm @@ -1,14 +1,20 @@ +package Insteon; + +use strict; + # Category=Insteon #@ This module creates voice commands for all Insteon_Device, Insteon_Link and Insteon_PLM items. my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_scan_failure_cnt,$_sync_cnt,$_sync_failure_cnt); +my $init_complete; +my (@_scan_devices); -$_scan_link_tables_v = new Voice_Cmd 'Scan all link tables'; +#my $_scan_link_tables_v = new Voice_Cmd 'Scan all link tables'; -if ($_scan_link_tables_v->state_now()) { - &_get_next_linkscan(); # unless $_scan_cnt; # prevent multiple concurrent scans -} +#if ($_scan_link_tables_v->state_now()) { +# &_get_next_linkscan(); # unless $_scan_cnt; # prevent multiple concurrent scans +#} sub _get_next_linkscan { @@ -18,68 +24,80 @@ sub _get_next_linkscan } else { $_scan_failure_cnt = 0; } - my @devices = (); - push @devices,@_insteon_plm; - push @devices,@_insteon_device; - push @devices,@_scannable_link; - my $dev_cnt = @devices; - my $return_next = ($current_name) ? 0 : 1; - my $next_name = undef; + if (!(scalar(@_scan_devices))) { + push @_scan_devices, &Insteon::active_interface; + push @_scan_devices, &Insteon::find_members("Insteon::Insteon_Device"); + $_scan_cnt = 0; + } - if ($current_name) { - for (my $i=0; $i<$dev_cnt; $i++) { - if ($devices[$i] eq $current_name) { + return unless scalar(@_scan_devices); + + my $current_obj = $_scan_devices[0]; + my $next_obj = $current_obj; +# my @devices = (); +# push @devices,@_insteon_plm; +# push @devices,@_insteon_device; +# push @devices,@_scannable_link; +# my $dev_cnt = @devices; +# my $return_next = ($current_name) ? 0 : 1; +# my $next_name = undef; + +# if ($current_name) { +# for (my $i=0; $i<$dev_cnt; $i++) { +# if ($devices[$i] eq $current_name) { if ($_scan_failure_cnt == 0) { # get the next - $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - $_scan_cnt = $i + 2; +# $next_name = $devices[$i+1] if $i+1 < $dev_cnt; + $next_obj = shift @_scan_devices; +# $_scan_cnt = $i + 2; + $_scan_cnt += 1; # remove the queue_timer_callback - my $current_obj = $objects_by_object_name{$current_name}; +# my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { $current_obj->queue_timer_callback(''); } # don't try to scan devices that are not responders - my $next_obj = $objects_by_object_name{$next_name}; - if (ref $next_obj and $next_obj->isa('Insteon_Device') - and !($next_obj->is_responder) and !($next_obj->is_plm_controlled)) { - &main::print_log("[Scan all link tables] $next_name is not a candidate for scanning. Moving to next"); - $current_name = $next_name; - # move on - next; +# my $next_obj = &main::get_object_by_name($next_name); + while (ref $next_obj and $next_obj->isa('Insteon::Insteon_Device') + and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { + &main::print_log("[Scan all link tables] " . $next_obj->get_object_name . " is not a candidate for scanning. Moving to next"); + $next_obj = shift @_scan_devices; } - } elsif ($_scan_failure_cnt == 1) { + } elsif ($_scan_failure_cnt == 1) { # try again - $next_name = $current_name; - &main::print_log("[Scan all link tables] WARN: failure occurred when scanning $current_name. Trying again..."); - $_scan_cnt = $i + 1; +# $next_name = $current_name; + $next_obj = $current_obj; + &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " . $current_obj->get_object_name . ". Trying again..."); +# $_scan_cnt = $i + 1; } else { # skip because this is a repeat failure - $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - &main::print_log("[Scan all link tables] WARN: failure occurred when scanning $current_name. Moving on..."); +# $next_name = $devices[$i+1] if $i+1 < $dev_cnt; + $next_obj = shift @_scan_devices; + &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " . $current_obj->get_object_name . ". Moving on..."); $_scan_failure_cnt = 0; # reset failure counter - $_scan_cnt = $i + 2; +# $_scan_cnt += $i + 2; # remove the queue_timer_callback - my $current_obj = $objects_by_object_name{$current_name}; +# my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { $current_obj->queue_timer_callback(''); } } - last; - } - } - } else { - if ($dev_cnt) { - $next_name = $devices[0]; - $_scan_cnt = 1; - } - } +# last; +# } +# } +# } else { +# if ($dev_cnt) { +# $next_name = $devices[0]; +# $_scan_cnt = 1; +# } +# } - if ($next_name) { - my $obj = $objects_by_object_name{$next_name}; - if ($obj) { - &main::print_log("[Scan all link tables] Now scanning: " . $obj->get_object_name . " ($_scan_cnt of $dev_cnt)"); - $obj->queue_timer_callback('&main::_get_next_linkscan(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); - $obj->scan_link_table('&main::_get_next_linkscan(\'' . $next_name . '\')'); + if ($next_obj) { +# my $obj = &main::get_object_by_name($next_name); + if ($next_obj) { + &main::print_log("[Scan all link tables] Now scanning: " . $next_obj->get_object_name . " ($_scan_cnt of ?)"); + $next_obj->queue_timer_callback('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\',1)') unless $next_obj->isa('Insteon_PLM'); + $next_obj->scan_link_table('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\')'); } } else { $_scan_cnt = 0; @@ -87,11 +105,11 @@ sub _get_next_linkscan } } -$_sync_links_v = new Voice_Cmd 'Sync all links'; +#my $_sync_links_v = new Voice_Cmd 'Sync all links'; -if ($_sync_links_v->state_now()) { - &_process_sync_links(); # unless $_sync_cnt; -} +#if ($_sync_links_v->state_now()) { +# &_process_sync_links(); # unless $_sync_cnt; +#} sub _process_sync_links { @@ -115,14 +133,14 @@ sub _process_sync_links $next_name = $devices[$i+1] if $i+1 < $dev_cnt; $_sync_cnt = $i + 2; # remove the queue_timer_callback - my $current_obj = $objects_by_object_name{$current_name}; + my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { $current_obj->queue_timer_callback(''); } # don't try to scan devices that are not responders - my $next_obj = $objects_by_object_name{$next_name}; - if (ref $next_obj and $next_obj->isa('Insteon_Device') - and !($next_obj->is_responder) and !($next_obj->is_plm_controlled)) { + my $next_obj = &main::get_object_by_name($next_name); + if (ref $next_obj and $next_obj->isa('Insteon::Insteon_Device') + and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { &main::print_log("[Sync all links] $next_name is not a candidate for syncing. Moving to next"); $current_name = $next_name; # move on @@ -140,7 +158,7 @@ sub _process_sync_links $_sync_failure_cnt = 0; # reset failure counter $_sync_cnt = $i + 2; # remove the queue_timer_callback - my $current_obj = $objects_by_object_name{$current_name}; + my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { $current_obj->queue_timer_callback(''); } @@ -153,7 +171,7 @@ sub _process_sync_links } if ($next_name) { - my $obj = $objects_by_object_name{$next_name}; + my $obj = &main::get_object_by_name($next_name); if ($obj) { &main::print_log("[Sync all links] Now syncing links: " . $obj->get_object_name . " ($_sync_cnt of $dev_cnt)"); $obj->queue_timer_callback('&main::_process_sync_links(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); @@ -167,29 +185,36 @@ sub _process_sync_links sub uninstall_insteon_item_commands { - &trigger_delete('scan insteon link tables'); + &main::trigger_delete('scan insteon link tables'); } -if ($Reload) { +sub init { + + # only run once + return if $init_complete; + $init_complete = 1; # initialize scan and sync counters $_scan_cnt = 0; $_sync_cnt = 0; + @_scan_devices = (); # create trigger my $trig_cmd = "time_cron '00 02 * * *'"; - &trigger_set($trig_cmd,'&_get_next_linkscan()','NoExpire','scan insteon link tables') - unless &trigger_get('scan insteon link tables'); + &main::trigger_set($trig_cmd,'&_get_next_linkscan()','NoExpire','scan insteon link tables') + unless &main::trigger_get('scan insteon link tables'); @_insteon_plm = (); @_insteon_device = (); @_insteon_link = (); - my $insteon_menu_states = $config_parms{insteon_menu_states} if $config_parms{insteon_menu_states}; - &::print_log("Generating Voice commands for all Insteon objects"); + + my $insteon_menu_states = $main::config_parms{insteon_menu_states} if $main::config_parms{insteon_menu_states}; + &main::print_log("Generating Voice commands for all Insteon objects"); my $object_string; - for my $object_name (keys %objects_by_object_name) { - my $object = $objects_by_object_name{$object_name}; - next unless $object->isa('Insteon_Device') or $object->isa('Insteon_Link') or $object->isa('Insteon_PLM'); + for my $object (&main::list_all_objects) { + next unless ref $object; + next unless $object->isa('Insteon::BaseInterface') or $object->isa('Insteon::BaseObject'); + my $object_name = $object->get_object_name; # ignore the thermostat next if $object->isa('Insteon_Thermostat'); my $command = $object_name; @@ -199,27 +224,27 @@ sub uninstall_insteon_item_commands { $object_string .= "use vars '${object_name}_v';\n"; my $states = 'on,off'; my $group = ($object->isa('Insteon_PLM')) ? '' : $object->group; - if ($object->isa('Insteon_Link')) { - $states = 'on,off,sync links'; #,resume,enroll,unenroll,manual'; + if ($object->isa('Insteon::BaseController')) { + $states = 'on,off,sync links'; #,resume,enroll,unenroll,manual'; my $cmd_states = $states; - if ($object->is_plm_controlled) { + if ($object->isa('Insteon::InterfaceController')) { $cmd_states .= ',initiate linking as controller,cancel linking'; } else { $cmd_states .= ",link to interface,unlink with interface"; } - if ($object->is_root and !($object->is_plm_controlled)) { + if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { $cmd_states .= ",status,scan link table,log links"; push @_scannable_link, $object_name; } $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - if ($object->is_plm_controlled) { + if ($object->isa('Insteon::BaseController')) { $object_string .= "$object_name_v -> tie_event('$object_name->initiate_linking_as_controller(\"$group\")', 'initiate linking as controller');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->interface()->cancel_linking','cancel linking');\n\n"; } else { $object_string .= "$object_name_v -> tie_event('$object_name->link_to_interface','link to interface');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->unlink_to_interface','unlink with interface');\n\n"; } - if ($object->is_root and !($object->is_plm_controlled)) { + if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; @@ -227,12 +252,13 @@ sub uninstall_insteon_item_commands { $object_string .= "$object_name_v -> tie_event('$object_name->sync_links()','sync links');\n\n"; $object_string .= "$object_name_v -> tie_items($object_name, 'on');\n\n"; $object_string .= "$object_name_v -> tie_items($object_name, 'off');\n\n"; - $object_string .= &store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_link_commands'); + $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_link_commands'); push @_insteon_link, $object_name; - } elsif ($object->isa('Insteon_Device')) { - $states = $insteon_menu_states if $insteon_menu_states; + } elsif ($object->isa('Insteon::BaseDevice')) { + $states = $insteon_menu_states if $insteon_menu_states + && ($object->can('is_dimmable') && $object->is_dimmable); my $cmd_states = "$states,status,scan link table,log links,update onlevel/ramprate"; #,on level,ramp rate"; - $cmd_states .= ",link to interface,unlink with interface" if $object->is_controller; + $cmd_states .= ",link to interface,unlink with interface" if $object->isa("Insteon::BaseController") || $object->is_controller; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; foreach my $state (split(/,/,$states)) { $object_string .= "$object_name_v -> tie_items($object_name, '$state');\n\n"; @@ -241,17 +267,17 @@ sub uninstall_insteon_item_commands { $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->update_local_properties','update onlevel/ramprate');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; - if ($object->is_controller) { + if ($object->isa("Insteon::BaseController") || $object->is_controller) { $object_string .= "$object_name_v -> tie_event('$object_name->link_to_interface','link to interface');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->unlink_to_interface','unlink with interface');\n\n"; } # the remote_set_button_taps provide incorrect/inconsistent results # $object_string .= "$object_name_v -> tie_event('$object_name->remote_set_button_tap(1)','on level');\n\n"; # $object_string .= "$object_name_v -> tie_event('$object_name->remote_set_button_tap(2)','ramp rate');\n\n"; - $object_string .= &store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); + $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,log links,delete orphan links,reset serial"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,log links,delete orphan links,scan all link tables,debug on, debug off"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -259,12 +285,206 @@ sub uninstall_insteon_item_commands { $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','log links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->reset_serial_object','reset serial');\n\n"; - $object_string .= &store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); + $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','debug on');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','debug off');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::_get_next_linkscan','scan all link tables');\n\n"; + $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } } + + package main; eval $object_string; print "Error in insteon_item_commands: $@\n" if $@; + package Insteon; +} + +sub add +{ + my ($object) = @_; + + my $insteon_manager = InsteonManager->instance(); + if ($insteon_manager->remove_item($object)) { + # print out debug info + } + $insteon_manager->add_item($object); +} + +sub find_members +{ + my ($name) = @_; + + my $insteon_manager = InsteonManager->instance(); + return $insteon_manager->find_members($name); +} + + +sub get_object +{ + my ($p_deviceid, $p_group) = @_; + + my $retObj = undef; + + my $insteon_manager = InsteonManager->instance(); + my @search_objects = (); + push @search_objects, $insteon_manager->find_members('Insteon::Insteon_Device'); + push @search_objects, $insteon_manager->find_members('Insteon::BaseObject'); + for my $obj (@search_objects) + { + #Match on Insteon objects only + # if ($obj->isa("Insteon::Insteon_Device")) + # { + if (lc $obj->device_id() eq lc $p_deviceid) + { + if ($p_group) + { + if (lc $p_group eq lc $obj->group) + { + $retObj = $obj; + last; + } + } else { + $retObj = $obj; + last; + } + } + # } + } + + return $retObj; +} + +sub active_interface +{ + my ($interface) = @_; + my $insteon_manager = InsteonManager->instance(); + + $insteon_manager->active_interface($interface) if $interface; +#print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; + return $insteon_manager->_active_interface; + +} + +package InsteonManager; + +use strict; +use base 'Class::Singleton'; + +sub _new_instance +{ + my $class = shift; + my $self = bless {}, $class; + + return $self; +} + +sub _active_interface +{ + my ($self, $interface) = @_; + # setup hooks the first time that an interface is made active + if (!($$self{active_interface}) and $interface) { + &main::print_log("[Insteon] Setting up initialization hooks") if $main::Debug{insteon}; + &main::MainLoop_pre_add_hook(\&Insteon::BaseInterface::check_for_data, 1); + &main::Reload_post_add_hook(\&Insteon::BaseInterface::poll_all, 1); + $Insteon::init_complete = 0; + &main::MainLoop_pre_add_hook(\&Insteon::init, 1); + } + $$self{active_interface} = $interface if $interface; + return $$self{active_interface}; +} + +sub add +{ + my ($self,@p_objects) = @_; + + my @l_objects; + + for my $l_object (@p_objects) { + if ($l_object->isa('Group_Item') ) { + @l_objects = $$l_object{members}; + for my $obj (@l_objects) { + $self->add($obj); + } + } else { + $self->add_item($l_object); + } + } +} + +sub add_item +{ + my ($self,$p_object) = @_; + + push @{$$self{objects}}, $p_object; + if ($p_object->isa('Insteon::BaseInterface') and !($self->_active_interface)) { + $self->_active_interface($p_object); + } + return $p_object; +} + +sub remove_all_items { + my ($self) = @_; + + if (ref $$self{objects}) { + foreach (@{$$self{objects}}) { + # $_->untie_items($self); + } + } + delete $self->{objects}; +} + +sub add_item_if_not_present { + my ($self, $p_object) = @_; + + if (ref $$self{objects}) { + foreach (@{$$self{objects}}) { + if ($_ eq $p_object) { + return 0; + } + } + } + $self->add_item($p_object); + return 1; +} + +sub remove_item { + my ($self, $p_object) = @_; + + if (ref $$self{objects}) { + for (my $i = 0; $i < scalar(@{$$self{objects}}); $i++) { + if ($$self{objects}->[$i] eq $p_object) { + splice @{$$self{objects}}, $i, 1; + return 1; + } + } + } + return 0; +} + + +sub is_member { + my ($self, $p_object) = @_; + + my @l_objects = @{$$self{objects}}; + for my $l_object (@l_objects) { + if ($l_object eq $p_object) { + return 1; + } + } + return 0; +} + +sub find_members { + my ($self,$p_type) = @_; + + my @l_found; + my @l_objects = @{$$self{objects}}; + for my $l_object (@l_objects) { + if ($l_object->isa($p_type)) { + push @l_found, $l_object; + } + } + return @l_found; } +1 diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm new file mode 100755 index 000000000..e2c5100da --- /dev/null +++ b/lib/Insteon/AllLinkDatabase.pm @@ -0,0 +1,1360 @@ +=begin comment +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +File: + AllLinkDatabase.pm + +Description: + Generic class implementation of an insteon device's all link database. + +Author(s): + Gregg Liming / gregg@limings.net + +License: + This free software is licensed under the terms of the GNU public license. + + +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +=cut + + +package Insteon::AllLinkDatabase; + +use strict; +use Insteon; +use Insteon::Lighting; + +# @Insteon::AllLinkDatabase::ISA = ('Generic_Item'); + + +sub new +{ + my ($class, $device) = @_; + my $self={}; + bless $self,$class; + $$self{device} = $device; + return $self; +} + +sub _send_cmd +{ + my ($self, $msg) = @_; + $$self{device}->_send_cmd($msg); +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = ''; + if ($$self{aldb}) { + my $aldb = ''; + foreach my $aldb_key (keys %{$$self{aldb}}) { + next unless $aldb_key eq 'empty' || $aldb_key eq 'duplicates' || $$self{aldb}{$aldb_key}{inuse}; + $aldb .= '|' if $aldb; # separate sections + my $record = ''; + if ($aldb_key eq 'empty') { + foreach my $address (@{$$self{aldb}{empty}}) { + $record .= ';' if $record; + $record .= $address; + } + $record = 'empty=' . $record; + } elsif ($aldb_key eq 'duplicates') { + my $duplicate_record = ''; + foreach my $address (@{$$self{aldb}{duplicates}}) { + $duplicate_record .= ';' if $duplicate_record; + $duplicate_record .= $address; + } + $record = 'duplicates=' . $duplicate_record; + } else { + my %aldb_record = %{$$self{aldb}{$aldb_key}}; + foreach my $record_key (keys %aldb_record) { + next unless $aldb_record{$record_key}; + $record .= ',' if $record; + $record .= $record_key . '=' . $aldb_record{$record_key}; + } + } + $aldb .= $record; + } +# &::print_log("[AllLinkDataBase] aldb restore string: $aldb") if $main::Debug{insteon}; + $restore_string .= $$self{device}->get_object_name . "->_adlb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_adlb;\n"; + } + return $restore_string; +} + +sub restore_aldb +{ + my ($self,$aldb) = @_; + if ($aldb) { + foreach my $aldb_section (split(/\|/,$aldb)) { + my %aldb_record = (); + my @aldb_empty = (); + my @aldb_duplicates = (); + my $deviceid = ''; + my $groupid = '01'; + my $is_controller = 0; + my $subaddress = '00'; + foreach my $aldb_entry (split(/,/,$aldb_section)) { + my ($key,$value) = split(/=/,$aldb_entry); + next unless $key and defined($value) and $value ne ''; + if ($key eq 'empty') { + @aldb_empty = split(/;/,$value); + } elsif ($key eq 'duplicates') { + @aldb_duplicates = split(/;/,$value); + } else { + $deviceid = lc $value if ($key eq 'deviceid'); + $groupid = lc $value if ($key eq 'group'); + $is_controller = $value if ($key eq 'is_controller'); + $subaddress = $value if ($key eq 'data3'); + $aldb_record{$key} = $value if $key and defined($value); + } + } + if (@aldb_empty) { + @{$$self{aldb}{empty}} = @aldb_empty; + } elsif (@aldb_duplicates) { + @{$$self{aldb}{duplicates}} = @aldb_duplicates; + } elsif (scalar %aldb_record) { + next unless $deviceid; + my $aldbkey = $deviceid . $groupid . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $aldbkey .= $subaddress; + } + %{$$self{aldb}{$aldbkey}} = %aldb_record; + } + } +# $self->log_alllink_table(); + } +} + + + + +package Insteon::ALDB_i1; + +use strict; +use Insteon; +use Insteon::Lighting; +use Insteon::Message; + +@Insteon::ALDB_i1::ISA = ('Insteon::AllLinkDatabase'); + +sub new +{ + my ($class,$device) = @_; + + my $self = new Insteon::AllLinkDatabase($device); + bless $self,$class; + return $self; +} + +sub _on_poke +{ + my ($self,%msg) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); + if (($$self{_mem_activity} eq 'update') or ($$self{_mem_activity} eq 'add')) { + if ($$self{_mem_action} eq 'aldb_flag') { + $$self{_mem_action} = 'aldb_group'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_group') { + $$self{_mem_action} = 'aldb_devhi'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_devhi') { + $$self{_mem_action} = 'aldb_devmid'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_devmid') { + $$self{_mem_action} = 'aldb_devlo'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_devlo') { + $$self{_mem_action} = 'aldb_data1'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_data1') { + $$self{_mem_action} = 'aldb_data2'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_data2') { + $$self{_mem_action} = 'aldb_data3'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_data3') { + ## update the aldb records w/ the changes that were made + my $aldbkey = $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + my $subaddress = $$self{pending_aldb}{data3}; + if (($subaddress ne '00') and ($subaddress ne '01')) { + $aldbkey .= $subaddress; + } + $$self{aldb}{$aldbkey}{data1} = $$self{pending_aldb}{data1}; + $$self{aldb}{$aldbkey}{data2} = $$self{pending_aldb}{data2}; + $$self{aldb}{$aldbkey}{data3} = $$self{pending_aldb}{data3}; + $$self{aldb}{$aldbkey}{inuse} = 1; # needed so that restore string will preserve record + if ($$self{_mem_activity} eq 'add') { + $$self{aldb}{$aldbkey}{is_controller} = $$self{pending_aldb}{is_controller}; + $$self{aldb}{$aldbkey}{deviceid} = lc $$self{pending_aldb}{deviceid}; + $$self{aldb}{$aldbkey}{group} = lc $$self{pending_aldb}{group}; + $$self{aldb}{$aldbkey}{address} = $$self{pending_aldb}{address}; + # on completion, check to see if the empty links list is now empty; if so, + # then decrement the current address and add it to the list + my $num_empty = @{$$self{aldb}{empty}}; + if (!($num_empty)) { + my $low_address = 0; + for my $key (keys %{$$self{aldb}}) { + next if $key eq 'empty' or $key eq 'duplicates'; + my $new_address = hex($$self{aldb}{$key}{address}); + if (!($low_address)) { + $low_address = $new_address; + next; + } else { + $low_address = $new_address if $new_address < $low_address; + } + } + $low_address = sprintf('%04X', $low_address - 8); + unshift @{$$self{aldb}{empty}}, $low_address; + } + } + # clear out mem_activity flag + $$self{_mem_activity} = undef; + if (defined $$self{_mem_callback}) { + my $callback = $$self{_mem_callback}; + # clear it out *before* the eval + $$self{_mem_callback} = undef; + package main; + eval ($callback); + package Insteon::ALDB_i1; + &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) + if $@ and $main::Debug{insteon}; + } + } + } elsif ($$self{_mem_activity} eq 'update_local') { + if ($$self{_mem_action} eq 'local_onlevel') { + $$self{_mem_lsb} = '21'; + $$self{_mem_action} = 'local_ramprate'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'local_ramprate') { + if ($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) { + # update from eeprom--only a kpl issue + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); + } + } + } elsif ($$self{_mem_activity} eq 'update_flags') { + # update from eeprom--only a kpl issue + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'delete') { + # clear out mem_activity flag + $$self{_mem_activity} = undef; + # add the address of the deleted link to the empty list + push @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; + if (exists $$self{pending_aldb}{deviceid}) { + my $key = lc $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + my $subaddress = $$self{pending_aldb}{data3}; + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + delete $$self{aldb}{$key}; + } + + if (defined $$self{_mem_callback}) { + my $callback = $$self{_mem_callback}; + # clear it out *before* the eval + $$self{_mem_callback} = undef; + package main; + eval ($callback); + &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon::ALDB_i1; + $$self{_mem_callback} = undef; + } + } +# +} + +sub _on_peek +{ + my ($self,%msg) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); + if ($msg{is_extended}) { + &::print_log("[Insteon::ALDB_i1]: extended peek for " . $$self{device}->{object_name} + . " is " . $msg{extra}) if $main::Debug{insteon}; + } else { + if ($$self{_mem_action} eq 'aldb_peek') { + if ($$self{_mem_activity} eq 'scan') { + $$self{_mem_action} = 'aldb_flag'; + # if the device is responding to the peek, then init the link table + # if at the very start of a scan + if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { + # reinit the aldb hash as there will be a new one + $$self{aldb} = undef; + # reinit the empty address list + @{$$self{aldb}{empty}} = (); + # and, also the duplicates list + @{$$self{aldb}{duplicates}} = (); + } + } elsif ($$self{_mem_activity} eq 'update') { + $$self{_mem_action} = 'aldb_data1'; + } elsif ($$self{_mem_activity} eq 'update_local') { + $$self{_mem_action} = 'local_onlevel'; + } elsif ($$self{_mem_activity} eq 'update_flags') { + $$self{_mem_action} = 'update_flags'; + } elsif ($$self{_mem_activity} eq 'delete') { + $$self{_mem_action} = 'aldb_flag'; + } elsif ($$self{_mem_activity} eq 'add') { + $$self{_mem_action} = 'aldb_flag'; + } + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_flag') { + if ($$self{_mem_activity} eq 'scan') { + my $flag = hex($msg{extra}); + $$self{pending_aldb}{inuse} = ($flag & 0x80) ? 1 : 0; + $$self{pending_aldb}{is_controller} = ($flag & 0x40) ? 1 : 0; + $$self{pending_aldb}{highwater} = ($flag & 0x02) ? 1 : 0; + if (!($$self{pending_aldb}{highwater})) { + # since this is the last unused memory location, then add it to the empty list + unshift @{$$self{aldb}{empty}}, $$self{_mem_msb} . $$self{_mem_lsb}; + $$self{_mem_action} = undef; + # clear out mem_activity flag + $$self{_mem_activity} = undef; + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " completed link memory scan") + if $main::Debug{insteon}; + if (defined $$self{_mem_callback}) { + package main; + eval ($$self{_mem_callback}); + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . ": error during scan callback $@") + if $@ and $main::Debug{insteon}; + package Insteon::ALDB_i1; + $$self{_mem_callback} = undef; + } + # ping the device as part of the scan if we don't already have a devcat + # if (!($self->{devcat})) { + # $self->ping(); + # } + } else { + $$self{pending_aldb}{flag} = $msg{extra}; + ## confirm that we have a high-water mark; otherwise stop + $$self{pending_aldb}{address} = $$self{_mem_msb} . $$self{_mem_lsb}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_group'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_activity} eq 'add') { + my $flag = ($$self{pending_aldb}{is_controller}) ? 'E2' : 'A2'; + $$self{pending_aldb}{flag} = $flag; + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($flag); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $flag, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'delete') { + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra('02'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => '02', 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_group') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{group} = lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_devhi'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, +# 'is_synchronous' => 1); + } else { + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{group}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{group}, +# 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_devhi') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{deviceid} = lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_devmid'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'add') { + my $devid = substr($$self{pending_aldb}{deviceid},0,2); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($devid); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_devmid') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{deviceid} .= lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_devlo'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'add') { + my $devid = substr($$self{pending_aldb}{deviceid},2,2); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($devid); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_devlo') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{deviceid} .= lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_data1'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'add') { + my $devid = substr($$self{pending_aldb}{deviceid},4,2); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($devid); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_data1') { + if ($$self{_mem_activity} eq 'scan') { + $$self{_mem_action} = 'aldb_data2'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{pending_aldb}{data1} = $msg{extra}; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + # poke the new value + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{data1}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data1}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_data2') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{data2} = $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_data3'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + # poke the new value + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{data2}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data2}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_data3') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{data3} = $msg{extra}; + # check the previous record if highwater is set + if ($$self{pending_aldb}{highwater}) { + if ($$self{pending_aldb}{inuse}) { + # save pending_aldb and then clear it out + my $aldbkey = lc $$self{pending_aldb}{deviceid} + . $$self{pending_aldb}{group} + . $$self{pending_aldb}{is_controller}; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + my $subaddress = $$self{pending_aldb}{data3}; + if ($subaddress ne '00' and $subaddress ne '01') { + $aldbkey .= $subaddress; + } + # check for duplicates + if (exists $$self{aldb}{$aldbkey} && $$self{aldb}{$aldbkey}{inuse}) { + unshift @{$$self{aldb}{duplicates}}, $$self{pending_aldb}{address}; + } else { + %{$$self{aldb}{$aldbkey}} = %{$$self{pending_aldb}}; + } + } else { + # TO-DO: record the locations of deleted aldb records for subsequent reuse + unshift @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; + } + my $newaddress = sprintf("%04X", hex($$self{pending_aldb}{address}) - 8); + $$self{pending_aldb} = undef; + $self->_peek($newaddress); + } + } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + # poke the new value + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{data3}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data3}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'local_onlevel') { + my $on_level = $self->local_onlevel; + $on_level = &Insteon::DimmableLight::convert_level($on_level); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($on_level); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $on_level, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'local_ramprate') { + my $ramp_rate = $$self{_ramprate}; + $ramp_rate = '1f' unless $ramp_rate; + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($ramp_rate); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $ramp_rate, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'update_flags') { + my $flags = $$self{_operating_flags}; + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($flags); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $flags, 'is_synchronous' => 1); + } +# +# &::print_log("AllLinkDataBase: peek for " . $self->{object_name} +# . " is " . $msg{extra}) if $main::Debug{insteon}; + } +} + + +sub scan_link_table +{ + my ($self,$callback) = @_; + $$self{_mem_activity} = 'scan'; + $$self{_mem_callback} = ($callback) ? $callback : undef; + $self->_peek('0FF8',0); +} + +sub delete_link +{ + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + if ($link_parms{address}) { + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_mem_activity} = 'delete'; + $$self{pending_aldb}{address} = $link_parms{address}; + $self->_peek($link_parms{address},0); + + } else { + my $insteon_object = $link_parms{object}; + my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; + my $groupid = $link_parms{group}; + $groupid = '01' unless $groupid; + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; + # get the address via lookup into the hash + my $key = lc $deviceid . $groupid . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + my $address = $$self{aldb}{$key}{address}; + if ($address) { + &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$address] with the following data" + . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); + # now, alter the flags byte such that the in_use flag is set to 0 + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_mem_activity} = 'delete'; + $$self{pending_aldb}{deviceid} = lc $deviceid; + $$self{pending_aldb}{group} = $groupid; + $$self{pending_aldb}{is_controller} = $is_controller; + $$self{pending_aldb}{address} = $address; + $self->_peek($address,0); + } else { + &main::print_log('[Insteon::ALDB_i1] WARN: (' . $$self{device}->get_object_name . ') attempt to delete link that does not exist!' + . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); + if ($link_parms{callback}) { + package main; + eval($link_parms{callback}); + &::print_log("[Insteon::ALDB_i1] error encountered during delete_link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon::AllLinkDataBase; + } + } + } +} + +sub delete_orphan_links +{ + my ($self) = @_; + @{$$self{delete_queue}} = (); # reset the work queue + my $selfname = $$self{device}->get_object_name; + my $num_deleted = 0; + for my $linkkey (keys %{$$self{aldb}}) { + if ($linkkey ne 'empty' and $linkkey ne 'duplicates') { + my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; + next unless $deviceid; + my $group = $$self{aldb}{$linkkey}{group}; + my $is_controller = $$self{aldb}{$linkkey}{is_controller}; + my $data3 = $$self{aldb}{$linkkey}{data3}; + my $device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface + : &Insteon::get_object($deviceid,'01'); + if (!($device)) { +# &::print_log("[AllLinkDataBase] " . $self->get_object_name . " now deleting orphaned link w/ details: " +# . (($is_controller) ? "controller" : "responder") +# . ", deviceid=$deviceid, group=$group"); + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", cause => "no device could be found"); + push @{$$self{delete_queue}}, \%delete_req; + } elsif ($device->isa("Insteon::BaseInterface") and $is_controller) { + # ignore since this is just a link back to the PLM + } elsif ($device->isa("Insteon::BaseInterface")) { + # does the PLM have a link point back? If not, the delete this one + if (!($device->has_link($self,$group,1))) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + # is there an entry in the items.mht that corresponds to this link? + if ($is_controller) { + # TO-DO: handle this case + } else { + my $plm_link = $device->get_device('000000',$group); + if ($plm_link) { + my $is_invalid = 1; + foreach my $member_ref (keys %{$$plm_link{members}}) { + my $member = $$plm_link{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) { + $member = @lights[0]; # pick the first + } + } + if ($member->device_id eq $self->device_id) { + if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { + $is_invalid = 0; + last; + } + } + } + if ($is_invalid) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link is defined for the plm controlled scene", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } else { + # delete the link since it doesn't exist + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no plm link could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + } else { + if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link to the device could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } else { + my $is_invalid = 1; + my $link = ($is_controller) ? &Insteon::get_object($self->device_id,$group) + : &Insteon::get_object($device->device_id,$group); + if ($link) { + foreach my $member_ref (keys %{$$link{members}}) { + my $member = $$link{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) { + $member = @lights[0]; # pick the first + } + } + if ($member->isa('Insteon::BaseDevice') and !($member->is_root)) { + $member = $member->get_root; + } + if ($member->isa('Insteon::BaseDevice') and !($is_controller) and ($member->device_id eq $self->device_id)) { + $is_invalid = 0; + last; + } elsif ($member->isa('Insteon::BaseDevice') and $is_controller and ($member->device_id eq $device->device_id)) { + $is_invalid = 0; + last; + } + + } + } + if ($is_invalid) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no reverse link could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + } + } elsif ($linkkey eq 'duplicates') { + my $address = pop @{$$self{aldb}{duplicates}}; + while ($address) { + my %delete_req = (address => $address, + callback => "$selfname->_process_delete_queue()", + cause => "duplicate record found"); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + $address = pop @{$$self{aldb}{duplicates}}; + } + } + } + $$self{delete_queue_processed} = 0; + $self->_process_delete_queue(); + return $num_deleted; +} + +sub _process_delete_queue { + my ($self) = @_; + my $num_in_queue = @{$$self{delete_queue}}; + if ($num_in_queue) { + my $delete_req_ptr = shift(@{$$self{delete_queue}}); + my %delete_req = %$delete_req_ptr; + if ($delete_req{address}) { + &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting duplicate record at address " + . $delete_req{address}); + } else { + &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " + . (($delete_req{is_controller}) ? "controller" : "responder") + . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name + : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); + } + $self->delete_link(%delete_req); + $$self{delete_queue_processed}++; + } else { + $self->interface->_process_delete_queue($$self{delete_queue_processed}); + } +} + +sub add_link +{ + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + my $device_id; + my $insteon_object = $link_parms{object}; + my $group = $link_parms{group}; + if (!(defined($insteon_object))) { + $device_id = lc $link_parms{deviceid}; + $insteon_object = &Insteon::get_object($device_id, $group); + } else { + $device_id = lc $insteon_object->device_id; + } + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + # check whether the link already exists + my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; + # get the address via lookup into the hash + my $key = lc $device_id . $group . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + if (defined $$self{aldb}{$key}{inuse}) { + &::print_log("[Insteon::ALDB_i1] WARN: attempt to add link to " . $$self{device}->get_object_name . " that already exists! " + . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); + if ($link_parms{callback}) { + package main; + eval($link_parms{callback}); + &::print_log("[Insteon::ALDB_i1] failure occurred in callback eval for " . $$self{device}->get_object_name . ":" . $@) + if $@ and $main::Debug{insteon}; + package Insteon::ALDB_i1; + } + } else { + # strip optional % sign to append on_level + my $on_level = $link_parms{on_level}; + $on_level =~ s/(\d)%?/$1/; + $on_level = '100' unless defined($on_level); # 100% == on is the default + # strip optional s (seconds) to append ramp_rate + my $ramp_rate = $link_parms{ramp_rate}; + $ramp_rate =~ s/(\d)s?/$1/; + $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default + &::print_log("[Insteon::ALDB_i1] adding link record " . $$self{device}->get_object_name + . " light level controlled by " . $insteon_object->get_object_name + . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; + my $data1 = &Insteon::DimmableLight::convert_level($on_level); + my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; + # get the first available memory location + my $address = pop @{$$self{aldb}{empty}}; + # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails + $$self{_mem_activity} = 'add'; + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); + } +} + +sub update_link +{ + my ($self, %link_parms) = @_; + my $insteon_object = $link_parms{object}; + my $group = $link_parms{group}; + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + # strip optional % sign to append on_level + my $on_level = $link_parms{on_level}; + $on_level =~ s/(\d+)%?/$1/; + # strip optional s (seconds) to append ramp_rate + my $ramp_rate = $link_parms{ramp_rate}; + $ramp_rate =~ s/(\d)s?/$1/; + &::print_log("[Insteon::ALDB_i1] updating " . $$self{device}->get_object_name . " light level controlled by " . $insteon_object->get_object_name + . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; + my $data1 = sprintf('%02X',$on_level * 2.55); + $data1 = 'ff' if $on_level eq '100'; + $data1 = '00' if $on_level eq '0'; + my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; + my $deviceid = $insteon_object->device_id; + my $subaddress = $data3; + # get the address via lookup into the hash + my $key = lc $deviceid . $group . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + my $address = $$self{aldb}{$key}{address}; + $$self{_mem_activity} = 'update'; + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $self->_write_link($address, $deviceid, $group, $is_controller, $data1, $data2, $data3); +} + + +sub log_alllink_table +{ + my ($self) = @_; + &::print_log("[Insteon::ALDB_i1] link table for " . $$self{device}->get_object_name . " (devcat: $$self{devcat}):"); + foreach my $aldbkey (sort(keys(%{$$self{aldb}}))) { + next if $aldbkey eq 'empty' or $aldbkey eq 'duplicates'; + my ($device); + my $is_controller = $$self{aldb}{$aldbkey}{is_controller}; + if ($$self{device}->interface()->device_id() and ($$self{device}->interface()->device_id() eq $$self{aldb}{$aldbkey}{deviceid})) { + $device = $$self{device}->interface; + } else { + $device = &Insteon::get_object($$self{aldb}{$aldbkey}{deviceid},'01'); + } + my $object_name = ($device) ? $device->get_object_name : $$self{aldb}{$aldbkey}{deviceid}; + + my $on_level = 'unknown'; + if (defined $$self{aldb}{$aldbkey}{data1}) { + if ($$self{aldb}{$aldbkey}{data1}) { + $on_level = int((hex($$self{aldb}{$aldbkey}{data1})*100/255) + .5) . "%"; + } else { + $on_level = '0%'; + } + } + + my $rspndr_group = $$self{aldb}{$aldbkey}{data3}; + $rspndr_group = '01' if $rspndr_group eq '00'; + + my $ramp_rate = 'unknown'; + if ($$self{aldb}{$aldbkey}{data2}) { + if (!($$self{device}->isa('Insteon::DimmableLight')) or (!($is_controller) and ($rspndr_group != '01'))) { + $ramp_rate = 'none'; + if ($on_level eq '0%') { + $on_level = 'off'; + } else { + $on_level = 'on'; + } + } else { + $ramp_rate = &Insteon::LampLinc::get_ramp_from_code($$self{aldb}{$aldbkey}{data2}) . "s"; + } + } + + &::print_log("[Insteon::ALDB_i1] [0x" . $$self{aldb}{$aldbkey}{address} . "] " . + (($$self{aldb}{$aldbkey}{is_controller}) ? "contlr($$self{aldb}{$aldbkey}{group}) record to " + . $object_name . "($rspndr_group), (d1:$$self{aldb}{$aldbkey}{data1}, d2:$$self{aldb}{$aldbkey}{data2}, d3:$$self{aldb}{$aldbkey}{data3})" + : "rspndr($rspndr_group) record to " . $object_name . "($$self{aldb}{$aldbkey}{group})" + . ": onlevel=$on_level and ramp=$ramp_rate (d3:$$self{aldb}{$aldbkey}{data3})")) if $main::Debug{insteon}; + } + foreach my $address (@{$$self{aldb}{empty}}) { + &::print_log("[Insteon::ALDB_i1] [0x$address] is empty"); + } + + foreach my $address (@{$$self{aldb}{duplicates}}) { + &::print_log("[Insteon::ALDB_i1] [0x$address] holds a duplicate entry"); + } + +} + +sub update_local_properties +{ + my ($self) = @_; + $$self{_mem_activity} = 'update_local'; + $self->_peek('0032'); # 0032 is the address for the onlevel +} + +sub update_flags +{ + my ($self, $flags) = @_; + return unless defined $flags; + + $$self{_mem_activity} = 'update_flags'; + $$self{_operating_flags} = $flags; + $self->_peek('0023'); +} + +sub get_link_record +{ + my ($self,$link_key) = @_; + my %link_record = (); + %link_record = %{$$self{aldb}{$link_key}} if $$self{aldb}{$link_key}; + return %link_record; +} + + + +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $key = lc $insteon_object->device_id . $group . $is_controller; + $subaddress = '00' unless $subaddress; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + return (defined $$self{aldb}{$key}) ? 1 : 0; +} + +sub _write_link +{ + my ($self, $address, $deviceid, $group, $is_controller, $data1, $data2, $data3) = @_; + if ($address) { + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " address: $address found for device: $deviceid and group: $group"); + # change address for start of change to be address + offset + if ($$self{_mem_activity} eq 'update') { + $address = sprintf('%04X',hex($address) + 5); + } + $$self{pending_aldb}{address} = $address; + $$self{pending_aldb}{deviceid} = lc $deviceid; + $$self{pending_aldb}{group} = lc $group; + $$self{pending_aldb}{is_controller} = $is_controller; + $$self{pending_aldb}{data1} = (defined $data1) ? lc $data1 : '00'; + $$self{pending_aldb}{data2} = (defined $data2) ? lc $data2 : '00'; + # Note: if device is a KeypadLinc, then $data3 must be assigned the value of the applicable button (01) + if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) { + &::print_log("[Insteon::ALDB_i1] setting data3 to " . $self->group . " for this keypadlinc") + if $main::Debug{insteon}; + $data3 = $self->group; + } + $$self{pending_aldb}{data3} = (defined $data3) ? lc $data3 : '00'; + $self->_peek($address); + } else { + &::print_log("[Insteon::ALDB_i1] WARN: " . $$self{device}->get_object_name + . " write_link failure: no address available for record to device: $deviceid and group: $group" . + " and is_controller: $is_controller");; + } +} + +sub _peek +{ + my ($self, $address, $extended) = @_; + my $msb = substr($address,0,2); + my $lsb = substr($address,2,2); + if ($extended) { + my $message = $self->device->derive_message('peek','insteon_ext_send', + $lsb . "0000000000000000000000000000"); + $self->interface->queue_message($message); + + } else { + $$self{_mem_lsb} = $lsb; + $$self{_mem_msb} = $msb; + $$self{_mem_action} = 'aldb_peek'; + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " accessing memory at location: 0x" . $address); + my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'set_address_msb'); + $message->extra($msb); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'set_address_msb', 'extra' => $msb, 'is_synchronous' => 1); + } +} + + + +package Insteon::ALDB_i2; + +use strict; +use Insteon; +use Insteon::Lighting; + +@Insteon::ALDB_i2::ISA = ('Insteon::AllLinkDatabase'); + +sub new +{ + my ($class,$device) = @_; + + my $self = new Insteon::AllLinkDatabase($device); + bless $self,$class; + return $self; +} + + + + + +package Insteon::ALDB_PLM; + +use strict; +use Insteon; +use Insteon::Lighting; + +@Insteon::ALDB_PLM::ISA = ('Insteon::AllLinkDatabase'); + +sub new +{ + my ($class,$device) = @_; + + my $self = new Insteon::AllLinkDatabase($device); + bless $self,$class; + return $self; +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = ''; + if ($$self{aldb}) { + my $link = ''; + foreach my $link_key (keys %{$$self{aldb}}) { + $link .= '|' if $link; # separate sections + my %link_record = %{$$self{aldb}{$link_key}}; + my $record = ''; + foreach my $record_key (keys %link_record) { + next unless $link_record{$record_key}; + $record .= ',' if $record; + $record .= $record_key . '=' . $link_record{$record_key}; + } + $link .= $record; + } + $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_linktable(q~$link~) if " . $$self{device}->get_object_name . "->_aldb;\n"; + } + return $restore_string; +} + +sub restore_linktable +{ + my ($self, $links) = @_; + if ($links) { + foreach my $link_section (split(/\|/,$links)) { + my %link_record = (); + my $deviceid = ''; + my $groupid = '01'; + my $is_controller = 0; + foreach my $link_record (split(/,/,$link_section)) { + my ($key,$value) = split(/=/,$link_record); + $deviceid = $value if ($key eq 'deviceid'); + $groupid = $value if ($key eq 'group'); + $is_controller = $value if ($key eq 'is_controller'); + $link_record{$key} = $value if $key and defined($value); + } + my $linkkey = $deviceid . $groupid . $is_controller; + %{$$self{aldb}{lc $linkkey}} = %link_record; + } +# $self->log_alllink_table(); + } +} + +sub log_alllink_table +{ + my ($self) = @_; + foreach my $linkkey (sort(keys(%{$$self{aldb}}))) { + my $data3 = $$self{aldb}{$linkkey}{data3}; + my $is_controller = $$self{aldb}{$linkkey}{is_controller}; + my $group = ($is_controller) ? $data3 : $$self{aldb}{$linkkey}{group}; + $group = '01' if $group == '00'; + my $device = &Insteon::get_object($$self{aldb}{$linkkey}{deviceid},$group); + my $object_name = ($device) ? $device->get_object_name : $$self{aldb}{$linkkey}{deviceid}; + &::print_log("[Insteon::ALDB_PLM] " . + (($is_controller) ? "cntlr($$self{aldb}{$linkkey}{group}) record to " + . $object_name + : "responder record to " . $object_name . "($$self{aldb}{$linkkey}{group})") + . " (d1=$$self{aldb}{$linkkey}{data1}, d2=$$self{aldb}{$linkkey}{data2}, " + . "d3=$data3)") + if $main::Debug{insteon}; + } +} + +sub parse_alllink +{ + my ($self, $data) = @_; + if (substr($data,4,6)) { + my %link = (); + my $flag = substr($data,4,1); + $link{is_controller} = (hex($flag) & 0x04) ? 1 : 0; + $link{flags} = substr($data,4,2); + $link{group} = lc substr($data,6,2); + $link{deviceid} = lc substr($data,8,6); + $link{data1} = substr($data,14,2); + $link{data2} = substr($data,16,2); + $link{data3} = substr($data,18,2); + my $key = $link{deviceid} . $link{group} . $link{is_controller}; + %{$$self{aldb}{lc $key}} = %link; + } +} + +sub get_first_alllink +{ + my ($self) = @_; + $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_first_rec', $$self{device})); +} + +sub get_next_alllink +{ + my ($self) = @_; + $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_next_rec', $$self{device})); +} + +sub delete_orphan_links +{ + my ($self) = @_; + @{$$self{delete_queue}} = (); # reset the work queue + my $selfname = $$self{device}->get_object_name; + my $num_deleted = 0; + foreach my $linkkey (keys %{$$self{aldb}}) { + my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; + my $group = $$self{aldb}{$linkkey}{group}; + my $is_controller = $$self{aldb}{$linkkey}{is_controller}; + my $data3 = $$self{aldb}{$linkkey}{data3}; + my $device = &Insteon::get_object($deviceid,'01'); + # if a PLM link (regardless of responder or controller) exists to a device that is not known, then delete + if (!($device)) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $self, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } else { + my $is_invalid = 1; + my $link = undef; + if ($is_controller) { + # then, this is a PLM defined link; and, we won't care about responder links as we assume + # they're ok given that they reference known devices + $link = &Insteon::get_object('000000',$group); + if (!($link)) { + # a reference in the PLM's linktable does not match a scene member target + $is_invalid = 1; + } else { + # iterate over all of the members of the Insteon_Link item + foreach my $member_ref (keys %{$$link{members}}) { + my $member = $$link{members}{$member_ref}{object}; + # member will correspond to a scene member item + # and, if it is a light item, then get the real device + if ($member->isa('Light_Item')) { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) { + $member = @lights[0]; # pick the first + } + } + if ($member->isa('Insteon::BaseDevice')) { + my $linkmember = $member; + # make sure that this is a root device + if (!($member->is_root)) { + $member = $member->get_root; + } + if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) { + # at this point, the forward link is ok; but, only if the reverse + # link also exists. So, check: + if ($member->has_link($self, $group, 0, $data3)) { + $is_invalid = 0; + } + last; + } + } else { + $is_invalid = 0; + } + } + if ($is_invalid) { + # then, there is a good chance that a reciprocal link exists; if so, delet it too + if ($device->has_link($self,$group,0, $data3)) { + my %delete_req = (object => $self, group => $group, is_controller => 0, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $device, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } + } + } + if ($is_invalid) { + my %delete_req = (object => $device, group => $group, is_controller => 1, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $self, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } + } + } + } + + $$self{delete_queue_processed} = 0; # reset the counter + + # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links + for my $obj ($self->find_members('Insteon::BaseObject')) + { + #Match on real objects only + if (($obj->is_root)) + { + $num_deleted += $obj->delete_orphan_links(); + my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); + push @{$$self{delete_queue}}, \%delete_req; + } + } + $self->_process_delete_queue(); +} + +sub _process_delete_queue { + my ($self, $p_num_deleted) = @_; + $$self{delete_queue_processed} += $p_num_deleted if $p_num_deleted; + my $num_in_queue = @{$$self{delete_queue}}; + if ($num_in_queue) { + my $delete_req_ptr = shift(@{$$self{delete_queue}}); + my %delete_req = %$delete_req_ptr; + # distinguish between deleting PLM links and processing delete orphans for a root item + if ($delete_req{'root_object'}) { + $delete_req{'root_object'}->delete_orphan_links(); + } else { + if ($delete_req{linkdevice} eq $self) { + &::print_log("[Insteon::ALDB_PLM] now deleting orphaned link w/ details: " + . (($delete_req{is_controller}) ? "controller" : "responder") + . ", " . (($delete_req{object}) ? "object=" . $delete_req{object}->get_object_name + : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}") + if $main::Debug{insteon}; + $self->delete_link(%delete_req); + } elsif ($delete_req{linkdevice}) { + $delete_req{linkdevice}->delete_link(%delete_req); + } + } + } else { + &::print_log("[Insteon::ALDB_PLM] A total of $$self{delete_queue_processed} orphaned link records were deleted."); + } + +} + +sub delete_link +{ + # linkkey is concat of: deviceid, group, is_controller + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + my $num_deleted = 0; + my $insteon_object = $link_parms{object}; + my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; + my $group = $link_parms{group}; + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + my $linkkey = lc $deviceid . $group . (($is_controller) ? '1' : '0'); + if (defined $$self{aldb}{$linkkey}) { + my $cmd = '80' + . $$self{aldb}{$linkkey}{flags} + . $$self{aldb}{$linkkey}{group} + . $$self{aldb}{$linkkey}{deviceid} + . $$self{aldb}{$linkkey}{data1} + . $$self{aldb}{$linkkey}{data2} + . $$self{aldb}{$linkkey}{data3}; + $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; + delete $$self{aldb}{$linkkey}; + $num_deleted = 1; + my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); + $message->interface_data($cmd); + $$self{device}->queue_message($message); + } else { + &::print_log("[Insteon::ALDB_PLM] no entry in linktable could be found for linkkey: $linkkey"); + if ($link_parms{callback}) { + package main; + eval ($link_parms{callback}); + &::print_log("[Insteon_PLM] error in add link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + } + return $num_deleted; +} + +sub add_link +{ + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + my $device_id; + my $group = ($link_parms{group}) ? $link_parms{group} : '01'; + my $insteon_object = $link_parms{object}; + if (!(defined($insteon_object))) { + $device_id = lc $link_parms{deviceid}; + $insteon_object = &Insteon::get_object($device_id, $group); + } else { + $device_id = lc $insteon_object->device_id; + } + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + # first, confirm that the link does not already exist + my $linkkey = lc $device_id . $group . $is_controller; + if (defined $$self{aldb}{$linkkey}) { + &::print_log("[Insteon::ALDB_PLM] WARN: attempt to add link to PLM that already exists! " + . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); + if ($link_parms{callback}) { + package main; + eval ($link_parms{callback}); + &::print_log("[Insteon_PLM] error in add link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + } else { + my $control_code = ($is_controller) ? '40' : '41'; + # flags should be 'a2' for responder and 'e2' for controller + my $flags = ($is_controller) ? 'E2' : 'A2'; + my $data1 = (defined $link_parms{data1}) ? $link_parms{data1} : (($is_controller) ? '01' : '00'); + my $data2 = (defined $link_parms{data2}) ? $link_parms{data2} : '00'; + my $data3 = (defined $link_parms{data3}) ? $link_parms{data3} : '00'; + # from looking at manually linked records, data1 and data2 are both 00 for responder records + # and, data1 is 01 and usually data2 is 00 for controller records + + my $cmd = $control_code + . $flags + . $group + . $device_id + . $data1 + . $data2 + . $data3; + $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; + $$self{aldb}{$linkkey}{flags} = lc $flags; + $$self{aldb}{$linkkey}{group} = lc $group; + $$self{aldb}{$linkkey}{is_controller} = $is_controller; + $$self{aldb}{$linkkey}{deviceid} = lc $device_id; + $$self{aldb}{$linkkey}{data1} = lc $data1; + $$self{aldb}{$linkkey}{data2} = lc $data2; + $$self{aldb}{$linkkey}{data3} = lc $data3; + my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); + $message->interface_data($cmd); + $$self{device}->queue_message($message); + } +} + + + + +1; diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm new file mode 100755 index 000000000..5a03d4fe8 --- /dev/null +++ b/lib/Insteon/BaseInsteon.pm @@ -0,0 +1,1426 @@ +=begin comment +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +File: + BaseInsteon.pm + +Description: + Generic class implementation of an Insteon Device. + +Author(s): + Gregg Liming / gregg@limings.net + +License: + This free software is licensed under the terms of the GNU public license. + +Usage: + + $ip_patio_light = new Insteon_Device($myPLM,"33.44.55"); + + $ip_patio_light->set("ON"); + +Special Thanks to: + Brian Warren for significant testing and patches + Bruce Winter - MH + +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +=cut + +package Insteon::BaseObject; + +use strict; +use Insteon; +use Insteon::AllLinkDatabase; +use Insteon::Message; + +@Insteon::BaseObject::ISA = ('Generic_Item'); + +our %message_types = ( + on => 0x11, + off => 0x13 +); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + my $self={}; + bless $self,$class; + + $$self{message_types} = \%message_types; + + if (defined $p_deviceid) { + my ($deviceid, $group) = $p_deviceid =~ /(\w\w\.\w\w\.\w\w):?(.+)?/; + # if a group is passed in, then assume it can be a controller + $$self{is_controller} = ($group) ? 1 : 0; + $self->device_id($deviceid); + $group = '01' unless $group; + $group = '0' . $group if length($group) == 1; + $self->group(uc $group); + } + + if ($p_interface) { + $self->interface($p_interface); + } else { + $self->interface(&Insteon::active_interface()); + } + + $self->restore_data('level'); + + $self->initialize(); + $$self{level} = undef; + $$self{flag} = "0F"; + $$self{ackMode} = "1"; + $$self{awaiting_ack} = 0; + $$self{is_acknowledged} = 0; + $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; + $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack + @{$$self{command_stack}} = (); + $$self{_onlevel} = undef; + $$self{is_responder} = 1; + + &Insteon::add($self); + return $self; +} + +sub initialize +{ + my ($self) = @_; + $$self{m_write} = 1; + $$self{m_is_locally_set} = 0; + # persist local, simple attribs + + # do we really need to ping the devices anymore for a devcat? + $$self{ping_timer} = new Timer(); + $$self{ping_timerTime} = 300; +# $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self) +# unless $self->group eq '01' and defined $self->devcat; +} + +sub interface +{ + my ($self,$p_interface) = @_; + if (defined $p_interface) { + $$self{interface} = $p_interface; + } + return $$self{interface}; +} + +sub device_id +{ + my ($self,$p_device_id) = @_; + + if (defined $p_device_id) + { + $p_device_id =~ /(\w\w)\W?(\w\w)\W?(\w\w)/; + $$self{device_id}=$1 . $2 . $3; + } + return $$self{device_id}; +} + +sub group +{ + my ($self, $p_group) = @_; + $$self{m_group} = $p_group if $p_group; + return $$self{m_group}; +} + +sub set +{ + my ($self,$p_state,$p_setby,$p_response) = @_; + return if &main::check_for_tied_filters($self, $p_state); + + # Override any set_with_timer requests + if ($$self{set_timer}) { + &Timer::unset($$self{set_timer}); + delete $$self{set_timer}; + } + + # did the queue timer go off? + if (ref $p_setby and $p_setby eq $$self{ping_timer}) { + if (! (defined($$self{devcat}))) { + $self->ping(); + # set the timer again in case nothing occurs + $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self); + } + } elsif ($self->_is_valid_state($p_state)) { + # always reset the is_locally_set property unless set_by is the device + $$self{m_is_locally_set} = 0 unless ref $p_setby and $p_setby eq $self; + + # handle invalid state for non-dimmable devices + if (($p_state eq 'dim' or $p_state eq 'bright') and !($self->isa('Insteon::DimmableLight'))) { + $p_state = 'on'; + } + + if (ref $p_setby and (($p_setby eq $self->interface()) + or (($p_setby->isa('Insteon::BaseObject')) + and (($p_setby eq $self) + or (&main::set_by_to_target($p_setby) eq $self->interface))))) + { + # don't reset the object w/ the same state if set from the interface + return if (lc $p_state eq lc $self->state) and $self->is_acknowledged + and not(($p_setby->isa('Insteon::BaseObject') and ($p_setby eq $self))); + &::print_log("[Insteon::BaseObject] " . $self->get_object_name() + . "::set($p_state, $p_setby)") if $main::Debug{insteon}; + $self->set_receive($p_state,$p_setby,$p_response) if defined $p_state; + } else { + my $message = $self->derive_message($p_state); + $self->_send_cmd($message); + +# $self->_send_cmd(command => $p_state, +# type => (($self->isa('Insteon::Insteon_Link') and !($self->is_root)) ? 'alllink' : 'standard')); + &::print_log("[Insteon::BaseObject] " . $self->get_object_name() . "::set($p_state, $p_setby)") + if $main::Debug{insteon}; + $self->is_acknowledged(0); + $$self{pending_state} = $p_state; + $$self{pending_setby} = $p_setby; + $$self{pending_response} = $p_response; + } + $self->level($p_state) if $self->isa("Insteon::BaseDevice"); # update the level value +# $self->SUPER::set($p_state,$p_setby,$p_response) if defined $p_state; + } else { + &::print_log("[Insteon::BaseObject] failed state validation with state=$p_state"); + } +} + +sub is_acknowledged +{ + my ($self, $p_ack) = @_; + $$self{is_acknowledged} = $p_ack if defined $p_ack; + if ($p_ack) { + $self->set_receive($$self{pending_state},$$self{pending_setby}, $$self{pending_response}) if defined $$self{pending_state}; + $$self{pending_state} = undef; + $$self{pending_setby} = undef; + $$self{pending_response} = undef; + } + return $$self{is_acknowledged}; +} + +sub set_receive +{ + my ($self, $p_state, $p_setby, $p_response) = @_; + $self->SUPER::set($p_state, $p_setby, $p_response); +} + +sub set_with_timer { + my ($self, $state, $time, $return_state, $additional_return_states) = @_; + return if &main::check_for_tied_filters($self, $state); + + $self->set($state) unless $state eq ''; + + return unless $time; + + my $state_change = ($state eq 'off') ? 'on' : 'off'; + $state_change = $return_state if defined $return_state; + $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; + + $state_change .= ';' . $additional_return_states if $additional_return_states; + + $$self{set_timer} = &Timer::new() unless $$self{set_timer}; + my $object_name = $self->{object_name}; + my $action = "$object_name->set('$state_change')"; + $$self{set_timer}->set($time, $action); +} + +sub _send_cmd +{ + my ($self, $message) = @_; +# $msg{type} = 'standard' unless $msg{type}; + +# my $message = $self->derive_message($msg{command},$msg{type},$msg{extra}); + + if ($message->command eq 'peek' + or $message->command eq 'poke' + or $message->command eq 'status_request' + or $message->command eq 'do_read_ee' + or $message->command eq 'set_address_msb' + ) + { + push(@{$$self{command_stack}}, $message); + } + else + { + unshift(@{$$self{command_stack}},$message); + } + $self->_process_command_stack(); +} + +sub derive_message +{ + my ($self, $p_command, $p_extra) = @_; + my @args; + my $level; + + #msg id + my ($command, $subcommand) = split(/:/, $p_command, 2); + $command=lc($command); +# &::print_log("XLATE:$msg:$substate:$p_state:"); + + my $message; + + if ($self->isa("Insteon::BaseController")) + { + # only send out as all-link if the link originates from the plm + if ($self->isa("Insteon::InterfaceController")) + { # return the size of the command stack + $message = new Insteon::InsteonMessage('all_link_send', $self); + } + elsif ($self->is_root) + { # return the size of the command stack + $message = new Insteon::InsteonMessage('insteon_send', $self); + } else { + # silently ignore as this is now permitted if via "surrogate" + } + } elsif ($self->isa("Insteon::BaseObject")) { + $message = new Insteon::InsteonMessage('insteon_send', $self); + } + + if (!(defined $p_extra)) { + if ($command eq 'on') + { + if ($self->isa('Insteon::BaseDevice') && defined $self->local_onlevel) { + $level = 2.55 * $self->local_onlevel; + $command = 'on_fast'; + } else { + $level=255; + } + } elsif ($command eq 'off') + { + $level = 0; + } elsif ($command=~/^([1]?[0-9]?[0-9])/) + { + if ($1 < 1) { + $command='off'; + $level = 0; + } else { + $level = ($self->isa('Insteon::DimmableLight')) ? $1 * 2.55 : 255; + $command='on'; + } + } + } + + # confirm that the resulting $msg is legitimate + if (!(defined($self->message_type_code($command)))) { + &::print_log("[Insteon::BaseInsteon] invalid state=$command") if $main::Debug{insteon}; + return undef; + } + + if ($p_extra) + { $message->extra($p_extra); + + } elsif ($subcommand) { + $message->extra($subcommand); + } else { + if ($command eq 'on') + { + $message->extra(sprintf("%02X",$level)); + } else { + $message->extra('00'); + } + } + + $message->command($command); + return $message; +} + +sub message_type_code +{ + my ($self, $msg) = @_; + my $msg_type_ptr = $$self{message_types}; + my %msg_types = %$msg_type_ptr; + my $code = $msg_types{$msg}; + return $code; +} + +sub message_type +{ + my ($self, $cmd1) = @_; + my $msg_type; + my $msg_type_ptr = $$self{message_types}; + my %msg_types = %$msg_type_ptr; + for my $key (keys %msg_types){ + if (pack("C",$msg_types{$key}) eq pack("H*",$cmd1)) + { +# &::print_log("[Insteon::BaseObject] found: $key"); + $msg_type=$key; + last; + } + } + return $msg_type; +} + +sub _is_info_request +{ + my ($self, $cmd, $ack_setby, %msg) = @_; + my $is_info_request = ($cmd eq 'status_request') ? 1 : 0; +#print "cmd: $cmd; is_info_request: $is_info_request\n"; + if ($is_info_request) { + my $ack_on_level = (hex($msg{extra}) >= 254) ? 100 : sprintf("%d", hex($msg{extra}) * 100 / 255); + &::print_log("[Insteon::BaseObject] received status for " . + $self->{object_name} . " with on-level: $ack_on_level%, " + . "hops left: $msg{hopsleft}") if $main::Debug{insteon}; + $self->level($ack_on_level); # update the level value + if ($ack_on_level == 0) { + $self->SUPER::set('off', $ack_setby); + } elsif ($ack_on_level > 0 and !($self->isa('Insteon::DimmableLight'))) { + $self->SUPER::set('on', $ack_setby); + } else { + $self->SUPER::set($ack_on_level . '%', $ack_setby); + } + # if this were a scene controller, then also propogate the result to all members + } + return $is_info_request; + +} + +sub _process_message +{ + my ($self,$p_setby,%msg) = @_; + my $p_state = undef; + + # the current approach assumes that links from other controllers to some responder + # would be seen by the plm by also direct linking the controller as a responder + # and not putting the plm into monitor mode. This means that updating the state + # of the responder based upon the link controller's request is handled + # by Insteon_Link. + $$self{m_is_locally_set} = 1 if $msg{source} eq lc $self->device_id; + if ($msg{is_ack}) { + my $pending_cmd = ($$self{_prior_msg}) ? $$self{_prior_msg}->command : $msg{command}; + if ($$self{awaiting_ack}) { + my $ack_setby = (ref $$self{m_status_request_pending}) + ? $$self{m_status_request_pending} : $p_setby; + if ($self->_is_info_request($pending_cmd,$ack_setby,%msg)) { + $self->is_acknowledged(1); + $$self{m_status_request_pending} = 0; + $self->_process_command_stack(%msg); + } elsif (($pending_cmd eq 'peek') or ($pending_cmd eq 'set_address_msb')) { + $self->_aldb->_on_peek(%msg) if $self->_aldb; + $self->_process_command_stack(%msg); + } elsif (($pending_cmd eq 'poke') or ($pending_cmd eq 'set_address_msb')) { + $self->_aldb->_on_poke(%msg) if $self->_aldb; + $self->_process_command_stack(%msg); + } else { + $self->is_acknowledged(1); + # signal receipt of message to the command stack in case commands are queued + $self->_process_command_stack(%msg); + &::print_log("[Insteon::BaseObject] received command/state (awaiting) acknowledge from " . $self->{object_name} + . ": $pending_cmd and data: $msg{extra}") if $main::Debug{insteon}; + } + } else { + # allow non-synchronous messages to also use the _is_info_request hook + $self->_is_info_request($pending_cmd,$p_setby,%msg); + $self->is_acknowledged(1); + # signal receipt of message to the command stack in case commands are queued + $self->_process_command_stack(%msg); + &::print_log("[Insteon::BaseObject] received command/state acknowledge from " . $self->{object_name} + . ": " . (($msg{command}) ? $msg{command} : "(unknown)") + . " and data: $msg{extra}") if $main::Debug{insteon}; + } + } elsif ($msg{is_nack}) { + if ($$self{awaiting_ack}) { + # NOTE!!! NACKs are usually a sign of a burnt-out bulb!! + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + . " ... waiting for retry"); + } else { + if ($self->isa('Insteon::BaseLight')) + { + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + . ". It may be unplugged or have a burned out bulb") if $main::Debug{insteon}; + } + else + { + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + . " ... skipping"); + } + $self->is_acknowledged(0); + $self->_process_command_stack(%msg); + } + } elsif ($msg{command} eq 'start_manual_change') { + # do nothing; although, maybe anticipate change? we should always get a stop + } elsif ($msg{command} eq 'stop_manual_change') { + # request status so that the final state can be known + $self->request_status($self); + } elsif ($msg{type} eq 'broadcast') { + $self->devcat($msg{devcat}); + &::print_log("[Insteon::BaseObject] device category: $msg{devcat} received for " . $self->{object_name}); + # stop ping timer now that we have a devcat; possibly may want to change this behavior to allow recurring pings + $$self{ping_timer}->stop(); + } else { + ## TO-DO: make sure that the state passed by command is something that is reasonable to set + $p_state = $msg{command}; + if ($msg{type} eq 'alllink') + { + $$self{_pending_cleanup} = 1; + } + elsif ($msg{type} eq 'cleanup') + { + $self->set($p_state, $self); # unless (lc($self->state) eq lc($p_state)) and + # ($msg{type} eq 'cleanup' and $$self{_pending_cleanup}); + $$self{_pending_cleanup} = 0; + } + } +} + +sub _process_command_stack +{ + my ($self, %ackmsg) = @_; + if (%ackmsg) { # which may also be something that can be interpretted as a "nack" + # determine whether to unset awaiting_ack + # for now, be "dumb" and just unset it + $$self{awaiting_ack} = 0; + } + if (!($$self{awaiting_ack})) { + my $callback = undef; + my $message = pop(@{$$self{command_stack}}); + # convert ptr to cmd hash + if ($message) + { + my $plm_queue_size = $self->interface->queue_message($message); + + # send msg + if ($message->command eq 'peek' + or $message->command eq 'poke' + or $message->command eq 'status_request' + or $message->command eq 'do_read_ee' + or $message->command eq 'set_address_msb' + ) + { + $$self{awaiting_ack} = 1; + } + else + { + $$self{awaiting_ack} = 0; + } + + $$self{_prior_msg} = $message; + # TO-DO: adjust timer based upon (1) type of message and (2) retry_count + my $queue_time = $$self{max_queue_time} + $plm_queue_size; + # if is_synchronous, then no other command can be sent until an insteon ack or nack is received + # for this command + } else { + # and, always clear awaiting_ack and _prior_msg + $$self{awaiting_ack} = 0; + $$self{_prior_msg} = undef; + } + if ($callback) { + package main; + eval ($callback); + &::print_log("[Insteon::BaseObject] error in queue timer callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon::BaseObject; + } + } else { +# &::print_log("[Insteon_Device] " . $self->get_object_name . " command queued but not yet sent; awaiting ack from prior command") if $main::Debug{insteon}; + } +} + +sub _is_valid_state +{ + my ($self,$state) = @_; + if (!(defined($state)) or $state eq '') { + return 0; + } + + my ($msg, $substate) = split(/:/, $state, 2); + $msg=lc($msg); + + if ($msg=~/^([1]?[0-9]?[0-9])/) + { + if ($1 < 1) { + $msg='off'; + } else { + $msg='on'; + } + } + + # confirm that the resulting $msg is legitimate + if (!(defined($message_types{$msg}))) { + return 0; + } else { + return 1; + } +} + + +#################################### +### ##################### +### BaseObject ##################### +### ##################### +#################################### + +package Insteon::BaseDevice; + +use strict; +use Insteon; +use Insteon::AllLinkDatabase; + +@Insteon::BaseDevice::ISA = ('Insteon::BaseObject'); + +our %message_types = ( + %Insteon::BaseObject::message_types, + assign_to_group => 0x01, + delete_from_group => 0x02, + linking_mode => 0x09, + unlinking_mode => 0x0A, + ping => 0x10, + on_fast => 0x12, + off_fast => 0x14, + start_manual_change => 0x17, + stop_manual_change => 0x18, + status_request => 0x19, + get_operating_flags => 0x1f, + set_operating_flags => 0x20, + do_read_ee => 0x24, + remote_set_button_tap => 0x25, + set_led_status => 0x27, + set_address_msb => 0x28, + poke => 0x29, + poke_extended => 0x2a, + peek => 0x2b, + peek_internal => 0x2c, + poke_internal => 0x2d +); + + +my %operating_flags = ( + 'program_lock_on' => '00', + 'program_lock_off' => '01', + 'led_on_during_tx' => '02', + 'led_off_during_tx' => '03', + 'resume_dim_on' => '04', + 'beeper_enabled' => '04', + 'resume_dim_off' => '05', + 'beeper_off' => '05', + 'eight_key_kpl' => '06', + 'load_sense_on' => '06', + 'six_key_kpl' => '07', + 'load_sense_off' => '07', + 'led_backlight_off' => '08', + 'led_off' => '08', + 'led_backlight_on' => '09', + 'led_enabled' => '09', + 'key_beep_enabled' => '0a', + 'one_minute_warn_disabled' => '0a', + 'key_beep_off' => '0b', + 'one_minute_warn_enabled' => '0b' +); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + my $self= new Insteon::BaseObject($p_deviceid,$p_interface); + bless $self,$class; + + $$self{message_types} = \%message_types; + + if ($self->group eq '01') { + $$self{aldb} = new Insteon::ALDB_i1($self); + } + + $self->restore_data('level'); + + $self->initialize(); + $self->rate(undef); + $$self{level} = undef; + $$self{flag} = "0F"; + $$self{ackMode} = "1"; + $$self{awaiting_ack} = 0; + $$self{is_acknowledged} = 0; + $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; + $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack + @{$$self{command_stack}} = (); + $$self{_onlevel} = undef; + $$self{is_responder} = 1; + + return $self; +} + +sub initialize +{ + my ($self) = @_; + $$self{m_write} = 1; + $$self{m_is_locally_set} = 0; + # persist local, simple attribs + + # do we really need to ping the devices anymore for a devcat? + $$self{ping_timer} = new Timer(); + $$self{ping_timerTime} = 300; +} + +sub rate +{ + my ($self,$p_rate) = @_; + $$self{rate} = $p_rate if defined $p_rate; + return $$self{rate}; +} + +sub set_receive +{ + my ($self, $p_state, $p_setby, $p_response) = @_; + $self->level($p_state) if $self->can('level'); # update the level value + $self->SUPER::set_receive($p_state, $p_setby, $p_response); +} + +sub is_controller +{ + my ($self) = @_; + return $$self{is_controller}; +} + +sub is_responder +{ + my ($self,$is_responder) = @_; + $$self{is_responder} = $is_responder if defined $is_responder; + if ($self->is_root) { + return $$self{is_responder}; + } else { + my $root_obj = $self->get_root(); + if (ref $root_obj) { + return $$root_obj{is_responder}; + } else { + return 0; + } + } +} + +sub link_to_interface +{ + my ($self,$p_group, $p_data3) = @_; + my $group = $p_group; + $group = '01' unless $group; + # add a link first to this device back to interface + # and, add a reference to creating a link from interface back to device via hook + my $callback_instance = $self->interface->get_object_name; + my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; + my %link_info = ( object => $self->interface, group => $group, is_controller => 1, + on_level => '100%', ramp_rate => '0.1s', + callback => "$callback_instance->add_link('$callback_info')"); + $link_info{data3} = $p_data3 if $p_data3; + if ($self->_aldb) { + $self->_aldb->add_link(%link_info); + } else { + &main::print_log("[BaseInsteon] This item " . $self->get_object_name . + " does not have an ALDB object. Linking is not permitted."); + } +} + +sub unlink_to_interface +{ + my ($self,$p_group) = @_; + my $group = $p_group; + $group = '01' unless $group; + my $callback_instance = $self->interface->get_object_name; + my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; + if ($self->_aldb) { + $self->_aldb->delete_link(object => $self->interface, group => $group, is_controller => 1, + callback => "$callback_instance->delete_link('$callback_info')"); + } else { + &main::print_log("[BaseInsteon] This item " . $self->get_object_name . + " does not have an ALDB object. Unlinking is not permitted."); + } +} + + +sub _aldb +{ + my ($self) = @_; + return $$self{aldb}; +} + + +sub set_operating_flag { + my ($self, $flag) = @_; + + if (!(exists($operating_flags{$flag}))) { + &::print_log("[Insteon::BaseDevice] $flag is not a support operating flag"); + return; + } + + if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { + # TO-DO: check devcat to determine if the action is supported by the device + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_operating_flags'); + $message->extra($operating_flags{$flag}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'set_operating_flags', 'extra' => $operating_flags{$flag}); + } else { + &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); + return; + } +} + +sub get_operating_flag { + my ($self) = @_; + + if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { + # TO-DO: check devcat to determine if the action is supported by the device + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'get_operating_flags'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'get_operating_flags'); + } else { + &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); + return; + } +} + +sub writable { + my ($self, $p_write) = @_; + if (defined $p_write) { + if ($p_write =~ /r/i or $p_write =~/^0/) { + $$self{m_write} = 0; + } else { + $$self{m_write} = 1; + } + } + return $$self{m_write}; +} + +sub is_locally_set { + my ($self) = @_; + return $$self{m_is_locally_set}; +} + + +sub is_root { + my ($self) = @_; + return (($self->group eq '01') and !($self->isa('Insteon::InterfaceController'))) ? 1 : 0; +} + +sub get_root { + my ($self) = @_; + if ($self->is_root) { + return $self; + } else { + return &Insteon::get_object($self->device_id, '01'); + } +} + + +### WARN: Testing using the following does not produce results as expected. Use at your own risk. [GL] +sub remote_set_button_tap +{ + my ($self,$p_number_taps) = @_; + my $taps = ($p_number_taps =~ /2/) ? '02' : '01'; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'remote_set_button_tap'); + $message->extra($taps); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'remote_set_button_tap', 'extra' => $taps); +} + +sub request_status +{ + my ($self, $requestor) = @_; + $$self{m_status_request_pending} = ($requestor) ? $requestor : 1; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'status_request'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'status_request', 'is_synchronous' => 1); +} + +sub ping +{ + my ($self) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'ping'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'ping'); +} + +sub set_led_status +{ + my ($self, $status_mask) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_led_status'); + $message->extra($status_mask); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'set_led_status', 'extra' => $status_mask); +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = $self->SUPER::restore_string(); + if ($self->_aldb) { + $restore_string .= $self->_aldb->restore_string(); + } + if ($$self{states}) { + my $states = ''; + foreach my $state (@{$$self{states}}) { + $states .= '|' if $states; + $states .= $state; + } + $restore_string .= $self->{object_name} . "->restore_states(q~$states~);\n"; + } + return $restore_string; +} + +sub restore_states +{ + my ($self, $states) = @_; + if ($states) { + @{$$self{states}} = split(/\|/,$states); + } +} + +sub restore_aldb +{ + my ($self,$aldb) = @_; + if ($self->_aldb and $aldb) { + $self->_aldb->restore_aldb($aldb); + } +} + +sub devcat +{ + my ($self, $devcat) = @_; + if ($devcat) { + $$self{devcat} = $devcat; + if (($$self{devcat} =~ /^01\w\w/) or ($$self{devcat} =~ /^02\w\w/) && !($self->states)) { + $self->states( 'on,off' ); + } + } + return $$self{devcat}; +} + +sub states +{ + my ($self, $states) = @_; + if ($states) { + @{$$self{states}} = split(/,/,$states); + } + if ($$self{states}) { + return @{$$self{states}}; + } else { + return undef; + } + +} + + +sub local_onlevel +{ + my ($self, $p_onlevel) = @_; + if (defined $p_onlevel) { + my ($onlevel) = $p_onlevel =~ /(\d+)%?/; + $$self{_onlevel} = $onlevel; + } + return $$self{_onlevel}; +} + +sub local_ramprate +{ + my ($self, $p_ramprate) = @_; + if (defined $p_ramprate) { + $$self{_ramprate} = &Insteon::BaseDevice::convert_ramp($p_ramprate); + } + return $$self{_ramprate}; + +} + + +sub scan_link_table +{ + my ($self,$callback) = @_; + $self->_aldb->scan_link_table($callback) if $self->_aldb; +} + +sub delete_orphan_links +{ + my ($self) = @_; + return $self->_aldb->delete_orphan_links if $self->_aldb; +} + +sub _process_delete_queue { + my ($self) = @_; + $self->_aldb->_process_delete_queue() if $self->_aldb; +} + +sub log_alllink_table +{ + my ($self) = @_; + $self->_aldb->log_alllink_table if $self->_aldb; +} + +sub update_local_properties +{ + my ($self) = @_; + if ($self->isa('Insteon::DimmableLight')) { + $self->_aldb->update_local_properties() if $self->_aldb; + } else { + &::print_log("[Insteon::BaseDevice] update_local_properties may only be applied to dimmable devices!"); + } +} + +sub update_flags +{ + my ($self, $flags) = @_; + if (!($self->isa('Insteon::KeyPadLinc') or $self->isa('Insteon::KeyPadLincRelay'))) { + &::print_log("[Insteon::BaseDevice] Operating flags may only be revised on keypadlincs!"); + return; + } + return unless defined $flags; + + $self->_aldb->update_flags($flags) if $self->_aldb; +} + + +#################################### +### ################# +### BaseController ################# +### ################# +#################################### + +package Insteon::BaseController; + +use strict; +use Insteon; + +@Insteon::BaseController::ISA = ('Generic_Item'); + +sub new +{ + my ($class,$p_deviceid,$p_interface,$p_devcat) = @_; + + # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller + my $self = {}; + bless $self,$class; +# don't apply ping timer to this class +# $$self{ping_timer}->stop(); + return $self; +} + +sub add +{ + my ($self, $obj, $on_level, $ramp_rate) = @_; + if (ref $obj and ($obj->isa('Light_Item') or $obj->isa('Insteon::BaseDevice'))) { + if ($$self{members} && $$self{members}{$obj}) { + print "[Insteon_Link] An object (" . $obj->{object_name} . ") already exists " + . "in this scene. Aborting add request.\n"; + return; + } + if ($on_level =~ /^sur/i) { + $on_level = '100%'; + $$obj{surrogate} = $self; + } elsif (lc $on_level eq 'on') { + $on_level = '100%'; + } elsif (lc $on_level eq 'off') { + $on_level = '0%'; + } + $on_level = '100%' unless $on_level; + $$self{members}{$obj}{on_level} = $on_level; + $$self{members}{$obj}{object} = $obj; + $ramp_rate =~ s/s$//i; + $$self{members}{$obj}{ramp_rate} = $ramp_rate if defined $ramp_rate; + } else { + &::print_log("[Insteon_Link] WARN: unable to add $obj as items of this type are not supported!"); + } +} + +sub sync_links +{ + my ($self, $callback) = @_; + @{$$self{sync_queue}} = (); # reset the work queue + $$self{sync_queue_callback} = ($callback) ? $callback : undef; + my $insteon_object = $self->interface; + if (!($self->isa('Insteon::InterfaceController'))) { + $insteon_object = &Insteon::get_object($self->device_id,'01'); + if (!(defined($insteon_object))) { + &main::print_log("[Insteon_Link] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " + . "Please double check your items.mht file."); + } + } + my $self_link_name = $self->get_object_name; + # abort if $insteon_object doesn't exist + $self->_process_sync_queue() unless $insteon_object; + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my $member = $$self{members}{$member_ref}{object}; + # find real device if member is a Light_Item + if ($member->isa('Light_Item')) { + my @children = $member->find_members('Insteon::BaseDevice'); + $member = $children[0]; + } + my $linkmember = $member; + # find real device if member's group is not '01'; for example, cross-linked KeypadLincs + if ($member->group ne '01') { + $member = &Insteon::get_object($member->device_id,'01'); + } + my $tgt_on_level = $$self{members}{$member_ref}{on_level}; + $tgt_on_level = '100%' unless defined $tgt_on_level; + + my $tgt_ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $tgt_ramp_rate = '0' unless defined $tgt_ramp_rate; + # first, check existance for each link; if found, then perform an update (unless link is to PLM) + # if not, then add the link + if ($member->has_link($insteon_object, $self->group, 0, $linkmember->group)) { + # TO-DO: only update link if the on_level and ramp_rate are different + my $requires_update = 0; + $tgt_on_level =~ s/(\d+)%?/$1/; + $tgt_ramp_rate =~ s/(\d)s?/$1/; + my $adlbkey = lc $insteon_object->device_id . $self->group . '0'; + if (($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + and $linkmember->group ne '01') { + $adlbkey .= $linkmember->group; + } + if (!($member->isa('Insteon::DimmableLight'))) { + if ($tgt_on_level >= 1 and $$member{adlb}{$adlbkey}{data1} ne 'ff') { + $requires_update = 1; + $tgt_on_level = 100; + } elsif ($tgt_on_level == 0 and $$member{adlb}{$adlbkey}{data1} ne '00') { + $requires_update = 1; + } + if ($$member{adlb}{$adlbkey}{data2} ne '00') { + $tgt_ramp_rate = 0; + } + } else { + $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; + my $link_on_level = hex($$member{adlb}{$adlbkey}{data1})/2.55; + my $raw_ramp_rate = $$member{adlb}{$adlbkey}{data2}; + my $raw_tgt_ramp_rate = &Insteon::BaseDevice::convert_ramp($tgt_ramp_rate); + if ($raw_ramp_rate != $raw_tgt_ramp_rate) { + $requires_update = 1; + } elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) { + $requires_update = 1; + } + } + if ($requires_update) { + my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, + group => $self->group, is_controller => 0, + on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } + } else { + my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, + group => $self->group, is_controller => 0, + on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } + if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) { + my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, + group => $self->group, is_controller => 1, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } + } + } + # if not a plm controlled link, then confirm that a link back to the plm exists + if (!($self->isa('Insteon::InterfaceController'))) { + my $subaddress = ($self->isa('Insteon::KeyPadLincRelay') or $self->isa('Insteon::KeyPadLinc')) ? $self->group : '00'; + if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) { + my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, + group => $self->group, is_controller => 1, + callback => "$self_link_name->_process_sync_queue()" ); + $link_req{data3} = $self->group if $insteon_object->isa('Insteon::KeyPadLincRelay') or $insteon_object->isa('Insteon::KeyPadLinc'); + push @{$$self{sync_queue}}, \%link_req; + } + if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) { + my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, + group => $self->group, is_controller => 0, + callback => "$self_link_name->_process_sync_queue()" ); + push @{$$self{sync_queue}}, \%link_req; + } + } + my $num_sync_queue = @{$$self{sync_queue}}; + if (!($num_sync_queue)) { + &::print_log("[Insteon_Link] Nothing to do when syncing links for " . $self->get_object_name) + if $main::Debug{insteon}; + } + $self->_process_sync_queue(); + + # TO-DO: consult links table to determine if any "orphaned links" refer to this device; if so, then delete + # WARN: can't immediately do this as the link tables aren't finalized on the above operations + # until the end of the actual insteon memory poke sequences; therefore, may need to handle separately +} + +sub _process_sync_queue { + my ($self) = @_; + # get next in queue if it exists + my $num_sync_queue = @{$$self{sync_queue}}; + if ($num_sync_queue) { + my $link_req_ptr = shift(@{$$self{sync_queue}}); + my %link_req = %$link_req_ptr; + if ($link_req{cmd} eq 'update') { + my $link_member = $link_req{member}; + $link_member->update_link(%link_req); + } elsif ($link_req{cmd} eq 'add') { + my $link_member = $link_req{member}; + $link_member->add_link(%link_req); + } + } elsif ($$self{sync_queue_callback}) { + package main; + eval ($$self{sync_queue_callback}); + &::print_log("[Insteon_Link] error in sync links callback: " . $@) + if $@ and $main::Debug{insteon}; + $$self{sync_queue_callback} = undef; + package Insteon::Insteon_link; + } +} + +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + # prevent reciprocal setby loops + return if (ref $p_setby and ($p_setby ne $self) and $p_setby->can('get_set_by') and + $p_setby->{set_by} eq $self); + return if &main::check_for_tied_filters($self, $p_state); + + # prevent setby internal Insteon_Device timers + return if $p_setby eq $$self{ping_timer}; + + my $link_state = 'on'; + if ($p_state eq 'off') { + $link_state = 'off'; + } elsif ($p_state =~ /\d+%?/) { + my ($dim_state) = $p_state =~ /(\d+)%?/; + $link_state = 'off' if $dim_state == 0; + } +# if ($self->isa('Insteon::InterfaceController') or !($self->is_root)) { + # iterate over the members + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my $member = $$self{members}{$member_ref}{object}; + my $on_state = $$self{members}{$member_ref}{on_level}; + $on_state = '100%' unless $on_state; + my $local_state = $on_state; + $local_state = 'on' if $local_state eq '100%' + && $member->isa('Insteon::BaseDevice') && !($member->is_root); + $local_state = 'off' if $local_state eq '0%' or $link_state eq 'off'; + if ($member->isa('Light_Item')) { + # if they are Light_Items, then set their on_dim attrib to the member on level + # and then "blank" them via the manual method for a tad over the ramp rate + # In addition, locate the Light_Item's Insteon_Device member and do the + # same as if the member were an Insteon_Device + my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $ramp_rate = 0 unless defined $ramp_rate; + $ramp_rate = $ramp_rate + 2; + my @lights = $member->find_members('Insteon::BaseDevice'); + if (@lights) { + my $light = @lights[0]; + # remember the current state to support resume + $$self{members}{$member_ref}{resume_state} = $light->state; + $member->manual($light, $ramp_rate); + $light->set_receive($local_state,$self); + } else { + $member->manual(1, $ramp_rate); + } + $member->set_on_state($local_state) unless $link_state eq 'off'; + } elsif ($member->isa('Insteon::BaseDevice')) { + # remember the current state to support resume + $$self{members}{$member_ref}{resume_state} = $member->state; + # if they are Insteon_Device objects, then simply set_receive their state to + # the member on level + $member->set_receive($local_state,$self); + } + } + } +# } + if (($self->isa("Insteon::KeyPadLinc") or $self->isa("Insteon::KeyPadLincRelay"))and !($self->is_root)) { + if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) { + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + } elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::Insteon_Link') or $$self{surrogate}->isa('Insteon::InterfaceController'))) { + $$self{surrogate}->set($link_state, $p_setby, $p_respond) + unless ref $p_setby and $p_setby eq $self; + } else { + &::print_log("[Insteon_Link] You may not directly attempt to set a keypadlinc's button " + . " unless you have defined a reverse link with the \"surrogate\" keyword"); + } + } else { + $self->Insteon::BaseObject::set((($self->is_root) ? $p_state : $link_state), $p_setby, $p_respond); + } +} + +sub update_members +{ + my ($self) = @_; + # iterate over the members + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my ($device); + my $member = $$self{members}{$member_ref}{object}; + my $on_state = $$self{members}{$member_ref}{on_level}; + $on_state = '100%' unless $on_state; + my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $ramp_rate = 0 unless defined $ramp_rate; + if ($member->isa('Light_Item')) { + # if they are Light_Items, then locate the Light_Item's Insteon_Device member + my @lights = $member->find_members('Insteon::BaseDevice'); + if (@lights) { + $device = @lights[0]; + } + } elsif ($member->isa('Insteon::BaseDevice')) { + $device = $member; + } + if ($device) { + my %current_record = $device->get_link_record($self->device_id . $self->group); + if (%current_record) { + &::print_log("[Insteon_Link] remote record: $current_record{data1}") + if $::Debug{insteon}; + } + } + } + } +} + + +sub initiate_linking_as_controller +{ + my ($self, $p_group) = @_; + # iterate over the members + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my $member = $$self{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) { + # if they are Light_Items, then set them to manual to avoid automation + # while manually setting light parameters + $member->manual(1,120,120); # 120 seconds should be enough + } + } + } + $self->interface()->initiate_linking_as_controller($p_group); +} + +sub derive_message +{ + my ($self, $p_state, $p_extra) = @_; + if ($self->is_root) { + return $self->Insteon::BaseObject::derive_message($p_state, $p_extra); + } else { + return $self->Insteon::BaseObject::derive_message($p_state, $p_extra); + } +} + + +#################################### +### ##################### +### DeviceController ############### +### ############### +#################################### + + +package Insteon::DeviceController; + +use strict; +use Insteon; + +@Insteon::DeviceController::ISA = ('Insteon::BaseController'); + +sub new +{ + my ($class,$p_deviceid,$p_interface,$p_devcat) = @_; + + # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller + my $self = new Insteon::BaseController($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub request_status +{ + my ($self,$requestor) = @_; +# if ($self->group ne '01') { + if ($$self{members} and !($self->isa('Insteon::InterfaceController'))) { + &::print_log("[Insteon_Link] requesting status for members of " . $$self{object_name}); + foreach my $member (keys %{$$self{members}}) { + next if $requestor eq $$self{members}{$member}{object}; + if ($$self{members}{$member}{object}->isa('Insteon::BaseDevice')) { + $$self{members}{$member}{object}->request_status($self); + } + } + } + # the following has bad assumptions in that we don't always know if a device is a responder + # since it could be a slave + if ($self->is_root && $self->is_responder) { + $self->Insteon::BaseDevice::request_status($requestor); + } +} + +sub link_to_interface +{ + my ($self, $p_group, $p_data3) = @_; + my $group = $p_group; + $group = $self->group unless $group; + # get the surrogate device for this if group is not '01' + if ($self->group ne '01') { + my $surrogate_obj = &Insteon::get_object($self->device_id,'01'); + if ($p_data3) { + $surrogate_obj->link_to_interface($group,$p_data3); + } elsif ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { + $surrogate_obj->link_to_interface($group,$self->group); + } else { + $surrogate_obj->link_to_interface($group); + } + # next, if the link is a keypadlinc, then create the reverse link to permit + # control over the button's light + if ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { + + } + } else { + if ($p_data3) { + $self->SUPER::link_to_interface($group, $p_data3); + } else { + $self->SUPER::link_to_interface($group); + } + } +} + +sub unlink_to_interface +{ + my ($self,$p_group) = @_; + my $group = $p_group; + $group = $self->group unless $group; + # get the surrogate device for this if group is not '01' + if ($self->group ne '01') { + my $surrogate_obj = &Insteon::get_object($self->device_id,'01'); + $surrogate_obj->unlink_to_interface($group); + # next, if the link is a keypadlinc, then delete the reverse link to permit + # control over the button's light + if ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { + + } + } else { + $self->SUPER::unlink_to_interface($group); + } +} + + + +#################################### +### ############ +### InterfaceController ############ +### ############ +#################################### + + +package Insteon::InterfaceController; + +use strict; +use Insteon; + +@Insteon::InterfaceController::ISA = ('Insteon::BaseController','Insteon::BaseObject'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller + my $self = new Insteon::BaseObject($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub is_root +{ + return 0; +} + +1; diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm new file mode 100755 index 000000000..78ea08ff0 --- /dev/null +++ b/lib/Insteon/BaseInterface.pm @@ -0,0 +1,339 @@ + +package Insteon::BaseInterface; + +use strict; +use Insteon::Message; +@Insteon::BaseInterface::ISA = ('Class::Singleton'); + +sub check_for_data +{ + my $interface = &Insteon::active_interface(); + $interface->check_for_data(); +} + +sub poll_all { + my $scan_at_startup = $main::config_parms{Insteon_PLM_scan_at_startup}; + $scan_at_startup = 1 unless defined $scan_at_startup; + $scan_at_startup = 0 unless $main::Save{mh_exit} eq 'normal'; + my $plm = &Insteon::active_interface(); + if (defined $plm) { + if (!($plm->device_id) and !($$plm{_id_check})) { + $$plm{_id_check} = 1; + $plm->queue_message(new Insteon::InsteonMessage('plm_info', $plm)); + } + if ($scan_at_startup) { + + for my $insteon_device (&Insteon::find_members('Insteon::BaseDevice')) { + if ($insteon_device and $insteon_device->is_root and $insteon_device->is_responder) + { + # don't request status for objects associated w/ other than the primary group + # as they are psuedo links + $insteon_device->request_status(); + } + if ($insteon_device->devcat) { + # reset devcat so as to trigger any device specific properties + $insteon_device->devcat($insteon_device->devcat); + } + } + } + } +} + +sub new +{ + my ($class) = @_; + + my $self = {}; + @{$$self{command_stack2}} = (); + @{$$self{command_history}} = (); + bless $self, $class; +# &Insteon::add($self); + return $self; +} + +sub _is_duplicate +{ + my ($self, $cmd) = @_; + return 1 if ($self->active_message && $self->active_message->interface_data eq $cmd); + my $duplicate_detected = 0; + # check for duplicates of $cmd already in command_stack and ignore if they exist + foreach my $message (@{$$self{command_stack2}}) { + if ($message->interface_data eq $cmd) { + $duplicate_detected = 1; + last; + } + } + return $duplicate_detected; +} + +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $key = lc $insteon_object->device_id . $group . $is_controller; + return (defined $$self{links}{$key}) ? 1 : 0; +} + +sub active_message +{ + my ($self, $message) = @_; + if (defined $message) + { + $$self{active_message} = $message; + } + return $$self{active_message}; +} + +sub clear_active_message +{ + my ($self) = @_; + $$self{active_message} = undef; +# $self->_clear_timeout('command'); + $$self{xmit_in_progress} = 0; +} + +sub retry_active_message +{ + my ($self) = @_; +# $self->_clear_timeout('command'); + $$self{xmit_in_progress} = 0; +} + +sub queue_message +{ + my ($self, $message) = @_; + + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size unless $message; + + #queue any new command + if (defined $message) + { + my $setby = $message->setby; + if ($self->_is_duplicate($message->interface_data) && !($message->isa('Insteon::X10Message'))) { + &main::print_log("[Insteon_PLM] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; + } else { + my $queue_size = @{$$self{command_stack2}}; +# &main::print_log("[Insteon_PLM] Command stack size: $queue_size") if $queue_size > 0 and $main::Debug{insteon}; + $message->queue_time($::Time); + if ($setby and ref($setby) and $setby->can('set_retry_timeout') + and $setby->get_object_name) { + $message->callback($setby->get_object_name . "->set_retry_timeout()"); + } + unshift(@{$$self{command_stack2}}, $message); + } + } + # and, begin processing either this entry or the oldest one in the queue + $self->process_queue(); +} + +sub process_queue +{ + my ($self) = @_; + + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size unless !($$self{xmit_in_progress}); + + # get pending command record + my $pending_message = $self->active_message; + + if (!($pending_message)) { + $pending_message = pop(@{$$self{command_stack2}}); + $self->active_message($pending_message) if $pending_message; + #put the command back into the stack.. Its not our job to tamper with this array + # push(@{$$self{command_stack2}},$pending_message) if $pending_message; + } + + #we dont transmit on top of another xmit + if (!($$self{xmit_in_progress})) { # && ($self->_check_timeout('command')!=0)) { + #always send the oldest command first + if ($pending_message) + { + if (!($self->_check_timeout('xmit')==0)) { + + if ($self->active_message->send($self) == 0) + { + &::print_log("[Insteon_PLM] WARN: number of retries (" + . $self->active_message->send_attempts + . ") for " . $self->active_message->to_string() + . " exceeds limit. Now moving on...") if $main::Debug{insteon}; + # clear active message and try again + $self->clear_active_message(); + $self->process_queue(); + } + } + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size; + } + else + { + # clear the timer + $self->_clear_timeout('command'); + return 0; + } + } else { +# &::print_log("[Insteon_PLM] active transmission; moving on...") if $main::Debug{insteon}; + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size; + } + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size; +} + +sub device_id { + my ($self, $p_deviceid) = @_; + $$self{deviceid} = $p_deviceid if defined $p_deviceid; + return $$self{deviceid}; +} + +sub get_device +{ + my ($self, $p_deviceid, $p_group) = @_; + foreach my $device (&Insteon::find_members('Insteon::BaseDevice')) { + if (lc $device->device_id eq lc $p_deviceid and lc $device->group eq lc $p_group) { + return $device; + } + } +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = $self->SUPER::restore_string(); + $restore_string .= $self->_adlb->restore_string(); + return $restore_string; +} + +sub restore_linktable +{ + my ($self,$aldb) = @_; + if ($self->_aldb and $aldb) { + $self->_aldb->restore_linktable($aldb); + } +} + + +sub log_alllink_table +{ + my ($self) = @_; + $self->_aldb->log_alllink_table if $self->_aldb; +} + +sub delete_orphan_links +{ + my ($self) = @_; + return $self->_aldb->delete_orphan_links if $self->_aldb; +} + + ###################### + ### EVENT HANDLERS ### +###################### + +sub on_interface_info_received +{ + my ($self) = @_; + &::print_log("[Insteon_PLM] PLM id: " . $self->device_id . + " firmware: " . $self->firmware) + if $main::Debug{insteon}; + $self->clear_active_message(); +} + + +sub on_standard_insteon_received +{ + my ($self, $message_data) = @_; + my %msg = &Insteon::InsteonMessage::command_to_hash($message_data); + if (%msg) + { + # get the matching object + my $object = &Insteon::get_object($msg{source}, $msg{group}); + if (defined $object) + { + if ($msg{type} ne 'broadcast') + { + $msg{command} = $object->message_type($msg{cmd_code}); + &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") + if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; + } +# &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; + $object->_process_message($self, %msg); + if ($msg{is_ack} or $msg{is_nack}) + { + $self->clear_active_message(); + } + } + else + { + &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); + } + # treat the message as legitimate even if an object match did not occur + } +} + +sub on_extended_insteon_received +{ + my ($self, $message_data) = @_; + my %msg = &Insteon::InsteonMessage::command_to_hash($message_data); + if (%msg) + { + # get the matching object + my $object = &Insteon::get_object($msg{source}, $msg{group}); + if (defined $object) + { + if ($msg{type} ne 'broadcast') + { + $msg{command} = $object->message_type($msg{cmd_code}); + &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") + if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; + } + &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; + $object->_process_message($self, %msg); + if ($msg{is_ack} or $msg{is_nack}) + { + $self->clear_active_message(); + } + } + else + { + &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); + } + # treat the message as legitimate even if an object match did not occur + } + +} + + ################################# + ### INTERNAL METHODS/FUNCTION ### +################################# + +sub _set_timeout +{ + my ($self, $timeout_name, $timeout_in_millis) = @_; + my $tickcount = &main::get_tickcount + $timeout_in_millis; + $tickcount += 2**32 if $tickcount < 0; # force a wrap; to be handleded by check timeout + $$self{"_timeout_$timeout_name"} = $tickcount; +} + +sub _check_timeout +{ + my ($self, $timeout_name) = @_; + return 0 unless $timeout_name; + return -1 unless defined $$self{"_timeout_$timeout_name"}; + my $current_tickcount = &main::get_tickcount; + return 0 if (($current_tickcount >= 2**16) and ($$self{"_timeout_$timeout_name"} < 2**16)); + return ($current_tickcount > $$self{"_timeout_$timeout_name"}) ? 1 : 0; +} + +sub _clear_timeout +{ + my ($self, $timeout_name) = @_; + $$self{"_timeout_$timeout_name"} = undef; +} + +sub _aldb +{ + my ($self) = @_; + return $$self{aldb}; +} + + +1 diff --git a/lib/Insteon/Controller.pm b/lib/Insteon/Controller.pm new file mode 100755 index 000000000..478f2f890 --- /dev/null +++ b/lib/Insteon/Controller.pm @@ -0,0 +1,55 @@ + +package Insteon::RemoteLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::RemoteLinc::ISA = ('Insteon::DeviceController','Insteon::BaseDevice'); + +my %message_types = ( + %Insteon::BaseDevice::message_types, + bright => 0x15, + dim => 0x16 +); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseDevice($p_deviceid,$p_interface); + $$self{message_types} = \%message_types; + bless $self,$class; + return $self; +} + +sub set +{ + my ($self,$p_state,$p_setby,$p_response) = @_; + return if &main::check_for_tied_filters($self, $p_state); + + # Override any set_with_timer requests + if ($$self{set_timer}) { + &Timer::unset($$self{set_timer}); + delete $$self{set_timer}; + } + + # if it can't be controlled (i.e., a responder), then don't send out any signals + # motion sensors seem to get multiple fast reports; don't trigger on both + if (not defined($self->get_idle_time) or $self->get_idle_time > 1) { + &::print_log("[Insteon::RemoteLinc] " . $self->get_object_name() + . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; + $self->set_receive($p_state,$p_setby); + } else { + &::print_log("[Insteon::RemoteLinc] " . $self->get_object_name() + . "::set_receive($p_state, $p_setby) deferred due to repeat within 1 second") + if $main::Debug{insteon}; + } + return; +} + +sub is_responder +{ + return 0; +} + +1 \ No newline at end of file diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm new file mode 100755 index 000000000..9ba9e4e94 --- /dev/null +++ b/lib/Insteon/Lighting.pm @@ -0,0 +1,266 @@ +package Insteon::BaseLight; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::BaseLight::ISA = ('Insteon::BaseDevice'); + +#my %message_types = ( +# %SUPER::message_types +#); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseDevice($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub level +{ + my ($self, $p_level) = @_; + if (defined $p_level) { + my $level = 100; + if ($p_level eq 'off') + { + $level = 0; + } + $$self{level} = $level; + } + return $$self{level}; + +} + +package Insteon::DimmableLight; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::DimmableLight::ISA = ('Insteon::BaseLight'); + +my %message_types = ( + %SUPER::message_types, + bright => 0x15, + dim => 0x16 +); + +my %ramp_h2n = ( + '00' => 540, + '01' => 480, + '02' => 420, + '03' => 360, + '04' => 300, + '05' => 270, + '06' => 240, + '07' => 210, + '08' => 180, + '09' => 150, + '0a' => 120, + '0b' => 90, + '0c' => 60, + '0d' => 47, + '0e' => 43, + '0f' => 39, + '10' => 34, + '11' => 32, + '12' => 30, + '13' => 28, + '14' => 26, + '15' => 23.5, + '16' => 21.5, + '17' => 19, + '18' => 8.5, + '19' => 6.5, + '1a' => 4.5, + '1b' => 2, + '1c' => .5, + '1d' => .3, + '1e' => .2, + '1f' => .1 +); + +sub convert_ramp +{ + my ($ramp_in_seconds) = @_; + if ($ramp_in_seconds) { + foreach my $rampkey (sort keys %ramp_h2n) { + return $rampkey if $ramp_in_seconds >= $ramp_h2n{$rampkey}; + } + } else { + return '1f'; + } +} + +sub get_ramp_from_code +{ + my ($ramp_code) = @_; + if ($ramp_code) { + return $ramp_h2n{$ramp_code}; + } else { + return 0; + } +} + +sub convert_level +{ + my ($on_level) = @_; + my $level = 'ff'; + if (defined ($on_level)) { + if ($on_level eq '100') { + $level = 'ff'; + } elsif ($on_level eq '0') { + $level = '00'; + } else { + $level = sprintf('%02X',$on_level * 2.55); + } + } + return $level; +} + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub level +{ + my ($self, $p_level) = @_; + if (defined $p_level) { + my $level = undef; + if ($p_level eq 'on') + { + # set the level based on any locally defined on level + $level = $self->local_onlevel if $self->can('local_onlevel'); + # set to 100 if a local on level is not defined + $level=100 unless defined($level); + } elsif ($p_level eq 'off') + { + $level = 0; + } elsif ($p_level =~ /^([1]?[0-9]?[0-9])%?$/) + { + if ($1 < 1) { + $level = 0; + } else { + $level = $1; + } + } + $$self{level} = $level if defined $level; + } + return $$self{level}; + +} + + +package Insteon::ApplianceLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::ApplianceLinc::ISA = ('Insteon::BaseLight'); + +#my %message_types = ( +# %SUPER::message_types +#); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + + +package Insteon::LampLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::LampLinc::ISA = ('Insteon::DimmableLight'); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +package Insteon::SwitchLincRelay; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::SwitchLincRelay::ISA = ('Insteon::DeviceController','Insteon::BaseLight'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + +package Insteon::SwitchLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::SwitchLinc::ISA = ('Insteon::DeviceController','Insteon::DimmableLight'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + +package Insteon::KeyPadLincRelay; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::KeyPadLincRelay::ISA = ('Insteon::DeviceController', 'Insteon::BaseLight'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +package Insteon::KeyPadLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::KeyPadLinc::ISA = ('Insteon::DeviceController', 'Insteon::DimmableLight'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + +1 diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm new file mode 100755 index 000000000..ae8a76f21 --- /dev/null +++ b/lib/Insteon/Message.pm @@ -0,0 +1,605 @@ + +package Insteon::BaseMessage; + +use strict; +use Insteon; + +sub new +{ + my ($class) = @_; + my $self={}; + bless $self,$class; + + $$self{send_attempts} = 0; + + return $self; +} + +sub interface_data +{ + my ($self, $interface_data) = @_; + if ($interface_data) + { + $$self{interface_data} = $interface_data; + } + return $$self{interface_data}; +} + +sub queue_time +{ + my ($self, $queue_time) = @_; + if ($queue_time) + { + $$self{queue_time} = $queue_time; + } + return $$self{queue_time}; +} + +sub callback +{ + my ($self, $callback) = @_; + if ($callback) + { + $$self{callback} = $callback; + } + return $$self{callback}; +} + +sub send_attempts +{ + my ($self, $send_attempts) = @_; + if ($send_attempts) + { + $$self{send_attempts} = $send_attempts; + } + return $$self{send_attempts}; +} + +sub setby +{ + my ($self, $setby) = @_; + if ($setby) + { + $$self{setby} = $setby; + } + return $$self{setby}; +} + +sub respond +{ + my ($self, $respond) = @_; + if ($respond) + { + $$self{respond} = $respond; + } + return $$self{respond}; +} + +sub send +{ + my ($self, $interface) = @_; + if ($self->send_attempts < 5) + { + + if ($self->send_attempts > 0) + { + &::print_log("[Insteon::BaseMessage] WARN: now resending " + . $self->to_string() . " after " . $self->send_attempts + . " attempts.") if $main::Debug{insteon}; + } + + # need to set timeout as a function of retries; also need to alter hop count + + $self->send_attempts($self->send_attempts + 1); + $interface->_send_cmd($self, $self->send_timeout); + if ($self->callback) { + package main; + eval $self->callback; + &::print_log("[Insteon::BaseMessage] problem w/ retry callback: $@") if $@; + package Insteon::Message; + } + return 1; + } + else + { + return 0; + } + +} + +sub send_timeout +{ + my ($self, $timeout) = @_; + $$self{send_timeout} = $timeout if defined $timeout; + return $$self{send_timeout}; +} + +sub to_string +{ + my ($self) = @_; + return $self->interface_data; +} + +package Insteon::InsteonMessage; +use strict; +use Insteon; + +@Insteon::InsteonMessage::ISA = ('Insteon::BaseMessage'); + +sub new +{ + my ($class, $command_type, $setby, $command, $extra) = @_; + my $self= new Insteon::BaseMessage(); + bless $self,$class; + + $self->command_type($command_type); + $self->setby($setby); + $self->command($command); + $self->extra($extra); + $self->send_timeout(2000); + + return $self; +} + + +sub command_to_hash +{ + my ($p_state) = @_; + my %msg = (); + my $hopflag = hex(uc substr($p_state,13,1)); + $msg{hopsleft} = $hopflag >> 2; + my $msgflag = hex(uc substr($p_state,12,1)); + $msg{is_extended} = (0x01 & $msgflag) ? 1 : 0; + if ($msg{is_extended}) { + $msg{source} = substr($p_state,0,6); + $msg{destination} = substr($p_state,6,6); + $msg{extra} = substr($p_state,16,16); + } else { + $msg{source} = substr($p_state,0,6); + $msgflag = $msgflag >> 1; + if ($msgflag == 4) { + $msg{type} = 'broadcast'; + $msg{devcat} = substr($p_state,6,4); + $msg{firmware} = substr($p_state,10,2); + $msg{is_master} = substr($p_state,16,2); + $msg{dev_attribs} = substr($p_state,18,2); + } elsif ($msgflag ==6) { + $msg{type} = 'alllink'; + $msg{group} = substr($p_state,10,2); + } else { + $msg{destination} = substr($p_state,6,6); + if ($msgflag == 2) { + $msg{type} = 'cleanup'; + $msg{group} = substr($p_state,16,2); + } elsif ($msgflag == 3) { + $msg{type} = 'cleanup'; + $msg{is_ack} = 1; + } elsif ($msgflag == 7) { + $msg{type} = 'cleanup'; + $msg{is_nack} = 1; + } elsif ($msgflag == 0) { + $msg{type} = 'direct'; + $msg{extra} = substr($p_state,16,2); + } elsif ($msgflag == 1) { + $msg{type} = 'direct'; + $msg{is_ack} = 1; + $msg{extra} = substr($p_state,16,2); + } elsif ($msgflag == 5) { + $msg{type} = 'direct'; + $msg{is_nack} = 1; + } + } + } + $msg{cmd_code} = substr($p_state,14,2); + + return %msg; +} + + +sub command +{ + my ($self, $command) = @_; + $$self{command} = $command if $command; + return $$self{command}; +} + +sub command_type +{ + my ($self, $command_type) = @_; + $$self{command_type} = $command_type if $command_type; + return $$self{command_type}; +} + +sub extra +{ + my ($self, $extra) = @_; + $$self{extra} = $extra if $extra; + return $$self{extra}; +} + +sub send_timeout +{ +# hop timing in seconds; this method returns timeout in millisconds +# hops standard extended +# ---- -------- -------- +# 0 1.40 2.22 +# 1 1.70 2.69 +# 2 1.90 3.01 +# 3 2.00 3.17 + + my ($self, $ignore) = @_; + if ($self->command_type eq 'all_link_send') + { + return 2000; + } + elsif ($self->command_type eq 'insteon_ext_send') + { + if ($self->send_attempts == 1) + { + return 2220; + } + elsif ($self->send_attempts == 2) + { + return 2690; + } + elsif ($self->send_attempts >= 3) + { + return 3170; + } + } + else + { + if ($self->send_attempts == 1) + { + return 1700; + } + elsif ($self->send_attempts == 2) + { + return 1900; + } + elsif ($self->send_attempts >= 3) + { + return 2000; + } + } +} + +sub to_string +{ + my ($self) = @_; + my $result = ''; + if ($self->setby) + { + $result .= 'obj=' . $self->setby->get_object_name; + } + if ($result) + { + $result .= '; '; + } + $result .= 'command=' . $self->command; + if ($self->extra) + { + $result .= '; extra=' . $self->extra; + } + + return $result; +} + +sub interface_data +{ + my ($self, $interface_data) = @_; + my $result = $self->SUPER::interface_data($interface_data); + if (!($result) && + (($self->command_type eq 'insteon_send') + or ($self->command_type eq 'insteon_ext_send') + or ($self->command_type eq 'all_link_send'))) + { + return $self->_derive_interface_data(); + } + else + { + return $result; + } +} + +sub _derive_interface_data +{ + + my ($self) = @_; + my $cmd = ''; + my $level; + if ($self->command_type =~ /all_link_send/i) { + $cmd.=$self->setby->group; + } else { + $cmd.=$self->setby->device_id(); + if ($self->command_type =~ /insteon_ext_send/i) { + if ($self->send_attempts == 1) + { + $cmd.='15'; + } + elsif ($self->send_attempts == 2) + { + $cmd.='1A'; + } + elsif ($self->send_attempts >= 3) + { + $cmd.='1F'; + } + } else { + if ($self->send_attempts == 1) + { + $cmd.='05'; + } + elsif ($self->send_attempts == 2) + { + $cmd.='0A'; + } + elsif ($self->send_attempts >= 3) + { + $cmd.='0F'; + } + } + } + $cmd.= unpack("H*",pack("C",$self->setby->message_type_code($self->command))); + if ($self->extra) + { + $cmd.= $self->extra; + } + elsif ($self->command_type eq 'insteon_send') + { # auto append '00' if no extra defined for a standard insteon send + $cmd .= '00'; + } + + return $cmd; + +} + +package Insteon::X10Message; +use strict; +use Insteon; + +@Insteon::X10Message::ISA = ('Insteon::BaseMessage'); + +my %x10_house_codes = ( + a => 0x6, + b => 0xE, + c => 0x2, + d => 0xA, + e => 0x1, + f => 0x9, + g => 0x5, + h => 0xD, + i => 0x7, + j => 0xF, + k => 0x3, + l => 0xB, + m => 0x0, + n => 0x8, + o => 0x4, + p => 0xC +); + +my %mh_house_codes = ( + '6' => 'a', + 'e' => 'b', + '2' => 'c', + 'a' => 'd', + '1' => 'e', + '9' => 'f', + '5' => 'g', + 'd' => 'h', + '7' => 'i', + 'f' => 'j', + '3' => 'k', + 'b' => 'l', + '0' => 'm', + '8' => 'n', + '4' => 'o', + 'c' => 'p' +); + +my %x10_unit_codes = ( + 1 => 0x6, + 2 => 0xE, + 3 => 0x2, + 4 => 0xA, + 5 => 0x1, + 6 => 0x9, + 7 => 0x5, + 8 => 0xD, + 9 => 0x7, + 10 => 0xF, + a => 0xF, + 11 => 0x3, + b => 0x3, + 12 => 0xB, + c => 0xB, + 13 => 0x0, + d => 0x0, + 14 => 0x8, + e => 0x8, + 15 => 0x4, + f => 0x4, + 16 => 0xC, + g => 0xC + +); + +my %mh_unit_codes = ( + '6' => '1', + 'e' => '2', + '2' => '3', + 'a' => '4', + '1' => '5', + '9' => '6', + '5' => '7', + 'd' => '8', + '7' => '9', + 'f' => 'a', + '3' => 'b', + 'b' => 'c', + '0' => 'd', + '8' => 'e', + '4' => 'f', + 'c' => 'g' +); + +my %x10_commands = ( + on => 0x2, + j => 0x2, + off => 0x3, + k => 0x3, + bright => 0x5, + l => 0x5, + dim => 0x4, + m => 0x4, + preset_dim1 => 0xA, + preset_dim2 => 0xB, + all_off => 0x0, + p => 0x0, + all_lights_on => 0x1, + o => 0x1, + all_lights_off => 0x6, + status => 0xF, + status_on => 0xD, + status_off => 0xE, + hail_ack => 0x9, + ext_code => 0x7, + ext_data => 0xC, + hail_request => 0x8 +); + +my %mh_commands = ( + '2' => 'J', + '3' => 'K', + '5' => 'L', + '4' => 'M', + 'a' => 'preset_dim1', + 'b' => 'preset_dim2', +# '0' => 'all_off', + '0' => 'P', +# '1' => 'all_lights_on', + '1' => 'O', + '6' => 'all_lights_off', + 'f' => 'status', + 'd' => 'status_on', + 'e' => 'status_off', + '9' => 'hail_ack', + '7' => 'ext_code', + 'c' => 'ext_data', + '8' => 'hail_request' +); + +sub new +{ + my ($class, $interface_data) = @_; + my $self= new Insteon::BaseMessage(); + bless $self,$class; + + $self->interface_data($interface_data); + $self->send_timeout(2000); + + return $self; +} + +sub get_formatted_data +{ + my ($self) = @_; + + my $data = $self->interface_data; + + my $msg=undef; + if (uc(substr($data,length($data)-2,2)) eq '00') + { + $msg = "X"; + $msg.= uc($mh_house_codes{substr($data,4,1)}); + $msg.= uc($mh_unit_codes{substr($data,5,1)}); + for (my $index =6; $index{id_by_state}{$cmd}); + + my $hc = lc(substr($p_setby->{x10_id},1,1)); + my $uc = lc(substr($p_setby->{x10_id},2,1)); + + if ($hc eq undef) { + &main::print_log("[Insteon_PLM] Object:$p_setby Doesnt have an x10 id (yet)"); + return undef; + } + + if ($uc eq undef) { + &main::print_log("[Insteon_PLM] Message is for entire HC") if $main::Debug{insteon}; + } + else { + + #Every X10 message starts with the House and unit code + $msg = substr(unpack("H*",pack("C",$x10_house_codes{substr($id,1,1)})),1,1); + $msg.= substr(unpack("H*",pack("C",$x10_unit_codes{substr($id,2,1)})),1,1); + $msg.= "00"; + &main::print_log("[Insteon_PLM] x10 sending code: " . uc($hc . $uc) . " as insteon msg: " + . $msg) if $main::Debug{insteon}; + + push @data, $msg; + } + + my $ecmd; + #Iterate through the rest of the pairs of nibbles + my $spos = 3; + if ($uc eq undef) {$spos=1;} +# &::print_log("PLM:PAIR:$id:$spos:$ecmd:"); + for (my $pos = $spos; $posget_idle_time) or $self->get_idle_time > 1) { + &::print_log("[Insteon_Device] " . $self->get_object_name() + . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; + $self->set_receive($p_state,$p_setby); + } else { + &::print_log("[Insteon_Device] " . $self->get_object_name() + . "::set_receive($p_state, $p_setby) deferred due to repeat within 1 second") + if $main::Debug{insteon}; + } + return; +} + +sub is_responder +{ + return 0; +} + +1 \ No newline at end of file diff --git a/lib/Insteon_Device.pm b/lib/Insteon_Device.pm deleted file mode 100644 index 048f6eaa2..000000000 --- a/lib/Insteon_Device.pm +++ /dev/null @@ -1,1903 +0,0 @@ -=begin comment -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - -File: - Insteon_Device.pm - -Description: - Generic class implementation of an Insteon Device. - -Author(s): - Jason Sharpee / jason@sharpee.com - Gregg Liming / gregg@limings.net - -License: - This free software is licensed under the terms of the GNU public license. - -Usage: - - $ip_patio_light = new Insteon_Device($myPLM,"33.44.55"); - - $ip_patio_light->set("ON"); - -Special Thanks to: - Brian Warren for significant testing and patches - Bruce Winter - MH - -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -=cut - -use strict; - -package Insteon_Device; - -@Insteon_Device::ISA = ('Generic_Item'); - -my %message_types = ( - assign_to_group => 0x01, - delete_from_group => 0x02, - linking_mode => 0x09, - unlinking_mode => 0x0A, - ping => 0x10, - on => 0x11, - on_fast => 0x12, - off => 0x13, - off_fast => 0x14, - bright => 0x15, - dim => 0x16, - start_manual_change => 0x17, - stop_manual_change => 0x18, - status_request => 0x19, - get_operating_flags => 0x1f, - set_operating_flags => 0x20, - do_read_ee => 0x24, - remote_set_button_tap => 0x25, - set_led_status => 0x27, - set_address_msb => 0x28, - poke => 0x29, - poke_extended => 0x2a, - peek => 0x2b, - peek_internal => 0x2c, - poke_internal => 0x2d, - on_at_ramp_rate => 0x2e, - off_at_ramp_rate => 0x2f, - sprinkler_valve_on => 0x40, - sprinkler_valve_off => 0x41, - sprinkler_program_on => 0x42, - sprinkler_program_off => 0x43, - sprinkler_control => 0x44, - sprinkler_timers_request => 0x45, - thermostat_temp_up => 0x68, - thermostat_temp_down => 0x69, - thermostat_get_zone_temp => 0x6a, - thermostat_get_zone_setpoint => 0x6a, - thermostat_get_zone_humidity => 0x6a, - thermostat_control => 0x6b, - thermostat_get_mode => 0x6b, - thermostat_get_temp => 0x6b, - thermostat_setpoint_cool => 0x6c, - thermostat_setpoint_heat => 0x6d -); - -my %operating_flags = ( - 'program_lock_on' => '00', - 'program_lock_off' => '01', - 'led_on_during_tx' => '02', - 'led_off_during_tx' => '03', - 'resume_dim_on' => '04', - 'beeper_enabled' => '04', - 'resume_dim_off' => '05', - 'beeper_off' => '05', - 'eight_key_kpl' => '06', - 'load_sense_on' => '06', - 'six_key_kpl' => '07', - 'load_sense_off' => '07', - 'led_backlight_off' => '08', - 'led_off' => '08', - 'led_backlight_on' => '09', - 'led_enabled' => '09', - 'key_beep_enabled' => '0a', - 'one_minute_warn_disabled' => '0a', - 'key_beep_off' => '0b', - 'one_minute_warn_enabled' => '0b' -); - -my %ramp_h2n = ( - '00' => 540, - '01' => 480, - '02' => 420, - '03' => 360, - '04' => 300, - '05' => 270, - '06' => 240, - '07' => 210, - '08' => 180, - '09' => 150, - '0a' => 120, - '0b' => 90, - '0c' => 60, - '0d' => 47, - '0e' => 43, - '0f' => 39, - '10' => 34, - '11' => 32, - '12' => 30, - '13' => 28, - '14' => 26, - '15' => 23.5, - '16' => 21.5, - '17' => 19, - '18' => 8.5, - '19' => 6.5, - '1a' => 4.5, - '1b' => 2, - '1c' => .5, - '1d' => .3, - '1e' => .2, - '1f' => .1 -); - -sub convert_ramp -{ - my ($ramp_in_seconds) = @_; - if ($ramp_in_seconds) { - foreach my $rampkey (sort keys %ramp_h2n) { - return $rampkey if $ramp_in_seconds >= $ramp_h2n{$rampkey}; - } - } else { - return '1f'; - } -} - -sub get_ramp_from_code -{ - my ($ramp_code) = @_; - if ($ramp_code) { - return $ramp_h2n{$ramp_code}; - } else { - return 0; - } -} - -sub convert_level -{ - my ($on_level) = @_; - my $level = 'ff'; - if (defined ($on_level)) { - if ($on_level eq '100') { - $level = 'ff'; - } elsif ($on_level eq '0') { - $level = '00'; - } else { - $level = sprintf('%02X',$on_level * 2.55); - } - } - return $level; -} - -sub new -{ - my ($class,$p_interface,$p_deviceid,$p_devcat) = @_; - my $self={}; - bless $self,$class; - - if (defined $p_deviceid) { - my ($deviceid, $group) = $p_deviceid =~ /(\w\w\.\w\w\.\w\w):?(.+)?/; - # if a group is passed in, then assume it can be a controller - $$self{is_controller} = ($group) ? 1 : 0; - $self->device_id($deviceid); - $group = '01' unless $group; - $group = '0' . $group if length($group) == 1; - $self->group(uc $group); - } - if ($p_devcat) { - $self->devcat($p_devcat); - $self->restore_data('level','send_synchronously'); - } else { - $self->restore_data('devcat','level','send_synchronously'); - } - $self->initialize(); - $self->rate(undef); - $$self{level} = undef; - $$self{flag} = "0F"; - $$self{ackMode} = "1"; - $$self{awaiting_ack} = 0; - $$self{is_acknowledged} = 0; - $$self{queue_timer} = new Timer(); - $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; - $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack - @{$$self{command_stack}} = (); - $$self{_retry_count} = 0; # num times that a command has been resent - $$self{_onlevel} = undef; - if ($p_devcat and (($p_devcat eq '0005') or ($p_devcat eq '1001'))) { - $$self{is_responder} = 0; - } else { - $$self{is_responder} = 1; - } - $self->interface($p_interface) if defined $p_interface; - return $self; -} - -sub initialize -{ - my ($self) = @_; - $$self{send_synchronously} = undef; - $$self{m_write} = 1; - $$self{m_is_locally_set} = 0; - # persist local, simple attribs - $$self{ping_timer} = new Timer(); - $$self{ping_timerTime} = 300; - $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self) - unless $self->group eq '01' and defined $self->devcat; -} - -sub interface -{ - my ($self,$p_interface) = @_; - if (defined $p_interface) { - $$self{interface} = $p_interface; - # be sure to add the object to the interface - $$self{interface}->add_item_if_not_present($self); - } - return $$self{interface}; -} - -sub device_id -{ - my ($self,$p_device_id) = @_; - - if (defined $p_device_id) - { - $p_device_id =~ /(\w\w)\W?(\w\w)\W?(\w\w)/; - $$self{device_id}=$1 . $2 . $3; - } - return $$self{device_id}; -} - -sub rate -{ - my ($self,$p_rate) = @_; - $$self{rate} = $p_rate if defined $p_rate; - return $$self{rate}; -} - -sub send_synchronously -{ - my ($self, $p_send_sync) = @_; - $$self{send_synchronously} = $p_send_sync if defined $p_send_sync; - if (defined $$self{send_synchronously}) { - return $$self{send_synchronously}; - } elsif ($main::config_parms{Insteon_send_synchronously}) { - return 1; - } else { - return 0; - } -} - - -sub is_acknowledged -{ - my ($self, $p_ack) = @_; - $$self{is_acknowledged} = $p_ack if defined $p_ack; - if ($p_ack) { - $self->SUPER::set($$self{pending_state},$$self{pending_setby}, $$self{pending_response}) if defined $$self{pending_state}; - $$self{pending_state} = undef; - $$self{pending_setby} = undef; - $$self{pending_response} = undef; - } - return $$self{is_acknowledged}; -} - -sub is_controller -{ - my ($self) = @_; - return $$self{is_controller}; -} - -sub is_responder -{ - my ($self,$is_responder) = @_; - $$self{is_responder} = $is_responder if defined $is_responder; - if ($self->is_root) { - return $$self{is_responder}; - } else { - my $root_obj = $self->get_root(); - return (ref $root_obj) ? $$root_obj{is_responder} : 0; - } -} - -sub is_keypadlinc -{ - my ($self) = @_; - my $obj = $self->get_root; - if (($$obj{devcat} eq '0109') or ($$obj{devcat} =~ /010c/i) or ($$obj{devcat} =~ /020f/i) or ($$obj{devcat} eq '011b')) { - return 1; - } else { - return 0; - } -} - -sub is_remotelinc -{ - my ($self) = @_; - my $obj = $self->get_root; - if ($$obj{devcat} eq '0005') { - return 1; - } else { - return 0; - } -} - -sub level -{ - my ($self, $p_level) = @_; - if (defined $p_level) { - my $level = undef; - if ($p_level eq 'on') - { - # set the level based on any locally defined on level - $level = &Insteon_Device::local_onlevel; - # set to 100 if a local on level is not defined - $level=100 unless defined($level); - } elsif ($p_level eq 'off') - { - $level = 0; - } elsif ($p_level =~ /^([1]?[0-9]?[0-9])%?$/) - { - if ($1 < 1) { - $level = 0; - } else { - $level = ($self->is_dimmable) ? $1 : 100; - } - } - $$self{level} = $level if defined $level; - } - return $$self{level}; - -} - -sub set -{ - my ($self,$p_state,$p_setby,$p_response) = @_; - return if &main::check_for_tied_filters($self, $p_state); - - # Override any set_with_timer requests - if ($$self{set_timer}) { - &Timer::unset($$self{set_timer}); - delete $$self{set_timer}; - } - - if (!($self->is_plm_controlled) && !($self->is_responder)) { - # if it can't be controlled (i.e., a responder), then don't send out any signals - # motion sensors seem to get multiple fast reports; don't trigger on both - if (not defined($self->get_idle_time) or $self->get_idle_time > 1) { - &::print_log("[Insteon_Device] " . $self->get_object_name() - . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; - $self->set_receive($p_state,$p_setby); - } else { - &::print_log("[Insteon_Device] " . $self->get_object_name() - . "::set_receive($p_state, $p_setby) deferred due to repeat within 1 second") - if $main::Debug{insteon}; - } - return; - } - - # did the queue timer go off? - if (ref $p_setby and $p_setby eq $$self{queue_timer}) { - $self->_process_command_stack(); - } elsif (ref $p_setby and $p_setby eq $$self{ping_timer}) { - if (! (defined($$self{devcat}))) { - $self->ping(); - # set the timer again in case nothing occurs - $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self); - } - } elsif ($self->_is_valid_state($p_state)) { - # always reset the is_locally_set property unless set_by is the device - $$self{m_is_locally_set} = 0 unless ref $p_setby and $p_setby eq $self; - - # handle invalid state for non-dimmable devices - if (($p_state eq 'dim' or $p_state eq 'bright') and !($self->is_dimmable)) { - $p_state = 'on'; - } - - if (ref $p_setby and (($p_setby eq $self->interface()) - or ($p_setby->isa('Insteon_Device') and (($p_setby eq $self) - or (&main::set_by_to_target($p_setby) eq $self->interface))))) - { - # don't reset the object w/ the same state if set from the interface - return if (lc $p_state eq lc $self->state) and $self->is_acknowledged - and not (($p_setby->isa('Insteon_Device') and (($p_setby eq $self)))); - &::print_log("[Insteon_Device] " . $self->get_object_name() - . "::set($p_state, $p_setby)") if $main::Debug{insteon}; - $self->SUPER::set($p_state,$p_setby,$p_response) if defined $p_state; - } else { - $self->_send_cmd(command => $p_state, - type => (($self->isa('Insteon_Link') and !($self->is_root)) ? 'alllink' : 'standard'), - 'is_synchronous' => $self->send_synchronously); - &::print_log("[Insteon_Device] " . $self->get_object_name() . "::set($p_state, $p_setby)") - if $main::Debug{insteon}; - $self->is_acknowledged(0); - $$self{pending_state} = $p_state; - $$self{pending_setby} = $p_setby; - $$self{pending_response} = $p_response; - } - $self->level($p_state); # update the level value -# $self->SUPER::set($p_state,$p_setby,$p_response) if defined $p_state; - } else { - &::print_log("[Insteon_Device] failed state validation with state=$p_state"); - } -} - -sub set_with_timer { - my ($self, $state, $time, $return_state, $additional_return_states) = @_; - return if &main::check_for_tied_filters($self, $state); - - $self->set($state) unless $state eq ''; - - return unless $time; - - my $state_change = ($state eq 'off') ? 'on' : 'off'; - $state_change = $return_state if defined $return_state; - $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; - - $state_change .= ';' . $additional_return_states if $additional_return_states; - - $$self{set_timer} = &Timer::new() unless $$self{set_timer}; - my $object_name = $self->{object_name}; - my $action = "$object_name->set('$state_change')"; - $$self{set_timer}->set($time, $action); -} - -sub link_to_interface -{ - my ($self,$p_group, $p_data3) = @_; - my $group = $p_group; - $group = '01' unless $group; - # add a link first to this device back to interface - # and, add a reference to creating a link from interface back to device via hook - my $callback_instance = $self->interface->get_object_name; - my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; - my %link_info = ( object => $self->interface, group => $group, is_controller => 1, - on_level => '100%', ramp_rate => '0.1s', - callback => "$callback_instance->add_link('$callback_info')"); - $link_info{data3} = $p_data3 if $p_data3; - $self->add_link(%link_info); -} - -sub unlink_to_interface -{ - my ($self,$p_group) = @_; - my $group = $p_group; - $group = '01' unless $group; - my $callback_instance = $self->interface->get_object_name; - my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; - $self->delete_link(object => $self->interface, group => $group, is_controller => 1, - callback => "$callback_instance->delete_link('$callback_info')"); -} - -sub queue_timer_callback -{ - my ($self, $callback) = @_; - $$self{queue_timer_callback} = $callback if defined $callback; - return $$self{queue_timer_callback}; -} - -sub _send_cmd -{ - my ($self, %msg) = @_; - $msg{type} = 'standard' unless $msg{type}; - if ($msg{is_synchronous}) { - push(@{$$self{command_stack}}, \%msg); - } else { - unshift(@{$$self{command_stack}}, \%msg); - } - $self->_process_command_stack(); -} - -sub _process_command_stack -{ - my ($self, %ackmsg) = @_; - if (%ackmsg) { # which may also be something that can be interpretted as a "nack" - # determine whether to unset awaiting_ack - # for now, be "dumb" and just unset it - $$self{awaiting_ack} = 0; - # is there an "on_ack" command to now be performed? if so, queue it - if ($ackmsg{on_ack}) { - # process the on_ack command - # any new command needs to be pushed on to the queue in front of other pending cmds - } - } - if ($$self{queue_timer}->expired or !($$self{awaiting_ack})) { - my $callback = undef; - if ($$self{queue_timer}->expired) { - if ($$self{_prior_msg} and $$self{_retry_count} < 2) { - # first check to see if type is an alllink; if so, then don't keep retrying until - # proper handling of alllink cleanup status is implemented in Insteon_PLM - if ($$self{_prior_msg}{type} eq 'alllink' and (!($self->is_plm_controlled))) { - # do nothing - } else { - push(@{$$self{command_stack}}, \%{$$self{_prior_msg}}); - &::print_log("[Insteon_Device] WARN: queue timer on " . $self->get_object_name . - " expired. Attempting resend: $$self{_prior_msg}{command}"); - } - } else { - &::print_log("[Insteon_Device] WARN: queue timer on " . $self->get_object_name . - " expired. Trying next command if queued."); - $$self{m_status_request_pending} = 0; # hack--need a better way - if ($self->queue_timer_callback) { - if ($$self{_prior_msg} and ($$self{_prior_msg}{is_synchronous})) { - # get rid of any pending next command as we need to abort - pop(@{$$self{command_stack}}); - } - $callback = $self->queue_timer_callback; - $self->queue_timer_callback(''); # reset to prevent repeat callbacks - } - } - } - my $cmdptr = pop(@{$$self{command_stack}}); - # convert ptr to cmd hash - if ($cmdptr) { - my %cmd = %$cmdptr; - # convert cmd to insteon message - my $insteonmsg = $self->_xlate_mh_insteon($cmd{command},$cmd{type},$cmd{extra}); - if (!(defined($insteonmsg))) { - return; - } - my $plm_queue_size = $self->interface()->set($insteonmsg, $self); - # send msg - if ($cmd{is_synchronous}) { - $$self{awaiting_ack} = 1; - } else { - $$self{awaiting_ack} = 0; - } - # check to see if we are resending the same command; if so, then assume it is a retry and bump the counter - if ($$self{_prior_msg} and $$self{_prior_msg}{command} eq $cmd{command}) { - $$self{_retry_count} = ($$self{_retry_count}) ? $$self{_retry_count} + 1 : 1; - # unless there is a difference in the "extra" field which would be useful for something like repeat peeks - if (exists($$self{_prior_msg}{extra}) and exists($cmd{extra}) and ($$self{_prior_msg}{extra} ne $cmd{extra})) { - $$self{_retry_count} = 0; - } - } else { - $$self{_retry_count} = 0; - } - %{$$self{_prior_msg}} = %cmd; - # TO-DO: adjust timer based upon (1) type of message and (2) retry_count - my $queue_time = $$self{max_queue_time} + $plm_queue_size; - unless ($self->get_object_name) { - # needed because the initial startup scan occurs before names are assigned - $self->set_retry_timeout($queue_time); - } -# $$self{queue_timer}->set($queue_time,$self); - # if is_synchronous, then no other command can be sent until an insteon ack or nack is received - # for this command - } else { - # always unset the timer if no more commands - $$self{queue_timer}->unset(); - # and, always clear awaiting_ack and _prior_msg - $$self{awaiting_ack} = 0; - $$self{_prior_msg} = undef; - } - if ($callback) { - package main; - eval ($callback); - &::print_log("[Insteon_Device] error in queue timer callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_Device; - } - } else { - &::print_log("[Insteon_Device] " . $self->get_object_name . " command queued but not yet sent; awaiting ack from prior command") if $main::Debug{insteon}; - } -} - -sub set_operating_flag { - my ($self, $flag) = @_; - - if (!(exists($operating_flags{$flag}))) { - &::print_log("[Insteon_Device] $flag is not a support operating flag"); - return; - } - - if ($self->is_root and !($self->is_plm_controlled)) { - # TO-DO: check devcat to determine if the action is supported by the device - $self->_send_cmd('command' => 'set_operating_flags', 'extra' => $operating_flags{$flag}); - } else { - &::print_log("[Insteon_Device] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); - return; - } -} - -sub get_operating_flag { - my ($self) = @_; - - if ($self->is_root and !($self->is_plm_controlled)) { - # TO-DO: check devcat to determine if the action is supported by the device - $self->_send_cmd('command' => 'get_operating_flags'); - } else { - &::print_log("[Insteon_Device] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); - return; - } -} - - -sub set_retry_timeout { - my ($self, $timeout) = @_; -#print "########## now setting " . $self->get_object_name . " retry timeout to $$self{max_queue_time} seconds\n"; - my $timer_value = $timeout; - $timer_value = $$self{max_queue_time} unless $timer_value; - $$self{queue_timer}->set($timer_value,$self); -} - -sub writable { - my ($self, $p_write) = @_; - if (defined $p_write) { - if ($p_write =~ /r/i or $p_write =~/^0/) { - $$self{m_write} = 0; - } else { - $$self{m_write} = 1; - } - } - return $$self{m_write}; -} - -sub is_locally_set { - my ($self) = @_; - return $$self{m_is_locally_set}; -} - -sub is_plm_controlled { - my ($self) = @_; - return ($self->device_id eq '000000') ? 1 : 0; -} - -sub is_root { - my ($self) = @_; - return (($self->group eq '01') and !($self->is_plm_controlled)) ? 1 : 0; -} - -sub get_root { - my ($self) = @_; - if ($self->is_root) { - return $self; - } else { - return $self->interface->get_object($self->device_id, '01'); - } -} - -sub group -{ - my ($self, $p_group) = @_; - $$self{m_group} = $p_group if $p_group; - return $$self{m_group}; -} - -### WARN: Testing using the following does not produce results as expected. Use at your own risk. [GL] -sub remote_set_button_tap -{ - my ($self,$p_number_taps) = @_; - my $taps = ($p_number_taps =~ /2/) ? '02' : '01'; - $self->_send_cmd('command' => 'remote_set_button_tap', 'extra' => $taps); -} - -sub request_status -{ - my ($self, $requestor) = @_; - $$self{m_status_request_pending} = ($requestor) ? $requestor : 1; - $self->_send_cmd('command' => 'status_request', 'is_synchronous' => 1); -} - -sub ping -{ - my ($self) = @_; - $self->_send_cmd('command' => 'ping'); -} - -sub set_led_status -{ - my ($self, $status_mask) = @_; - $self->_send_cmd('command' => 'set_led_status', 'extra' => $status_mask); -} - -sub _is_valid_state -{ - my ($self,$state) = @_; - if (!(defined($state)) or $state eq '') { - return 0; - } - - my ($msg, $substate) = split(/:/, $state, 2); - $msg=lc($msg); - - if ($msg=~/^([1]?[0-9]?[0-9])/) - { - if ($1 < 1) { - $msg='off'; - } else { - $msg='on'; - } - } - - # confirm that the resulting $msg is legitimate - if (!(defined($message_types{$msg}))) { - return 0; - } else { - return 1; - } -} - -sub _is_info_request -{ - my ($self, $cmd, $ack_setby, %msg) = @_; - my $is_info_request = ($cmd eq 'status_request') ? 1 : 0; -#print "cmd: $cmd; is_info_request: $is_info_request\n"; - if ($is_info_request) { - my $ack_on_level = (hex($msg{extra}) >= 254) ? 100 : sprintf("%d", hex($msg{extra}) * 100 / 255); - &::print_log("[Insteon_Device] received status request report for " . - $self->{object_name} . " with on-level: $ack_on_level%, " - . "hops left: $msg{hopsleft}") if $main::Debug{insteon}; - $self->level($ack_on_level); # update the level value - if ($ack_on_level == 0) { - $self->SUPER::set('off', $ack_setby); - } elsif ($ack_on_level > 0 and !($self->is_dimmable)) { - $self->SUPER::set('on', $ack_setby); - } else { - $self->SUPER::set($ack_on_level . '%', $ack_setby); - } - } - return $is_info_request; - -} - -sub _process_message -{ - my ($self,$p_setby,%msg) = @_; - my $p_state = undef; - - # the current approach assumes that links from other controllers to some responder - # would be seen by the plm by also direct linking the controller as a responder - # and not putting the plm into monitor mode. This means that updating the state - # of the responder based upon the link controller's request is handled - # by Insteon_Link. - $$self{m_is_locally_set} = 1 if $msg{source} eq lc $self->device_id; - if ($msg{is_ack}) { - my $pending_cmd = ($$self{_prior_msg}) ? $$self{_prior_msg}{command} : $msg{command}; - if ($$self{awaiting_ack}) { - my $ack_setby = (ref $$self{m_status_request_pending}) - ? $$self{m_status_request_pending} : $p_setby; - if ($self->_is_info_request($pending_cmd,$ack_setby,%msg)) { - $self->is_acknowledged(1); - $$self{m_status_request_pending} = 0; - $self->_process_command_stack(%msg); - } elsif (($pending_cmd eq 'peek') or ($pending_cmd eq 'set_address_msb')) { - $self->_on_peek(%msg); - $self->_process_command_stack(%msg); - } elsif (($pending_cmd eq 'poke') or ($pending_cmd eq 'set_address_msb')) { - $self->_on_poke(%msg); - $self->_process_command_stack(%msg); - } else { - $self->is_acknowledged(1); - # signal receipt of message to the command stack in case commands are queued - $self->_process_command_stack(%msg); - &::print_log("[Insteon_Device] received command/state (awaiting) acknowledge from " . $self->{object_name} - . ": $pending_cmd and data: $msg{extra}") if $main::Debug{insteon}; - } - } else { - # allow non-synchronous messages to also use the _is_info_request hook - $self->_is_info_request($pending_cmd,$p_setby,%msg); - $self->is_acknowledged(1); - # signal receipt of message to the command stack in case commands are queued - $self->_process_command_stack(%msg); - &::print_log("[Insteon_Device] received command/state acknowledge from " . $self->{object_name} - . ": " . (($msg{command}) ? $msg{command} : "(unknown)") - . " and data: $msg{extra}") if $main::Debug{insteon}; - } - } elsif ($msg{is_nack}) { - if ($$self{awaiting_ack}) { - &::print_log("[Insteon_Device] WARN!! encountered a nack message for " . $self->{object_name} - . " ... waiting for retry"); - } else { - &::print_log("[Insteon_Device] WARN!! encountered a nack message for " . $self->{object_name} - . " ... skipping"); - $self->is_acknowledged(0); - $self->_process_command_stack(%msg); - } - } elsif ($msg{command} eq 'start_manual_change') { - # do nothing; although, maybe anticipate change? we should always get a stop - } elsif ($msg{command} eq 'stop_manual_change') { - $self->request_status($self); - } elsif ($msg{type} eq 'broadcast') { - $self->devcat($msg{devcat}); - &::print_log("[Insteon_Device] device category: $msg{devcat} received for " . $self->{object_name}); - # stop ping timer now that we have a devcat; possibly may want to change this behavior to allow recurring pings - $$self{ping_timer}->stop(); - } else { - ## TO-DO: make sure that the state passed by command is something that is reasonable to set - $p_state = $msg{command}; - $$self{_pending_cleanup} = 1 if $msg{type} eq 'alllink'; -# $self->set($p_state, $p_setby) unless (lc($self->state) eq lc($p_state)) and - $self->set($p_state, $self) unless (lc($self->state) eq lc($p_state)) and - ($msg{type} eq 'cleanup' and $$self{_pending_cleanup}); - $$self{_pending_cleanup} = 0 if $msg{type} eq 'cleanup'; - } -} - -sub _xlate_insteon_mh -{ - my ($p_state) = @_; - my %msg = (); - my $hopflag = hex(uc substr($p_state,13,1)); - $msg{hopsleft} = $hopflag >> 2; - my $msgflag = hex(uc substr($p_state,12,1)); - $msg{is_extended} = (0x01 & $msgflag) ? 1 : 0; - if ($msg{is_extended}) { - $msg{source} = substr($p_state,0,6); - $msg{destination} = substr($p_state,6,6); - $msg{extra} = substr($p_state,16,16); - } else { - $msg{source} = substr($p_state,0,6); - $msgflag = $msgflag >> 1; - if ($msgflag == 4) { - $msg{type} = 'broadcast'; - $msg{devcat} = substr($p_state,6,4); - $msg{firmware} = substr($p_state,10,2); - $msg{is_master} = substr($p_state,16,2); - $msg{dev_attribs} = substr($p_state,18,2); - } elsif ($msgflag ==6) { - $msg{type} = 'alllink'; - $msg{group} = substr($p_state,10,2); - } else { - $msg{destination} = substr($p_state,6,6); - if ($msgflag == 2) { - $msg{type} = 'cleanup'; - $msg{group} = substr($p_state,16,2); - } elsif ($msgflag == 3) { - $msg{type} = 'cleanup'; - $msg{is_ack} = 1; - } elsif ($msgflag == 7) { - $msg{type} = 'cleanup'; - $msg{is_nack} = 1; - } elsif ($msgflag == 0) { - $msg{type} = 'direct'; - $msg{extra} = substr($p_state,16,2); - } elsif ($msgflag == 1) { - $msg{type} = 'direct'; - $msg{is_ack} = 1; - $msg{extra} = substr($p_state,16,2); - } elsif ($msgflag == 5) { - $msg{type} = 'direct'; - $msg{is_nack} = 1; - } - } - } - my $cmd1 = substr($p_state,14,2); - - if ($msg{type} ne 'broadcast') { - &::print_log("[Insteon_Device] command:$cmd1; type:$msg{type}; group: $msg{group}") if (!($msg{is_ack} or $msg{is_nack})) - and $main::Debug{insteon}; - for my $key (keys %message_types){ - if (pack("C",$message_types{$key}) eq pack("H*",$cmd1)) - { - &::print_log("[Insteon_Device] found: $key") - if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; - $msg{command}=$key; - last; - } - } - } - return %msg; -} - -sub _xlate_mh_insteon -{ - my ($self,$p_state,$p_type, $p_extra) = @_; - my $cmd; - my @args; - my $level; - - #msg id - my ($msg, $substate) = split(/:/, $p_state, 2); - $msg=lc($msg); -# &::print_log("XLATE:$msg:$substate:$p_state:"); - - if (!(defined $p_extra)) { - if ($msg eq 'on') - { - if (defined $self->local_onlevel) { - $level = 2.55 * $self->local_onlevel; - $msg = 'on_fast'; - } else { - $level=255; - } - } elsif ($msg eq 'off') - { - $level = 0; - } elsif ($msg=~/^([1]?[0-9]?[0-9])/) - { - if ($1 < 1) { - $msg='off'; - $level = 0; - } else { - $level = ($self->is_dimmable) ? $1 * 2.55 : 255; - $msg='on'; - } - } - } - - # confirm that the resulting $msg is legitimate - if (!(defined($message_types{$msg}))) { - &::print_log("[Insteon_Device] invalid state=$msg") if $main::Debug{insteon}; - return undef; - } - - $cmd=''; - if ($p_type =~ /broadcast/i) { - $cmd.=$self->group; - } else { - $cmd.=$self->device_id(); - if ($p_type =~ /extended/i) { - $cmd.='1F'; - } else { - $cmd.='0F'; - } - } - $cmd.= unpack("H*",pack("C",$message_types{$msg})); - if ($p_extra) - { - $cmd.= $p_extra; - } elsif ($substate) { - $cmd.= $substate; - } else { - if ($msg eq 'on') - { - $cmd.= sprintf("%02X",$level); - } else { - $cmd.='00'; - } - } - return $cmd; -} - -sub _on_poke -{ - my ($self,%msg) = @_; - if (($$self{_mem_activity} eq 'update') or ($$self{_mem_activity} eq 'add')) { - if ($$self{_mem_action} eq 'adlb_flag') { - $$self{_mem_action} = 'adlb_group'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_group') { - $$self{_mem_action} = 'adlb_devhi'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_devhi') { - $$self{_mem_action} = 'adlb_devmid'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_devmid') { - $$self{_mem_action} = 'adlb_devlo'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_devlo') { - $$self{_mem_action} = 'adlb_data1'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_data1') { - $$self{_mem_action} = 'adlb_data2'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_data2') { - $$self{_mem_action} = 'adlb_data3'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_data3') { - ## update the adlb records w/ the changes that were made - my $adlbkey = $$self{pending_adlb}{deviceid} . $$self{pending_adlb}{group} . $$self{pending_adlb}{is_controller}; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - my $subaddress = $$self{pending_adlb}{data3}; - if (($subaddress ne '00') and ($subaddress ne '01')) { - $adlbkey .= $subaddress; - } - $$self{adlb}{$adlbkey}{data1} = $$self{pending_adlb}{data1}; - $$self{adlb}{$adlbkey}{data2} = $$self{pending_adlb}{data2}; - $$self{adlb}{$adlbkey}{data3} = $$self{pending_adlb}{data3}; - $$self{adlb}{$adlbkey}{inuse} = 1; # needed so that restore string will preserve record - if ($$self{_mem_activity} eq 'add') { - $$self{adlb}{$adlbkey}{is_controller} = $$self{pending_adlb}{is_controller}; - $$self{adlb}{$adlbkey}{deviceid} = lc $$self{pending_adlb}{deviceid}; - $$self{adlb}{$adlbkey}{group} = lc $$self{pending_adlb}{group}; - $$self{adlb}{$adlbkey}{address} = $$self{pending_adlb}{address}; - # on completion, check to see if the empty links list is now empty; if so, - # then decrement the current address and add it to the list - my $num_empty = @{$$self{adlb}{empty}}; - if (!($num_empty)) { - my $low_address = 0; - for my $key (keys %{$$self{adlb}}) { - next if $key eq 'empty' or $key eq 'duplicates'; - my $new_address = hex($$self{adlb}{$key}{address}); - if (!($low_address)) { - $low_address = $new_address; - next; - } else { - $low_address = $new_address if $new_address < $low_address; - } - } - $low_address = sprintf('%04X', $low_address - 8); - unshift @{$$self{adlb}{empty}}, $low_address; - } - } - # clear out mem_activity flag - $$self{_mem_activity} = undef; - if (defined $$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; - # clear it out *before* the eval - $$self{_mem_callback} = undef; - package main; - eval ($callback); - package Insteon_Device; - &::print_log("[Insteon_Device] error in link callback: " . $@) - if $@ and $main::Debug{insteon}; - } - } - } elsif ($$self{_mem_activity} eq 'update_local') { - if ($$self{_mem_action} eq 'local_onlevel') { - $$self{_mem_lsb} = '21'; - $$self{_mem_action} = 'local_ramprate'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'local_ramprate') { - if ($self->is_keypadlinc) { - # update from eeprom--only a kpl issue - $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); - } - } - } elsif ($$self{_mem_activity} eq 'update_flags') { - # update from eeprom--only a kpl issue - $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'delete') { - # clear out mem_activity flag - $$self{_mem_activity} = undef; - # add the address of the deleted link to the empty list - push @{$$self{adlb}{empty}}, $$self{pending_adlb}{address}; - if (exists $$self{pending_adlb}{deviceid}) { - my $key = lc $$self{pending_adlb}{deviceid} . $$self{pending_adlb}{group} . $$self{pending_adlb}{is_controller}; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - my $subaddress = $$self{pending_adlb}{data3}; - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - delete $$self{adlb}{$key}; - } - - if (defined $$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; - # clear it out *before* the eval - $$self{_mem_callback} = undef; - package main; - eval ($callback); - &::print_log("[Insteon_Device] error in link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_Device; - $$self{_mem_callback} = undef; - } - } -# -} - -sub _on_peek -{ - my ($self,%msg) = @_; - if ($msg{is_extended}) { - &::print_log("Insteon_Device: extended peek for " . $self->{object_name} - . " is " . $msg{extra}) if $main::Debug{insteon}; - } else { - if ($$self{_mem_action} eq 'adlb_peek') { - if ($$self{_mem_activity} eq 'scan') { - $$self{_mem_action} = 'adlb_flag'; - # if the device is responding to the peek, then init the link table - # if at the very start of a scan - if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { - # reinit the adlb hash as there will be a new one - $$self{adlb} = undef; - # reinit the empty address list - @{$$self{adlb}{empty}} = (); - # and, also the duplicates list - @{$$self{adlb}{duplicates}} = (); - } - } elsif ($$self{_mem_activity} eq 'update') { - $$self{_mem_action} = 'adlb_data1'; - } elsif ($$self{_mem_activity} eq 'update_local') { - $$self{_mem_action} = 'local_onlevel'; - } elsif ($$self{_mem_activity} eq 'update_flags') { - $$self{_mem_action} = 'update_flags'; - } elsif ($$self{_mem_activity} eq 'delete') { - $$self{_mem_action} = 'adlb_flag'; - } elsif ($$self{_mem_activity} eq 'add') { - $$self{_mem_action} = 'adlb_flag'; - } - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'adlb_flag') { - if ($$self{_mem_activity} eq 'scan') { - my $flag = hex($msg{extra}); - $$self{pending_adlb}{inuse} = ($flag & 0x80) ? 1 : 0; - $$self{pending_adlb}{is_controller} = ($flag & 0x40) ? 1 : 0; - $$self{pending_adlb}{highwater} = ($flag & 0x02) ? 1 : 0; - if (!($$self{pending_adlb}{highwater})) { - # since this is the last unused memory location, then add it to the empty list - unshift @{$$self{adlb}{empty}}, $$self{_mem_msb} . $$self{_mem_lsb}; - $$self{_mem_action} = undef; - # clear out mem_activity flag - $$self{_mem_activity} = undef; - &::print_log("[Insteon_Device] " . $self->get_object_name . " completed link memory scan") - if $main::Debug{insteon}; - if (defined $$self{_mem_callback}) { - package main; - eval ($$self{_mem_callback}); - &::print_log("[Insteon_Device] " . $self->get_object_name . ": error during scan callback $@") - if $@ and $main::Debug{insteon}; - package Insteon_Device; - $$self{_mem_callback} = undef; - } - # ping the device as part of the scan if we don't already have a devcat - if (!($self->{devcat})) { - $self->ping(); - } - } else { - $$self{pending_adlb}{flag} = $msg{extra}; - ## confirm that we have a high-water mark; otherwise stop - $$self{pending_adlb}{address} = $$self{_mem_msb} . $$self{_mem_lsb}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'adlb_group'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_activity} eq 'add') { - my $flag = ($$self{pending_adlb}{is_controller}) ? 'E2' : 'A2'; - $$self{pending_adlb}{flag} = $flag; - $self->_send_cmd('command' => 'poke', 'extra' => $flag, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'delete') { - $self->_send_cmd('command' => 'poke', 'extra' => '02', 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_group') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_adlb}{group} = lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'adlb_devhi'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, - 'is_synchronous' => 1); - } else { - $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_adlb}{group}, - 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_devhi') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_adlb}{deviceid} = lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'adlb_devmid'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { - my $devid = substr($$self{pending_adlb}{deviceid},0,2); - $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_devmid') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_adlb}{deviceid} .= lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'adlb_devlo'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { - my $devid = substr($$self{pending_adlb}{deviceid},2,2); - $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_devlo') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_adlb}{deviceid} .= lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'adlb_data1'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { - my $devid = substr($$self{pending_adlb}{deviceid},4,2); - $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_data1') { - if ($$self{_mem_activity} eq 'scan') { - $$self{_mem_action} = 'adlb_data2'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{pending_adlb}{data1} = $msg{extra}; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { - # poke the new value - $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_adlb}{data1}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_data2') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_adlb}{data2} = $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'adlb_data3'; - $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { - # poke the new value - $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_adlb}{data2}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'adlb_data3') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_adlb}{data3} = $msg{extra}; - # check the previous record if highwater is set - if ($$self{pending_adlb}{highwater}) { - if ($$self{pending_adlb}{inuse}) { - # save pending_adlb and then clear it out - my $adlbkey = lc $$self{pending_adlb}{deviceid} - . $$self{pending_adlb}{group} - . $$self{pending_adlb}{is_controller}; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - my $subaddress = $$self{pending_adlb}{data3}; - if ($subaddress ne '00' and $subaddress ne '01') { - $adlbkey .= $subaddress; - } - # check for duplicates - if (exists $$self{adlb}{$adlbkey} && $$self{adlb}{$adlbkey}{inuse}) { - unshift @{$$self{adlb}{duplicates}}, $$self{pending_adlb}{address}; - } else { - %{$$self{adlb}{$adlbkey}} = %{$$self{pending_adlb}}; - } - } else { - # TO-DO: record the locations of deleted ADLB records for subsequent reuse - unshift @{$$self{adlb}{empty}}, $$self{pending_adlb}{address}; - } - my $newaddress = sprintf("%04X", hex($$self{pending_adlb}{address}) - 8); - $$self{pending_adlb} = undef; - $self->_peek($newaddress); - } - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { - # poke the new value - $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_adlb}{data3}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'local_onlevel') { - my $on_level = $self->local_onlevel; - $on_level = &Insteon_Device::convert_level($on_level); - $self->_send_cmd('command' => 'poke', 'extra' => $on_level, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'local_ramprate') { - my $ramp_rate = $$self{_ramprate}; - $ramp_rate = '1f' unless $ramp_rate; - $self->_send_cmd('command' => 'poke', 'extra' => $ramp_rate, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'update_flags') { - my $flags = $$self{_operating_flags}; - $self->_send_cmd('command' => 'poke', 'extra' => $flags, 'is_synchronous' => 1); - } -# -# &::print_log("Insteon_Device: peek for " . $self->{object_name} -# . " is " . $msg{extra}) if $main::Debug{insteon}; - } -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = $self->SUPER::restore_string(); - if ($$self{adlb}) { - my $adlb = ''; - foreach my $adlb_key (keys %{$$self{adlb}}) { - next unless $adlb_key eq 'empty' || $adlb_key eq 'duplicates' || $$self{adlb}{$adlb_key}{inuse}; - $adlb .= '|' if $adlb; # separate sections - my $record = ''; - if ($adlb_key eq 'empty') { - foreach my $address (@{$$self{adlb}{empty}}) { - $record .= ';' if $record; - $record .= $address; - } - $record = 'empty=' . $record; - } elsif ($adlb_key eq 'duplicates') { - my $duplicate_record = ''; - foreach my $address (@{$$self{adlb}{duplicates}}) { - $duplicate_record .= ';' if $duplicate_record; - $duplicate_record .= $address; - } - $record = 'duplicates=' . $duplicate_record; - } else { - my %adlb_record = %{$$self{adlb}{$adlb_key}}; - foreach my $record_key (keys %adlb_record) { - next unless $adlb_record{$record_key}; - $record .= ',' if $record; - $record .= $record_key . '=' . $adlb_record{$record_key}; - } - } - $adlb .= $record; - } -# &::print_log("[Insteon_Device] ADLB restore string: $adlb") if $main::Debug{insteon}; - $restore_string .= $self->{object_name} . "->restore_adlb(q~$adlb~);\n"; - } - if ($$self{states}) { - my $states = ''; - foreach my $state (@{$$self{states}}) { - $states .= '|' if $states; - $states .= $state; - } - $restore_string .= $self->{object_name} . "->restore_states(q~$states~);\n"; - } - return $restore_string; -} - -sub restore_states -{ - my ($self, $states) = @_; - if ($states) { - @{$$self{states}} = split(/\|/,$states); - } -} - -sub restore_adlb -{ - my ($self,$adlb) = @_; - if ($adlb) { - foreach my $adlb_section (split(/\|/,$adlb)) { - my %adlb_record = (); - my @adlb_empty = (); - my @adlb_duplicates = (); - my $deviceid = ''; - my $groupid = '01'; - my $is_controller = 0; - my $subaddress = '00'; - foreach my $adlb_entry (split(/,/,$adlb_section)) { - my ($key,$value) = split(/=/,$adlb_entry); - next unless $key and defined($value) and $value ne ''; - if ($key eq 'empty') { - @adlb_empty = split(/;/,$value); - } elsif ($key eq 'duplicates') { - @adlb_duplicates = split(/;/,$value); - } else { - $deviceid = lc $value if ($key eq 'deviceid'); - $groupid = lc $value if ($key eq 'group'); - $is_controller = $value if ($key eq 'is_controller'); - $subaddress = $value if ($key eq 'data3'); - $adlb_record{$key} = $value if $key and defined($value); - } - } - if (@adlb_empty) { - @{$$self{adlb}{empty}} = @adlb_empty; - } elsif (@adlb_duplicates) { - @{$$self{adlb}{duplicates}} = @adlb_duplicates; - } elsif (scalar %adlb_record) { - next unless $deviceid; - my $adlbkey = $deviceid . $groupid . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $adlbkey .= $subaddress; - } - %{$$self{adlb}{$adlbkey}} = %adlb_record; - } - } -# $self->log_alllink_table(); - } -} - -sub devcat -{ - my ($self, $devcat) = @_; - if ($devcat) { - $$self{devcat} = $devcat; - if (($$self{devcat} =~ /^01\w\w/) or ($$self{devcat} =~ /^02\w\w/) && !($self->states)) { - $self->states( 'on,off' ); - } - } - return $$self{devcat}; -} - -sub states -{ - my ($self, $states) = @_; - if ($states) { - @{$$self{states}} = split(/,/,$states); - } - if ($$self{states}) { - return @{$$self{states}}; - } else { - return undef; - } - -} - -sub is_dimmable -{ - my ($self) = @_; - if (!($self->is_root)) { - return 0; - } else { - if ($$self{devcat}) { - if ($$self{devcat} =~ /^01\w\w/) { - return 1; - } else { - return 0; - } - } else { - &::print_log("[Insteon_Device] WARN: making assumption that " . $self->get_object_name . " is dimmable because devcat is not yet known") - if $main::Debug{insteon}; - return 1; - } - } -} - -sub local_onlevel -{ - my ($self, $p_onlevel) = @_; - if (defined $p_onlevel) { - my ($onlevel) = $p_onlevel =~ /(\d+)%?/; - $$self{_onlevel} = $onlevel; - } - return $$self{_onlevel}; -} - -sub local_ramprate -{ - my ($self, $p_ramprate) = @_; - if (defined $p_ramprate) { - $$self{_ramprate} = &Insteon_Device::convert_ramp($p_ramprate); - } - return $$self{_ramprate}; - -} - -sub set_receive -{ - my ($self, $p_state, $p_setby, $p_response) = @_; - $self->level($p_state); # update the level value - $self->SUPER::set($p_state, $p_setby, $p_response); -} - -sub scan_link_table -{ - my ($self,$callback) = @_; - $$self{_mem_activity} = 'scan'; - $$self{_mem_callback} = ($callback) ? $callback : undef; - $self->_peek('0FF8',0); -} - -sub delete_link -{ - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - if ($link_parms{address}) { - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $$self{_mem_activity} = 'delete'; - $$self{pending_adlb}{address} = $link_parms{address}; - $self->_peek($link_parms{address},0); - - } else { - my $insteon_object = $link_parms{object}; - my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; - my $groupid = $link_parms{group}; - $groupid = '01' unless $groupid; - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; - # get the address via lookup into the hash - my $key = lc $deviceid . $groupid . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - my $address = $$self{adlb}{$key}{address}; - if ($address) { - &main::print_log("[Insteon_Device] Now deleting link [0x$address] with the following data" - . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); - # now, alter the flags byte such that the in_use flag is set to 0 - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $$self{_mem_activity} = 'delete'; - $$self{pending_adlb}{deviceid} = lc $deviceid; - $$self{pending_adlb}{group} = $groupid; - $$self{pending_adlb}{is_controller} = $is_controller; - $$self{pending_adlb}{address} = $address; - $self->_peek($address,0); - } else { - &main::print_log('[Insteon_Device] WARN: (' . $self->get_object_name . ') attempt to delete link that does not exist!' - . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); - if ($link_parms{callback}) { - package main; - eval($link_parms{callback}); - &::print_log("[Insteon_Device] error encountered during delete_link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_Device; - } - } - } -} - -sub delete_orphan_links -{ - my ($self) = @_; - @{$$self{delete_queue}} = (); # reset the work queue - my $selfname = $self->get_object_name; - my $num_deleted = 0; - for my $linkkey (keys %{$$self{adlb}}) { - if ($linkkey ne 'empty' and $linkkey ne 'duplicates') { - my $deviceid = lc $$self{adlb}{$linkkey}{deviceid}; - next unless $deviceid; - my $group = $$self{adlb}{$linkkey}{group}; - my $is_controller = $$self{adlb}{$linkkey}{is_controller}; - my $data3 = $$self{adlb}{$linkkey}{data3}; - my $device = ($deviceid eq lc $self->interface->device_id) ? $self->interface - : $self->interface->get_object($deviceid,'01'); - if (!($device)) { -# &::print_log("[Insteon_Device] " . $self->get_object_name . " now deleting orphaned link w/ details: " -# . (($is_controller) ? "controller" : "responder") -# . ", deviceid=$deviceid, group=$group"); - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", cause => "no device could be found"); - push @{$$self{delete_queue}}, \%delete_req; - } elsif ($device->isa("Insteon_PLM") and $is_controller) { - # ignore since this is just a link back to the PLM - } elsif ($device->isa("Insteon_PLM")) { - # does the PLM have a link point back? If not, the delete this one - if (!($device->has_link($self,$group,1))) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - # is there an entry in the items.mht that corresponds to this link? - if ($is_controller) { - # TO-DO: handle this case - } else { - my $plm_link = $device->get_device('000000',$group); - if ($plm_link) { - my $is_invalid = 1; - foreach my $member_ref (keys %{$$plm_link{members}}) { - my $member = $$plm_link{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon_Device'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->device_id eq $self->device_id) { - if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { - $is_invalid = 0; - last; - } - } - } - if ($is_invalid) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no link is defined for the plm controlled scene", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } else { - # delete the link since it doesn't exist - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no plm link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } - } else { - if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no link to the device could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } else { - my $is_invalid = 1; - my $link = ($is_controller) ? $self->interface->get_object($self->device_id,$group) - : $self->interface->get_object($device->device_id,$group); - if ($link) { - foreach my $member_ref (keys %{$$link{members}}) { - my $member = $$link{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon_Device'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->isa('Insteon_Device') and !($member->is_root)) { - $member = $member->get_root; - } - if ($member->isa('Insteon_Device') and !($is_controller) and ($member->device_id eq $self->device_id)) { - $is_invalid = 0; - last; - } elsif ($member->isa('Insteon_Device') and $is_controller and ($member->device_id eq $device->device_id)) { - $is_invalid = 0; - last; - } - - } - } - if ($is_invalid) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no reverse link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } - } - } elsif ($linkkey eq 'duplicates') { - my $address = pop @{$$self{adlb}{duplicates}}; - while ($address) { - my %delete_req = (address => $address, - callback => "$selfname->_process_delete_queue()", - cause => "duplicate record found"); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - $address = pop @{$$self{adlb}{duplicates}}; - } - } - } - $$self{delete_queue_processed} = 0; - $self->_process_delete_queue(); - return $num_deleted; -} - -sub _process_delete_queue { - my ($self) = @_; - my $num_in_queue = @{$$self{delete_queue}}; - if ($num_in_queue) { - my $delete_req_ptr = shift(@{$$self{delete_queue}}); - my %delete_req = %$delete_req_ptr; - if ($delete_req{address}) { - &::print_log("[Insteon_Device] " . $self->get_object_name . " now deleting duplicate record at address " - . $delete_req{address}); - } else { - &::print_log("[Insteon_Device] " . $self->get_object_name . " now deleting orphaned link w/ details: " - . (($delete_req{is_controller}) ? "controller" : "responder") - . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name - : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); - } - $self->delete_link(%delete_req); - $$self{delete_queue_processed}++; - } else { - $self->interface->_process_delete_queue($$self{delete_queue_processed}); - } -} - -sub add_link -{ - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - my $device_id; - my $insteon_object = $link_parms{object}; - my $group = $link_parms{group}; - if (!(defined($insteon_object))) { - $device_id = lc $link_parms{deviceid}; - $insteon_object = $self->interface->get_object($device_id, $group); - } else { - $device_id = lc $insteon_object->device_id; - } - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - # check whether the link already exists - my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; - # get the address via lookup into the hash - my $key = lc $device_id . $group . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - if (defined $$self{adlb}{$key}{inuse}) { - &::print_log("[Insteon_Device] WARN: attempt to add link to " . $self->get_object_name . " that already exists! " - . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); - if ($link_parms{callback}) { - package main; - eval($link_parms{callback}); - &::print_log("[Insteon_Device] failure occurred in callback eval for " . $self->get_object_name . ":" . $@) - if $@ and $main::Debug{insteon}; - package Insteon_Device; - } - } else { - # strip optional % sign to append on_level - my $on_level = $link_parms{on_level}; - $on_level =~ s/(\d)%?/$1/; - $on_level = '100' unless defined($on_level); # 100% == on is the default - # strip optional s (seconds) to append ramp_rate - my $ramp_rate = $link_parms{ramp_rate}; - $ramp_rate =~ s/(\d)s?/$1/; - $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default - &::print_log("[Insteon_Device] adding link record " . $self->get_object_name - . " light level controlled by " . $insteon_object->get_object_name - . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; - my $data1 = &Insteon_Device::convert_level($on_level); - my $data2 = ($self->is_dimmable) ? &Insteon_Device::convert_ramp($ramp_rate) : '00'; - my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; - # get the first available memory location - my $address = pop @{$$self{adlb}{empty}}; - # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails - $$self{_mem_activity} = 'add'; - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); - } -} - -sub update_link -{ - my ($self, %link_parms) = @_; - my $insteon_object = $link_parms{object}; - my $group = $link_parms{group}; - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - # strip optional % sign to append on_level - my $on_level = $link_parms{on_level}; - $on_level =~ s/(\d+)%?/$1/; - # strip optional s (seconds) to append ramp_rate - my $ramp_rate = $link_parms{ramp_rate}; - $ramp_rate =~ s/(\d)s?/$1/; - &::print_log("[Insteon_Device] updating " . $self->get_object_name . " light level controlled by " . $insteon_object->get_object_name - . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; - my $data1 = sprintf('%02X',$on_level * 2.55); - $data1 = 'ff' if $on_level eq '100'; - $data1 = '00' if $on_level eq '0'; - my $data2 = ($self->is_dimmable) ? &Insteon_Device::convert_ramp($ramp_rate) : '00'; - my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; - my $deviceid = $insteon_object->device_id; - my $subaddress = $data3; - # get the address via lookup into the hash - my $key = lc $deviceid . $group . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - my $address = $$self{adlb}{$key}{address}; - $$self{_mem_activity} = 'update'; - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $self->_write_link($address, $deviceid, $group, $is_controller, $data1, $data2, $data3); -} - - -sub log_alllink_table -{ - my ($self) = @_; - &::print_log("[Insteon_Device] link table for " . $self->get_object_name . " (devcat: $$self{devcat}):"); - foreach my $adlbkey (sort(keys(%{$$self{adlb}}))) { - next if $adlbkey eq 'empty' or $adlbkey eq 'duplicates'; - my ($device); - my $is_controller = $$self{adlb}{$adlbkey}{is_controller}; - if ($self->interface()->device_id() and ($self->interface()->device_id() eq $$self{adlb}{$adlbkey}{deviceid})) { - $device = $self->interface; - } else { - $device = $self->interface()->get_object($$self{adlb}{$adlbkey}{deviceid},'01'); - } - my $object_name = ($device) ? $device->get_object_name : $$self{adlb}{$adlbkey}{deviceid}; - - my $on_level = 'unknown'; - if (defined $$self{adlb}{$adlbkey}{data1}) { - if ($$self{adlb}{$adlbkey}{data1}) { - $on_level = int((hex($$self{adlb}{$adlbkey}{data1})*100/255) + .5) . "%"; - } else { - $on_level = '0%'; - } - } - - my $rspndr_group = $$self{adlb}{$adlbkey}{data3}; - $rspndr_group = '01' if $rspndr_group eq '00'; - - my $ramp_rate = 'unknown'; - if ($$self{adlb}{$adlbkey}{data2}) { - if (!($self->is_dimmable) or (!($is_controller) and ($rspndr_group != '01'))) { - $ramp_rate = 'none'; - if ($on_level eq '0%') { - $on_level = 'off'; - } else { - $on_level = 'on'; - } - } else { - $ramp_rate = $ramp_h2n{$$self{adlb}{$adlbkey}{data2}} . "s"; - } - } - - &::print_log("[Insteon_Device] aldb $adlbkey [0x" . $$self{adlb}{$adlbkey}{address} . "] " . - (($$self{adlb}{$adlbkey}{is_controller}) ? "contlr($$self{adlb}{$adlbkey}{group}) record to " - . $object_name . "($rspndr_group), (d1:$$self{adlb}{$adlbkey}{data1}, d2:$$self{adlb}{$adlbkey}{data2}, d3:$$self{adlb}{$adlbkey}{data3})" - : "rspndr($rspndr_group) record to " . $object_name . "($$self{adlb}{$adlbkey}{group})" - . ": onlevel=$on_level and ramp=$ramp_rate (d3:$$self{adlb}{$adlbkey}{data3})")) if $main::Debug{insteon}; - } - foreach my $address (@{$$self{adlb}{empty}}) { - &::print_log("[Insteon_Device] adlb [0x$address] is empty"); - } - - foreach my $address (@{$$self{adlb}{duplicates}}) { - &::print_log("[Insteon_Device] adlb [0x$address] holds a duplicate entry"); - } - -} - -sub get_link_record -{ - my ($self,$link_key) = @_; - my %link_record = (); - %link_record = %{$$self{adlb}{$link_key}} if $$self{adlb}{$link_key}; - return %link_record; -} - -sub update_local_properties -{ - my ($self) = @_; - if ($self->is_dimmable) { - $$self{_mem_activity} = 'update_local'; - $self->_peek('0032'); # 0032 is the address for the onlevel - } else { - &::print_log("[Insteon_Device] update_local_properties may only be applied to dimmable devices!"); - } -} - -sub update_flags -{ - my ($self, $flags) = @_; - if (!($self->is_keypadlinc)) { - &::print_log("[Insteon_Device] Operating flags may only be revised on keypadlincs!"); - return; - } - return unless defined $flags; - - $$self{_mem_activity} = 'update_flags'; - $$self{_operating_flags} = $flags; - $self->_peek('0023'); -} - - -sub has_link -{ - my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = lc $insteon_object->device_id . $group . $is_controller; - $subaddress = '00' unless $subaddress; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - return (defined $$self{adlb}{$key}) ? 1 : 0; -} - -sub _write_link -{ - my ($self, $address, $deviceid, $group, $is_controller, $data1, $data2, $data3) = @_; - if ($address) { - &::print_log("[Insteon_Device] " . $self->get_object_name . " address: $address found for device: $deviceid and group: $group"); - # change address for start of change to be address + offset - if ($$self{_mem_activity} eq 'update') { - $address = sprintf('%04X',hex($address) + 5); - } - $$self{pending_adlb}{address} = $address; - $$self{pending_adlb}{deviceid} = lc $deviceid; - $$self{pending_adlb}{group} = lc $group; - $$self{pending_adlb}{is_controller} = $is_controller; - $$self{pending_adlb}{data1} = (defined $data1) ? lc $data1 : '00'; - $$self{pending_adlb}{data2} = (defined $data2) ? lc $data2 : '00'; - # Note: if device is a KeypadLinc, then $data3 must be assigned the value of the applicable button (01) - if (($self->is_keypadlinc) and ($data3 eq '00')) { - &::print_log("[Insteon_Device] setting data3 to " . $self->group . " for this keypadlinc") - if $main::Debug{insteon}; - $data3 = $self->group; - } - $$self{pending_adlb}{data3} = (defined $data3) ? lc $data3 : '00'; - $self->_peek($address); - } else { - &::print_log("[Insteon_Device] WARN: " . $self->get_object_name - . " write_link failure: no address available for record to device: $deviceid and group: $group" . - " and is_controller: $is_controller");; - } -} - -sub _peek -{ - my ($self, $address, $extended) = @_; - my $msb = substr($address,0,2); - my $lsb = substr($address,2,2); - if ($extended) { - $$self{interface}->set($self->_xlate_mh_insteon('peek','extended', - $lsb . "0000000000000000000000000000"),$self); - } else { - $$self{_mem_lsb} = $lsb; - $$self{_mem_msb} = $msb; - $$self{_mem_action} = 'adlb_peek'; - &::print_log("[Insteon_Device] " . $self->get_object_name . " accessing memory at location: 0x" . $address); - $self->_send_cmd('command' => 'set_address_msb', 'extra' => $msb, 'is_synchronous' => 1); - } -} - - -1; diff --git a/lib/Insteon_Irrigation.pm b/lib/Insteon_Irrigation.pm index 7d2726062..727d6a164 100644 --- a/lib/Insteon_Irrigation.pm +++ b/lib/Insteon_Irrigation.pm @@ -3,7 +3,6 @@ AUTHORS Gregg Liming David Norwood -Evan P. Hall INITIAL CONFIGURATION In user code: @@ -58,7 +57,7 @@ use strict; package Insteon_Irrigation; -@Insteon_Irrigation::ISA = ('Insteon_Link'); +@Insteon_Irrigation::ISA = ('Insteon_Device'); # -------------------- START OF SUBROUTINES -------------------- @@ -175,4 +174,4 @@ sub _is_info_request { # Overload methods we don't use, but would otherwise cause Insteon traffic. sub request_status { return 0 } - 1; \ No newline at end of file +1; \ No newline at end of file diff --git a/lib/Insteon_Link.pm b/lib/Insteon_Link.pm deleted file mode 100644 index beb4160ae..000000000 --- a/lib/Insteon_Link.pm +++ /dev/null @@ -1,429 +0,0 @@ -=begin comment -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - -File: - Insteon_Link.pm - -Description: - Generic class implementation of a Insteon Device. - -Author(s): - Gregg Liming / gregg@limings.net - Jason Sharpee / jason@sharpee.com - -License: - This free software is licensed under the terms of the GNU public license. - -Usage: - - $insteon_family_movie = new Insteon_Device($myPIM,30,1); - - $insteon_familty_movie->set("on"); - -Special Thanks to: - Brian Warren for signficant testing and patches - Bruce Winter - MH - -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -=cut - -use Insteon_Device; - -use strict; -package Insteon_Link; - -@Insteon_Link::ISA = ('Insteon_Device'); - -my %message_types = ( - %SUPER::message_types -); - -sub new -{ - my ($class,$p_interface,$p_deviceid,$p_devcat) = @_; - - # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller - my $self = $class->SUPER::new($p_interface,$p_deviceid,$p_devcat); - bless $self,$class; -# don't apply ping timer to this class - $$self{ping_timer}->stop(); - return $self; -} - -sub add -{ - my ($self, $obj, $on_level, $ramp_rate) = @_; - if (ref $obj and (($obj->isa('Insteon_Device') and !($obj->is_plm_controlled)) or $obj->isa('Light_Item'))) { - if ($$self{members} && $$self{members}{$obj}) { - print "[Insteon_Link] An object (" . $obj->{object_name} . ") already exists " - . "in this scene. Aborting add request.\n"; - return; - } - if ($on_level =~ /^sur/i) { - $on_level = '100%'; - $$obj{surrogate} = $self; - } elsif (lc $on_level eq 'on') { - $on_level = '100%'; - } elsif (lc $on_level eq 'off') { - $on_level = '0%'; - } - $on_level = '100%' unless $on_level; - $$self{members}{$obj}{on_level} = $on_level; - $$self{members}{$obj}{object} = $obj; - $ramp_rate =~ s/s$//i; - $$self{members}{$obj}{ramp_rate} = $ramp_rate if defined $ramp_rate; - } else { - &::print_log("[Insteon_Link] WARN: unable to add $obj as items of this type are not supported!"); - } -} - -sub sync_links -{ - my ($self, $callback) = @_; - @{$$self{sync_queue}} = (); # reset the work queue - $$self{sync_queue_callback} = ($callback) ? $callback : undef; - my $insteon_object = $self->interface; - if (!($self->is_plm_controlled)) { - $insteon_object = $self->interface->get_object($self->device_id,'01'); - if (!(defined($insteon_object))) { - &main::print_log("[Insteon_Link] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " - . "Please double check your items.mht file."); - } - } - my $self_link_name = $self->get_object_name; - # abort if $insteon_object doesn't exist - $self->_process_sync_queue() unless $insteon_object; - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my $member = $$self{members}{$member_ref}{object}; - # find real device if member is a Light_Item - if ($member->isa('Light_Item')) { - my @children = $member->find_members('Insteon_Device'); - $member = $children[0]; - } - my $linkmember = $member; - # find real device if member's group is not '01'; for example, cross-linked KeypadLincs - if ($member->group ne '01') { - $member = $self->interface->get_object($member->device_id,'01'); - } - my $tgt_on_level = $$self{members}{$member_ref}{on_level}; - $tgt_on_level = '100%' unless defined $tgt_on_level; - - my $tgt_ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $tgt_ramp_rate = '0' unless defined $tgt_ramp_rate; - # first, check existance for each link; if found, then perform an update (unless link is to PLM) - # if not, then add the link - if ($member->has_link($insteon_object, $self->group, 0, $linkmember->group)) { - # TO-DO: only update link if the on_level and ramp_rate are different - my $requires_update = 0; - $tgt_on_level =~ s/(\d+)%?/$1/; - $tgt_ramp_rate =~ s/(\d)s?/$1/; - my $adlbkey = lc $insteon_object->device_id . $self->group . '0'; - if ($member->is_keypadlinc and $linkmember->group ne '01') { - $adlbkey .= $linkmember->group; - } - if (!($member->is_dimmable)) { - if ($tgt_on_level >= 1 and $$member{adlb}{$adlbkey}{data1} ne 'ff') { - $requires_update = 1; - $tgt_on_level = 100; - } elsif ($tgt_on_level == 0 and $$member{adlb}{$adlbkey}{data1} ne '00') { - $requires_update = 1; - } - if ($$member{adlb}{$adlbkey}{data2} ne '00') { - $tgt_ramp_rate = 0; - } - } else { - $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; - my $link_on_level = hex($$member{adlb}{$adlbkey}{data1})/2.55; - my $raw_ramp_rate = $$member{adlb}{$adlbkey}{data2}; - my $link_ramp_rate = &Insteon_Device::get_ramp_from_code($raw_ramp_rate); - if ($link_ramp_rate != $tgt_ramp_rate) { - $requires_update = 1; - } elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) { - $requires_update = 1; - } - } - if ($requires_update) { - my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, - group => $self->group, is_controller => 0, - on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->is_keypadlinc) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; - } - } else { - my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, - group => $self->group, is_controller => 0, - on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->is_keypadlinc) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; - } - if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) { - my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, - group => $self->group, is_controller => 1, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->is_keypadlinc) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; - } - } - } - # if not a plm controlled link, then confirm that a link back to the plm exists - if (!($self->is_plm_controlled)) { - my $subaddress = ($self->is_keypadlinc) ? $self->group : '00'; - if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) { - my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, - group => $self->group, is_controller => 1, - callback => "$self_link_name->_process_sync_queue()" ); - $link_req{data3} = $self->group if $insteon_object->is_keypadlinc; - push @{$$self{sync_queue}}, \%link_req; - } - if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) { - my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, - group => $self->group, is_controller => 0, - callback => "$self_link_name->_process_sync_queue()" ); - push @{$$self{sync_queue}}, \%link_req; - } - } - my $num_sync_queue = @{$$self{sync_queue}}; - if (!($num_sync_queue)) { - &::print_log("[Insteon_Link] Nothing to do when syncing links for " . $self->get_object_name) - if $main::Debug{insteon}; - } - $self->_process_sync_queue(); - - # TO-DO: consult links table to determine if any "orphaned links" refer to this device; if so, then delete - # WARN: can't immediately do this as the link tables aren't finalized on the above operations - # until the end of the actual insteon memory poke sequences; therefore, may need to handle separately -} - -sub _process_sync_queue { - my ($self) = @_; - # get next in queue if it exists - my $num_sync_queue = @{$$self{sync_queue}}; - if ($num_sync_queue) { - my $link_req_ptr = shift(@{$$self{sync_queue}}); - my %link_req = %$link_req_ptr; - if ($link_req{cmd} eq 'update') { - my $link_member = $link_req{member}; - $link_member->update_link(%link_req); - } elsif ($link_req{cmd} eq 'add') { - my $link_member = $link_req{member}; - $link_member->add_link(%link_req); - } - } elsif ($$self{sync_queue_callback}) { - package main; - eval ($$self{sync_queue_callback}); - &::print_log("[Insteon_Link] error in sync links callback: " . $@) - if $@ and $main::Debug{insteon}; - $$self{sync_queue_callback} = undef; - package Insteon_link; - } -} - -sub set -{ - my ($self, $p_state, $p_setby, $p_respond) = @_; - return if &main::check_for_tied_filters($self, $p_state); - - # prevent setby internal Insteon_Device timers - return if $p_setby eq $$self{ping_timer}; - if (ref $p_setby and $p_setby eq $$self{queue_timer}) { - $self->_process_command_stack(); - return; - } - - my $link_state = 'on'; - if ($p_state eq 'off') { - $link_state = 'off'; - } elsif ($p_state =~ /\d+%?/) { - my ($dim_state) = $p_state =~ /(\d+)%?/; - $link_state = 'off' if $dim_state == 0; - } - if ($self->is_plm_controlled or !($self->is_root)) { - # iterate over the members - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my $member = $$self{members}{$member_ref}{object}; - my $on_state = $$self{members}{$member_ref}{on_level}; - $on_state = '100%' unless $on_state; - my $local_state = $on_state; - $local_state = 'on' if $local_state eq '100%' - && $member->isa('Insteon_Device') && !($member->is_root); - $local_state = 'off' if $local_state eq '0%' or $link_state eq 'off'; - if ($member->isa('Light_Item')) { - # if they are Light_Items, then set their on_dim attrib to the member on level - # and then "blank" them via the manual method for a tad over the ramp rate - # In addition, locate the Light_Item's Insteon_Device member and do the - # same as if the member were an Insteon_Device - my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $ramp_rate = 0 unless defined $ramp_rate; - $ramp_rate = $ramp_rate + 2; - my @lights = $member->find_members('Insteon_Device'); - if (@lights) { - my $light = @lights[0]; - # remember the current state to support resume - $$self{members}{$member_ref}{resume_state} = $light->state; - $member->manual($light, $ramp_rate); - $light->set_receive($local_state,$self); - } else { - $member->manual(1, $ramp_rate); - } - $member->set_on_state($local_state) unless $link_state eq 'off'; - } elsif ($member->isa('Insteon_Device')) { - # remember the current state to support resume - $$self{members}{$member_ref}{resume_state} = $member->state; - # if they are Insteon_Device objects, then simply set_receive their state to - # the member on level - $member->set_receive($local_state,$self); - } - } - } - } - if ($self->is_keypadlinc and !($self->is_root)) { - if (ref $p_setby and $p_setby->isa('Insteon_Device')) { - $self->SUPER::set($p_state, $p_setby, $p_respond); - } elsif (ref $$self{surrogate} && $$self{surrogate}->isa('Insteon_Link')) { - $$self{surrogate}->set($link_state, $p_setby, $p_respond) - unless ref $p_setby and $p_setby eq $self; - } else { - &::print_log("[Insteon_Link] You may not directly attempt to set a keypadlinc's button " - . " unless you have defined a reverse link with the \"surrogate\" keyword"); - } - } else { - $self->SUPER::set((($self->is_root) ? $p_state : $link_state), $p_setby, $p_respond); - } -} - -sub update_members -{ - my ($self) = @_; - # iterate over the members - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my ($device); - my $member = $$self{members}{$member_ref}{object}; - my $on_state = $$self{members}{$member_ref}{on_level}; - $on_state = '100%' unless $on_state; - my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $ramp_rate = 0 unless defined $ramp_rate; - if ($member->isa('Light_Item')) { - # if they are Light_Items, then locate the Light_Item's Insteon_Device member - my @lights = $member->find_members('Insteon_Device'); - if (@lights) { - $device = @lights[0]; - } - } elsif ($member->isa('Insteon_Device')) { - $device = $member; - } - if ($device) { - my %current_record = $device->get_link_record($self->device_id . $self->group); - if (%current_record) { - &::print_log("[Insteon_Link] remote record: $current_record{data1}") - if $::Debug{insteon}; - } - } - } - } -} - -sub link_to_interface -{ - my ($self, $p_group, $p_data3) = @_; - my $group = $p_group; - $group = $self->group unless $group; - return if $self->device_id eq '000000'; # don't allow this to be used for PLM links - # get the surrogate device for this if group is not '01' - if ($self->group ne '01') { - my $surrogate_obj = $self->interface->get_object($self->device_id,'01'); - if ($p_data3) { - $surrogate_obj->link_to_interface($group,$p_data3); - } elsif ($surrogate_obj->is_keypadlinc) { - $surrogate_obj->link_to_interface($group,$self->group); - } else { - $surrogate_obj->link_to_interface($group); - } - # next, if the link is a keypadlinc, then create the reverse link to permit - # control over the button's light - if ($surrogate_obj->is_keypadlinc) { - - } - } else { - if ($p_data3) { - $self->SUPER::link_to_interface($group, $p_data3); - } else { - $self->SUPER::link_to_interface($group); - } - } -} - -sub unlink_to_interface -{ - my ($self,$p_group) = @_; - my $group = $p_group; - $group = $self->group unless $group; - return if $self->device_id eq '000000'; # don't allow this to be used for PLM links - # get the surrogate device for this if group is not '01' - if ($self->group ne '01') { - my $surrogate_obj = $self->interface->get_object($self->device_id,'01'); - $surrogate_obj->unlink_to_interface($group); - # next, if the link is a keypadlinc, then delete the reverse link to permit - # control over the button's light - if ($surrogate_obj->is_keypadlinc) { - - } - } else { - $self->SUPER::unlink_to_interface($group); - } -} - -sub initiate_linking_as_controller -{ - my ($self, $p_group) = @_; - # iterate over the members - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my $member = $$self{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - # if they are Light_Items, then set them to manual to avoid automation - # while manually setting light parameters - $member->manual(1,120,120); # 120 seconds should be enough - } - } - } - $self->interface()->initiate_linking_as_controller($p_group); -} - -sub _xlate_mh_insteon -{ - my ($self, $p_state, $p_type, $p_extra) = @_; - if ($self->is_root) { - return $self->SUPER::_xlate_mh_insteon($p_state, $p_type, $p_extra); - } else { - return $self->SUPER::_xlate_mh_insteon($p_state, 'broadcast', $p_extra); - } -} - -sub request_status -{ - my ($self,$requestor) = @_; - if (!($self->is_root) and (!(ref $requestor) or ($requestor eq $self))) { - &::print_log("[Insteon_Link] requesting status for members of " . $$self{object_name}); - foreach my $member (keys %{$$self{members}}) { - $$self{members}{$member}{object}->request_status($self); - } - } else { - $self->SUPER::request_status($requestor); - } -} - -1; \ No newline at end of file diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index bcce54c5a..4338fa86e 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -25,12 +25,7 @@ Usage: Example initialization: - $myPLM = new Insteon_PLM("Insteon_PLM"); - #Turn Light Module ID L5 On - $myPLM->send_plm_cmd(0x0263b900); - $myPLM->send_plm_cmd(0x0263b280); - Notes: Special Thanks to: @@ -42,275 +37,79 @@ Special Thanks to: =cut -use strict; package Insteon_PLM; -@Insteon_PLM::ISA = ('Serial_Item'); - -my %Insteon_PLM_Data; - -my %plm_commands = ( -#PLM Serial Commands - plm_info => 0x60, - plm_reset => 0x67, - user_user_reset => 0x55, - plm_get_config => 0x73, - plm_set_config => 0x6B, - plm_led_on => 0x6D, - plm_led_off => 0x6E, - plm_button_event => 0x54, - insteon_send => 0x62, - insteon_received => 0x50, - insteon_ext_received => 0x51, - insteon_nak => 0x70, - insteon_ack => 0x71, - x10_send => 0x63, - x10_received => 0x52, - all_link_complete => 0x53, - all_link_clean_failed => 0x56, - all_link_record => 0x57, - all_link_clean_status => 0x58, - all_link_send => 0x61, - all_link_start => 0x64, - rf_sleep => 0x72 -); - -my %x10_house_codes = ( - a => 0x6, - b => 0xE, - c => 0x2, - d => 0xA, - e => 0x1, - f => 0x9, - g => 0x5, - h => 0xD, - i => 0x7, - j => 0xF, - k => 0x3, - l => 0xB, - m => 0x0, - n => 0x8, - o => 0x4, - p => 0xC -); - -my %mh_house_codes = ( - '6' => 'a', - 'e' => 'b', - '2' => 'c', - 'a' => 'd', - '1' => 'e', - '9' => 'f', - '5' => 'g', - 'd' => 'h', - '7' => 'i', - 'f' => 'j', - '3' => 'k', - 'b' => 'l', - '0' => 'm', - '8' => 'n', - '4' => 'o', - 'c' => 'p' -); +use strict; +use Insteon::BaseInterface; +use Insteon::BaseInsteon; +use Insteon::AllLinkDatabase; -my %x10_unit_codes = ( - 1 => 0x6, - 2 => 0xE, - 3 => 0x2, - 4 => 0xA, - 5 => 0x1, - 6 => 0x9, - 7 => 0x5, - 8 => 0xD, - 9 => 0x7, - 10 => 0xF, - a => 0xF, - 11 => 0x3, - b => 0x3, - 12 => 0xB, - c => 0xB, - 13 => 0x0, - d => 0x0, - 14 => 0x8, - e => 0x8, - 15 => 0x4, - f => 0x4, - 16 => 0xC, - g => 0xC - -); +@Insteon_PLM::ISA = ('Serial_Item','Insteon::BaseInterface'); -my %mh_unit_codes = ( - '6' => '1', - 'e' => '2', - '2' => '3', - 'a' => '4', - '1' => '5', - '9' => '6', - '5' => '7', - 'd' => '8', - '7' => '9', - 'f' => 'a', - '3' => 'b', - 'b' => 'c', - '0' => 'd', - '8' => 'e', - '4' => 'f', - 'c' => 'g' -); -my %x10_commands = ( - on => 0x2, - j => 0x2, - off => 0x3, - k => 0x3, - bright => 0x5, - l => 0x5, - dim => 0x4, - m => 0x4, - preset_dim1 => 0xA, - preset_dim2 => 0xB, - all_off => 0x0, - p => 0x0, - all_lights_on => 0x1, - o => 0x1, - all_lights_off => 0x6, - status => 0xF, - status_on => 0xD, - status_off => 0xE, - hail_ack => 0x9, - ext_code => 0x7, - ext_data => 0xC, - hail_request => 0x8 +my %prefix = ( +#PLM Serial Commands + insteon_received => '0250', + insteon_ext_received => '0251', + x10_received => '0252', + all_link_complete => '0253', + plm_button_event => '0254', + user_user_reset => '0255', + all_link_clean_failed => '0256', + all_link_record => '0257', + all_link_clean_status => '0258', + plm_info => '0260', + all_link_send => '0261', + insteon_send => '0262', + insteon_ext_send => '0262', + x10_send => '0263', + all_link_start => '0264', + all_link_cancel => '0265', + plm_reset => '0267', + all_link_first_rec => '0269', + all_link_next_rec => '026a', + plm_set_config => '026b', + plm_led_on => '026d', + plm_led_off => '026e', + all_link_manage_rec => '026f', + insteon_nak => '0270', + insteon_ack => '0271', + rf_sleep => '0272', + plm_get_config => '0273' ); -my %mh_commands = ( - '2' => 'J', - '3' => 'K', - '5' => 'L', - '4' => 'M', - 'a' => 'preset_dim1', - 'b' => 'preset_dim2', -# '0' => 'all_off', - '0' => 'P', -# '1' => 'all_lights_on', - '1' => 'O', - '6' => 'all_lights_off', - 'f' => 'status', - 'd' => 'status_on', - 'e' => 'status_off', - '9' => 'hail_ack', - '7' => 'ext_code', - 'c' => 'ext_data', - '8' => 'hail_request' -); sub serial_startup { my ($instance) = @_; - my $port = $::config_parms{$instance . "_serial_port"}; -# my $speed = $::config_parms{$instance . "_baudrate"}; - my $speed = 19200; + my $speed = 19200; - $Insteon_PLM_Data{$instance}{'serial_port'} = $port; - &::print_log("[Insteon_PLM] serial:$port:$speed"); + &::print_log("[Insteon_PLM] serial:$port:$speed"); &::serial_port_create($instance, $port, $speed,'none','raw'); - if (1==scalar(keys %Insteon_PLM_Data)) { # Add hooks on first call only - &::MainLoop_pre_add_hook(\&Insteon_PLM::check_for_data, 1); - &::Reload_post_add_hook(\&Insteon_PLM::poll_all, 1); - } -} - - -sub poll_all { - my $scan_at_startup = $::config_parms{Insteon_PLM_scan_at_startup}; - $scan_at_startup = 1 unless defined $scan_at_startup; - $scan_at_startup = 0 unless $main::Save{mh_exit} eq 'normal'; - if ($scan_at_startup) { - for my $port_name (keys %Insteon_PLM_Data) { - my $plm = $Insteon_PLM_Data{$port_name}{'obj'}; - if (defined $plm) { - for my $insteon_device ($plm->find_members('Insteon_Device')) { - if ($insteon_device and $insteon_device->is_root and $insteon_device->is_responder) - { - # don't request status for objects associated w/ other than the primary group - # as they are psuedo links - $insteon_device->request_status() if $insteon_device->group eq '01'; - } - if ($insteon_device->devcat) { - # reset devcat so as to trigger any device specific properties - $insteon_device->devcat($insteon_device->devcat); - } - } - } - } - } -} - - -sub check_for_data { - - for my $port_name (keys %Insteon_PLM_Data) { - my $plm = $Insteon_PLM_Data{$port_name}{'obj'}; - &::check_for_generic_serial_data($port_name) if $::Serial_Ports{$port_name}{object}; - my $data = $::Serial_Ports{$port_name}{data}; - # always check for data first; if it exists, then process; otherwise check if pending commands exist - if ($data) { - #lets turn this into Hex. I hate perl binary funcs - my $data = unpack "H*", $data; - -# $::Serial_Ports{$port_name}{data} = undef; -# main::print_log("PLM $port_name got:$data: [$::Serial_Ports{$port_name}{data}]"); - my $processedNibs; - $processedNibs = $plm->_parse_data($data); - $processedNibs = 0 unless $processedNibs; -# &::print_log("PLM Proc:$processedNibs:" . length($data)); - if (length($data) > $processedNibs) { - $main::Serial_Ports{$port_name}{data}=pack("H*",substr($data,$processedNibs,length($data)-$processedNibs)); - } else { - $main::Serial_Ports{$port_name}{data} = ''; - } - - # if no data being received, then check if any timeouts have expired - } elsif (defined $plm) { - if ($plm->_check_timeout('command') == 1) { - $plm->_clear_timeout('command'); - if ($$plm{xmit_in_progress}) { - &::print_log("[Insteon_PLM] WARN: No acknowledgement from PLM to last command requires forced abort of current command." - . " This may reflect a problem with your environment."); - $$plm{xmit_in_progress} = 0; - pop(@{$$plm{command_stack2}}); # pop the active command off the queue - $plm->send_plm_cmd(); - } else { - &::print_log("[Insteon_PLM] PLM xmit timer expired but no transmission in place. Moving on...") if $main::Debug{insteon}; - } - } elsif ($plm->_check_timeout('xmit') == 1) { - $plm->_clear_timeout('xmit'); - $plm->send_plm_cmd(); - } - } - } } sub new { my ($class, $port_name, $p_deviceid) = @_; $port_name = 'Insteon_PLM' if !$port_name; + my $port = $::config_parms{$port_name . "_serial_port"}; - my $self = {}; + my $self = new Insteon::BaseInterface(); $$self{state} = ''; $$self{said} = ''; $$self{state_now} = ''; $$self{port_name} = $port_name; + $$self{port} = $port; $$self{last_command} = ''; $$self{xmit_in_progress} = 0; - @{$$self{command_stack2}} = (); - @{$$self{command_history}} = (); $$self{_prior_data_fragment} = ''; - $$self{retry_count} = 0; bless $self, $class; - $Insteon_PLM_Data{$port_name}{'obj'} = $self; + $$self{aldb} = new Insteon::ALDB_PLM($self); + $self->debug(0); + + &Insteon::add($self); + $self->device_id($p_deviceid) if defined $p_deviceid; $$self{xmit_delay} = $::config_parms{Insteon_PLM_xmit_delay}; @@ -322,74 +121,98 @@ sub new { $self->_clear_timeout('xmit'); $self->_clear_timeout('command'); -# $Insteon_PLM_Data{$port_name}{'send_count'} = 0; -# push(@{$$self{states}}, 'on', 'off'); - return $self; } -sub set +sub debug { - my ($self,$p_state,$p_setby,$p_response) = @_; - - my ($package, $filename, $line) = caller; -# &::print_log("PLM xmit:" , $p_setby->{object_name} . ":$p_state:$p_setby"); - - #identify the type of device that sent the request - if ( - $p_setby->isa("X10_Item") or - $p_setby->isa("X10_Switchlinc") or - $p_setby->isa("X10_Appliance") - ) - { - $self->_xlate_mh_x10($p_state,$p_setby); - } elsif ($p_setby->isa("Insteon_Link")) { - # only send out as all-link if the link originates from the plm - if ($p_setby->is_plm_controlled) { - # return the size of the command stack - return $self->send_plm_cmd('0261' . $p_state, $p_setby); - } elsif ($p_setby->is_root) { - # return the size of the command stack - return $self->send_plm_cmd('0262' . $p_state, $p_setby); - } else { - # silently ignore as this is now permitted if via "surrogate" -# &::print_log("[Insteon_PLM] WARN: you may not attempt to set an Insteon_Link unless " -# . "it is a root device (group = 01) or controlled by the PLM. Set request now being ignored"); - } - } elsif ($p_setby->isa("Insteon_Device")) { - return $self->send_plm_cmd('0262' . $p_state, $p_setby); - } else { - $self->_xlate_mh_x10($p_state,$p_setby); - } + my ($self, $debug) = @_; + if (defined $debug) + { + $$self{debug} = $debug; + } + return $$self{debug}; } -# the following is only intended for diagnostic purposes; use at your own risk -sub reset_serial_object { +sub restore_string +{ + my ($self) = @_; + my $restore_string = $self->SUPER::restore_string(); + if ($self->_aldb) { + $restore_string .= $self->_aldb->restore_string(); + } + return $restore_string; +} - my ($self) = @_; +sub check_for_data { - for my $port_name (keys %Insteon_PLM_Data) { - my $plm_obj = $Insteon_PLM_Data{$port_name}{'obj'}; - next unless $plm_obj eq $self; - my $port = $Insteon_PLM_Data{$port_name}{'serial_port'}; - # delete out the current serial port - my $port_key = $::Serial_Ports{$port_name}{port}; - if ($port_key) { - &::print_log("[Insteon_PLM] clearing serial port: $port_key"); - $::Serial_Ports{object_by_port}{$port_key} = undef; - } - &::print_log("[Insteon_PLM] creating new serial port for $port_name"); - &::serial_port_create($port_name, $port, 19200, 'none', 'raw'); - } - return; + my ($self) = @_; + my $port_name = $$self{port_name}; + &::check_for_generic_serial_data($port_name) if $::Serial_Ports{$port_name}{object}; + my $data = $::Serial_Ports{$port_name}{data}; + # always check for data first; if it exists, then process; otherwise check if pending commands exist + if ($data) + { + #lets turn this into Hex. I hate perl binary funcs + my $data = unpack "H*", $data; + + my $processedNibs; + $processedNibs = $self->_parse_data($data); + $processedNibs = 0 unless $processedNibs; +# &::print_log("PLM Proc:$processedNibs:" . length($data)); + if (length($data) > $processedNibs) + { + $main::Serial_Ports{$port_name}{data}=pack("H*",substr($data,$processedNibs,length($data)-$processedNibs)); + } + else + { + $main::Serial_Ports{$port_name}{data} = ''; + } + + # if no data being received, then check if any timeouts have expired + } + elsif (defined $self) + { + if ($self->_check_timeout('command') == 1) + { + $self->_clear_timeout('command'); + if ($$self{xmit_in_progress}) { +# &::print_log("[Insteon_PLM] WARN: No acknowledgement from PLM to last command requires forced abort of current command." +# . " This may reflect a problem with your environment."); + $$self{xmit_in_progress} = 0; +# pop(@{$$self{command_stack2}}); # pop the active command off the queue + $self->retry_active_message(); + $self->process_queue(); + } + else + { + &::print_log("[Insteon_PLM] PLM command timer expired but no transmission in place. Moving on...") if $main::Debug{insteon}; + $self->clear_active_message(); + $self->process_queue(); + } + } + elsif ($self->_check_timeout('xmit') == 1) + { + $self->_clear_timeout('xmit'); + if (!($$self{xmit_in_progress})) + { + print "################ xmit timer\n"; + $self->process_queue(); + } + } + } } -sub has_link +sub set { - my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = lc $insteon_object->device_id . $group . $is_controller; - return (defined $$self{links}{$key}) ? 1 : 0; + my ($self,$p_state,$p_setby,$p_response) = @_; + + my @x10_commands = &Insteon::X10Message::generate_commands($p_state, $p_setby); + foreach my $command (@x10_commands) + { + $self->queue_message(new Insteon::X10Message($command)); + } } sub complete_linking_as_responder @@ -399,10 +222,17 @@ sub complete_linking_as_responder # it is not clear that group should be anything as the group will be taken from the controller $group = '01' unless $group; # set up the PLM as the responder - my $cmd = '0264'; # start all linking - $cmd .= '00'; # responder code + my $cmd = '00'; # responder code $cmd .= $group; # WARN - must be 2 digits and in hex!! - $self->send_plm_cmd($cmd) + my $message = new Insteon::InsteonMessage('all_link_start', $self); + $message->interface_data($cmd); + $self->queue_message($message) +} + +sub log_alllink_table +{ + my ($self) = @_; + $self->_aldb->log_alllink_table if $self->_aldb; } sub scan_link_table @@ -411,7 +241,7 @@ sub scan_link_table $$self{links} = undef; # clear out the old $$self{_mem_activity} = 'scan'; $$self{_mem_callback} = ($callback) ? $callback : undef; - $self->get_first_alllink(); + $self->_aldb->get_first_alllink(); } sub initiate_linking_as_controller @@ -420,10 +250,11 @@ sub initiate_linking_as_controller $group = 'FF' unless $group; # set up the PLM as the responder - my $cmd = '0264'; # start all linking - $cmd .= '01'; # controller code + my $cmd = '01'; # controller code $cmd .= $group; # WARN - must be 2 digits and in hex!! - $self->send_plm_cmd($cmd); + my $message = new Insteon::InsteonMessage('all_link_start', $self); + $message->interface_data($cmd); + $self->queue_message($message); } sub initiate_unlinking_as_controller @@ -432,156 +263,57 @@ sub initiate_unlinking_as_controller $group = 'FF' unless $group; # set up the PLM as the responder - my $cmd = '0264'; # start all linking - $cmd .= 'FF'; # controller code + my $cmd = 'FF'; # controller code $cmd .= $group; # WARN - must be 2 digits and in hex!! - $self->send_plm_cmd($cmd); -} - -sub get_first_alllink -{ - my ($self) = @_; - $self->send_plm_cmd('0269'); + my $message = new Insteon::InsteonMessage('all_link_start', $self); + $message->interface_data($cmd); + $self->queue_message($message); } -sub get_next_alllink -{ - my ($self) = @_; - $self->send_plm_cmd('026A'); -} sub cancel_linking { my ($self) = @_; - $self->send_plm_cmd('0265'); + $self->queue_message(new Insteon::InsteonMessage('all_link_cancel', $self)); } -sub _is_duplicate +sub _aldb { - my ($self, $cmd) = @_; - my $duplicate_detected = 0; - # check for duplicates of $cmd already in command_stack and ignore if they exist - foreach my $cmdrec (@{$$self{command_stack2}}) { - if (($cmdrec->{cmd} eq $cmd) and ($cmd !~ /^0263/)) { - $duplicate_detected = 1; - last; - } - } - return $duplicate_detected; + my ($self) = @_; + return $$self{aldb}; } -sub send_plm_cmd -{ - my ($self, $cmd, $p_setby) = @_; - - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size unless $cmd or !($$self{xmit_in_progress}); - - # get pending command record - my $cmdptr = pop(@{$$self{command_stack2}}); - my %cmd_record = (); - my $pending_cmd = ''; - my $pending_callback = ''; - if ($cmdptr) { - %cmd_record = %$cmdptr; - $pending_cmd = $cmd_record{cmd}; - $pending_callback = $cmd_record{callback}; - #put the command back into the stack.. Its not our job to tamper with this array - push(@{$$self{command_stack2}},\%cmd_record) if %cmd_record; - } - #queue any new command ($cmd) - if (defined $cmd and $cmd ne '') - { - if ($self->_is_duplicate($cmd)) { - &main::print_log("[Insteon_PLM] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; - } else { - my $queue_size = @{$$self{command_stack2}}; - &main::print_log("[Insteon_PLM] Command stack size: $queue_size") if $queue_size > 0 and $main::Debug{insteon}; - # &::print_log("PLM Add Command:" . $cmd . ":XmitInProgress:" . $$self{xmit_in_progress} . ":" ); - my %cmd_record = (); - $cmd_record{cmd} = $cmd; - $cmd_record{queue_time} = $::Time; - if ($p_setby and ref($p_setby) and $p_setby->can('set_retry_timeout') - and $p_setby->get_object_name) { - $cmd_record{callback} = $p_setby->get_object_name . "->set_retry_timeout()"; -#print "setting callback to $cmd_record{callback}\n"; - } - # pending command becomes the newest queued command if stack is empty - unless ($pending_cmd) { - $pending_cmd = $cmd; - $pending_callback = $cmd_record{callback}; - } - unshift(@{$$self{command_stack2}},\%cmd_record); - } - } - #we dont transmit on top of another xmit - if (!($$self{xmit_in_progress})) { - #always send the oldest command first - if (defined $pending_cmd and $pending_cmd ne '') - { - my $prior_cmd_time = pop(@{$$self{command_history}}); - while ($prior_cmd_time) { - if ($::Time - $prior_cmd_time > 1) { - $prior_cmd_time = pop(@{$$self{command_history}}); - } else { - # put it back on the queue; we're done - push(@{$$self{command_history}}, $prior_cmd_time); - $prior_cmd_time = 0; - } - } - my $past_cmds_in_history = @{$$self{command_history}}; - # need logic to change based upon whether the command is x10 or not -# &::print_log("[Insteon_PLM] num commands in past 1 seconds: $past_cmds_in_history") if $main::Debug{insteon}; - if ($past_cmds_in_history > 3 and !($::config_parms{Insteon_PLM_disable_throttling})) { - &::print_log("[Insteon_PLM] num commands in 1 second exceeded threshold. Now delaying additional transmission for 1 second") if $main::Debug{insteon}; - $self->_set_timeout('xmit',1000); - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; - } - if (!($self->_check_timeout('xmit')==0)) { - $self->_send_cmd($pending_cmd); - if ($pending_callback) { - package main; - eval $pending_callback; - &::print_log("[Insteon_PLM] problem w/ retry callback: $@") if $@; - package Insteon_PLM; - } - } - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; - } - } else { -# &::print_log("[Insteon_PLM] active transmission; moving on...") if $main::Debug{insteon}; - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; - } - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; -} sub _send_cmd { - my ($self, $cmd) = @_; + my ($self, $message, $cmd_timeout) = @_; + my $instance = $$self{port_name}; + if (!(ref $main::Serial_Ports{$instance}{object})) { + print "WARN: Insteon_PLM serial port not initialized!\n"; + return; + } unshift(@{$$self{command_history}},$::Time); $$self{xmit_in_progress} = 1; - $self->_set_timeout('command',3000); # a commmand needs to be PLM ack'd w/i 3 seconds or it gets dropped - my $instance = $$self{port_name}; -# &::print_log("PLM: Executing command:$cmd:") unless $main::config_parms{no_log} =~/Insteon_PLM/; - my $data = pack("H*",$cmd); - $main::Serial_Ports{$instance}{object}->write($data); -### Dont overrun the controller.. Its easy, so lets wait a bit -# select(undef,undef,undef,0.15); - #X10 is sloooooow - # however, the ack/nack processing seems to allow some comms (notably insteon) to proceed - # much faster--hence the ability to overide the slow default of 0.5 seconds + my $command = $message->interface_data; my $delay = $$self{xmit_delay}; - if (substr($cmd,0,4) eq '0263') { # is x10; so, be slow + if ($message->isa('Insteon::X10Message')) { # is x10; so, be slow + $command = $prefix{x10_send} . $command; $delay = $$self{xmit_x10_delay}; - } + # clear command timeout so that we don't wait for an insteon ack before sending the next command + } else { + my $command_type = $message->command_type; + $command = $prefix{$command_type} . $command; + $self->_set_timeout('command', $cmd_timeout); # a commmand needs to be PLM ack'd w/i 3 seconds or it gets dropped + } + + my $data = pack("H*",$command); +# &::print_log("PLM: Executing command:$command:") unless $main::config_parms{no_log} =~/Insteon_PLM/; + $main::Serial_Ports{$instance}{object}->write($data) if $main::Serial_Ports{$instance}; + + if ($delay) { $self->_set_timeout('xmit',$delay * 1000); -# select(undef,undef,undef,$delay); } $$self{'last_change'} = $main::Time; } @@ -595,62 +327,73 @@ sub _parse_data { # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it if ($$self{_data_fragment}) { - &::print_log("[Insteon_PLM] Prepending prior data fragment: $$self{_data_fragment}") if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; $$self{_prior_data_fragment} = $$self{_data_fragment}; $data = $$self{_data_fragment} . $data; $$self{_data_fragment} = ''; } - &::print_log( "[Insteon_PLM] Parsing serial data: $data") if $main::Debug{insteon}; + &::print_log( "[Insteon_PLM] Parsing serial data: $data") if $self->debug; # begin by pulling out any PLM ack/nacks my $prev_cmd = ''; - my $cmdptr = pop(@{$$self{command_stack2}}); - my %cmd_record = (); - if ($cmdptr) { - %cmd_record = %$cmdptr; - $prev_cmd = lc $cmd_record{cmd}; + my $pending_message = $self->active_message; + if ($pending_message) { + $prev_cmd = lc $pending_message->interface_data; + if ($pending_message->isa('Insteon::X10Message')) + { + $prev_cmd = $prefix{x10_send} . $prev_cmd; + } else { + my $command_type = $pending_message->command_type; + $prev_cmd = $prefix{$command_type} . $prev_cmd; + } } + my $residue_data = ''; - my $process_next_command = 0; + my $process_next_command = 1; my $nack_count = 0; - if (defined $prev_cmd and $prev_cmd ne '') + my $entered_ack_loop; + if (defined $prev_cmd and $prev_cmd ne '') { -# &::print_log("PLM: Defined:$prev_cmd"); my $ackcmd = $prev_cmd . '06'; my $nackcmd = $prev_cmd . '15'; my $badcmd = $prev_cmd . '0f'; - my $entered_ack_loop = 0; - foreach my $data_1 (split(/($ackcmd)|($nackcmd)|(0260\w{12}06)|(0260\w{12}15)|($badcmd)/,$data)) + foreach my $data_1 (split(/($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)/,$data)) { #ignore blanks.. the split does odd things next if $data_1 eq ''; - - $entered_ack_loop = 1; - - if ($data_1 =~ /^($ackcmd)|($nackcmd)|(0260\w{12}06)|(0260\w{12}15)|($badcmd)$/) { + $entered_ack_loop = 1; + if ($data_1 =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) + { $processedNibs+=length($data_1); my $ret_code = substr($data_1,length($data_1)-2,2); -# &::print_log("PLM: Return code $ret_code"); - if ($ret_code eq '06') { - my $record_type = substr($data_1,0,4); - if ($record_type eq '0260') { - $self->device_id(substr($data_1,4,6)); - $self->firmware(substr($data_1,14,2)); - &::print_log("[Insteon_PLM] PLM id: " . $self->device_id . - " firmware: " . $self->firmware) - if $main::Debug{insteon}; - } elsif ($record_type eq '0269' or $record_type eq '026a') { + my $record_type = substr($data_1,0,4); + my $message_data = substr($data_1,4,length($data_1)-4); + if ($ret_code eq '06') + { + if ($record_type eq $prefix{plm_info}) + { + $self->device_id(substr($message_data,0,6)); + $self->firmware(substr($message_data,10,2)); + $self->on_interface_info_received(); + } + elsif ($record_type eq $prefix{all_link_first_rec} + or $record_type eq $prefix{all_link_next_rec}) + { $$self{_next_link_ok} = 1; } - $$self{xmit_in_progress} = 0; - # check to see if it is an all-link and if so, then remember for "cleanup" - if ($data_1 =~ /0261\w{6}06/) { - $$self{pending_alllink} = $prev_cmd; + else + { + &::print_log("[Insteon_PLM] DEBUG: received interface acknowledge: " + . $pending_message->to_string) if $self->debug; + } + + if ($data_1 =~ /$prefix{x10_send}\w{4}06/) + { + $self->clear_active_message(); } - $self->_clear_timeout('command'); - $process_next_command = 1; - $$self{retry_count} = 0; - if (($record_type eq '026f') and $$self{_mem_callback}) { + + if (($record_type eq $prefix{all_link_manage_rec}) and $$self{_mem_callback}) + { my $callback = $$self{_mem_callback}; $$self{_mem_callback} = undef; package main; @@ -659,157 +402,174 @@ sub _parse_data { if $@ and $main::Debug{insteon}; package Insteon_PLM; } - } elsif ($ret_code eq '15' or $ret_code eq '0f') { #NAK or "bad" command received - my $record_type = substr($data_1,0,4); - $$self{xmit_in_progress} = 0; - $self->_clear_timeout('command'); - $process_next_command = 1; - if ($record_type eq '0269' or $record_type eq '026a') { + } + elsif ($ret_code eq '15' or $ret_code eq '0f') + { #NAK or "bad" command received + $self->clear_active_message(); # regardless, we're not retrying as we'll just get the same + + if ($record_type eq $prefix{all_link_first_rec} + or $record_type eq $prefix{all_link_next_rec}) + { + # both of these conditions are ok as it just means + # we've reached the end of the memory $$self{_next_link_ok} = 0; $$self{_mem_activity} = undef; - } else { - &::print_log("[Insteon_PLM] Prior cmd failed"); - } - if ($$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; - $$self{_mem_callback} = undef; - package main; - eval ($callback); - &::print_log("[Insteon_PLM] error encountered during nack callback: " . $@) + if ($$self{_mem_callback}) + { + my $callback = $$self{_mem_callback}; + $$self{_mem_callback} = undef; + package main; + eval ($callback); + &::print_log("[Insteon_PLM] error encountered during nack callback: " . $@) if $@ and $main::Debug{insteon}; - package Insteon_PLM; + package Insteon_PLM; + } + } else { + &::print_log("[Insteon_PLM] WARN: received NACK for " + . $pending_message->to_string() + . ". If this is a light fixture, check bulb"); } - } else { + } + else + { # We have a problem (Usually we stepped on another X10 command) - &::print_log("[Insteon_PLM] Command error: $data_1."); - $$self{xmit_in_progress} = 0; - $self->_clear_timeout('command'); + &::print_log("[Insteon_PLM] ERROR: encountered $data_1. " + . $pending_message->to_string()); +# $$self{xmit_in_progress} = 0; + $self->retry_active_message(); #move it off the top of the stack and re-transmit later! #TODO: We should keep track of an errored command and kill it if it fails twice. prevent an infinite loop here - $process_next_command = 1; } - } else { + } + else + { $residue_data .= $data_1; - } - } - if (!($process_next_command)) { - # then, didn't get a match and need to push the command back on the stack - unless ($self->_is_duplicate($cmd_record{cmd})) { - push(@{$$self{command_stack2}}, \%cmd_record); } } - $residue_data = $data unless $entered_ack_loop; - } else { - $residue_data = $data; + + $residue_data = $data unless $entered_ack_loop or $residue_data; + } + else + { + $residue_data = $data unless $residue_data; } - my $entered_rcv_loop = 0; + my $entered_rcv_loop = 0; - foreach my $data_1 (split(/(0252\w{4})|(0250\w{18})|(0251\w{46})|(0253\w{16})|(0256\w{8})|(0257\w{16})|(0258\w{2})/,$residue_data)) + foreach my $data_1 (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})/,$residue_data)) { #ignore blanks.. the split does odd things next if $data_1 eq ''; - $entered_rcv_loop = 1; - + $entered_rcv_loop = 1; + #we found a matching command in stream, add to processed bytes $processedNibs+=length($data_1); - if (substr($data_1,0,4) eq '0250') { #Insteon Standard Received - if (length($data_1) != 22) { - $$self{_data_fragment} = $data_1; - } else { - $$self{_data_fragment} .= $data_1 unless $self->delegate($data_1); - } - } elsif (substr($data_1,0,4) eq '0251') { #Insteon Extended Received - if (length($data_1) != 50) { - $$self{_data_fragment} = $data_1; - } else { - $$self{_data_fragment} .= $data_1 unless $self->delegate($data_1); - } - } elsif (substr($data_1,0,4) eq '0252') { #X10 Received - if (length($data_1) != 8) { - $$self{_data_fragment} = $data_1; - } else { - my $x10_data = $self->_xlate_x10_mh($data_1); - &::print_log("[Insteon_PLM] received x10 data: $x10_data") if $main::Debug{insteon} - &::process_serial_data($x10_data,undef,$self); - } - } elsif (substr($data_1,0,4) eq '0253') { #ALL-Linking Completed - if (length($data_1) != 20) { - $$self{_data_fragment} = $data_1; - } else { - my $link_address = substr($data_1,8,6); - &::print_log("[Insteon_PLM] ALL-Linking Completed with $link_address ($data_1)") if $main::Debug{insteon}; - } - } elsif (substr($data_1,0,4) eq '0256') { #ALL-Link Cleanup Failure Report - if (length($data_1) != 12) { - $$self{_data_fragment} = $data_1; - } else { - &::print_log("[Insteon_PLM] ALL-Link Cleanup Failure Report:$data_1") if $main::Debug{insteon}; - } - } elsif (substr($data_1,0,4) eq '0257') { #ALL-Link Record Response - if (length($data_1) != 20) { - $$self{_data_fragment} = $data_1; - } else { - &::print_log("[Insteon_PLM] ALL-Link Record Response:$data_1") if $main::Debug{insteon}; - $self->parse_alllink($data_1); + my $parsed_prefix = substr($data_1,0,4); + my $message_length = length($data_1); + + my $message_data = substr($data_1,4,length($data_1)-4); + + if ($parsed_prefix eq $prefix{insteon_received} and ($message_length == 22)) + { #Insteon Standard Received + $self->on_standard_insteon_received($message_data); + } + elsif ($parsed_prefix eq $prefix{insteon_ext_received} and ($message_length == 50)) + { #Insteon Extended Received + $self->on_extended_insteon_received($message_data); + } + elsif($parsed_prefix eq $prefix{x10_received} and ($message_length == 8)) + { #X10 Received + my $x10_message = new Insteon::X10Message($message_data); + my $x10_data = $x10_message->get_formatted_data(); + &::print_log("[Insteon_PLM] received x10 data: $x10_data") if $main::Debug{insteon} + &::process_serial_data($x10_data,undef,$self); + } + elsif ($parsed_prefix eq $prefix{all_link_complete} and ($message_length == 20)) + { #ALL-Linking Completed + my $link_address = substr($message_data,4,6); + &::print_log("[Insteon_PLM] ALL-Linking Completed with $link_address ($message_data)") if $main::Debug{insteon}; + $self->clear_active_message(); + } + elsif ($parsed_prefix eq $prefix{all_link_clean_failed} and ($message_length == 14)) + { #ALL-Link Cleanup Failure Report + $self->retry_active_message(); + # extract out the pertinent parts of the message for display purposes + # bytes 0-1 - ignore; 2-3 - group; 4-9 device address + my $failure_group = substr($message_data,2,2); + my $failure_device = substr($message_data,4,6); + + &::print_log("[Insteon_PLM] Recieved all-link cleanup failure from device: " + . "$failure_device and group: failure_group") if $main::Debug{insteon}; + } + elsif ($parsed_prefix eq $prefix{all_link_record} and ($message_length == 20)) + { #ALL-Link Record Response + &::print_log("[Insteon_PLM] ALL-Link Record Response:$message_data") if $main::Debug{insteon}; + $self->_aldb->parse_alllink($message_data); + # before doing the next, make sure that the pending command + # (if it sitll exists) is pulled from the queue + $self->clear_active_message(); + + $self->_aldb->get_next_alllink(); + } + elsif ($parsed_prefix eq $prefix{all_link_clean_status} and ($message_length == 6)) + { #ALL-Link Cleanup Status Report + my $cleanup_ack = substr($message_data,0,2); + if ($cleanup_ack eq '15') + { + my $delay_in_seconds = 1.0; # this may need to be tweaked + &::print_log("[Insteon_PLM] Received all-link cleanup failure for current message." + . " Attempting resend in " . $delay_in_seconds . " seconds.") + if $main::Debug{insteon}; + $self->retry_active_message(); + # except that we should cause a bit of a delay to let things settle out + $self->_set_timeout('xmit',$delay_in_seconds * 1000); + $process_next_command = 0; } - } elsif (substr($data_1,0,4) eq '0258') { #ALL-Link Cleanup Status Report - if (length($data_1) != 6) { - $$self{_data_fragment} = $data_1; - } else { - my $cleanup_ack = substr($data_1,4,2); - if ($cleanup_ack eq '15') { - $$self{retry_count} += 1; - if ($$self{retry_count} < 3) { - &::print_log("[Insteon_PLM] All-Link Cleanup reports failure. Attempting resend") - if $main::Debug{insteon}; - - $self->send_plm_cmd($$self{pending_alllink}) if $$self{pending_alllink}; - } else { - # move on - $$self{retry_count} = 0; - $$self{pending_alllink} = undef; - } - } else { - &::print_log("[Insteon_PLM] ALL-Link Cleanup reports success") if $main::Debug{insteon}; - # attempt to process the message by the link object; this acknowledgement will reset - # the auto-retry timer - if ($$self{pending_alllink}) { - my $group = substr($$self{pending_alllink},4,2); - my $link = $self->get_object('000000',$group); - if ($link) { - my %msg = ('type' => 'cleanup', + else + { + my $message_to_string = ($self->active_message) ? $self->active_message->to_string() : ""; + &::print_log("[Insteon_PLM] Received all-link cleanup success: $message_to_string") + if $main::Debug{insteon}; + + # attempt to process the message by the link object; this acknowledgement will reset + # the auto-retry timer + if ($self->active_message && ($self->active_message->command_type == 'all_link_send')) + { + my $group = substr($self->active_message->interface_data,0,2); + my $link = &Insteon::get_object('000000',$group); + if ($link) + { + my %msg = ('type' => 'cleanup', 'group' => $group, 'is_ack' => 1, 'command' => 'cleanup' ); - $link->_process_message($self, %msg); - $$self{pending_alllink} = undef; # clear it - } + $link->_process_message($self, %msg); } } + $self->clear_active_message(); } - } elsif (substr($data_1,0,2) eq '15') { #NAK Received - if (!($nack_count)) { + } + elsif (substr($data_1,0,2) eq '15') + { #NAK Received + if (!($nack_count)) + { my $nack_delay = ($::config_parms{Insteon_PLM_disable_throttling}) ? 0.3 : 1.0; &::print_log("[Insteon_PLM] Interface extremely busy. Resending command" . " after delaying for $nack_delay second") if $main::Debug{insteon}; $self->_set_timeout('xmit',$nack_delay * 1000); - $$self{retry_count} += 1; - if ($$self{retry_count} < 3) { - unless ($self->_is_duplicate($cmd_record{cmd})) { - push(@{$$self{command_stack2}}, \%cmd_record); - } - } - $$self{xmit_in_progress} = 0; - $self->_clear_timeout('command'); + $self->retry_active_message(); +# $$self{xmit_in_progress} = 0; $process_next_command = 0; $nack_count++; } - } else { + } + else + { # it's probably a fragment; so, handle it + # it it's the same as last time, then drop it as we can't recover $$self{_data_fragment} .= $data_1 unless $data_1 eq $$self{_prior_data_fragment}; } } @@ -817,637 +577,16 @@ sub _parse_data { $$self{_data_fragment} = $residue_data unless $entered_rcv_loop or $$self{_data_fragment}; if ($process_next_command) { - $self->process_command_stack(); + $self->process_queue(); } return $processedNibs; } -sub process_command_stack -{ - my ($self) = @_; - ## send any remaining commands in stack - my $stack_count = @{$$self{command_stack2}}; - if ($stack_count> 0 ) - { - #send any remaining commands. - $self->send_plm_cmd(); - } -} - -sub _xlate_mh_x10 -{ - my ($self,$p_state,$p_setby) = @_; - - my $msg; - my $cmd=$p_state; - $cmd=~ s/\:.*$//; - $cmd=lc($cmd); - - my $id=lc($p_setby->{id_by_state}{$cmd}); - - my $hc = lc(substr($p_setby->{x10_id},1,1)); - my $uc = lc(substr($p_setby->{x10_id},2,1)); - - if ($hc eq undef) { - &main::print_log("[Insteon_PLM] Object:$p_setby Doesnt have an x10 id (yet)"); - return undef; - } - - if ($uc eq undef) { - &main::print_log("[Insteon_PLM] Message is for entire HC") if $main::Debug{insteon}; - } - else { - - #Every X10 message starts with the House and unit code - $msg = "02"; - $msg.= unpack("H*",pack("C",$plm_commands{x10_send})); - $msg.= substr(unpack("H*",pack("C",$x10_house_codes{substr($id,1,1)})),1,1); - $msg.= substr(unpack("H*",pack("C",$x10_unit_codes{substr($id,2,1)})),1,1); - $msg.= "00"; - &main::print_log("[Insteon_PLM] x10 sending code: " . uc($hc . $uc) . " as insteon msg: " - . $msg) if $main::Debug{insteon}; - $self->send_plm_cmd($msg); - } - - my $ecmd; - #Iterate through the rest of the pairs of nibbles - my $spos = 3; - if ($uc eq undef) {$spos=1;} -# &::print_log("PLM:PAIR:$id:$spos:$ecmd:"); - for (my $pos = $spos; $possend_plm_cmd($msg); - } -} - -sub _xlate_x10_mh -{ - my ($self,$data) = @_; - - my $msg=undef; - if (uc(substr($data,length($data)-2,2)) eq '00') - { - $msg = "X"; - $msg.= uc($mh_house_codes{substr($data,4,1)}); - $msg.= uc($mh_unit_codes{substr($data,5,1)}); - for (my $index =6; $indexget_object($msg{source}, $msg{group}); - &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group; $msg{group}") - if (!(defined $object)); - if (defined $object) { - &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; - $object->_process_message($self, %msg); - } - return 1; # treat the message as legitimate even if an object match did not occur - } else { - return 0; - } -} +# dummy sub required to support the X10 integrtion -sub parse_alllink -{ - my ($self, $data) = @_; - if (substr($data,8,6)) { - my %link = (); - my $flag = substr($data,4,1); - $link{is_controller} = (hex($flag) & 0x04) ? 1 : 0; - $link{flags} = substr($data,4,2); - $link{group} = lc substr($data,6,2); - $link{deviceid} = lc substr($data,8,6); - $link{data1} = substr($data,14,2); - $link{data2} = substr($data,16,2); - $link{data3} = substr($data,18,2); - my $key = $link{deviceid} . $link{group} . $link{is_controller}; - %{$$self{links}{lc $key}} = %link; - } - $self->get_next_alllink(); -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = $self->SUPER::restore_string(); - if ($$self{links}) { - my $link = ''; - foreach my $link_key (keys %{$$self{links}}) { - $link .= '|' if $link; # separate sections - my %link_record = %{$$self{links}{$link_key}}; - my $record = ''; - foreach my $record_key (keys %link_record) { - next unless $link_record{$record_key}; - $record .= ',' if $record; - $record .= $record_key . '=' . $link_record{$record_key}; - } - $link .= $record; - } -# &::print_log("[Insteon_PLM] AllLink restore string: $link") if $main::Debug{insteon}; - $restore_string .= $self->{object_name} . "->restore_linktable(q~$link~);\n"; - } - return $restore_string; -} - -sub restore_linktable -{ - my ($self, $links) = @_; - if ($links) { - foreach my $link_section (split(/\|/,$links)) { - my %link_record = (); - my $deviceid = ''; - my $groupid = '01'; - my $is_controller = 0; - foreach my $link_record (split(/,/,$link_section)) { - my ($key,$value) = split(/=/,$link_record); - $deviceid = $value if ($key eq 'deviceid'); - $groupid = $value if ($key eq 'group'); - $is_controller = $value if ($key eq 'is_controller'); - $link_record{$key} = $value if $key and defined($value); - } - my $linkkey = $deviceid . $groupid . $is_controller; - %{$$self{links}{lc $linkkey}} = %link_record; - } -# $self->log_alllink_table(); - } -} - -sub log_alllink_table -{ - my ($self) = @_; - foreach my $linkkey (sort(keys(%{$$self{links}}))) { - my $data3 = $$self{links}{$linkkey}{data3}; - my $is_controller = $$self{links}{$linkkey}{is_controller}; - my $group = ($is_controller) ? $data3 : $$self{links}{$linkkey}{group}; - $group = '01' if $group == '00'; - my $device = $self->get_object($$self{links}{$linkkey}{deviceid},$group); - my $object_name = ($device) ? $device->get_object_name : $$self{links}{$linkkey}{deviceid}; - &::print_log("[Insteon_PLM] " . - (($is_controller) ? "cntlr($$self{links}{$linkkey}{group}) record to " - . $object_name - : "responder record to " . $object_name . "($$self{links}{$linkkey}{group})") - . " (d1=$$self{links}{$linkkey}{data1}, d2=$$self{links}{$linkkey}{data2}, " - . "d3=$data3)") - if $main::Debug{insteon}; - } -} - -sub delete_orphan_links -{ - my ($self) = @_; - @{$$self{delete_queue}} = (); # reset the work queue - my $selfname = $self->get_object_name; - my $num_deleted = 0; - foreach my $linkkey (keys %{$$self{links}}) { - my $deviceid = lc $$self{links}{$linkkey}{deviceid}; - my $group = $$self{links}{$linkkey}{group}; - my $is_controller = $$self{links}{$linkkey}{is_controller}; - my $data3 = $$self{links}{$linkkey}{data3}; - my $device = $self->get_object($deviceid,'01'); - # if a PLM link (regardless of responder or controller) exists to a device that is not known, then delete - if (!($device)) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $self, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - } else { - my $is_invalid = 1; - my $link = undef; - if ($is_controller) { - # then, this is a PLM defined link; and, we won't care about responder links as we assume - # they're ok given that they reference known devices - $link = $self->get_object('000000',$group); - if (!($link)) { - # a reference in the PLM's linktable does not match a scene member target - $is_invalid = 1; - } else { - # iterate over all of the members of the Insteon_Link item - foreach my $member_ref (keys %{$$link{members}}) { - my $member = $$link{members}{$member_ref}{object}; - # member will correspond to a scene member item - # and, if it is a light item, then get the real device - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon_Device'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->isa('Insteon_Device')) { - my $linkmember = $member; - # make sure that this is a root device - if (!($member->is_root)) { - $member = $member->get_root; - } - if (lc $member->device_id eq $$self{links}{$linkkey}{deviceid}) { - # at this point, the forward link is ok; but, only if the reverse - # link also exists. So, check: - if ($member->has_link($self, $group, 0, $data3)) { - $is_invalid = 0; - } - last; - } - } else { - $is_invalid = 0; - } - } - if ($is_invalid) { - # then, there is a good chance that a reciprocal link exists; if so, delet it too - if ($device->has_link($self,$group,0, $data3)) { - my %delete_req = (object => $self, group => $group, is_controller => 0, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $device, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - } - } - } - if ($is_invalid) { - my %delete_req = (object => $device, group => $group, is_controller => 1, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $self, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - } - } - } - } - - $$self{delete_queue_processed} = 0; # reset the counter - - # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links - for my $obj ($self->find_members('Insteon_Device')) - { - #Match on real objects only - if (($obj->is_root)) - { - $num_deleted += $obj->delete_orphan_links(); - my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); - push @{$$self{delete_queue}}, \%delete_req; - } - } - $self->_process_delete_queue(); -} - -sub _process_delete_queue { - my ($self, $p_num_deleted) = @_; - $$self{delete_queue_processed} += $p_num_deleted if $p_num_deleted; - my $num_in_queue = @{$$self{delete_queue}}; - if ($num_in_queue) { - my $delete_req_ptr = shift(@{$$self{delete_queue}}); - my %delete_req = %$delete_req_ptr; - # distinguish between deleting PLM links and processing delete orphans for a root item - if ($delete_req{'root_object'}) { - $delete_req{'root_object'}->delete_orphan_links(); - } else { - if ($delete_req{linkdevice} eq $self) { - &::print_log("[Insteon_PLM] now deleting orphaned link w/ details: " - . (($delete_req{is_controller}) ? "controller" : "responder") - . ", " . (($delete_req{object}) ? "object=" . $delete_req{object}->get_object_name - : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}") - if $main::Debug{insteon}; - $self->delete_link(%delete_req); - } elsif ($delete_req{linkdevice}) { - $delete_req{linkdevice}->delete_link(%delete_req); - } - } - } else { - &::print_log("[Insteon_PLM] A total of $$self{delete_queue_processed} orphaned link records were deleted."); - } - -} - -sub delete_link -{ - # linkkey is concat of: deviceid, group, is_controller - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - my $num_deleted = 0; - my $insteon_object = $link_parms{object}; - my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; - my $group = $link_parms{group}; - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - my $linkkey = lc $deviceid . $group . (($is_controller) ? '1' : '0'); - if (defined $$self{links}{$linkkey}) { - my $cmd = '026F' . '80' - . $$self{links}{$linkkey}{flags} - . $$self{links}{$linkkey}{group} - . $$self{links}{$linkkey}{deviceid} - . $$self{links}{$linkkey}{data1} - . $$self{links}{$linkkey}{data2} - . $$self{links}{$linkkey}{data3}; - $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; - delete $$self{links}{$linkkey}; - $num_deleted = 1; - $self->send_plm_cmd($cmd); - } else { - &::print_log("[Insteon_PLM] no entry in linktable could be found for linkkey: $linkkey"); - if ($link_parms{callback}) { - package main; - eval ($link_parms{callback}); - &::print_log("[Insteon_PLM] error in add link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; - } - } - return $num_deleted; -} - -sub add_link -{ - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - my $device_id; - my $group = ($link_parms{group}) ? $link_parms{group} : '01'; - my $insteon_object = $link_parms{object}; - if (!(defined($insteon_object))) { - $device_id = lc $link_parms{deviceid}; - $insteon_object = $self->get_object($device_id, $group); - } else { - $device_id = lc $insteon_object->device_id; - } - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - # first, confirm that the link does not already exist - my $linkkey = lc $device_id . $group . $is_controller; - if (defined $$self{links}{$linkkey}) { - &::print_log("[Insteon_PLM] WARN: attempt to add link to PLM that already exists! " - . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); - if ($link_parms{callback}) { - package main; - eval ($link_parms{callback}); - &::print_log("[Insteon_PLM] error in add link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; - } - } else { - my $control_code = ($is_controller) ? '40' : '41'; - # flags should be 'a2' for responder and 'e2' for controller - my $flags = ($is_controller) ? 'E2' : 'A2'; - my $data1 = (defined $link_parms{data1}) ? $link_parms{data1} : (($is_controller) ? '01' : '00'); - my $data2 = (defined $link_parms{data2}) ? $link_parms{data2} : '00'; - my $data3 = (defined $link_parms{data3}) ? $link_parms{data3} : '00'; - # from looking at manually linked records, data1 and data2 are both 00 for responder records - # and, data1 is 01 and usually data2 is 00 for controller records - - my $cmd = '026F' - . $control_code - . $flags - . $group - . $device_id - . $data1 - . $data2 - . $data3; - $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; - $$self{links}{$linkkey}{flags} = lc $flags; - $$self{links}{$linkkey}{group} = lc $group; - $$self{links}{$linkkey}{is_controller} = $is_controller; - $$self{links}{$linkkey}{deviceid} = lc $device_id; - $$self{links}{$linkkey}{data1} = lc $data1; - $$self{links}{$linkkey}{data2} = lc $data2; - $$self{links}{$linkkey}{data3} = lc $data3; - $self->send_plm_cmd($cmd); - } -} - -sub get_object -{ - my ($self, $p_deviceid, $p_group) = @_; - - my $retObj = undef; - - for my $obj (@{$$self{objects}}) - { - #Match on Insteon objects only - if ($obj->isa("Insteon_Device")) - { - if (lc $obj->device_id() eq lc $p_deviceid) - { - if ($p_group) - { - if (lc $p_group eq lc $obj->group) - { - $retObj = $obj; - last; - } - } else { - $retObj = $obj; - last; - } - } - } - } - - return $retObj; -} - - -sub add_id_state -{ - my ($self,$id,$state) = @_; -# &::print_log("PLM: AddIDSTATE:$id:$state"); -} - -sub add -{ - my ($self,@p_objects) = @_; - - my @l_objects; - - for my $l_object (@p_objects) { - if ($l_object->isa('Group_Item') ) { - @l_objects = $$l_object{members}; - for my $obj (@l_objects) { - $self->add($obj); - } - } else { - $self->add_item($l_object); - } - } -} - -sub add_item -{ - my ($self,$p_object) = @_; - - push @{$$self{objects}}, $p_object; - - if (!($self->device_id) and !($$self{_id_check})) { - $$self{_id_check} = 1; - $self->send_plm_cmd('0260'); - } - -# if ($p_object->isa('Insteon_Device') and $p_object->is_root and $p_object->devcat ne '0005') -# { - # don't request status for objects associated w/ other than the primary group - # as they are psuedo links -# my $scan_at_startup = $::config_parms{Insteon_PLM_scan_at_startup}; -# $scan_at_startup = 1 unless defined $scan_at_startup; -# $scan_at_startup = 0 unless $main::Save{mh_exit} eq 'normal'; -# $p_object->request_status() if $p_object->group eq '01' and $scan_at_startup; -# } - return $p_object; -} - -sub remove_all_items { - my ($self) = @_; - - if (ref $$self{objects}) { - foreach (@{$$self{objects}}) { - # $_->untie_items($self); - } - } - delete $self->{objects}; -} - -sub add_item_if_not_present { - my ($self, $p_object) = @_; - - if (ref $$self{objects}) { - foreach (@{$$self{objects}}) { - if ($_ eq $p_object) { - return 0; - } - } - } - $self->add_item($p_object); - return 1; -} - -sub remove_item { - my ($self, $p_object) = @_; - - if (ref $$self{objects}) { - for (my $i = 0; $i < scalar(@{$$self{objects}}); $i++) { - if ($$self{objects}->[$i] eq $p_object) { - splice @{$$self{objects}}, $i, 1; - # $p_object->untie_items($self); - return 1; - } - } - } - return 0; -} - - -sub is_member { - my ($self, $p_object) = @_; - - my @l_objects = @{$$self{objects}}; - for my $l_object (@l_objects) { - if ($l_object eq $p_object) { - return 1; - } - } - return 0; -} - -sub find_members { - my ($self,$p_type) = @_; - - my @l_found; - my @l_objects = @{$$self{objects}}; - for my $l_object (@l_objects) { - if ($l_object->isa($p_type)) { - push @l_found, $l_object; - } - } - return @l_found; -} - -sub device_id { - my ($self, $p_deviceid) = @_; - $$self{deviceid} = $p_deviceid if defined $p_deviceid; - return $$self{deviceid}; -} - -sub get_device -{ - my ($self, $p_deviceid, $p_group) = @_; - foreach my $device ($self->find_members('Insteon_Device')) { - if (lc $device->device_id eq lc $p_deviceid and lc $device->group eq lc $p_group) { - return $device; - } - } -} - -sub _set_timeout -{ - my ($self, $timeout_name, $timeout_in_millis) = @_; - my $tickcount = &main::get_tickcount + $timeout_in_millis; - $tickcount += 2**32 if $tickcount < 0; # force a wrap; to be handleded by check timeout - $$self{"_timeout_$timeout_name"} = $tickcount; -} - -sub _check_timeout -{ - my ($self, $timeout_name) = @_; - return 0 unless $timeout_name; - return -1 unless defined $$self{"_timeout_$timeout_name"}; - my $current_tickcount = &main::get_tickcount; - return 0 if (($current_tickcount >= 2**16) and ($$self{"_timeout_$timeout_name"} < 2**16)); - return ($current_tickcount > $$self{"_timeout_$timeout_name"}) ? 1 : 0; -} - -sub _clear_timeout -{ - my ($self, $timeout_name) = @_; - $$self{"_timeout_$timeout_name"} = undef; +sub add_id_state { + # do nothing } sub firmware { @@ -1456,12 +595,5 @@ sub firmware { return $$self{firmware}; } -=begin -sub default_getstate -{ - my ($self,$p_state) = @_; - return $$self{m_obj}->state(); -} -=cut -1; +1; diff --git a/lib/Telephony_xAP.pm b/lib/Telephony_xAP.pm index bcec1e2cd..49f3760bf 100644 --- a/lib/Telephony_xAP.pm +++ b/lib/Telephony_xAP.pm @@ -148,10 +148,11 @@ sub meteor_out_complete_hook sub callerid_hook { my ($self,$p_xap)= @_; - $self->cid_name(''); + my $cidname = $$p_xap{'incoming.callwithcid'}{name}; + $cidname = '' unless $cidname; $self->cid_number(''); $self->cid_type(''); - $self->cid_name($$p_xap{'incoming.callwithcid'}{name}); + $self->cid_name($cidname); $self->cid_number($$p_xap{'incoming.callwithcid'}{phone}); $self->cid_type('N'); # N-Normal, P-Private/Blocked, U-Unknown; if (uc $$p_xap{'incoming.callwithcid'}{rnnumber} eq 'UNAVAILABLE' or @@ -166,7 +167,7 @@ sub meteor_in_cid_hook { my ($self,$p_xap,$block_name)= @_; my $cidname = $$p_xap{'incoming.callwithcid'}{name}; - $cidname = '' unless $cidname; + $cidname = '' unless $cidname && $$p_xap{'incoming.callwithcid'}{rnname} ne 'Unavailable'; my $cidphone = $$p_xap{'incoming.callwithcid'}{phone}; $cidphone = '' unless $cidphone; $self->cid_type(''); diff --git a/lib/Timer.pm b/lib/Timer.pm index dd7245126..07fadcade 100644 --- a/lib/Timer.pm +++ b/lib/Timer.pm @@ -73,7 +73,7 @@ sub restore_string { my ($self) = @_; my $expire_time = $self->{expire_time}; - return unless $self->{time} or ($expire_time and $expire_time > main::get_tickcount); + return unless $self->{time} or ($expire_time and $expire_time > &main::get_tickcount); my $restore_string = "set $self->{object_name} $self->{period}" if $self->{period}; $restore_string .= ", q|$self->{action}|" if $self->{action}; @@ -84,7 +84,6 @@ sub restore_string { $restore_string .= $self->{object_name} . "->{time} = q~$self->{time}~;\n" if $self->{time}; $restore_string .= $self->{object_name} . "->{time_pause} = q~$self->{time_pause}~;\n" if $self->{time_pause}; $restore_string .= $self->{object_name} . "->{time_adjust} = q~$self->{time_adjust}~;\n" if $self->{time_adjust}; - return $restore_string; } @@ -119,7 +118,6 @@ sub set { $repeat = 0 unless defined $repeat; # print "db1 $main::Time_Date running set s=$self s=$state a=$action t=$self->{text} c=@c\n"; return if &main::check_for_tied_filters($self, $state); - # Set states for NEXT pass, so expired, active, etc, # checks are consistent for one pass. push @sets_from_previous_pass, $self; @@ -143,7 +141,7 @@ sub set_from_last_pass { } # Turn a timer on else { - $self->{expire_time} = ($state * 1000) + main::get_tickcount; + $self->{expire_time} = ($state * 1000) + &main::get_tickcount; $self->{period} = $state; $self->{repeat} = $repeat; if ($action) { @@ -211,7 +209,7 @@ sub expired { ($self) = @_; # print "db $self->{expire_time} $self->{pass_triggered}\n"; if ($self->{expire_time} and - $self->{expire_time} < main::get_tickcount) { + $self->{expire_time} < &main::get_tickcount) { # print "db expired1 loop=$self->{pass_triggered} lc= $main::Loop_Count\n"; # Reset if we finished the trigger pass @@ -235,14 +233,14 @@ sub expired { sub hours_remaining { ($self) = @_; return if inactive $self; - my $diff = $self->{expire_time} - main::get_tickcount; + my $diff = $self->{expire_time} - &main::get_tickcount; # print "d=$diff s=$self st=", $self->{expire_time}, "\n"; return sprintf("%3.1f", $diff/(60*60000)); } sub hours_remaining_now { ($self) = @_; return if inactive $self; - my $hours_left = int(.5 + ($self->{expire_time} - main::get_tickcount) / (60*60000)); + my $hours_left = int(.5 + ($self->{expire_time} - &main::get_tickcount) / (60*60000)); if ($hours_left and $self->{hours_remaining} != $hours_left) { $self->{hours_remaining} = $hours_left; @@ -256,14 +254,14 @@ sub hours_remaining_now { sub minutes_remaining { ($self) = @_; return if inactive $self; - my $diff = $self->{expire_time} - main::get_tickcount; + my $diff = $self->{expire_time} - &main::get_tickcount; # print "d=$diff s=$self st=", $self->{expire_time}, "\n"; return sprintf("%3.1f", $diff/60000); } sub minutes_remaining_now { ($self) = @_; return if inactive $self; - my $minutes_left = int(.5 + ($self->{expire_time} - main::get_tickcount) / 60000); + my $minutes_left = int(.5 + ($self->{expire_time} - &main::get_tickcount) / 60000); if ($minutes_left and $self->{minutes_remaining} != $minutes_left) { $self->{minutes_remaining} = $minutes_left; @@ -277,13 +275,13 @@ sub minutes_remaining_now { sub seconds_remaining { ($self) = @_; return if inactive $self; - my $diff = $self->{expire_time} - main::get_tickcount; + my $diff = $self->{expire_time} - &main::get_tickcount; return sprintf("%3.1f", $diff/1000); } sub seconds_remaining_now { ($self) = @_; return if inactive $self; - my $seconds_left = int(.5 + ($self->{expire_time} - main::get_tickcount) / 1000); + my $seconds_left = int(.5 + ($self->{expire_time} - &main::get_tickcount) / 1000); if ($seconds_left and $self->{seconds_remaining} != $seconds_left) { $self->{seconds_remaining} = $seconds_left; @@ -298,7 +296,7 @@ sub seconds_remaining_now { sub active { ($self) = @_; if (($self->{expire_time} and - $self->{expire_time} >= main::get_tickcount) or + $self->{expire_time} >= &main::get_tickcount) or ($self->{set_next_pass})) { return 1; } diff --git a/lib/read_table_A.pl b/lib/read_table_A.pl index ce47834e4..1192e30e0 100644 --- a/lib/read_table_A.pl +++ b/lib/read_table_A.pl @@ -14,7 +14,7 @@ #print_log "Using read_table_A.pl"; -my (%groups, %objects, %packages); +my (%groups, %objects, %packages, %addresses); sub read_table_init_A { # reset known groups @@ -22,6 +22,7 @@ sub read_table_init_A { %groups=(); %objects=(); %packages=(); + %addresses=(); } sub read_table_A { @@ -32,7 +33,7 @@ sub read_table_A { } $record =~ s/\s*#.*$//; - my ($code, $address, $name, $object, $grouplist, $comparison, $limit, @other, $other, $vcommand, $occupancy,$network,$password); + my ($code, $address, $name, $object, $grouplist, $comparison, $limit, @other, $other, $vcommand, $occupancy,$network,$password, $interface); my(@item_info) = split(',\s*', $record); my $type = uc shift @item_info; @@ -84,29 +85,71 @@ sub read_table_A { } # ---------------------------------------------------------------------- elsif($type eq "INSTEON_PLM") { - require 'Insteon_PLM.pm'; + require Insteon_PLM; ($name, $grouplist, @other) = @item_info; $other = join ', ', (map {"'$_'"} @other); # Quote data - $object = "Insteon_PLM('Insteon_PLM')"; + $object = "Insteon_PLM('Insteon_PLM',$other)"; } - elsif($type eq "IPLD") { - require 'Insteon_Device.pm'; - ($address, $name, $grouplist, $object, @other) = @item_info; + elsif($type eq "INSTEON_LAMPLINC") { + require Insteon::Lighting; + ($address, $name, $grouplist, @other) = @item_info; $other = join ', ', (map {"'$_'"} @other); # Quote data - $object = "Insteon_Device(\$$object, \'$address\', $other)"; + $object = "Insteon::LampLinc(\'$address\',$other)"; } - elsif($type eq "IPLL") { - require 'Insteon_Link.pm'; - ($address, $name, $grouplist, $object, @other) = @item_info; + elsif($type eq "INSTEON_APPLIANCELINC") { + require Insteon::Lighting; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::ApplianceLinc(\'$address\',$other)"; + } + elsif($type eq "INSTEON_SWITCHLINC") { + require Insteon::Lighting; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::SwitchLinc(\'$address\',$other)"; + } + elsif($type eq "INSTEON_SWITCHLINCRELAY") { + require Insteon::Lighting; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::SwitchLincRelay(\'$address\',$other)"; + } + elsif($type eq "INSTEON_KEYPADLINC") { + require Insteon::Lighting; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::KeyPadLinc(\'$address\', $other)"; + } + elsif($type eq "INSTEON_KEYPADLINCRELAY") { + require Insteon::Lighting; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::KeyPadLincRelay(\'$address\', $other)"; + } + elsif($type eq "INSTEON_REMOTELINC") { + require Insteon::Controller; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::RemoteLinc(\'$address\', $other)"; + } + elsif($type eq "INSTEON_MOTIONSENSOR") { + require Insteon::Security; + ($address, $name, $grouplist, @other) = @item_info; + $other = join ', ', (map {"'$_'"} @other); # Quote data + $object = "Insteon::MotionSensor(\'$address\', $other)"; + } + elsif($type eq "INSTEON_ICONTROLLER") { + require Insteon::BaseInsteon; + ($address, $name, $grouplist, @other) = @item_info; $other = join ', ', (map {"'$_'"} @other); # Quote data my ($deviceid,$groupid) = $address =~ /(\S+):(\S+)/; - if ($deviceid =~ /$object/i) { - $object = "Insteon_Link(\$$object, \'00.00.00:$groupid\', $other)"; + if ($groupid) { + $object = "Insteon::InterfaceController(\'00.00.00:$groupid\', $other)"; } else { - $object = "Insteon_Link(\$$object, \'$address\', $other)"; + $object = "Insteon::InterfaceController(\'00.00.00:$address\', $other)"; } } - elsif($type eq 'IPLT') { + elsif($type eq 'IPLT' or $type eq 'INSTEON_THERMOSTAT') { require 'Insteon_Thermostat.pm'; ($address, $name, $grouplist, $object, @other) = @item_info; $other = join ', ', (map {"'$_'"} @other); # Quote data @@ -797,7 +840,7 @@ sub read_table_A { if( ! $packages{xPL_Plugwise}++ ) { # first time for this object type? $code .= "use xPL_Plugwise;\n"; } - } + } elsif($type eq "XPL_SECURITYGATEWAY") { ($address, $name, $grouplist, @other) = @item_info; $other = join ', ', (map {"'$_'"} @other); # Quote data diff --git a/lib/site/DateTime/TimeZone.pm b/lib/site/DateTime/TimeZone.pm index 39b5dca73..f26a9b459 100644 --- a/lib/site/DateTime/TimeZone.pm +++ b/lib/site/DateTime/TimeZone.pm @@ -1,11 +1,13 @@ package DateTime::TimeZone; +use 5.006; + use strict; +use warnings; -use vars qw( $VERSION ); -$VERSION = '0.6603'; +our $VERSION = '0.84'; -use DateTime::TimeZoneCatalog; +use DateTime::TimeZone::Catalog; use DateTime::TimeZone::Floating; use DateTime::TimeZone::Local; use DateTime::TimeZone::OffsetOnly; @@ -24,7 +26,7 @@ use constant OFFSET => 4; use constant IS_DST => 5; use constant SHORT_NAME => 6; -my %SpecialName = map { $_ => 1 } qw( EST MST HST EST5EDT CST6CDT MST7MDT PST8PDT ); +my %SpecialName = map { $_ => 1 } qw( EST MST HST CET EET MET WET EST5EDT CST6CDT MST7MDT PST8PDT ); sub new { @@ -33,13 +35,13 @@ sub new { name => { type => SCALAR } }, ); - if ( exists $DateTime::TimeZone::LINKS{ $p{name} } ) + if ( exists $DateTime::TimeZone::Catalog::LINKS{ $p{name} } ) { - $p{name} = $DateTime::TimeZone::LINKS{ $p{name} }; + $p{name} = $DateTime::TimeZone::Catalog::LINKS{ $p{name} }; } - elsif ( exists $DateTime::TimeZone::LINKS{ uc $p{name} } ) + elsif ( exists $DateTime::TimeZone::Catalog::LINKS{ uc $p{name} } ) { - $p{name} = $DateTime::TimeZone::LINKS{ uc $p{name} }; + $p{name} = $DateTime::TimeZone::Catalog::LINKS{ uc $p{name} }; } unless ( $p{name} =~ m,/, @@ -100,7 +102,7 @@ sub new $zone->can('olson_version') ? $zone->olson_version() : 'unknown'; - my $catalog_version = __PACKAGE__->catalog_olson_version(); + my $catalog_version = DateTime::TimeZone::Catalog->OlsonVersion(); if ( $object_version ne $catalog_version ) { @@ -404,9 +406,13 @@ sub category { (split /\//, $_[0]->{name}, 2)[0] } sub is_valid_name { - my $tz = eval { $_[0]->new( name => $_[1] ) }; + my $tz; + { + local $@; + $tz = eval { $_[0]->new( name => $_[1] ) }; + } - return $tz && UNIVERSAL::isa( $tz, 'DateTime::TimeZone') ? 1 : 0 + return $tz && $tz->isa('DateTime::TimeZone') ? 1 : 0 } sub STORABLE_freeze @@ -444,7 +450,11 @@ sub STORABLE_thaw # sub offset_as_seconds { - shift if eval { $_[0]->isa('DateTime::TimeZone') }; + { + local $@; + shift if eval { $_[0]->isa('DateTime::TimeZone') }; + } + my $offset = shift; return undef unless defined $offset; @@ -479,7 +489,11 @@ sub offset_as_seconds sub offset_as_string { - shift if eval { $_[0]->isa('DateTime::TimeZone') }; + { + local $@; + shift if eval { $_[0]->isa('DateTime::TimeZone') }; + } + my $offset = shift; return undef unless defined $offset; @@ -501,54 +515,54 @@ sub offset_as_string ); } -# These methods all operate on data contained in the DateTime/TimeZoneCatalog.pm file. +# These methods all operate on data contained in the DateTime/TimeZone/Catalog.pm file. sub all_names { - return wantarray ? @DateTime::TimeZone::ALL : [@DateTime::TimeZone::ALL]; + return wantarray ? @DateTime::TimeZone::Catalog::ALL : [@DateTime::TimeZone::Catalog::ALL]; } sub categories { return wantarray - ? @DateTime::TimeZone::CATEGORY_NAMES - : [@DateTime::TimeZone::CATEGORY_NAMES]; + ? @DateTime::TimeZone::Catalog::CATEGORY_NAMES + : [@DateTime::TimeZone::Catalog::CATEGORY_NAMES]; } sub links { return - wantarray ? %DateTime::TimeZone::LINKS : {%DateTime::TimeZone::LINKS}; + wantarray ? %DateTime::TimeZone::Catalog::LINKS : {%DateTime::TimeZone::Catalog::LINKS}; } sub names_in_category { shift if $_[0]->isa('DateTime::TimeZone'); - return unless exists $DateTime::TimeZone::CATEGORIES{ $_[0] }; + return unless exists $DateTime::TimeZone::Catalog::CATEGORIES{ $_[0] }; return wantarray - ? @{ $DateTime::TimeZone::CATEGORIES{ $_[0] } } - : [ $DateTime::TimeZone::CATEGORIES{ $_[0] } ]; + ? @{ $DateTime::TimeZone::Catalog::CATEGORIES{ $_[0] } } + : [ $DateTime::TimeZone::Catalog::CATEGORIES{ $_[0] } ]; } sub countries { wantarray - ? ( sort keys %DateTime::TimeZone::ZONES_BY_COUNTRY ) - : [ sort keys %DateTime::TimeZone::ZONES_BY_COUNTRY ]; + ? ( sort keys %DateTime::TimeZone::Catalog::ZONES_BY_COUNTRY ) + : [ sort keys %DateTime::TimeZone::Catalog::ZONES_BY_COUNTRY ]; } sub names_in_country { shift if $_[0]->isa('DateTime::TimeZone'); - return unless exists $DateTime::TimeZone::ZONES_BY_COUNTRY{ lc $_[0] }; + return unless exists $DateTime::TimeZone::Catalog::ZONES_BY_COUNTRY{ lc $_[0] }; return wantarray - ? @{ $DateTime::TimeZone::ZONES_BY_COUNTRY{ lc $_[0] } } - : $DateTime::TimeZone::ZONES_BY_COUNTRY{ lc $_[0] }; + ? @{ $DateTime::TimeZone::Catalog::ZONES_BY_COUNTRY{ lc $_[0] } } + : $DateTime::TimeZone::Catalog::ZONES_BY_COUNTRY{ lc $_[0] }; } @@ -623,34 +637,21 @@ C object is returned. If the "name" parameter is "local", then the module attempts to determine the local time zone for the system. -First it checks C<$ENV> for keys named "TZ", "SYS$TIMEZONE_RULE", -"SYS$TIMEZONE_NAME", "UCX$TZ", or "TCPIP$TZC" (the last 4 are for -VMS). If this is defined, and it is not the string "local", then it -is treated as any other valid name (including "floating"), and the -constructor tries to create a time zone based on that name. +The method for finding the local zone varies by operating system. See +the appropriate module for details of how we check for the local time +zone. + +=over 4 -Next, it checks for the existence of a symlink at F. -It follows this link to the real file and figures out what the file's -name is. It then tries to turn this name into a valid time zone. For -example, if this file is linked to F, -it will end up trying "US/Central", which will then be converted to -"America/Chicago" internally. +=item * L -Some systems just copy the relevant file to F instead -of making a symlink. In this case, we look in F -for a file that has the same size and content as F to -determine the local time zone. +=item * L -Then it checks for a file called F or F. -If one of these exists, it is read and it tries to create a time zone -with the name contained in the file. +=item * L -Finally, it checks for a file called F. If this -file exists, it looks for a line inside the file matching -C. If this line exists, it tries the -value as a time zone name. +=back -If none of these methods work, it gives up and dies. +If a local time zone is not found, then an exception will be thrown. =head2 $tz->offset_for_datetime( $dt ) @@ -756,7 +757,7 @@ use C to do so. =head2 DateTime::TimeZone->names_in_country( $country_code ) -Given a two-letter ISO3066 country code, this method returns a list of +Given a two-letter ISO3166 country code, this method returns a list of time zones used in that country. The country code may be of any case. In scalar context, it returns an array reference, while in list context it returns an array. @@ -793,12 +794,33 @@ your module with Storable. =head1 SUPPORT Support for this module is provided via the datetime@perl.org email -list. See http://lists.perl.org/ for more details. +list. See http://datetime.perl.org/?MailingList for details. Please submit bugs to the CPAN RT system at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=datetime%3A%3Atimezone or via email at bug-datetime-timezone@rt.cpan.org. +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, +please consider making a "donation" to me via PayPal. I spend a lot of +free time creating free software, and would appreciate any support +you'd care to offer. + +Please note that B in order +for me to continue working on this particular software. I will +continue to do so, inasmuch as I have in the past, for as long as it +interests me. + +Similarly, a donation made in this way will probably not make me work +on this software much more, unless I get so many donations that I can +consider working on free software full time, which seems unlikely at +best. + +To donate, log into PayPal and send money to autarch@urth.org or use +the button on this page: +L + =head1 AUTHOR Dave Rolsky @@ -811,7 +833,7 @@ datetime@perl.org list. =head1 COPYRIGHT -Copyright (c) 2003-2007 David Rolsky. All rights reserved. This +Copyright (c) 2003-2008 David Rolsky. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/site/HTTP/Date.pm b/lib/site/HTTP/Date.pm index a2e08b533..95e568e1c 100644 --- a/lib/site/HTTP/Date.pm +++ b/lib/site/HTTP/Date.pm @@ -1,6 +1,5 @@ package HTTP::Date; # $Date$ -$VERSION = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); require 5.004; require Exporter; diff --git a/lib/site/HTTP/Headers.pm b/lib/site/HTTP/Headers.pm index febee2eb3..755b95d4f 100644 --- a/lib/site/HTTP/Headers.pm +++ b/lib/site/HTTP/Headers.pm @@ -6,7 +6,6 @@ use strict; use Carp (); use vars qw($VERSION $TRANSLATE_UNDERSCORE); -$VERSION = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); # The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used # as a replacement for '-' in header field names. diff --git a/lib/site/HTTP/Message.pm b/lib/site/HTTP/Message.pm index 36a26163f..295d563f4 100644 --- a/lib/site/HTTP/Message.pm +++ b/lib/site/HTTP/Message.pm @@ -4,7 +4,7 @@ package HTTP::Message; use strict; use vars qw($VERSION $AUTOLOAD); -$VERSION = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); +$VERSION = '1.23'; require HTTP::Headers; require Carp; diff --git a/lib/site/HTTP/Request.pm b/lib/site/HTTP/Request.pm index 4902fa624..54a6030ad 100644 --- a/lib/site/HTTP/Request.pm +++ b/lib/site/HTTP/Request.pm @@ -4,7 +4,6 @@ package HTTP::Request; require HTTP::Message; @ISA = qw(HTTP::Message); -$VERSION = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); use strict; diff --git a/lib/site/HTTP/Response.pm b/lib/site/HTTP/Response.pm index fb56ed38a..e7d8999bf 100644 --- a/lib/site/HTTP/Response.pm +++ b/lib/site/HTTP/Response.pm @@ -4,7 +4,6 @@ package HTTP::Response; require HTTP::Message; @ISA = qw(HTTP::Message); -$VERSION = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); use strict; use HTTP::Status (); diff --git a/lib/site/HTTP/Status.pm b/lib/site/HTTP/Status.pm index ebb02c4c6..31a77fd53 100644 --- a/lib/site/HTTP/Status.pm +++ b/lib/site/HTTP/Status.pm @@ -11,7 +11,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT = qw(is_info is_success is_redirect is_error status_message); @EXPORT_OK = qw(is_client_error is_server_error); -$VERSION = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); +$VERSION = '1.23'; # Note also addition of mnemonics to @EXPORT below From 19f6f309f01d46c794614fa89690765b2a0901c7 Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Mon, 26 Jul 2010 02:23:13 +0000 Subject: [PATCH 003/150] synced changes from main tree to insteon branch --- lib/EIB_Device.pm | 6 +-- lib/Omnistat.pm | 28 +++++++++++--- lib/Owfs_Item.pm | 89 ++++++++++++++++++++++++++++++++++++++++++-- lib/Telephony_xAP.pm | 7 ++-- lib/Timer.pm | 22 ++++++----- lib/X10_MR26.pm | 6 ++- lib/X10_W800.pm | 4 +- lib/xPL_Items.pm | 50 ++++++++++++++++++++++++- lib/xPL_Plugwise.pm | 9 ++++- 9 files changed, 186 insertions(+), 35 deletions(-) diff --git a/lib/EIB_Device.pm b/lib/EIB_Device.pm index ea08d96ee..5831ba33d 100644 --- a/lib/EIB_Device.pm +++ b/lib/EIB_Device.pm @@ -44,6 +44,7 @@ sub startup { die "Parameter eib_device has changed to eib_connection!\nPlease change ini file!\n\n" if $::config_parms{eib_device}; return unless my $dev = $::config_parms{eib_connection}; # Is EIB enabled? printf " - initializing EIB connection to '$dev' ..."; + &main::print_log ("Initializing EIB connection"); if ($dev =~ /(.+):(.+)/) { # Using eibd communication die "EIB: Only ip supported on eibd communication" unless $1 eq "ip"; @@ -299,9 +300,6 @@ sub sendGroup { my @msg = (0x0027,$Dest); # EIB_GROUP_PACKET push @msg, $str; sendRequest ($Sock, pack "nna*", @msg); - goto error unless my $answer = getRequest ($Sock); - my $head = unpack ("n", $answer); - goto error unless $head == 0x0027; return 1; error: @@ -375,7 +373,7 @@ sub check_for_eibddata { my $data = pack "CCnnCa*", 0xbc, 0x00, $tmpdat[0], $tmpdat[1], 0xe1, $tmpdat[2]; #print "Modified packet: ", unpack("H*",$data), "\n"; my $msg = decode($data); - EIB_Item::receive_msg($msg); + EIB_Item::receive_msg($msg) unless $msg->{'src'} eq "0.0.0"; } else { # Close socket in case of errors close $EIBSock; diff --git a/lib/Omnistat.pm b/lib/Omnistat.pm index 32f50b590..31d50a753 100644 --- a/lib/Omnistat.pm +++ b/lib/Omnistat.pm @@ -423,16 +423,25 @@ sub new { foreach my $reg (0x3b .. 0x3f) { $$self{cache_agelimit}{$reg} = 54; # CACHE_TIMEOUT_SHORT } - # temperatures and what the stat outputs, we only cache 10 seconds + # temperatures and what the stat outputs, we only cache 9 seconds + # to allow for a 10 second refresh rate. foreach my $reg (0x40, 0x44, 0x48) { - $$self{cache_agelimit}{$reg} = 10; # CACHE_TIMEOUT_VERYSHORT + $$self{cache_agelimit}{$reg} = 9; # CACHE_TIMEOUT_VERYSHORT } - #The next line is an experiment with http_server.pm to allow other objects to show up in the web interface $$self{html_text} = "Set Thermostat"; + omnistat_debug("Omnistat[$$self{address}] object created"); bless $self,$class; + + # This is to work around a timing bug where the first query doesn't get a proper ack + # we just "prime" the device and connection by making one query to it where we ignore the answer + # no idea why this is needed, but it works for me and things are stable afterwards -- merlin + $self->{'PRIME'}=1; + $self->send_cmd("0x01 0x20 0x40 0x01 0x62", 1); + $self->{'PRIME'}=0; + return $self; } @@ -517,6 +526,12 @@ sub send_cmd { } my $rcvd_ack = hex(substr($rcvd, 0 , 4)); + if ($self->{'PRIME'}) + { + omnistat_debug("Omnistat[$$self{address}]->send_cmd skipping error check and return value during prime"); + return; + } + # FIXME? Those two dies aren't ideal, but it happens that you get corruption or bad data on a reply. # Expected for 01 20 3b 0e 6a is something like # 0x81 0xf2 0x3b 0x7c 0x71 0x03 0x00 0x00 0x7d 0x07 0x1e 0x0f 0x00 0x00 0x00 0x02 0x0c 0x5d @@ -760,7 +775,7 @@ sub translate_time { sub translate_stat_output { my ( $self, $reg48 ) = @_; - die "Omnistat::translate_stat_output got non hex value in $reg48" unless (is_hex($reg48)); + die "Omnistat::translate_stat_output got non hex value in '$reg48'" unless (is_hex($reg48)); # see reg 0x48 / output register at the top of this file my $output = "off"; $output = "fan" if (hex($reg48) & 8); @@ -1003,9 +1018,9 @@ sub get_temp { # ******************************************************** sub get_stat_output { my ( $self ) = @_; - my $reg48 = hex( $self->read_cached_reg("0x48",1) ); + my $reg48 = $self->read_cached_reg("0x48",1); - return self->translate_stat_output($reg48); + return $self->translate_stat_output($reg48); } # ************************************** @@ -1301,6 +1316,7 @@ sub read_cached_reg { # if one cache value was stale, retrieve the whole list now $value = $self->read_reg($register, $count, "true") if (not defined $regval); + $value =~ s/\s+$//; omnistat_debug("Omnistat[$$self{address}]->read_cached_reg: reg=$register count=$count value=$value"); diff --git a/lib/Owfs_Item.pm b/lib/Owfs_Item.pm index c9e562bcd..d2ecbf651 100644 --- a/lib/Owfs_Item.pm +++ b/lib/Owfs_Item.pm @@ -10,7 +10,7 @@ offering a simple PERL API interface. Requirements: - Download and install OWFS + Download and install OWFS (tested against release owfs-2.7p21) http://www.owfs.org Setup: @@ -18,9 +18,10 @@ Setup: In your code module, instantation the Owfs_Item class to interface with some one-wire element. The one-wire device can be found using the OWFS html interface. -configure mh.privite.ini +configure mh.private.ini owfs_port = 3030 # defined port where the owfs server is listening + # (owserver defaults to 4304) Example Usage: @@ -86,7 +87,7 @@ sub new { # Initialize the OWFS perl interface ( server tcp port ) my $port = 3030; - $port = "$main::config_parm{owfs_port}" if exists $main::config_parm{owfs_port}; + $port = "$main::config_parms{owfs_port}" if exists $main::config_parms{owfs_port}; &main::print_log ("Owfs_Item:: Initializing port: $port $location") if $main::Debug{owfs}; OW::init ( "$port" ); @@ -203,6 +204,88 @@ sub _remove { } } +#======================================================================================= +# +# Owfs_DS18S20 +# +# This package specifically handles the DS18S20 Thermometer +# +#======================================================================================= + +=begin comment + +Usage: + + $sensor = new Owfs_DS18S20 ( "", , ); + + - of the form family.address; identifies the one-wire device + - ASCII string identifier providing a useful name for device_id + - seconds between acquisitions + + Example: + + $ds18S20 = new Owfs_DS18S20 ( "10.DB2506000000", "Living Room", 2 ); + + my $temperature = get_temperature $ds18S20; + +=cut + +use strict; + +package Owfs_DS18S20; + +@Owfs_DS18S20::ISA = ('Owfs_Item'); + +sub new { + my ($class, $ds18S20, $location, $interval) = @_; + my $self = new Owfs_Item ( $ds18S20, $location ); + bless $self,$class; + + $interval = 10 unless $interval; + $interval = 10 if ($interval < 10); + $self->{interval} = $interval; + + $self->{timer} = new Timer; + $self->{timer}->set($self->{interval}, sub {&Owfs_DS18S20::run_loop($self)}); + $self->{temperature} = 0; + $self->{index} = 0; + return $self; +} + +sub get_temperature { + my $self = shift; + return ($self->{temperature}); +} + +sub state { + my $self = shift; + return ($self->{temperature}); +} + +sub run_loop { + my $self = shift; + my $index = $self->{index}; + &main::print_log ( "Owfs_DS18S20:: index: $index") if $main::Debug{owfs}; + + # issue simultaneous to start a conversion + if ($self->{index} == 0) { + $self->set_root ( "simultaneous/temperature", "1" ); + } else { + $self->{temperature} = $self->get ( "temperature"); + $self->SUPER::set($$self{temperature}); + &main::print_log ("Owfs_DS18S20 temperature: $$self{temperature}") if $main::Debug{owfs}; + } + + # udpate the index + $self->{index} += 1; + if ($self->{index} >= 2) { + $self->{index} = 0; + } + + # reschedule the timer for next pass + $self->{timer}->set($self->{interval}, sub {&Owfs_DS18S20::run_loop($self)}); +} + #======================================================================================= # # Owfs_DS2450 diff --git a/lib/Telephony_xAP.pm b/lib/Telephony_xAP.pm index 49f3760bf..bcec1e2cd 100644 --- a/lib/Telephony_xAP.pm +++ b/lib/Telephony_xAP.pm @@ -148,11 +148,10 @@ sub meteor_out_complete_hook sub callerid_hook { my ($self,$p_xap)= @_; - my $cidname = $$p_xap{'incoming.callwithcid'}{name}; - $cidname = '' unless $cidname; + $self->cid_name(''); $self->cid_number(''); $self->cid_type(''); - $self->cid_name($cidname); + $self->cid_name($$p_xap{'incoming.callwithcid'}{name}); $self->cid_number($$p_xap{'incoming.callwithcid'}{phone}); $self->cid_type('N'); # N-Normal, P-Private/Blocked, U-Unknown; if (uc $$p_xap{'incoming.callwithcid'}{rnnumber} eq 'UNAVAILABLE' or @@ -167,7 +166,7 @@ sub meteor_in_cid_hook { my ($self,$p_xap,$block_name)= @_; my $cidname = $$p_xap{'incoming.callwithcid'}{name}; - $cidname = '' unless $cidname && $$p_xap{'incoming.callwithcid'}{rnname} ne 'Unavailable'; + $cidname = '' unless $cidname; my $cidphone = $$p_xap{'incoming.callwithcid'}{phone}; $cidphone = '' unless $cidphone; $self->cid_type(''); diff --git a/lib/Timer.pm b/lib/Timer.pm index 07fadcade..dd7245126 100644 --- a/lib/Timer.pm +++ b/lib/Timer.pm @@ -73,7 +73,7 @@ sub restore_string { my ($self) = @_; my $expire_time = $self->{expire_time}; - return unless $self->{time} or ($expire_time and $expire_time > &main::get_tickcount); + return unless $self->{time} or ($expire_time and $expire_time > main::get_tickcount); my $restore_string = "set $self->{object_name} $self->{period}" if $self->{period}; $restore_string .= ", q|$self->{action}|" if $self->{action}; @@ -84,6 +84,7 @@ sub restore_string { $restore_string .= $self->{object_name} . "->{time} = q~$self->{time}~;\n" if $self->{time}; $restore_string .= $self->{object_name} . "->{time_pause} = q~$self->{time_pause}~;\n" if $self->{time_pause}; $restore_string .= $self->{object_name} . "->{time_adjust} = q~$self->{time_adjust}~;\n" if $self->{time_adjust}; + return $restore_string; } @@ -118,6 +119,7 @@ sub set { $repeat = 0 unless defined $repeat; # print "db1 $main::Time_Date running set s=$self s=$state a=$action t=$self->{text} c=@c\n"; return if &main::check_for_tied_filters($self, $state); + # Set states for NEXT pass, so expired, active, etc, # checks are consistent for one pass. push @sets_from_previous_pass, $self; @@ -141,7 +143,7 @@ sub set_from_last_pass { } # Turn a timer on else { - $self->{expire_time} = ($state * 1000) + &main::get_tickcount; + $self->{expire_time} = ($state * 1000) + main::get_tickcount; $self->{period} = $state; $self->{repeat} = $repeat; if ($action) { @@ -209,7 +211,7 @@ sub expired { ($self) = @_; # print "db $self->{expire_time} $self->{pass_triggered}\n"; if ($self->{expire_time} and - $self->{expire_time} < &main::get_tickcount) { + $self->{expire_time} < main::get_tickcount) { # print "db expired1 loop=$self->{pass_triggered} lc= $main::Loop_Count\n"; # Reset if we finished the trigger pass @@ -233,14 +235,14 @@ sub expired { sub hours_remaining { ($self) = @_; return if inactive $self; - my $diff = $self->{expire_time} - &main::get_tickcount; + my $diff = $self->{expire_time} - main::get_tickcount; # print "d=$diff s=$self st=", $self->{expire_time}, "\n"; return sprintf("%3.1f", $diff/(60*60000)); } sub hours_remaining_now { ($self) = @_; return if inactive $self; - my $hours_left = int(.5 + ($self->{expire_time} - &main::get_tickcount) / (60*60000)); + my $hours_left = int(.5 + ($self->{expire_time} - main::get_tickcount) / (60*60000)); if ($hours_left and $self->{hours_remaining} != $hours_left) { $self->{hours_remaining} = $hours_left; @@ -254,14 +256,14 @@ sub hours_remaining_now { sub minutes_remaining { ($self) = @_; return if inactive $self; - my $diff = $self->{expire_time} - &main::get_tickcount; + my $diff = $self->{expire_time} - main::get_tickcount; # print "d=$diff s=$self st=", $self->{expire_time}, "\n"; return sprintf("%3.1f", $diff/60000); } sub minutes_remaining_now { ($self) = @_; return if inactive $self; - my $minutes_left = int(.5 + ($self->{expire_time} - &main::get_tickcount) / 60000); + my $minutes_left = int(.5 + ($self->{expire_time} - main::get_tickcount) / 60000); if ($minutes_left and $self->{minutes_remaining} != $minutes_left) { $self->{minutes_remaining} = $minutes_left; @@ -275,13 +277,13 @@ sub minutes_remaining_now { sub seconds_remaining { ($self) = @_; return if inactive $self; - my $diff = $self->{expire_time} - &main::get_tickcount; + my $diff = $self->{expire_time} - main::get_tickcount; return sprintf("%3.1f", $diff/1000); } sub seconds_remaining_now { ($self) = @_; return if inactive $self; - my $seconds_left = int(.5 + ($self->{expire_time} - &main::get_tickcount) / 1000); + my $seconds_left = int(.5 + ($self->{expire_time} - main::get_tickcount) / 1000); if ($seconds_left and $self->{seconds_remaining} != $seconds_left) { $self->{seconds_remaining} = $seconds_left; @@ -296,7 +298,7 @@ sub seconds_remaining_now { sub active { ($self) = @_; if (($self->{expire_time} and - $self->{expire_time} >= &main::get_tickcount) or + $self->{expire_time} >= main::get_tickcount) or ($self->{set_next_pass})) { return 1; } diff --git a/lib/X10_MR26.pm b/lib/X10_MR26.pm index b38a0a621..ac388c818 100644 --- a/lib/X10_MR26.pm +++ b/lib/X10_MR26.pm @@ -58,8 +58,9 @@ sub check_for_data { &main::check_for_generic_serial_data('MR26'); my $data = $main::Serial_Ports{MR26}{data_record}; $main::Serial_Ports{MR26}{data_record} = undef; + #&main::main::print_log("MR26 entered read loop data\n") if (&main::main::new_second(10)); return unless $data; - + &main::main::print_log("MR26 got data") if $main::Debug{mr26}; # Data gets sent multiple times # - Check time and loop count. If mh paused (e.g. sending ir data) # then we better also check loop count. @@ -68,6 +69,7 @@ sub check_for_data { my $repeat_time = $main::config_parms{MR26_multireceive_delay} or 400; my $repeat_data = ($data eq $prev_data) && ($time < $prev_time + $repeat_time or $main::Loop_Count < $prev_loop + 7); return if $repeat_data and $prev_done; + &main::main::print_log("MR26 data is not dupe") if $main::Debug{mr26}; $prev_data = $data; $prev_time = $time; $prev_loop = $main::Loop_Count; @@ -92,7 +94,7 @@ sub check_for_data { my(@bytes); if (($bytes[0], $bytes[2]) = $data =~ /^\xd5\xaa(.)(.)$/) { - my $state = X10_RF::decode_rf_bytes('mr26', @bytes); + my $state = X10_RF::decode_rf_bytes('MR26', @bytes); # If we got a bad checksum, throw out the rest of the data in the # buffer since we probably have a corrupt data stream. diff --git a/lib/X10_W800.pm b/lib/X10_W800.pm index 653447b23..be4af98df 100644 --- a/lib/X10_W800.pm +++ b/lib/X10_W800.pm @@ -95,7 +95,7 @@ sub check_for_data { # data from a corrupt data stream. # NOTE: get_tickcount wraps, so $time < $new_data_time test is to # make sure that doesn't become a problem. - if (&X10_W800::is_within_timeout($time, $new_data_time, 2000)) { + if (not &X10_W800::is_within_timeout($time, $new_data_time, 2000)) { my $hex = unpack "H*", $main::Serial_Ports{W800}{data}; &::print_log("W800: flushing incomplete data: $hex") if $main::Debug{w800}; @@ -145,7 +145,7 @@ sub check_for_data { # have checksums at all. See X10_RF.pm for more details. my @bytes = $data =~ /^(.)(.)(.)(.)$/s; - my $state = X10_RF::decode_rf_bytes('w800', @bytes); + my $state = X10_RF::decode_rf_bytes('W800', @bytes); # If the decode_rf_bytes routine didn't like the data that it got, # strip the first byte off and let the rest be resubmitted in case a diff --git a/lib/xPL_Items.pm b/lib/xPL_Items.pm index 728a3db55..4634079ee 100644 --- a/lib/xPL_Items.pm +++ b/lib/xPL_Items.pm @@ -8,11 +8,57 @@ Info: http://www.xplproject.org.uk http://www.xaphal.com - - Authors: 10/26/2002 Created by Bruce Winter bruce@misterhouse.net + +xPL works by using the xPL Hub built in misterhouse and listening for +xPL connections. See: +http://misterhouse.wikispaces.com/xAP+and+xPL+-+Getting+Started + +Relevant variables for mh.private.ini are: +#ipaddress_xpl_broadcast = 192.168.205.255 +#ipaddress_xpl = 192.168.205.3 +#xpl_disable = 1 +#xpl_nohub = 1 + +You can disable the mh internal xPL hub if you are running a more capable one. +To get data input, you can use something like + +xpl-rfxcom-rx --verbose --rfxcom-rx-verbose --rfxcom-rx-tty /dev/rfxcom --interface eth1 + +from xPL-Perl. Then watch for sensor updates passing by and paste their info +in your device table, like so: +XPL_SENSOR, bnz-rfxcomrx.gargamel:bthr918n.e6, oregon_intemp, XPL_temp, temp + +Another option to figure out the name to use in XPL_SENSOR is to use +xpl-logger -head -body -i ethx 2>&1 | grep "xpl-trig\/" +(or without the grep for more details on which field is called what). + +A few samples: +XPL_SENSOR, iranger-rfx.*:WGR918, oregon_winddir, , direction +XPL_SENSOR, iranger-rfx.*:BHTR968, oregon_intemp, , temp +XPL_SENSOR, bnz-owfs.*:10.2223EF010800, owfs_temp, , temp +XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000, owfs_humidity, , humidity +XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000.1, owfs_humidity1, , humidity +XPL_X10SECURITY, iranger-rfx.*:F8, x10sec_garage1, , ds10 + +Note that XPL_SENSOR should just be used for XPL messages of the x10.basic +type. XPL_X10SECURITY is for x10.security schema, while there is no way to currently +read x10.basic messages (see this file for more supported schemas). + +Once it is running, objects get variables including these (gathered with Data::Dumper) +'state' => '17.9', +'states_nosubstate' => 1, +'states_substate' ? +'address' => 'bnz-rfxcomrx.gargamel', +'states_nomultistate' => 1, +'states_multistate' ? +'target_address' => '*', +'_device_id' => 'bthr918n.e6' + +So, you would write this to print temperature: +print_log $oregon_intemp->state =cut use strict; diff --git a/lib/xPL_Plugwise.pm b/lib/xPL_Plugwise.pm index fa496b0f1..9bfe1eef6 100644 --- a/lib/xPL_Plugwise.pm +++ b/lib/xPL_Plugwise.pm @@ -94,6 +94,7 @@ sub request_stat { my $name = $circle->get_object_name(); &::print_log("[xPL_PlugwiseGateway] Requesting state for $name over xPL") if $main::Debug{xpl_plugwise}; $circle->request_stat(); + sleep(1); } } } @@ -263,15 +264,19 @@ sub ignore_message { sub default_setstate { my ($self, $state, $substate, $set_by) = @_; + + #&::print_log("[xPL_Plugwise] setstate: $state"); + if ($set_by =~ /^xpl/i) { if ($$self{changed} =~ /plugwise\.basic/) { &::print_log("[xPL_Plugwise] " . $self->get_object_name . " state is $state") if $main::Debug{xpl_plugwise}; # TO-DO: process all of the other pertinent attributes available return -1 if $self->state eq $state; # don't propagate state unless it has changed - } + } } else { - my $cmnd = ($state =~ /^off/i) ? 'off' : 'on'; + + my $cmnd = ($state =~ /^off/i) ? 'off' : 'on'; return -1 if ($self->state eq $state); # Don't propagate state unless it has changed. &::print_log("[xPL_Plugwise] Request " . $self->get_object_name From 7cba1d9a1d663fc2333c5ef4c12f60890169bc34 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 26 Jul 2010 13:30:26 +0000 Subject: [PATCH 004/150] Attempt to avoid loops in request_status method for items with members. --- lib/Insteon/BaseInsteon.pm | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 5a03d4fe8..58822212c 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -990,7 +990,7 @@ sub add my ($self, $obj, $on_level, $ramp_rate) = @_; if (ref $obj and ($obj->isa('Light_Item') or $obj->isa('Insteon::BaseDevice'))) { if ($$self{members} && $$self{members}{$obj}) { - print "[Insteon_Link] An object (" . $obj->{object_name} . ") already exists " + print "[Insteon::BaseController] An object (" . $obj->{object_name} . ") already exists " . "in this scene. Aborting add request.\n"; return; } @@ -1008,7 +1008,7 @@ sub add $ramp_rate =~ s/s$//i; $$self{members}{$obj}{ramp_rate} = $ramp_rate if defined $ramp_rate; } else { - &::print_log("[Insteon_Link] WARN: unable to add $obj as items of this type are not supported!"); + &::print_log("[Insteon::BaseController] WARN: unable to add $obj as items of this type are not supported!"); } } @@ -1021,7 +1021,7 @@ sub sync_links if (!($self->isa('Insteon::InterfaceController'))) { $insteon_object = &Insteon::get_object($self->device_id,'01'); if (!(defined($insteon_object))) { - &main::print_log("[Insteon_Link] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " + &main::print_log("[Insteon::BaseController] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " . "Please double check your items.mht file."); } } @@ -1132,7 +1132,7 @@ sub sync_links } my $num_sync_queue = @{$$self{sync_queue}}; if (!($num_sync_queue)) { - &::print_log("[Insteon_Link] Nothing to do when syncing links for " . $self->get_object_name) + &::print_log("[Insteon::BaseController] Nothing to do when syncing links for " . $self->get_object_name) if $main::Debug{insteon}; } $self->_process_sync_queue(); @@ -1159,7 +1159,7 @@ sub _process_sync_queue { } elsif ($$self{sync_queue_callback}) { package main; eval ($$self{sync_queue_callback}); - &::print_log("[Insteon_Link] error in sync links callback: " . $@) + &::print_log("[Insteon::BaseController] error in sync links callback: " . $@) if $@ and $main::Debug{insteon}; $$self{sync_queue_callback} = undef; package Insteon::Insteon_link; @@ -1227,11 +1227,11 @@ sub set if (($self->isa("Insteon::KeyPadLinc") or $self->isa("Insteon::KeyPadLincRelay"))and !($self->is_root)) { if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) { $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); - } elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::Insteon_Link') or $$self{surrogate}->isa('Insteon::InterfaceController'))) { + } elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) { $$self{surrogate}->set($link_state, $p_setby, $p_respond) unless ref $p_setby and $p_setby eq $self; } else { - &::print_log("[Insteon_Link] You may not directly attempt to set a keypadlinc's button " + &::print_log("[Insteon::BaseController] You may not directly attempt to set a keypadlinc's button " . " unless you have defined a reverse link with the \"surrogate\" keyword"); } } else { @@ -1263,7 +1263,7 @@ sub update_members if ($device) { my %current_record = $device->get_link_record($self->device_id . $self->group); if (%current_record) { - &::print_log("[Insteon_Link] remote record: $current_record{data1}") + &::print_log("[Insteon::BaseController] remote record: $current_record{data1}") if $::Debug{insteon}; } } @@ -1328,12 +1328,17 @@ sub request_status { my ($self,$requestor) = @_; # if ($self->group ne '01') { - if ($$self{members} and !($self->isa('Insteon::InterfaceController'))) { - &::print_log("[Insteon_Link] requesting status for members of " . $$self{object_name}); + if ($$self{members} and !($self->isa('Insteon::InterfaceController')) + and (!(ref $requestor) or ($requestor eq $self))) { + &::print_log("[Insteon::DeviceController] requesting status for members of " . $$self{object_name}); foreach my $member (keys %{$$self{members}}) { - next if $requestor eq $$self{members}{$member}{object}; - if ($$self{members}{$member}{object}->isa('Insteon::BaseDevice')) { - $$self{members}{$member}{object}->request_status($self); + next unless $member->isa('Insteon::BaseObject'); + my $member_obj = $$self{members}{$member}{object}; + next if $requestor eq $member_obj; + if ($member_obj->isa('Insteon::BaseDevice')) { + &::print_log("[Insteon::DeviceController] checking status of " . $member_obj->get_object_name() + . " for requestor " . $requestor->get_object_name()); + $member_obj->request_status($self); } } } From caeda281947218f89ad9b6db15875b7824b9971c Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 26 Jul 2010 13:31:00 +0000 Subject: [PATCH 005/150] Fix typo in debug statement. --- lib/Insteon/Security.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/Security.pm b/lib/Insteon/Security.pm index 682eb1f8d..9616b4fcb 100755 --- a/lib/Insteon/Security.pm +++ b/lib/Insteon/Security.pm @@ -29,11 +29,11 @@ sub set # if it can't be controlled (i.e., a responder), then don't send out any signals # motion sensors seem to get multiple fast reports; don't trigger on both if (not defined($self->get_idle_time) or $self->get_idle_time > 1) { - &::print_log("[Insteon_Device] " . $self->get_object_name() + &::print_log("[Insteon::MotionSensor] " . $self->get_object_name() . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; $self->set_receive($p_state,$p_setby); } else { - &::print_log("[Insteon_Device] " . $self->get_object_name() + &::print_log("[Insteon::MotionSensor] " . $self->get_object_name() . "::set_receive($p_state, $p_setby) deferred due to repeat within 1 second") if $main::Debug{insteon}; } @@ -45,4 +45,4 @@ sub is_responder return 0; } -1 \ No newline at end of file +1 From 6bd16e9dba625cca89413b0334c4ff9e21bff12b Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 26 Jul 2010 13:38:49 +0000 Subject: [PATCH 006/150] Remove old references to Insteon_Device. --- lib/Insteon.pm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index cad6c9247..247f5fd69 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -26,7 +26,7 @@ sub _get_next_linkscan } if (!(scalar(@_scan_devices))) { push @_scan_devices, &Insteon::active_interface; - push @_scan_devices, &Insteon::find_members("Insteon::Insteon_Device"); + push @_scan_devices, &Insteon::find_members("Insteon::BaseDevice"); $_scan_cnt = 0; } @@ -327,7 +327,6 @@ sub get_object my $insteon_manager = InsteonManager->instance(); my @search_objects = (); - push @search_objects, $insteon_manager->find_members('Insteon::Insteon_Device'); push @search_objects, $insteon_manager->find_members('Insteon::BaseObject'); for my $obj (@search_objects) { From 02ad3a1139236bd5c7853c2f0e6505bf74612e2a Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 26 Jul 2010 13:45:56 +0000 Subject: [PATCH 007/150] Found more Insteon_Device references that required changing. --- lib/Insteon.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 247f5fd69..e21fcfb1a 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -4,7 +4,7 @@ use strict; # Category=Insteon -#@ This module creates voice commands for all Insteon_Device, Insteon_Link and Insteon_PLM items. +#@ This module creates voice commands for all insteon related items. my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_scan_failure_cnt,$_sync_cnt,$_sync_failure_cnt); my $init_complete; @@ -58,7 +58,7 @@ sub _get_next_linkscan } # don't try to scan devices that are not responders # my $next_obj = &main::get_object_by_name($next_name); - while (ref $next_obj and $next_obj->isa('Insteon::Insteon_Device') + while (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { &main::print_log("[Scan all link tables] " . $next_obj->get_object_name . " is not a candidate for scanning. Moving to next"); $next_obj = shift @_scan_devices; @@ -139,7 +139,7 @@ sub _process_sync_links } # don't try to scan devices that are not responders my $next_obj = &main::get_object_by_name($next_name); - if (ref $next_obj and $next_obj->isa('Insteon::Insteon_Device') + if (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { &main::print_log("[Sync all links] $next_name is not a candidate for syncing. Moving to next"); $current_name = $next_name; From be5026bc85fec204bbf4e83ad00fa70def31293d Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 26 Jul 2010 13:49:25 +0000 Subject: [PATCH 008/150] Fix bug referencing active_interface when it should have been _active_interface. --- lib/Insteon.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index e21fcfb1a..dfce33253 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -358,7 +358,7 @@ sub active_interface my ($interface) = @_; my $insteon_manager = InsteonManager->instance(); - $insteon_manager->active_interface($interface) if $interface; + $insteon_manager->_active_interface($interface) if $interface; #print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; return $insteon_manager->_active_interface; From 03a3bdb1475cf3f367b4d10be802d7d1166a9205 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 26 Jul 2010 15:23:44 +0000 Subject: [PATCH 009/150] Extend delay from 2 to 3 seconds for all_link messages. --- lib/Insteon/Message.pm | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index ae8a76f21..35dfa255c 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -230,7 +230,8 @@ sub send_timeout my ($self, $ignore) = @_; if ($self->command_type eq 'all_link_send') { - return 2000; + # note, the following was set to 2000 and that was insufficient + return 3000; } elsif ($self->command_type eq 'insteon_ext_send') { @@ -242,7 +243,11 @@ sub send_timeout { return 2690; } - elsif ($self->send_attempts >= 3) + elsif ($self->send_attempts = 3) + { + return 3000; + } + elsif ($self->send_attempts >= 4) { return 3170; } @@ -251,13 +256,17 @@ sub send_timeout { if ($self->send_attempts == 1) { - return 1700; + return 1400; } elsif ($self->send_attempts == 2) + { + return 1700; + } + elsif ($self->send_attempts = 3) { return 1900; } - elsif ($self->send_attempts >= 3) + elsif ($self->send_attempts >= 4) { return 2000; } @@ -551,12 +560,12 @@ sub generate_commands my $uc = lc(substr($p_setby->{x10_id},2,1)); if ($hc eq undef) { - &main::print_log("[Insteon_PLM] Object:$p_setby Doesnt have an x10 id (yet)"); + &main::print_log("[Insteon::Message] Object:$p_setby Doesnt have an x10 id (yet)"); return undef; } if ($uc eq undef) { - &main::print_log("[Insteon_PLM] Message is for entire HC") if $main::Debug{insteon}; + &main::print_log("[Insteon::Message] Message is for entire HC") if $main::Debug{insteon}; } else { From 264ea2d903a48169b9f4358ec4da52097a426b9c Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Mon, 26 Jul 2010 17:34:54 +0000 Subject: [PATCH 010/150] Fixed double typo in send_timeout = -> == --- lib/Insteon/Message.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 35dfa255c..6d7ed666c 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -243,7 +243,7 @@ sub send_timeout { return 2690; } - elsif ($self->send_attempts = 3) + elsif ($self->send_attempts == 3) { return 3000; } @@ -262,7 +262,7 @@ sub send_timeout { return 1700; } - elsif ($self->send_attempts = 3) + elsif ($self->send_attempts == 3) { return 1900; } From f2f337d027b6ac0495884e43a21097ae6f87d6fc Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Mon, 26 Jul 2010 17:41:52 +0000 Subject: [PATCH 011/150] insteon config file converter. --- lib/Insteon/convert_insteon_config | 40 ++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100755 lib/Insteon/convert_insteon_config diff --git a/lib/Insteon/convert_insteon_config b/lib/Insteon/convert_insteon_config new file mode 100755 index 000000000..16d40153d --- /dev/null +++ b/lib/Insteon/convert_insteon_config @@ -0,0 +1,40 @@ +#!/usr/bin/perl -w + +use strict; + +# Simple insteon.mht syntax converter by Marc MERLIN +# This is not even close to being foolproof but it may just work for you, or +# you can tweak the regexes a bit to make it work for you. +# If it breaks, you get to keep both pieces :) + +# Run: +# convert_insteon_config < old_items.mht > new_items.mht +# If you are upgrading from the old insteon code, you will also need +# to delete data/mh_temp.saved_states and mh_temp.saved_states.unused + +while (<>) +{ + # these work for all, but don't know what insteon device to set + s#IPLL,\s*PLM:(\d+),\s*#INSTEON_ICONTROLLER, $1, #i; + s#IPLL,#INSTEON_SWITCHLINC|SWITCHLINCRELAY|KEYPADLINC|REMOTELINC,#i; + s#IPLD,#INSTEON_LAMPLINC|APPLIANCELINC|MOTIONSENSOR,#i; + + # those are local hacks to do the right replaces with my config file + s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*switchlin. dimmer)#INSTEON_SWITCHLINC$1#i; + s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*switchlin. relay)#INSTEON_SWITCHLINCRELAY$1#i; + s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*_kpl)#INSTEON_KEYPADLINC$1#i; + s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*rlink)#INSTEON_REMOTELINC$1#i; + + s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*lamplin)#INSTEON_LAMPLINC$1#i; + s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*appliance lin)#INSTEON_APPLIANCELINC$1#i; + s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*_mos\d+)#INSTEON_MOTIONSENSOR$1#i; + + # obviously, the idea is that if you have any of those INSTEON_A|B|C left over + # after the regexes above, you need to fix them yourself or add more regexes. + + s#,\s*plm,?(?:\d+)?##i; + # restore 'plm' on the one line we need it on. + s/INSTEON_PLM/INSTEON_PLM, PLM/; + + print; +} From 91851423dda15573508a9070327dd00d69deda4b Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Wed, 4 Aug 2010 06:40:25 +0000 Subject: [PATCH 012/150] - new show_all_errors variable so that you get to see the full error each time it happens (by default mh only shows you the error in details the first time, for _any_ module and then that's it). - show how many times an error was triggered - add a module_allowed_errors variable to allow each module to set how many times they can error out before they get kicked out of the main loop (default was and still is 10, but not it's actually clear what's going on). For instance, I have: omnistat_allowed_errors = 999999999999 hvac_allowed_errors = 999999999999 --- bin/mh | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/bin/mh b/bin/mh index 03d68aeeb..6bf3d516e 100755 --- a/bin/mh +++ b/bin/mh @@ -121,7 +121,7 @@ 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 (@Loop_Code, @Sub_Code, %Sub_Code, %Run_Members, %Run_Members_Error_Count, %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); @@ -2866,12 +2866,12 @@ sub eval_user_code_loop { 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: $@"; + if ($usercode_error_flag and not $main::config_parms{"show_all_errors"} eq "yes") { + print "Error in user code shown in short form (set show_all_errors=yes in mh.private.init to get in full form each time):\n$@"; } else { $usercode_error_flag++; - my $error = "Error found in user code file: $config_parms{data_dir}/mh_temp.user_code\n\n"; + my $error = "Error found in user code file: $config_parms{data_dir}/mh_temp.user_code (error_count $usercode_error_flag)\n\n"; $error .= &eval_user_code_error($@, $user_code); print $error; @@ -4964,14 +4964,26 @@ sub store_object_data { sub read_user_code_loopcode { my ($member_name, $code) = @_; my $sub_name = "${member_name}_loopcode"; + my $allowed_errors; + + # Allows to set omnistat_allowed_errors = 1000000 in config file to keep running despite errors + $allowed_errors = $main::config_parms{${member_name}."_allowed_errors"}; + if (not defined $allowed_errors) { + $allowed_errors = 10; + } else { + print_log "$member_name has $allowed_errors allowed errors before being disabled"; + } $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" . + " if (\$Run_Members{'$member_name'} > $allowed_errors) { # 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" . + " \$Run_Members{'$member_name'} = 0; return;\n }". + " elsif (\$Run_Members{'$member_name'} > 2 and \$Run_Members{'$member_name'} != \$Run_Members_Error_Count{$member_name} ) {\n". + " display(\$Run_Members{'$member_name'}.' eval errors in $member_name out of $allowed_errors allowed before disable') }\n". + " \$Run_Members_Error_Count{$member_name} = \$Run_Members{'$member_name'};\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 . From 4b920ce784d892fd2153e4c36447347ad48efbf6 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 13 Aug 2010 13:24:21 +0000 Subject: [PATCH 013/150] Fix various bugs. --- lib/Insteon.pm | 16 +++++------ lib/Insteon/AllLinkDatabase.pm | 36 +++++++++++++++-------- lib/Insteon/BaseInsteon.pm | 52 +++++++++++++++++++++++++++++++--- lib/Insteon_PLM.pm | 5 ++-- 4 files changed, 83 insertions(+), 26 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index dfce33253..a73c8bf5f 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -54,7 +54,7 @@ sub _get_next_linkscan # remove the queue_timer_callback # my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { - $current_obj->queue_timer_callback(''); +# $current_obj->queue_timer_callback(''); } # don't try to scan devices that are not responders # my $next_obj = &main::get_object_by_name($next_name); @@ -79,7 +79,7 @@ sub _get_next_linkscan # remove the queue_timer_callback # my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { - $current_obj->queue_timer_callback(''); +# $current_obj->queue_timer_callback(''); } } # last; @@ -96,7 +96,7 @@ sub _get_next_linkscan # my $obj = &main::get_object_by_name($next_name); if ($next_obj) { &main::print_log("[Scan all link tables] Now scanning: " . $next_obj->get_object_name . " ($_scan_cnt of ?)"); - $next_obj->queue_timer_callback('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\',1)') unless $next_obj->isa('Insteon_PLM'); +# $next_obj->queue_timer_callback('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\',1)') unless $next_obj->isa('Insteon_PLM'); $next_obj->scan_link_table('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\')'); } } else { @@ -135,7 +135,7 @@ sub _process_sync_links # remove the queue_timer_callback my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { - $current_obj->queue_timer_callback(''); +# $current_obj->queue_timer_callback(''); } # don't try to scan devices that are not responders my $next_obj = &main::get_object_by_name($next_name); @@ -160,7 +160,7 @@ sub _process_sync_links # remove the queue_timer_callback my $current_obj = &main::get_object_by_name($current_name); if (!($current_obj->isa('Insteon_PLM'))) { - $current_obj->queue_timer_callback(''); +# $current_obj->queue_timer_callback(''); } } } @@ -174,8 +174,8 @@ sub _process_sync_links my $obj = &main::get_object_by_name($next_name); if ($obj) { &main::print_log("[Sync all links] Now syncing links: " . $obj->get_object_name . " ($_sync_cnt of $dev_cnt)"); - $obj->queue_timer_callback('&main::_process_sync_links(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); - $obj->sync_links('&main::_process_sync_links(\'' . $next_name . '\')'); +# $obj->queue_timer_callback('&main::_process_sync_links(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); + $obj->sync_links('&Insteon::_process_sync_links(\'' . $next_name . '\')'); } } else { $_sync_cnt = 0; @@ -359,7 +359,7 @@ sub active_interface my $insteon_manager = InsteonManager->instance(); $insteon_manager->_active_interface($interface) if $interface; -#print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; +print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; return $insteon_manager->_active_interface; } diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index e2c5100da..a08cab912 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -879,7 +879,7 @@ sub log_alllink_table $on_level = 'on'; } } else { - $ramp_rate = &Insteon::LampLinc::get_ramp_from_code($$self{aldb}{$aldbkey}{data2}) . "s"; + $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($$self{aldb}{$aldbkey}{data2}) . "s"; } } @@ -1082,9 +1082,20 @@ sub log_alllink_table my $data3 = $$self{aldb}{$linkkey}{data3}; my $is_controller = $$self{aldb}{$linkkey}{is_controller}; my $group = ($is_controller) ? $data3 : $$self{aldb}{$linkkey}{group}; - $group = '01' if $group == '00'; - my $device = &Insteon::get_object($$self{aldb}{$linkkey}{deviceid},$group); - my $object_name = ($device) ? $device->get_object_name : $$self{aldb}{$linkkey}{deviceid}; + $group = '01' if $group eq '00'; + my $deviceid = $$self{aldb}{$linkkey}{deviceid}; + my $device = &Insteon::get_object($deviceid,$group); + my $object_name = ''; + if ($device) + { + $object_name = $device->get_object_name; + } + else + { + $object_name = uc substr($deviceid,0,2) . '.' . + uc substr($deviceid,2,2) . '.' . + uc substr($deviceid,4,2); + } &::print_log("[Insteon::ALDB_PLM] " . (($is_controller) ? "cntlr($$self{aldb}{$linkkey}{group}) record to " . $object_name @@ -1098,16 +1109,17 @@ sub log_alllink_table sub parse_alllink { my ($self, $data) = @_; - if (substr($data,4,6)) { +# &::print_log("[DEBUG] $data"); + if (substr($data,0,6)) { my %link = (); - my $flag = substr($data,4,1); + my $flag = substr($data,0,1); $link{is_controller} = (hex($flag) & 0x04) ? 1 : 0; - $link{flags} = substr($data,4,2); - $link{group} = lc substr($data,6,2); - $link{deviceid} = lc substr($data,8,6); - $link{data1} = substr($data,14,2); - $link{data2} = substr($data,16,2); - $link{data3} = substr($data,18,2); + $link{flags} = substr($data,0,2); + $link{group} = lc substr($data,2,2); + $link{deviceid} = lc substr($data,4,6); + $link{data1} = substr($data,10,2); + $link{data2} = substr($data,12,2); + $link{data3} = substr($data,14,2); my $key = $link{deviceid} . $link{group} . $link{is_controller}; %{$$self{aldb}{lc $key}} = %link; } diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 58822212c..80e93530d 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -150,7 +150,8 @@ sub set if (($p_state eq 'dim' or $p_state eq 'bright') and !($self->isa('Insteon::DimmableLight'))) { $p_state = 'on'; } - + my $setby_name = $p_setby; + $setby_name = $p_setby->get_object_name() if (ref $p_setby and $p_setby->can('get_object_name')); if (ref $p_setby and (($p_setby eq $self->interface()) or (($p_setby->isa('Insteon::BaseObject')) and (($p_setby eq $self) @@ -160,7 +161,7 @@ sub set return if (lc $p_state eq lc $self->state) and $self->is_acknowledged and not(($p_setby->isa('Insteon::BaseObject') and ($p_setby eq $self))); &::print_log("[Insteon::BaseObject] " . $self->get_object_name() - . "::set($p_state, $p_setby)") if $main::Debug{insteon}; + . "::set($p_state, $setby_name)") if $main::Debug{insteon}; $self->set_receive($p_state,$p_setby,$p_response) if defined $p_state; } else { my $message = $self->derive_message($p_state); @@ -168,7 +169,7 @@ sub set # $self->_send_cmd(command => $p_state, # type => (($self->isa('Insteon::Insteon_Link') and !($self->is_root)) ? 'alllink' : 'standard')); - &::print_log("[Insteon::BaseObject] " . $self->get_object_name() . "::set($p_state, $p_setby)") + &::print_log("[Insteon::BaseObject] " . $self->get_object_name() . "::set($p_state, $setby_name)") if $main::Debug{insteon}; $self->is_acknowledged(0); $$self{pending_state} = $p_state; @@ -794,6 +795,49 @@ sub get_root { } } +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + return $aldb->has_link($insteon_object, $group, $is_controller, $subaddress); + } + else + { + return 0; + } + +} + +sub add_link +{ + my ($self, $parms_text) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + $aldb->add_link(%link_parms); + } + +} + +sub scan_link_table +{ + my ($self, $callback) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + return $aldb->scan_link_table($callback); + } + +} ### WARN: Testing using the following does not produce results as expected. Use at your own risk. [GL] sub remote_set_button_tap @@ -1336,7 +1380,7 @@ sub request_status my $member_obj = $$self{members}{$member}{object}; next if $requestor eq $member_obj; if ($member_obj->isa('Insteon::BaseDevice')) { - &::print_log("[Insteon::DeviceController] checking status of " . $member_obj->get_object_name() + &::print_log("[Insteon::DeviceController] checking status of " . $member_obj->get_object_name() . " for requestor " . $requestor->get_object_name()); $member_obj->request_status($self); } diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 4338fa86e..579b77a6d 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -196,7 +196,6 @@ sub check_for_data { $self->_clear_timeout('xmit'); if (!($$self{xmit_in_progress})) { - print "################ xmit timer\n"; $self->process_queue(); } } @@ -238,7 +237,9 @@ sub log_alllink_table sub scan_link_table { my ($self,$callback) = @_; - $$self{links} = undef; # clear out the old + #$$self{links} = undef; # clear out the old + $$self{adlb} = undef; + $$self{aldb} = new Insteon::ALDB_PLM($self); $$self{_mem_activity} = 'scan'; $$self{_mem_callback} = ($callback) ? $callback : undef; $self->_aldb->get_first_alllink(); From 977d5c2842dac23822b7b2a4cf35cc7b2681d42a Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 5 Jan 2011 17:29:10 +0000 Subject: [PATCH 014/150] Provide proper diagnostic feedback to missing SCENE_MEMBER entries --- lib/read_table_A.pl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/read_table_A.pl b/lib/read_table_A.pl index 1192e30e0..94df3c642 100644 --- a/lib/read_table_A.pl +++ b/lib/read_table_A.pl @@ -946,7 +946,8 @@ sub read_table_A { $code .= sprintf "\$%-35s -> add(\$%s);\n", $scene_name, $name; } } else { - print "\nThere is no object called $scene_name defined. Ignoring SCENE_MEMBER entry.\n"; + print "\nThere is no object called $scene_name defined. Ignoring SCENE_MEMBER entry.\n" unless $objects{$scene_name}; + print "\nThere is no object called $name defined. Ignoring SCENE_MEMBER entry.\n" unless $objects{$name}; } $object = ''; } else { From 5a42f7731c9e588c210f127bfb650e45f9a1a6de Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 5 Jan 2011 17:29:57 +0000 Subject: [PATCH 015/150] Various bug fixes. --- lib/Insteon.pm | 1 - lib/Insteon/AllLinkDatabase.pm | 29 +- lib/Insteon/BaseInsteon.pm | 19 + lib/Light_Item.pm | 2 +- lib/Light_Switch_Item.pm | 4 +- lib/xPL_Items.pm | 2392 ++++++++++++++++---------------- 6 files changed, 1249 insertions(+), 1198 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index a73c8bf5f..45bbba62a 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -359,7 +359,6 @@ sub active_interface my $insteon_manager = InsteonManager->instance(); $insteon_manager->_active_interface($interface) if $interface; -print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; return $insteon_manager->_active_interface; } diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index a08cab912..46ce13fdf 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -929,7 +929,12 @@ sub get_link_record sub has_link { my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = lc $insteon_object->device_id . $group . $is_controller; + my $key = ""; + if ($insteon_object->isa('Insteon::BaseObject')) { + lc $insteon_object->device_id . $group . $is_controller; + } else { + lc $$insteon_object{device}->device_id . $group . $is_controller; + } $subaddress = '00' unless $subaddress; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists if ($subaddress ne '00' and $subaddress ne '01') { @@ -1209,7 +1214,7 @@ sub delete_orphan_links my %delete_req = (object => $device, group => $group, is_controller => 1, callback => "$selfname->_process_delete_queue(1)", linkdevice => $self, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; +# push @{$$self{delete_queue}}, \%delete_req; } } } @@ -1218,14 +1223,14 @@ sub delete_orphan_links $$self{delete_queue_processed} = 0; # reset the counter # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links - for my $obj ($self->find_members('Insteon::BaseObject')) + for my $obj (&Insteon::find_members('Insteon::BaseObject')) { #Match on real objects only if (($obj->is_root)) { - $num_deleted += $obj->delete_orphan_links(); - my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); - push @{$$self{delete_queue}}, \%delete_req; +# $num_deleted += $obj->delete_orphan_links(); +# my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); +# push @{$$self{delete_queue}}, \%delete_req; } } $self->_process_delete_queue(); @@ -1366,6 +1371,18 @@ sub add_link } } +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $key = lc $insteon_object->device_id . $group . $is_controller; + $subaddress = '00' unless $subaddress; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + return (defined $$self{aldb}{$key}) ? 1 : 0; +} + diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 80e93530d..bd217e2b7 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -1343,6 +1343,25 @@ sub derive_message } } +sub find_members +{ + my ($self,$p_type) = @_; + + my @l_found; + if ($$self{members}) + { + foreach my $member_ref (keys %{$$self{members}}) + { + my $member = $$self{members}{$member_ref}{object}; + if ($member->isa($p_type)) + { + push @l_found, $member; + } + } + } + return @l_found; + +} #################################### ### ##################### diff --git a/lib/Light_Item.pm b/lib/Light_Item.pm index 84088df1e..6ecba1d67 100644 --- a/lib/Light_Item.pm +++ b/lib/Light_Item.pm @@ -541,7 +541,7 @@ sub is_on_restriction } if ( defined($p_setby) ) { #Automatic on events are no allowed to shutoff lights if someone is here - if ( $p_setby->isa('Light_Restriction') ) { + if ( $p_setby->isa('Light_Restriction_Item') ) { if ( ! ($self->is_somebody_present($p_setby, $p_state) ) ) { #If someone is in the room, allow the light on! $l_qualified=1; } diff --git a/lib/Light_Switch_Item.pm b/lib/Light_Switch_Item.pm index 9be56b033..4c9daef41 100644 --- a/lib/Light_Switch_Item.pm +++ b/lib/Light_Switch_Item.pm @@ -158,13 +158,13 @@ sub set { if ($p_setby and $$self{m_setby}) { foreach (@{$$self{m_setby}}) { - if ($p_setby->get_set_by() eq $_) { + if (($p_setby->get_set_by() eq $_) or ($p_setby->get_set_by() and $p_setby eq $p_setby->get_set_by())) { &::print_log("Light_Switch_Item($$self{object_name}): setting state to 'pressed'") if $main::Debug{occupancy}; $self->SUPER::set('pressed', $p_setby); last; } } - } + } } 1; diff --git a/lib/xPL_Items.pm b/lib/xPL_Items.pm index 4634079ee..b29d764db 100644 --- a/lib/xPL_Items.pm +++ b/lib/xPL_Items.pm @@ -1,1188 +1,1204 @@ -=begin comment - -xPL_Items.pm - Misterhouse interface for the xPL protocol - -Info: - - xPL websites: - http://www.xplproject.org.uk - http://www.xaphal.com - -Authors: - 10/26/2002 Created by Bruce Winter bruce@misterhouse.net - - -xPL works by using the xPL Hub built in misterhouse and listening for -xPL connections. See: -http://misterhouse.wikispaces.com/xAP+and+xPL+-+Getting+Started - -Relevant variables for mh.private.ini are: -#ipaddress_xpl_broadcast = 192.168.205.255 -#ipaddress_xpl = 192.168.205.3 -#xpl_disable = 1 -#xpl_nohub = 1 - -You can disable the mh internal xPL hub if you are running a more capable one. -To get data input, you can use something like - -xpl-rfxcom-rx --verbose --rfxcom-rx-verbose --rfxcom-rx-tty /dev/rfxcom --interface eth1 - -from xPL-Perl. Then watch for sensor updates passing by and paste their info -in your device table, like so: -XPL_SENSOR, bnz-rfxcomrx.gargamel:bthr918n.e6, oregon_intemp, XPL_temp, temp - -Another option to figure out the name to use in XPL_SENSOR is to use -xpl-logger -head -body -i ethx 2>&1 | grep "xpl-trig\/" -(or without the grep for more details on which field is called what). - -A few samples: -XPL_SENSOR, iranger-rfx.*:WGR918, oregon_winddir, , direction -XPL_SENSOR, iranger-rfx.*:BHTR968, oregon_intemp, , temp -XPL_SENSOR, bnz-owfs.*:10.2223EF010800, owfs_temp, , temp -XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000, owfs_humidity, , humidity -XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000.1, owfs_humidity1, , humidity -XPL_X10SECURITY, iranger-rfx.*:F8, x10sec_garage1, , ds10 - -Note that XPL_SENSOR should just be used for XPL messages of the x10.basic -type. XPL_X10SECURITY is for x10.security schema, while there is no way to currently -read x10.basic messages (see this file for more supported schemas). - -Once it is running, objects get variables including these (gathered with Data::Dumper) -'state' => '17.9', -'states_nosubstate' => 1, -'states_substate' ? -'address' => 'bnz-rfxcomrx.gargamel', -'states_nomultistate' => 1, -'states_multistate' ? -'target_address' => '*', -'_device_id' => 'bthr918n.e6' - -So, you would write this to print temperature: -print_log $oregon_intemp->state -=cut - -use strict; - -package xPL; - -@xPL::ISA = ('Generic_Item'); - -#se IO::Socket::INET; # Gives us the INADDR constants, but not in perl 5.0 :( - -my (@xpl_item_names, $started, %hub_ports, $xpl_listen, $xpl_hub_listen, $xpl_send, %xpl_hub_ports, $xpl_hbeat_interval, $xpl_hbeat_counter); -use vars '$xpl_data'; - - # Create sockets and add hook to check incoming data -sub startup { - return if $started++; # Allows us to call with $Reload or with xpl_module mh.ini parm - - # In case you don't want xpl for some reason - return if $::config_parms{xpl_disable}; - -# determine our local ipaddress(es) -my @ipaddresses = &::get_ip_address; - @xpl_item_names = (); - my ($port); - - # init the hbeat intervals and counters - $xpl_hbeat_interval = $::config_parms{xpl_hbeat_interval}; - $xpl_hbeat_interval = 5 unless $xpl_hbeat_interval; - $xpl_hbeat_counter = $xpl_hbeat_interval; - - if (!($::config_parms{xpl_disable})) { - undef $port; - $port = $::config_parms{xpl_port}; - $port = 3865 unless $port; - - # open the sending port - &open_port($port, 'send', 'xpl_send', 0, 1); - $xpl_send = new Socket_Item(undef, undef, 'xpl_send'); - # and send the heartbeat - - # Find and use the first open port - my $port_listen; - for my $p (49152 .. 65535) { - $port_listen = $p; - last if &open_port($port_listen, 'listen', 'xpl_listen', 1, 1); - } - $xpl_listen = new Socket_Item(undef, undef, 'xpl_listen'); - - # initialize the hub (listen) port - if ($::config_parms{xpl_nohub}) { - $xpl_hub_listen = undef; - } else { - if (&open_port($port, 'listen', 'xpl_hub_listen', 0, 1)) { - $xpl_hub_listen = new Socket_Item(undef, undef, 'xpl_hub_listen'); - print " - mh in xPL Hub mode\n"; - # now set up the hub port that will send to mh - $xpl_hub_ports{$port_listen} = &xPL::get_xpl_mh_source_info(); - my $port_name = "xpl_send_$port_listen"; - &open_port($port_listen, 'send', $port_name, 1, 1); - } else { - print " - mh automatically switching out of xPL Hub mode. Another application is binding to the hub port ($port)\n"; - } - } - - # now that a listen port exists, advertise it w/ the first hbeat msg - &xPL::send_xpl_heartbeat() if $xpl_send; - - } - - &::MainLoop_pre_add_hook(\&xPL::check_for_data, 1 ); - # add reload hook so that xpl_item_names list is reset - &::Reload_pre_add_hook(\&xPL::reload_hook,1); -} - -sub reload_hook { - @xpl_item_names = (); -} - -sub main::display_xpl -{ - my (%args) = @_; - my $schema = lc ${args}{schema}; - $schema = 'osd.basic' unless $schema; - if ($schema eq 'osd.basic') { - &main::display_xpl_osd_basic(%args); - } else { - &main::print_log("Display support for the schema, $schema, does not yet exist"); - } -} - -sub main::display_xpl_osd_basic -{ - my (%args) = @_; - my ($text, $duration, $address); - $text = $args{raw_text}; - $text = $args{text} unless $text; - $text =~ s/[\n\r ]+/ /gm; # strip out new lines and extra space - $text =~ s/\n/\\n/gm; # escape new lines - $duration = $args{duration}; - $duration = $args{display} unless $duration; # this apparently is the original param? - $duration = 10 unless $duration; # default to 10 sec display - $address = $args{to}; - $address = $args{address} unless $address; - $address = '*' unless $address; - # auto pre-pend text w/ a newline if it target a squeezebox and doesn't already have one - if ($address =~ /^slimdev-slimserv/i) { - $text = "\\n$text" unless $text =~ /\\n\S+/i; - } - &xPL::send('xPL', $address, 'osd.basic' => { command => 'write', delay => $duration, text => $text }); -} - -sub open_port { - my ($port, $send_listen, $port_name, $local, $verbose) = @_; - -# Need to re-open the port, if client app has been re-started?? - close $::Socket_Ports{$port_name}{sock} if $::Socket_Ports{$port_name}{sock}; -# return 0 if $::Socket_Ports{$port_name}{sock}; # Already open - - my $sock; - if ($send_listen eq 'send') { - my $dest_address; - if ($local) { -# $dest_address = $::config_parms{'ipaddress_xpl'}; -# $dest_address = $::config_parms{'xpl_address'} unless $dest_address; - if ($main::OS_win) { - $dest_address = $::Info{IPAddress_local} unless $dest_address; - } else { - $dest_address = '0.0.0.0'; - } - } else { -# $dest_address = inet_ntoa(INADDR_BROADCAST); - $dest_address = $::config_parms{'ipaddress_xpl_broadcast'}; - $dest_address = '255.255.255.255' unless $dest_address; - } - $sock = new IO::Socket::INET->new(PeerPort => $port, Proto => 'udp', - PeerAddr => $dest_address, Broadcast => 1); - print "db xPL_Items open_port: p=$port pn=$port_name l=$local a=$dest_address\n" if $sock and $main::Debug{xpl}; - - } - else { - my $listen_address; - if (!($local)) { - $listen_address = $::config_parms{'ipaddress_xpl'}; - $listen_address = $::config_parms{'xpl_address'} unless $listen_address; - } - if ($main::OS_win) { - $listen_address = $::Info{IPAddress_local} unless $listen_address; - } else { - # can't get *nix to bind to a specific address; defaults to kernel assigned default IP - $listen_address = '0.0.0.0'; - } - $sock = new IO::Socket::INET->new(LocalPort => $port, Proto => 'udp', - LocalAddr => $listen_address, Broadcast => 1); -# LocalAddr => '0.0.0.0', Broadcast => 1); -# LocalAddr => inet_ntoa(INADDR_ANY), Broadcast => 1); - print "db xPL_Items open_port: p=$port pn=$port_name l=$local a=$listen_address\n" if $sock and $main::Debug{xpl}; - - } - unless ($sock) { - print "\nError: Could not start a udp xPL send server on $port: $@\n\n" if $send_listen eq 'send'; - return 0; - } - - printf " - creating %-15s on %3s %5s %s\n", $port_name, 'udp', $port, $send_listen if $verbose; - - $::Socket_Ports{$port_name}{protocol} = 'udp'; - $::Socket_Ports{$port_name}{datatype} = 'raw'; - $::Socket_Ports{$port_name}{port} = $port; - $::Socket_Ports{$port_name}{sock} = $sock; - $::Socket_Ports{$port_name}{socka} = $sock; # UDP ports are always "active" - - return $sock; -} - - -sub check_for_data { - - if ($xpl_hub_listen && (my $xpl_hub_data = said $xpl_hub_listen)) { - &_process_incoming_xpl_hub_data($xpl_hub_data); - } - if ($xpl_listen && (my $xpl_data = said $xpl_listen)) { - &_process_incoming_xpl_data($xpl_data); - } - - # check to see if hbeats need to be sent - if (&::new_minute($xpl_hbeat_interval)) { - if ($xpl_send) { - if ($xpl_hbeat_counter == 5) { - &xPL::send_xpl_heartbeat(); - $xpl_hbeat_counter = $xpl_hbeat_interval; - } else { - $xpl_hbeat_counter = $xpl_hbeat_counter - 1; - } - } - } -} - - # Parse incoming xPL records -sub parse_data { - my ($data) = @_; - my ($data_type, %d); - print "db4 xPL data:\n$data\n" if $main::Debug{xpl} and $main::Debug{xpl} == 4; - for my $r (split /[\r\n]/, $data) { - next if $r =~ /^[\{\} ]*$/; - # Store xpl-header, xpl-heartbeat, and other data - if (my ($key, $value) = $r =~ /(.+?)=(.*)/) { - $key = lc $key; - $value = lc $value if ($data_type =~ /^xpl/); # Do not lc real data; - if (exists($d{$data_type}{$key})) { - $d{$data_type}{$key} .= "," . $value; # xpl allows "continuation lines" by having more than one tag possible - } else { - $d{$data_type}{$key} = $value; - } - print "db4 xpl parsed c=$data_type k=$key v=$value\n" if ($main::Debug{xpl} and $main::Debug{xpl} == 4); - } - # data_type (e.g. xpl-header, xpl-heartbeat, source.instance - else { - $data_type = lc $r; - } - } - return \%d; -} - -sub _process_incoming_xpl_hub_data { - my ($data) = @_; - my $ip_address = $::config_parms{'ipaddress_xpl'}; - $ip_address = $::Info{IPAddress_local} unless $ip_address; - - - undef $xpl_data; - $xpl_data = &parse_data($data); - - my ($source, $class, $target, $msg_type); - if (defined $$xpl_data{'xpl-stat'}) { - $msg_type = 'stat'; - $source = $$xpl_data{'xpl-stat'}{source}; - $target = $$xpl_data{'xpl-stat'}{target}; - } elsif ($$xpl_data{'xpl-cmnd'}) { - $msg_type = 'cmnd'; - $source = $$xpl_data{'xpl-cmnd'}{source}; - $target = $$xpl_data{'xpl-cmnd'}{target}; - } else { - $msg_type = 'trig'; - $source = $$xpl_data{'xpl-trig'}{source}; - $target = $$xpl_data{'xpl-trig'}{target}; - } - -# print "db1 xpl hub check: s=$source c=$class t=$target d=$data\n" if $main::Debug{xpl} and $main::Debug{xpl} == 1; - - return unless $source; - - my ($port); - # As a hub, echo data to other xpl listeners unless it's our own transmission - for $port (keys %xpl_hub_ports) { - # don't echo back the sender's own data - if ($xpl_hub_ports{$port} ne $source) { - my $sock = $::Socket_Ports{"xpl_send_$port"}{sock}; - print "db2 xpl hub: sending xpl data to p=$port destination=$xpl_hub_ports{$port} s=$sock d=\n$data.\n" if $main::Debug{xpl} and $main::Debug{xpl} == 2; - print $sock $data if defined($sock); - } - } - - # Log hearbeats of other apps; ignore hbeat.basic messages as these should not be handled by the hub - if ($$xpl_data{'hbeat.app'}) { - # rely on the xPL-message's remote-ip attribute in the hbeat.app as the basis for performing IP comparisons -# my $sender_iaddr = $::Socket_Ports{'xpl_listen'}{from_ip}; -# my $sender_ip_address = Socket::inet_ntoa($sender_iaddr) if $sender_iaddr; - my $sender_ip_address = $$xpl_data{'hbeat.app'}{'remote-ip'}; - # Open/re-open the port on every hbeat if it posts a listening port. - # Skip if it is our own hbeat (port = listen port) - if (($sender_ip_address eq $ip_address)) { - $port = $$xpl_data{'hbeat.app'}{port}; - if ($port) { - $xpl_hub_ports{$port} = $source; - my $port_name = "xpl_send_$port"; - my $msg = ($::Socket_Ports{$port_name}{sock}) ? 'renewing' : 'registering'; - print "db xpl $msg port=$port to xPL client $source" if $main::Debug{xpl}; - # xPL apps want local - &open_port($port, 'send', $port_name, 1, $msg eq 'registering'); - } - } - } - -} - -sub _process_incoming_xpl_data { - my ($data) = @_; - - undef $xpl_data; - $xpl_data = &parse_data($data); - - my ($source, $class, $target, $msg_type); - if (defined $$xpl_data{'xpl-stat'}) { - $msg_type = 'stat'; - $source = $$xpl_data{'xpl-stat'}{source}; - $target = $$xpl_data{'xpl-stat'}{target}; - } elsif ($$xpl_data{'xpl-cmnd'}) { - $msg_type = 'cmnd'; - $source = $$xpl_data{'xpl-cmnd'}{source}; - $target = $$xpl_data{'xpl-cmnd'}{target}; - } else { - $msg_type = 'trig'; - $source = $$xpl_data{'xpl-trig'}{source}; - $target = $$xpl_data{'xpl-trig'}{target}; - } - - print "db1 xpl check: s=$source c=$class t=$target d=$data\n" if $main::Debug{xpl} and $main::Debug{xpl} == 1; - - # the first time that this sub is called, the xpl_item_names array needs to be filled - if (!(@xpl_item_names)) { - foreach my $object_type (&::list_object_types) { - foreach my $object_name (&::list_objects_by_type($object_type)) { - my $object = &::get_object_by_name("$object_name"); - if ($object and $object->isa('xPL_Item')) { - push @xpl_item_names, $object_name; - } - } - } - } - - return unless $source; - # define target as '*' if undefined - $target = '*' if !($target); - - # continue processing unless we are the source (e.g., heart-beat) - if (!($source eq &xPL::get_xpl_mh_source_info())) { - # Set states in matching xPL objects - for my $name (@xpl_item_names) { #(&::list_objects_by_type('xPL_Item')) { - my $o = &main::get_object_by_name($name); - $o = $name unless $o; # In case we stored object directly - print "db3 xpl test o=$name s=$source oa=$$o{source}\n" if $main::Debug{xpl} and $main::Debug{xpl} == 3; - - # skip this object unless the source matches if a stat or trig - # otherwise, we check the target for a cmnd - # NOTE: the object's hash reference for "source" is "address" - my $regex_address = &wildcard_2_regex($$o{address}); - if ($$o{set_state_on_cmnd} and $msg_type eq 'cmnd') { - my $regex_target = &wildcard_2_regex($target); - next unless ($target =~ /^$regex_address$/i) or ($$o{address} =~ /^$regex_target$/i); - } else { - if ( $source =~ /^$regex_address$/i) { - # handle hbeat data - for my $section (keys %{$xpl_data}) { - if ($section =~ /^hbeat./i) { - if (lc $section eq 'hbeat.app') { - $o->_handle_alive_app(); - } else { - $o->_handle_dead_app(); - } - } - } - } else { - next; - } - } - - my $className; - # look at each section name; any that don't match the header titles is the classname - # since is there is only one "block" in an xPL message and its label is the classname - for my $section (keys %{$xpl_data}) { - if ($section) { - $className = $section unless ($section eq 'xpl-stat' || $section eq 'xpl-cmnd' || $section eq 'xpl-trig'); - } - } - # skip this object unless the classname matches - if ($className && $$o{class}) { - my $regex_class = &wildcard_2_regex($$o{class}); - next unless $className =~ /^$regex_class$/i; - } - - # check if device monitoring is enabled - if (!($className =~ /hbeat./i)) { - next if $o->ignore_message($xpl_data); - } - - # Find and set the state variable - my $state_value; - $$o{changed} = ''; - for my $section (keys %{$xpl_data}) { - $$o{sections}{$section} = 'received' unless $$o{sections}{$section}; - for my $key (keys %{$$xpl_data{$section}}) { - my $value = $$xpl_data{$section}{$key}; - # does a tied value convertor exist for this key and object? - my $value_convertor = $$o{_value_convertors}{$key} if defined($$o{_value_convertors}); - if ($value_convertor) { - print "db xpl: located value convertor: $value_convertor\n" if $main::Debug{xpl}; - my $converted_value = eval $value_convertor; - if ($@) { - print$@; - } else { - print "db xpl: converted value is: $converted_value\n" if $main::Debug{xpl}; - } - $value = $converted_value if $converted_value; - } - $$o{$section}{$key} = $value; - # Monitor what changed (real data, and include hbeat as it may include useful info, e.g., slimserver). - $$o{changed} .= "$section : $key = $value | " - unless $section eq 'xpl-stat' or $section eq 'xpl-trig' or $section eq 'xpl-cmnd' or ($section eq 'hbeat.app' and $key ne 'status'); - print "db3 xpl state check m=$$o{state_monitor} key=$section : $key value=$value\n" if $main::Debug{xpl};# and $main::Debug{xpl} == 3; - if ($$o{state_monitor}) { - foreach my $state_monitor (split(/\|/, $$o{state_monitor})) { - if ($state_monitor =~ /$section\s*[:=]\s*$key/i and defined $value) { - print "db3 xpl setting state to $value\n" if $main::Debug{xpl} and $main::Debug{xpl} == 3; - $state_value = $value; - } - } - } - } - } - # assign the "summary" of the message to state_value unless state_monitor is being used - $state_value = $$o{changed} unless $$o{state_monitor}; - print "db3 xpl set: n=$name to state=$state_value\n\n" if $main::Debug{xpl};# and $main::Debug{xpl} == 3; -# $$o{state} = $$o{state_now} = $$o{said} == $state_value if defined $state_value; -# Can not use Generic_Item set method, as state_next_path only carries state, not all other $section data, to the next pass -# $o -> SUPER::set($state_value, 'xPL') if defined $state_value; - if (defined $state_value and $state_value ne '') { - my $set_by_name = 'xPL'; - $set_by_name .= " [$source]"; # no longer needed: if ($::config_parms{'xpl_use_to_target'}); - $o -> SUPER::set_now($state_value, $set_by_name); - $o -> state_now_msg_type( "$msg_type" ); - } - } - } - -} - -sub get_mh_vendor_info { - return 'mhouse'; -} - -sub get_mh_device_info { - return 'mh'; -} - -sub get_xpl_mh_source_info { - my $instance = $::config_parms{xpl_title}; - $instance = $::config_parms{title} unless $instance; - $instance = ($instance =~ /misterhouse(.*)pid/i) ? 'misterhouse' : $instance; - $instance = &xPL::get_ok_name_part($instance); - return &get_mh_vendor_info() . '-' . &get_mh_device_info() . '.' . $instance; -} - -sub get_ok_name_part { - my ($in_name) = @_; - my $out_name = lc $in_name; - $out_name =~ tr/ /_/; - $out_name =~ s/[^a-z0-9\-_]//g; - return $out_name; -} - -#sub is_target { -# my ($target, $source) = @_; -# return ( (!($source eq &xPL::get_xpl_mh_source_info())) && -# ( (!($target)) -# || $target eq '*' -# || $target eq (&get_mh_vendor_info() . '.*') -# || $target eq (&get_mh_vendor_info() . '.' &get_mh_device_info() . '.*') -# || $target eq &xAP::get_xpl_mh_source_info() ) ); - -#} - -sub wildcard_2_regex { - my ($expr) = @_; - return unless $expr; - # convert all periods - $expr =~ s/\./(\\\.)/g; - # convert all asterisks - $expr =~ s/\*/(\.\*)/g; - # treat all :> as asterisks - $expr =~ s/:>/(\.\*)/g; - # convert all greater than symbols - $expr =~ s/>/(\.\*)/g; - - return $expr; -} - -sub received_data { - my ($protocol) = @_; - return $xpl_data; -} - -sub send { - my ($protocol, $class_address, @data) = @_; -# print "db5 xPL send: ca=$class_address d=@data xpl_send=$xpl_send\n" if ($main::Debug{xpl} and $main::Debug{xpl} == 5) or ($main::Debug{xpl} and $main::Debug{xpl} == 5); - - my $target = $class_address; - &sendXpl($target, 'cmnd', @data); -} - -sub sendXpl { - if (defined($xpl_send)) { - my ($target, $msg_type, @data) = @_; - my ($parms, $msg); - $msg = "xpl-$msg_type\n{\nhop=1\nsource=" . &xPL::get_xpl_mh_source_info() . "\n"; - if (defined($target)) { - $msg .= "target=$target\n"; - } - $msg .= "}\n"; - while (@data) { - my $section = shift @data; - $msg .= "$section\n{\n"; - my $ptr = shift @data; - if ($ptr) { - my %parms = %$ptr; - for my $key (sort keys %parms) { - # order is important for many xPL clients - # allow a sort key delimitted by ## to drive the order - my ($subkey1,$subkey2) = $key =~ /^(\S+)##(.*)/; - if (defined $subkey1 and defined $subkey2) { - $msg .= "$subkey2=$parms{$key}\n"; - } else { - $msg .= "$key=$parms{$key}\n"; - } - } - } - $msg .= "}\n"; - } - print "db5 xpl msg: $msg" if $main::Debug{xpl}; # and $main::Debug{xpl} == 5; - if ($xpl_send) { - # check to see if the socket is still valid - if (!($::Socket_Ports{'xpl_send'}{socka})) { - &xPL::_handleStaleXplSockets(); - } - $xpl_send->set($msg) if $::Socket_Ports{'xpl_send'}{socka}; - } - } else { - print "WARNING! xPL is disabled and you are trying to send xPL data!! (xPL::sendXpl())\n"; - } -} - -sub send_xpl_heartbeat { - my ($protocol) = @_; - my $port = $::Socket_Ports{xpl_listen}{port}; - my $ip_address = $::config_parms{'xpl_address'}; - $ip_address = $::config_parms{'ipaddress_xpl'} unless $ip_address; - $ip_address = $::Info{IPAddress_local} unless $ip_address and $ip_address ne '0.0.0.0'; - - my $msg; - if ($xpl_send) { - $msg = "xpl-stat\n{\nhop=1\nsource=" . &xPL::get_xpl_mh_source_info() . "\ntarget=*\n}\n"; - $msg .= "hbeat.app\n{\ninterval=$xpl_hbeat_interval\nport=$port\nremote-ip=$ip_address\n}\n"; - # check to see if all of the sockets are still valid - &xPL::_handleStaleXplSockets(); - $xpl_send->set($msg) if $::Socket_Ports{'xpl_send'}{socka}; - print "db6 xPL heartbeat: $msg.\n" if $main::Debug{xpl} and $main::Debug{xpl} == 6; - } else { - print "Error in xPL_Item::send_heartbeat. xPL send socket not available.\n"; - print "Either disable xPL (xpl_disable = 1) or resolve system network problem (UDP port 3865).\n"; - } -} - -sub _handleStaleXplSockets { - - # check main sending socket - my $port_name = 'xpl_send'; - if (!($::Socket_Ports{$port_name}{socka})) { - if (&xPL::open_port($::Socket_Ports{$port_name}{port}, 'send', $port_name, 0, 1)) { - print "Notice. xPL socket ($port_name) had been closed and has been reopened\n"; - } else { - print "WARNING! xPL socket ($port_name) had been closed and can not be reopened\n"; - } - } - # check main listening socket - $port_name = 'xpl_listen'; - if (!($::Socket_Ports{$port_name}{socka})) { - if (&xPL::open_port($::Socket_Ports{$port_name}{port}, 'listen', $port_name, 0, 1)) { - print "Notice. xPL socket ($port_name) had been closed and has been reopened\n"; - } else { - print "WARNING! xPL socket ($port_name) had been closed and can not be reopened\n"; - } - } - - # check the hub listening socket if hub mode is enabled - if (!($::config_parms{xpl_nohub})) { - $port_name = 'xpl_hub_listen'; - if (!($::Socket_Ports{$port_name}{socka})) { - if (&xPL::open_port($::Socket_Ports{$port_name}{port}, 'listen', $port_name, 0, 1)) { - print "Notice. xPL socket ($port_name) had been closed and has been reopened\n"; - } else { - print "WARNING! xPL socket ($port_name) had been closed and can not be reopened\n"; - } - } - # no need to check each hub "responder" socket as it is automatically reopened on receipt - # of client's heartbeat - } -} - - -package xPL_Item; -=begin comment - - IMPORTANT: Mark uses of following methods if for init purposes w/ # noloop. Sample use follows: - - $mySqueezebox = new xPL_Item('slimdev-slimserv.squeezebox'); - $mySqueezebox->manage_heartbeat_timeout(360, "speak 'Squeezebox is not reporting'",1); # noloop - - If # noloop is not used on manage_heartbeat_timeout, you will see many attempts to start the timer - - state_now(): returns all current section data using the following form (unless otherwise - set via state monitor): - : = | : = - - state_now(section_name): returns undef if not defined; otherwise, returns current data for - section name using the following form (unless otherwise set via state_monitor): - = | = - - current_section_names: returns the list of current section names delimitted by the pipe character - - tie_value_convertor(keyname, expr): ties the code reference in expr to keyname. The returned - value from expr is substituted into the key value. The reference in expr may use the variables - $section and $value for processing (where $section is the section name and $value is the - original value. - - e.g., $xpl_obj->tie_value_convertor('temp','$main::convert_c_to_f_degrees($value'); - note: the reference to '$main::' allows access to the user code sub - convert_c_to_f_degrees - - class_name(class_name): Sets/Gets the classname. Classname is actually the . - for xPL. It is also often referred to as the schema name. Used to filter - inbound messages. Except for generic "monitors", this shoudl be set. - - source(source): Sets/Gets the source (name). This is normally ... - It is used to filter inbound messages. Except for generic "monitors", this should be set. - - target_address(target_address): Sets/Gets the target (name). Syntax is similar to source. Used to direct (target) - the message to a specific device. Use "*" (default) for broadcast messages. - - manage_heartbeat_timeout(timeout, action, repeat). Sets the timeout interval (in secs) and action to be performed - on expiration of a timer w/ no corresponding heart-beat messages. Used to enable warnings/notices - of absent heart-beats. See comments on using # noloop above. Timeout should be set to a value - greater than the actual device heartbeat interval. Action/timer is not repeated unless - repeat is 1 or true. - - dead_action(action). Sets/gets the action to be applied on receipt of a "dead" heartbeat (the app - indicates that it is stopping/dying). Not all devices supply a "dead" heartbeat message; - therefore, use manage_heartbeat_timeout as the primary safeguard. - - app_status(). Gets the app status. Initially, set to "unknown" until receipt of first "alive" - heartbeat (then, set to "alive"). Set to "dead" on first dead heart-beat. - - send_cmnd(data). Sends xPL message to target device using data hash. - - device_monitor(deviceinfo): constrains state updates to only messages w/ a devicekey=devicevalue - pair. A common example is where deviceinfo is set to 'someid'. In this case, state updates - are constrained to occur only when a message constains "device=someid". deviceinfo can also - take the literal 'somekey = someid' for messages that use a key other than the literal: 'device'. - - -=cut - - -@xPL_Item::ISA = ('Generic_Item'); - - - # Support both send and receive objects -sub new { - my ($object_class, $xpl_source, @data, $xpl_class) = @_; - my $self = {}; - bless $self, $object_class; - - $xpl_source = '*' if !$xpl_source or $xpl_source eq '*'; - - $$self{state} = ''; - $$self{address} = $xpl_source; # left in place for legacy - $$self{address} = '*' if !$xpl_source; - $$self{target_address} = '*'; - $$self{class} = $xpl_class unless !$xpl_class; - $$self{m_timeoutHeartBeat} = 0; - $$self{m_appStatus} = 'unknown'; - $$self{m_timerHeartBeat} = new Timer(); - $$self{m_state_now_msg_type} = 'unknown'; - $$self{m_allow_empty_state} = 0; - - &xPL_Item::store_data($self, @data); - - $self->state_overload('off'); # By default, do not process ~;: strings as substate/multistate - - return $self; -} - -sub source { - my ($self, $p_strSource) = @_; - $$self{address} = $p_strSource if defined $p_strSource; - return $$self{address}; -} - -sub class_name { - - my ($self, $p_strClassName) = @_; - $$self{class} = $p_strClassName if defined $p_strClassName; - return $$self{class}; -} - -sub target_address { - my ($self, $p_strTarget) = @_; - $$self{target_address} = $p_strTarget if defined $p_strTarget; - return $$self{target_address}; -} - -sub device_name { - my ($self, $p_strDeviceName) = @_; - $$self{m_device_name} = $p_strDeviceName if $p_strDeviceName; - return $$self{m_device_name}; -} - -sub on_set_message { - my ($self, @data) = @_; - while (@data) { - my $section = shift @data; - my $ptr = shift @data; - my %parms = %$ptr; - for my $key (sort keys %parms) { - my $value = $parms{$key}; - $$self{_on_set_message}{$section}{$key} = $value; - } - } - return $$self{_on_set_message}; -} - -sub allow_empty_state { - my ($self, $p_allowEmptyState) = @_; - $$self{m_allow_empty_state} = $p_allowEmptyState if defined($p_allowEmptyState); - return $$self{m_allow_empty_state}; -} - -sub manage_heartbeat_timeout { - my ($self, $p_timeoutHeartBeat, $p_actionHeartBeat, $p_repeatAction) = @_; - if (defined($p_timeoutHeartBeat) and defined($p_actionHeartBeat)) { - my $m_repeatAction = 0; - $m_repeatAction = $p_repeatAction if $p_repeatAction; - $$self{m_actionHeartBeat} = $p_actionHeartBeat; - $$self{m_timeoutHeartBeat} = $p_timeoutHeartBeat; - $$self{m_timerHeartBeat}->set($$self{m_timeoutHeartBeat},$$self{m_actionHeartBeat}, $m_repeatAction); - $$self{m_timerHeartBeat}->start(); - } -} - -sub dead_action { - my ($self, $p_actionDeadApp) = @_; - $$self{m_app_Status} = 'dead'; - if (defined $p_actionDeadApp) { - $$self{m_actionDeadApp} = $p_actionDeadApp; - } - return $$self{m_actionDeadApp}; -} - -sub _handle_dead_app { - my ($self) = @_; - return eval $$self{m_actionDeadApp} if defined($$self{m_actionDeadApp}); -} - -sub _handle_alive_app { - my ($self) = @_; - $$self{m_appStatus} = 'alive'; - if ($$self{m_timeoutHeartBeat} != 0) { - $$self{m_timerHeartBeat}->restart() unless $$self{m_timerHeartBeat}->inactive(); - return 1; - } else { - $$self{m_timerHeartBeat}->stop() unless $$self{m_timerHeartBeat}->inactive(); - return 0; - } -} - -sub app_status { - my ($self) = @_; - return $$self{m_appStatus}; -} - -sub store_data { - my ($self, @data) = @_; - while (@data) { - my $section = shift @data; - $$self{class} = $section; - $$self{sections}{$section} = 'send'; - my $ptr = shift @data; - my %parms = %$ptr; - for my $key (sort keys %parms) { - my $value = $parms{$key}; - $$self{$section}{$key} = $value; - $$self{state_monitor} = "$section : $key" if $value eq '$state'; - } - } -} - -sub state_now { - my ($self, $section_name) = @_; - my $state_now = $self->SUPER::state_now(); - if ($section_name) { - # default section_state_now to undef unless it actually exists - my $section_state_now = undef; - for my $section (split(/\s+\|\s+/,$state_now)) { - my @section_data = split(/\s+:\s+/,$section); - my $section_ref = $section_data[0]; - next if $section_ref eq ''; - if ($section_ref eq $section_name) { - if (defined($section_state_now)) { - $section_state_now .= " | $section_data[1]"; - } else { - $section_state_now = $section_data[1]; - } - } - } - print "db xPL_Item:state_now: section data for $section_name is: $section_state_now\n" - if $main::Debug{xpl} and $section_state_now; - $state_now = $section_state_now; - } - return $state_now; -} - -sub current_section_names { - my ($self) = @_; - my $changed = $$self{changed}; - my $current_section_names = undef; - if ($changed) { - for my $section (split(/\s+\|\s+/,$changed)) { - my @section_data = split(/\s+:\s+/,$section); - if (defined($current_section_names)) { - $current_section_names .= " | $section_data[0]"; - } else { - $current_section_names = $section_data[0]; - } - } - - } - print "db xPL_Item:current_section_names : $current_section_names\n" if $main::Debug{xpl}; - return $current_section_names; -} - -sub tie_value_convertor { - my ($self, $key_name, $convertor) = @_; - $$self{_value_convertors}{$key_name} = $convertor if (defined($key_name) && defined($convertor)); - -} - - -sub device_monitor { - my ($self, $monitor_info) = @_; - if ($monitor_info) { - my ($key,$value) = $monitor_info =~ /(\S+)\s*=\s*(\S+)/; - if (!($value or $value =~ /^0/)) { - $value = ($key) ? $key : $monitor_info; - $key = 'device'; - } - $$self{_device_id} = lc $value; - $$self{_device_id_key} = lc $key; - } - if (defined $$self{_device_id}) { - return (($$self{_device_id_key}) ? $$self{_device_id_key} : 'device') . $$self{_device_id}; - } else { - return; - } -} - -sub default_setstate { - my ($self, $state, $substate, $set_by) = @_; - - # Send data, unless we are processing incoming data - return if $set_by =~ /^xpl/i; - - my @parms; - - if ($$self{_on_set_message}) { - for my $class_name (sort keys %{$$self{_on_set_message}}) { - my $block; - for my $msg_key (sort keys %{$$self{_on_set_message}{$class_name}}) { - my $field_value = eval($$self{_on_set_message}{$class_name}{$msg_key}); - $block->{$msg_key} = $field_value; - } - push @parms, $class_name, $block; - } - } else { - if ($$self{state_monitor}) { - foreach my $state_monitor (split(/\|/,$$self{state_monitor})) { - my ($section, $key) = $$self{state_monitor} =~ /(\S+)\s*[:=]\s*(\S+)/; - $$self{$section}{$key} = $state; - } - } - for my $section (sort keys %{$$self{sections}}) { - next unless $$self{sections}{$section} eq 'send'; # Do not echo received data - push @parms, $section, $$self{$section}; - } - } - - if (@parms) { - # sending stat info about ourselves? - if (lc $$self{source} eq &xPL::get_xpl_mh_source_info()) { - $self->send_trig(@parms); - } else { - # must be cmnd info to another device addressed by address - $self->send_cmnd(@parms); - } - } -} - -sub state_now_msg_type { - my ($self, $p_msgType) = @_; - $$self{m_state_now_msg_type} = $p_msgType if defined($p_msgType); - return $$self{m_state_now_msg_type}; -} - -# DO NOT use the following sub -# Instead, DO use either send_cmnd, send_trig or send_stat -sub send_message { - my ($self, $p_strTarget, @p_data) = @_; - $self->send_cmnd(@p_data); -} - -sub send_cmnd { - my ($self, @p_data) = @_; - if (defined $$self{_device_id}) { - my $classname = shift @p_data; - my $ptr = shift @p_data; - my @new_data = (); - $ptr->{$$self{_device_id_key}} = $$self{_device_id}; - push @new_data, $classname, $ptr; - &xPL::sendXpl($self->source, 'cmnd', @new_data); - } else { - &xPL::sendXpl($self->source, 'cmnd', @p_data); - } -} - -sub send_stat { - my ($self, @p_data) = @_; - if (defined $$self{_device_id}) { - my $classname = shift @p_data; - my $ptr = shift @p_data; - my @new_data = (); - $ptr->{$$self{_device_id_key}} = $$self{_device_id}; - push @new_data, $classname, $ptr; - &xPL::sendXpl('*', 'stat', @new_data); - } else { - &xPL::sendXpl('*', 'stat', @p_data); - } -} - -sub send_trig { - my ($self, @p_data) = @_; - if (defined $$self{_device_id}) { - my $classname = shift @p_data; - my $ptr = shift @p_data; - my @new_data = (); - $ptr->{$$self{_device_id_key}} = $$self{_device_id}; - push @new_data, $classname, $ptr; - &xPL::sendXpl('*', 'trig', @new_data); - } else { - &xPL::sendXpl('*', 'trig', @p_data); - } -} - -sub ignore_message { - my ($self, $p_data) = @_; - my $ignore_message = 0; - if ($$self{_device_id_key} and $self->class_name) { - print "Device monitoring enabled: key=$$self{_device_id_key}, id=$$self{_device_id}, tested value=" - . $$p_data{$self->class_name}{$$self{_device_id_key}} . "\n" if $main::Debug{xpl}; - $ignore_message = ($$self{_device_id} ne lc $$p_data{$self->class_name}{$$self{_device_id_key}}) ? 1 : 0; - } - return $ignore_message; -} - -package xPL_Sensor; - -@xPL_Sensor::ISA = ('xPL_Item'); - -sub new { - my ($class, $p_source, $p_type, $p_statekey) = @_; - my ($source,$deviceid) = $p_source =~ /(\S+):([\S ]+)/; - $source = $p_source unless $source; - my $self = $class->SUPER::new($source); - $$self{sensor_type} = $p_type if $p_type; - my $statekey = 'current'; - $statekey = $p_statekey if $p_statekey; - $self->SUPER::class_name('sensor.basic'); - $$self{state_monitor} = "sensor.basic : $statekey"; - $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; - return $self; -} - -sub type { - my ($self, $p_type) = @_; - $$self{sensor_type} = $p_type if $p_type; - return $$self{sensor_type}; -} - -sub current { - my ($self) = @_; - return $$self{'sensor.basic'}{current}; -} - -sub units { - my ($self) = @_; - return $$self{'sensor.basic'}{units}; -} - -sub lowest { - my ($self) = @_; - return $$self{'sensor.basic'}{lowest}; -} - -sub highest { - my ($self) = @_; - return $$self{'sensor.basic'}{highest}; -} - - -sub ignore_message { - my ($self, $p_data) = @_; - return 1 if $self->SUPER::ignore_message($p_data); # user xPL_Item's filter against deviceid - return ($$p_data{'sensor.basic'}{type} ne $$self{sensor_type}) ? 1 : 0; -} - -sub request_stat { - my ($self) = @_; - $self->SUPER::send_cmnd('sensor.request' => { 'request' => 'current', 'type' => "'$$self{sensor_type}'"}); -} - -package xPL_UPS; - -@xPL_UPS::ISA = ('xPL_Item'); - -sub new { - my ($class, $p_source, $p_statekey) = @_; - my ($source,$deviceid) = $p_source =~ /(\S+):(\S+)/; - $source = $p_source unless $source; - my $self = $class->SUPER::new($source); - my $statekey = $p_statekey; - $statekey = 'status'; -# $self->SUPER::class_name('ups.basic'); - $$self{state_monitor} = "ups.basic : $statekey|hbeat.app : $statekey"; - $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; - return $self; -} - -sub status { - my ($self, $p_status) = @_; - return ($$self{'ups.basic'}{status}) ? $$self{'ups.basic'}{status} : $$self{'hbeat.app'}{status}; -} - -sub event { - my ($self) = @_; - return $$self{'ups.basic'}{event}; -} - -sub ignore_message { - my ($self, $p_data) = @_; - return 1 if $self->SUPER::ignore_message($p_data); # user xPL_Item's filter against deviceid - return ($$p_data{'ups.basic'} or $$p_data{'hbeat.app'}) ? 0 : 1; -} - -package xPL_X10Security; - -@xPL_X10Security::ISA = ('xPL_Item'); - -sub new { - my ($class, $p_source, $p_type, $p_statekey) = @_; - my ($source,$deviceid) = $p_source =~ /(\S+):(\S+)/; - $source = $p_source unless $source; - my $self = $class->SUPER::new($source); - $$self{type} = $p_type if $p_type; - my $statekey = $p_statekey; - $statekey = 'command'; - $self->SUPER::class_name('x10.security'); - $$self{state_monitor} = "x10.security : $statekey"; - $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; - return $self; -} - -sub type { - my ($self, $p_type) = @_; - $$self{type} = $p_type if $p_type; - return $$self{type}; -} - -sub command { - my ($self) = @_; - return $$self{'x10.security'}{command}; -} - -sub tamper { - my ($self) = @_; - return $$self{'x10.security'}{tamper}; -} - -sub low_battery { - my ($self) = @_; - return $$self{'x10.security'}{'low-battery'}; -} - -sub delay { - my ($self) = @_; - return $$self{'x10.security'}{delay}; -} - -sub ignore_message { - my ($self, $p_data) = @_; - return 1 if $self->SUPER::ignore_message($p_data); # user xPL_Item's filter against deviceid - if ($$self{type}) { - return ($$p_data{'x10.security'}{type} ne $$self{type}) ? 1 : 0; - } else { - return 0; - } -} - - -package xPL_Rio; - -@xPL_Rio::ISA = ('xPL_Item'); - - # Support both send and receive objects -sub new { - my ($object_class, $xpl_source, $xpl_target) = @_; - my $self = {}; - bless $self, $object_class; - - $$self{state} = ''; - $$self{source} = $xpl_source; - $$self{target_address} = $xpl_target unless !$xpl_target; - - &xPL_Item::store_data($self, 'rio.basic' => {sel => '$state'}); - - @{$$self{states}} = ('play', 'stop', 'mute' , 'volume +20' , 'volume -20', 'volume 100' , - 'skip', 'back', 'random' ,'power on', 'power off', 'light on', 'light off'); - - return $self; - -} - -1; +=begin comment + +xPL_Items.pm - Misterhouse interface for the xPL protocol + +Info: + + xPL websites: + http://www.xplproject.org.uk + http://www.xaphal.com + +Authors: + 10/26/2002 Created by Bruce Winter bruce@misterhouse.net + + +xPL works by using the xPL Hub built in misterhouse and listening for +xPL connections. See: +http://misterhouse.wikispaces.com/xAP+and+xPL+-+Getting+Started + +Relevant variables for mh.private.ini are: +#ipaddress_xpl_broadcast = 192.168.205.255 +#ipaddress_xpl = 192.168.205.3 +#xpl_disable = 1 +#xpl_nohub = 1 + +You can disable the mh internal xPL hub if you are running a more capable one. +To get data input, you can use something like + +xpl-rfxcom-rx --verbose --rfxcom-rx-verbose --rfxcom-rx-tty /dev/rfxcom --interface eth1 + +from xPL-Perl. Then watch for sensor updates passing by and paste their info +in your device table, like so: +XPL_SENSOR, bnz-rfxcomrx.gargamel:bthr918n.e6, oregon_intemp, XPL_temp, temp + +Another option to figure out the name to use in XPL_SENSOR is to use +xpl-logger -head -body -i ethx 2>&1 | grep "xpl-trig\/" +(or without the grep for more details on which field is called what). + +A few samples: +XPL_SENSOR, iranger-rfx.*:WGR918, oregon_winddir, , direction +XPL_SENSOR, iranger-rfx.*:BHTR968, oregon_intemp, , temp +XPL_SENSOR, bnz-owfs.*:10.2223EF010800, owfs_temp, , temp +XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000, owfs_humidity, , humidity +XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000.1, owfs_humidity1, , humidity +XPL_X10SECURITY, iranger-rfx.*:F8, x10sec_garage1, , ds10 + +Note that XPL_SENSOR should just be used for XPL messages of the x10.basic +type. XPL_X10SECURITY is for x10.security schema, while there is no way to currently +read x10.basic messages (see this file for more supported schemas). + +Once it is running, objects get variables including these (gathered with Data::Dumper) +'state' => '17.9', +'states_nosubstate' => 1, +'states_substate' ? +'address' => 'bnz-rfxcomrx.gargamel', +'states_nomultistate' => 1, +'states_multistate' ? +'target_address' => '*', +'_device_id' => 'bthr918n.e6' + +So, you would write this to print temperature: +print_log $oregon_intemp->state +=cut + +use strict; + +package xPL; + +@xPL::ISA = ('Generic_Item'); + +#se IO::Socket::INET; # Gives us the INADDR constants, but not in perl 5.0 :( + +my (@xpl_item_names, $started, %hub_ports, $xpl_listen, $xpl_hub_listen, $xpl_send, %xpl_hub_ports, $xpl_hbeat_interval, $xpl_hbeat_counter); +use vars '$xpl_data'; + + # Create sockets and add hook to check incoming data +sub startup { + return if $started++; # Allows us to call with $Reload or with xpl_module mh.ini parm + + # In case you don't want xpl for some reason + return if $::config_parms{xpl_disable}; + +# determine our local ipaddress(es) +my @ipaddresses = &::get_ip_address; + @xpl_item_names = (); + my ($port); + + # init the hbeat intervals and counters + $xpl_hbeat_interval = $::config_parms{xpl_hbeat_interval}; + $xpl_hbeat_interval = 5 unless $xpl_hbeat_interval; + $xpl_hbeat_counter = $xpl_hbeat_interval; + + if (!($::config_parms{xpl_disable})) { + undef $port; + $port = $::config_parms{xpl_port}; + $port = 3865 unless $port; + + # open the sending port + &open_port($port, 'send', 'xpl_send', 0, 1); + $xpl_send = new Socket_Item(undef, undef, 'xpl_send'); + # and send the heartbeat + + # Find and use the first open port + my $port_listen; + for my $p (49152 .. 65535) { + $port_listen = $p; + last if &open_port($port_listen, 'listen', 'xpl_listen', 1, 1); + } + $xpl_listen = new Socket_Item(undef, undef, 'xpl_listen'); + + # initialize the hub (listen) port + if ($::config_parms{xpl_nohub}) { + $xpl_hub_listen = undef; + } else { + if (&open_port($port, 'listen', 'xpl_hub_listen', 0, 1)) { + $xpl_hub_listen = new Socket_Item(undef, undef, 'xpl_hub_listen'); + print " - mh in xPL Hub mode\n"; + # now set up the hub port that will send to mh + $xpl_hub_ports{$port_listen} = &xPL::get_xpl_mh_source_info(); + my $port_name = "xpl_send_$port_listen"; + &open_port($port_listen, 'send', $port_name, 1, 1); + } else { + print " - mh automatically switching out of xPL Hub mode. Another application is binding to the hub port ($port)\n"; + } + } + + # now that a listen port exists, advertise it w/ the first hbeat msg + &xPL::send_xpl_heartbeat() if $xpl_send; + + } + + &::MainLoop_pre_add_hook(\&xPL::check_for_data, 1 ); + # add reload hook so that xpl_item_names list is reset + &::Reload_pre_add_hook(\&xPL::reload_hook,1); +} + +sub reload_hook { + @xpl_item_names = (); +} + +sub main::display_xpl +{ + my (%args) = @_; + my $schema = lc ${args}{schema}; + $schema = 'osd.basic' unless $schema; + if ($schema eq 'osd.basic') { + &main::display_xpl_osd_basic(%args); + } else { + &main::print_log("Display support for the schema, $schema, does not yet exist"); + } +} + +sub main::display_xpl_osd_basic +{ + my (%args) = @_; + my ($text, $duration, $address); + $text = $args{raw_text}; + $text = $args{text} unless $text; + $text =~ s/[\n\r ]+/ /gm; # strip out new lines and extra space + $text =~ s/\n/\\n/gm; # escape new lines + $duration = $args{duration}; + $duration = $args{display} unless $duration; # this apparently is the original param? + $duration = 10 unless $duration; # default to 10 sec display + $address = $args{to}; + $address = $args{address} unless $address; + $address = '*' unless $address; + # auto pre-pend text w/ a newline if it target a squeezebox and doesn't already have one + if ($address =~ /^slimdev-slimserv/i) { + $text = "\\n$text" unless $text =~ /\\n\S+/i; + } + &xPL::send('xPL', $address, 'osd.basic' => { command => 'write', delay => $duration, text => $text }); +} + +sub open_port { + my ($port, $send_listen, $port_name, $local, $verbose) = @_; + +# Need to re-open the port, if client app has been re-started?? + close $::Socket_Ports{$port_name}{sock} if $::Socket_Ports{$port_name}{sock}; +# return 0 if $::Socket_Ports{$port_name}{sock}; # Already open + + my $sock; + if ($send_listen eq 'send') { + my $dest_address; + if ($local) { +# $dest_address = $::config_parms{'ipaddress_xpl'}; +# $dest_address = $::config_parms{'xpl_address'} unless $dest_address; + if ($main::OS_win) { + $dest_address = $::Info{IPAddress_local} unless $dest_address; + } else { + $dest_address = '0.0.0.0'; + } + } else { +# $dest_address = inet_ntoa(INADDR_BROADCAST); + $dest_address = $::config_parms{'ipaddress_xpl_broadcast'}; + $dest_address = '255.255.255.255' unless $dest_address; + } + $sock = new IO::Socket::INET->new(PeerPort => $port, Proto => 'udp', + PeerAddr => $dest_address, Broadcast => 1); + print "db xPL_Items open_port: p=$port pn=$port_name l=$local a=$dest_address\n" if $sock and $main::Debug{xpl}; + + } + else { + my $listen_address; + if (!($local)) { + $listen_address = $::config_parms{'ipaddress_xpl'}; + $listen_address = $::config_parms{'xpl_address'} unless $listen_address; + } + if ($main::OS_win) { + $listen_address = $::Info{IPAddress_local} unless $listen_address; + } else { + # can't get *nix to bind to a specific address; defaults to kernel assigned default IP + $listen_address = '0.0.0.0'; + } + $sock = new IO::Socket::INET->new(LocalPort => $port, Proto => 'udp', + LocalAddr => $listen_address, Broadcast => 1); +# LocalAddr => '0.0.0.0', Broadcast => 1); +# LocalAddr => inet_ntoa(INADDR_ANY), Broadcast => 1); + print "db xPL_Items open_port: p=$port pn=$port_name l=$local a=$listen_address\n" if $sock and $main::Debug{xpl}; + + } + unless ($sock) { + print "\nError: Could not start a udp xPL send server on $port: $@\n\n" if $send_listen eq 'send'; + return 0; + } + + printf " - creating %-15s on %3s %5s %s\n", $port_name, 'udp', $port, $send_listen if $verbose; + + $::Socket_Ports{$port_name}{protocol} = 'udp'; + $::Socket_Ports{$port_name}{datatype} = 'raw'; + $::Socket_Ports{$port_name}{port} = $port; + $::Socket_Ports{$port_name}{sock} = $sock; + $::Socket_Ports{$port_name}{socka} = $sock; # UDP ports are always "active" + + return $sock; +} + + +sub check_for_data { + + if ($xpl_hub_listen && (my $xpl_hub_data = said $xpl_hub_listen)) { + &_process_incoming_xpl_hub_data($xpl_hub_data); + } + if ($xpl_listen && (my $xpl_data = said $xpl_listen)) { + &_process_incoming_xpl_data($xpl_data); + } + + # check to see if hbeats need to be sent + if (&::new_minute($xpl_hbeat_interval)) { + if ($xpl_send) { + if ($xpl_hbeat_counter == 5) { + &xPL::send_xpl_heartbeat(); + $xpl_hbeat_counter = $xpl_hbeat_interval; + } else { + $xpl_hbeat_counter = $xpl_hbeat_counter - 1; + } + } + } +} + + # Parse incoming xPL records +sub parse_data { + my ($data) = @_; + my ($data_type, %d); + print "db4 xPL data:\n$data\n" if $main::Debug{xpl} and $main::Debug{xpl} == 4; + for my $r (split /[\r\n]/, $data) { + next if $r =~ /^[\{\} ]*$/; + # Store xpl-header, xpl-heartbeat, and other data + if (my ($key, $value) = $r =~ /(.+?)=(.*)/) { + $key = lc $key; + $value = lc $value if ($data_type =~ /^xpl/); # Do not lc real data; + if (exists($d{$data_type}{$key})) { + $d{$data_type}{$key} .= "," . $value; # xpl allows "continuation lines" by having more than one tag possible + } else { + $d{$data_type}{$key} = $value; + } + print "db4 xpl parsed c=$data_type k=$key v=$value\n" if ($main::Debug{xpl} and $main::Debug{xpl} == 4); + } + # data_type (e.g. xpl-header, xpl-heartbeat, source.instance + else { + $data_type = lc $r; + } + } + return \%d; +} + +sub _process_incoming_xpl_hub_data { + my ($data) = @_; + my $ip_address = $::config_parms{'ipaddress_xpl'}; + $ip_address = $::Info{IPAddress_local} unless $ip_address; + + + undef $xpl_data; + $xpl_data = &parse_data($data); + + my ($source, $class, $target, $msg_type); + if (defined $$xpl_data{'xpl-stat'}) { + $msg_type = 'stat'; + $source = $$xpl_data{'xpl-stat'}{source}; + $target = $$xpl_data{'xpl-stat'}{target}; + } elsif ($$xpl_data{'xpl-cmnd'}) { + $msg_type = 'cmnd'; + $source = $$xpl_data{'xpl-cmnd'}{source}; + $target = $$xpl_data{'xpl-cmnd'}{target}; + } else { + $msg_type = 'trig'; + $source = $$xpl_data{'xpl-trig'}{source}; + $target = $$xpl_data{'xpl-trig'}{target}; + } + +# print "db1 xpl hub check: s=$source c=$class t=$target d=$data\n" if $main::Debug{xpl} and $main::Debug{xpl} == 1; + + return unless $source; + + my ($port); + # As a hub, echo data to other xpl listeners unless it's our own transmission + for $port (keys %xpl_hub_ports) { + # don't echo back the sender's own data + if ($xpl_hub_ports{$port} ne $source) { + my $sock = $::Socket_Ports{"xpl_send_$port"}{sock}; + print "db2 xpl hub: sending xpl data to p=$port destination=$xpl_hub_ports{$port} s=$sock d=\n$data.\n" if $main::Debug{xpl} and $main::Debug{xpl} == 2; + print $sock $data if defined($sock); + } + } + + # Log hearbeats of other apps; ignore hbeat.basic messages as these should not be handled by the hub + if ($$xpl_data{'hbeat.app'}) { + # rely on the xPL-message's remote-ip attribute in the hbeat.app as the basis for performing IP comparisons +# my $sender_iaddr = $::Socket_Ports{'xpl_listen'}{from_ip}; +# my $sender_ip_address = Socket::inet_ntoa($sender_iaddr) if $sender_iaddr; + my $sender_ip_address = $$xpl_data{'hbeat.app'}{'remote-ip'}; + # Open/re-open the port on every hbeat if it posts a listening port. + # Skip if it is our own hbeat (port = listen port) + if (($sender_ip_address eq $ip_address)) { + $port = $$xpl_data{'hbeat.app'}{port}; + if ($port) { + $xpl_hub_ports{$port} = $source; + my $port_name = "xpl_send_$port"; + my $msg = ($::Socket_Ports{$port_name}{sock}) ? 'renewing' : 'registering'; + print "db xpl $msg port=$port to xPL client $source" if $main::Debug{xpl}; + # xPL apps want local + &open_port($port, 'send', $port_name, 1, $msg eq 'registering'); + } + } + } + +} + +sub _process_incoming_xpl_data { + my ($data) = @_; + + undef $xpl_data; + $xpl_data = &parse_data($data); + + my ($source, $class, $target, $msg_type); + if (defined $$xpl_data{'xpl-stat'}) { + $msg_type = 'stat'; + $source = $$xpl_data{'xpl-stat'}{source}; + $target = $$xpl_data{'xpl-stat'}{target}; + } elsif ($$xpl_data{'xpl-cmnd'}) { + $msg_type = 'cmnd'; + $source = $$xpl_data{'xpl-cmnd'}{source}; + $target = $$xpl_data{'xpl-cmnd'}{target}; + } else { + $msg_type = 'trig'; + $source = $$xpl_data{'xpl-trig'}{source}; + $target = $$xpl_data{'xpl-trig'}{target}; + } + + print "db1 xpl check: s=$source c=$class t=$target d=$data\n" if $main::Debug{xpl} and $main::Debug{xpl} == 1; + + # the first time that this sub is called, the xpl_item_names array needs to be filled + if (!(@xpl_item_names)) { + foreach my $object_type (&::list_object_types) { + foreach my $object_name (&::list_objects_by_type($object_type)) { + my $object = &::get_object_by_name("$object_name"); + if ($object and $object->isa('xPL_Item')) { + push @xpl_item_names, $object_name; + } + } + } + } + + return unless $source; + # define target as '*' if undefined + $target = '*' if !($target); + + # continue processing unless we are the source (e.g., heart-beat) + if (!($source eq &xPL::get_xpl_mh_source_info())) { + # Set states in matching xPL objects + for my $name (@xpl_item_names) { #(&::list_objects_by_type('xPL_Item')) { + my $o = &main::get_object_by_name($name); + $o = $name unless $o; # In case we stored object directly + print "db3 xpl test o=$name s=$source oa=$$o{source}\n" if $main::Debug{xpl} and $main::Debug{xpl} == 3; + + # skip this object unless the source matches if a stat or trig + # otherwise, we check the target for a cmnd + # NOTE: the object's hash reference for "source" is "address" + my $regex_address = &wildcard_2_regex($$o{address}); + if ($$o{set_state_on_cmnd} and $msg_type eq 'cmnd') { + my $regex_target = &wildcard_2_regex($target); + next unless ($target =~ /^$regex_address$/i) or ($$o{address} =~ /^$regex_target$/i); + } else { + if ( $source =~ /^$regex_address$/i) { + # handle hbeat data + for my $section (keys %{$xpl_data}) { + if ($section =~ /^hbeat./i) { + if (lc $section eq 'hbeat.app') { + $o->_handle_alive_app(); + } else { + $o->_handle_dead_app(); + } + } + } + } else { + next; + } + } + + my $className; + # look at each section name; any that don't match the header titles is the classname + # since is there is only one "block" in an xPL message and its label is the classname + for my $section (keys %{$xpl_data}) { + if ($section) { + $className = $section unless ($section eq 'xpl-stat' || $section eq 'xpl-cmnd' || $section eq 'xpl-trig'); + } + } + # skip this object unless the classname matches + if ($className && $$o{class}) { + my $regex_class = &wildcard_2_regex($$o{class}); + next unless $className =~ /^$regex_class$/i; + } + + # check if device monitoring is enabled + if (!($className =~ /hbeat./i)) { + next if $o->ignore_message($xpl_data); + } + + # Find and set the state variable + my $state_value; + $$o{changed} = ''; + for my $section (keys %{$xpl_data}) { + $$o{sections}{$section} = 'received' unless $$o{sections}{$section}; + for my $key (keys %{$$xpl_data{$section}}) { + my $value = $$xpl_data{$section}{$key}; + # does a tied value convertor exist for this key and object? + my $value_convertor = $$o{_value_convertors}{$key} if defined($$o{_value_convertors}); + if ($value_convertor) { + print "db xpl: located value convertor: $value_convertor\n" if $main::Debug{xpl}; + my $converted_value = eval $value_convertor; + if ($@) { + print$@; + } else { + print "db xpl: converted value is: $converted_value\n" if $main::Debug{xpl}; + } + $value = $converted_value if $converted_value; + } + $$o{$section}{$key} = $value; + # Monitor what changed (real data, and include hbeat as it may include useful info, e.g., slimserver). + $$o{changed} .= "$section : $key = $value | " + unless $section eq 'xpl-stat' or $section eq 'xpl-trig' or $section eq 'xpl-cmnd' or ($section eq 'hbeat.app' and $key ne 'status'); + print "db3 xpl state check m=$$o{state_monitor} key=$section : $key value=$value\n" if $main::Debug{xpl};# and $main::Debug{xpl} == 3; + if ($$o{state_monitor}) { + foreach my $state_monitor (split(/\|/, $$o{state_monitor})) { + if ($state_monitor =~ /$section\s*[:=]\s*$key/i and defined $value) { + print "db3 xpl setting state to $value\n" if $main::Debug{xpl} and $main::Debug{xpl} == 3; + $state_value = $value; + } + } + } + } + } + # assign the "summary" of the message to state_value unless state_monitor is being used + $state_value = $$o{changed} unless $$o{state_monitor}; + print "db3 xpl set: n=$name to state=$state_value\n\n" if $main::Debug{xpl};# and $main::Debug{xpl} == 3; +# $$o{state} = $$o{state_now} = $$o{said} == $state_value if defined $state_value; +# Can not use Generic_Item set method, as state_next_path only carries state, not all other $section data, to the next pass +# $o -> SUPER::set($state_value, 'xPL') if defined $state_value; + if (defined $state_value and $state_value ne '') { + my $set_by_name = 'xPL'; + $set_by_name .= " [$source]"; # no longer needed: if ($::config_parms{'xpl_use_to_target'}); + $o -> SUPER::set_now($state_value, $set_by_name); + $o -> state_now_msg_type( "$msg_type" ); + } + } + } + +} + +sub get_mh_vendor_info { + return 'mhouse'; +} + +sub get_mh_device_info { + return 'mh'; +} + +sub get_xpl_mh_source_info { + my $instance = $::config_parms{xpl_title}; + $instance = $::config_parms{title} unless $instance; + $instance = ($instance =~ /misterhouse(.*)pid/i) ? 'misterhouse' : $instance; + $instance = &xPL::get_ok_name_part($instance); + return &get_mh_vendor_info() . '-' . &get_mh_device_info() . '.' . $instance; +} + +sub get_ok_name_part { + my ($in_name) = @_; + my $out_name = lc $in_name; + $out_name =~ tr/ /_/; + $out_name =~ s/[^a-z0-9\-_]//g; + return $out_name; +} + +#sub is_target { +# my ($target, $source) = @_; +# return ( (!($source eq &xPL::get_xpl_mh_source_info())) && +# ( (!($target)) +# || $target eq '*' +# || $target eq (&get_mh_vendor_info() . '.*') +# || $target eq (&get_mh_vendor_info() . '.' &get_mh_device_info() . '.*') +# || $target eq &xAP::get_xpl_mh_source_info() ) ); + +#} + +sub wildcard_2_regex { + my ($expr) = @_; + return unless $expr; + # convert all periods + $expr =~ s/\./(\\\.)/g; + # convert all asterisks + $expr =~ s/\*/(\.\*)/g; + # treat all :> as asterisks + $expr =~ s/:>/(\.\*)/g; + # convert all greater than symbols + $expr =~ s/>/(\.\*)/g; + + return $expr; +} + +sub received_data { + my ($protocol) = @_; + return $xpl_data; +} + +sub send { + my ($protocol, $class_address, @data) = @_; +# print "db5 xPL send: ca=$class_address d=@data xpl_send=$xpl_send\n" if ($main::Debug{xpl} and $main::Debug{xpl} == 5) or ($main::Debug{xpl} and $main::Debug{xpl} == 5); + + my $target = $class_address; + &sendXpl($target, 'cmnd', @data); +} + +sub sendXpl { + if (defined($xpl_send)) { + my ($target, $msg_type, @data) = @_; + my ($parms, $msg); + $msg = "xpl-$msg_type\n{\nhop=1\nsource=" . &xPL::get_xpl_mh_source_info() . "\n"; + if (defined($target)) { + $msg .= "target=$target\n"; + } + $msg .= "}\n"; + while (@data) { + my $section = shift @data; + $msg .= "$section\n{\n"; + my $ptr = shift @data; + if ($ptr) { + my %parms = %$ptr; + for my $key (sort keys %parms) { + # order is important for many xPL clients + # allow a sort key delimitted by ## to drive the order + my ($subkey1,$subkey2) = $key =~ /^(\S+)##(.*)/; + if (defined $subkey1 and defined $subkey2) { + $msg .= "$subkey2=$parms{$key}\n"; + } else { + $msg .= "$key=$parms{$key}\n"; + } + } + } + $msg .= "}\n"; + } + print "db5 xpl msg: $msg" if $main::Debug{xpl}; # and $main::Debug{xpl} == 5; + if ($xpl_send) { + # check to see if the socket is still valid + if (!($::Socket_Ports{'xpl_send'}{socka})) { + &xPL::_handleStaleXplSockets(); + } + $xpl_send->set($msg) if $::Socket_Ports{'xpl_send'}{socka}; + } + } else { + print "WARNING! xPL is disabled and you are trying to send xPL data!! (xPL::sendXpl())\n"; + } +} + +sub send_xpl_heartbeat { + my ($protocol) = @_; + my $port = $::Socket_Ports{xpl_listen}{port}; + my $ip_address = $::config_parms{'xpl_address'}; + $ip_address = $::config_parms{'ipaddress_xpl'} unless $ip_address; + $ip_address = $::Info{IPAddress_local} unless $ip_address and $ip_address ne '0.0.0.0'; + + my $msg; + if ($xpl_send) { + $msg = "xpl-stat\n{\nhop=1\nsource=" . &xPL::get_xpl_mh_source_info() . "\ntarget=*\n}\n"; + $msg .= "hbeat.app\n{\ninterval=$xpl_hbeat_interval\nport=$port\nremote-ip=$ip_address\n}\n"; + # check to see if all of the sockets are still valid + &xPL::_handleStaleXplSockets(); + $xpl_send->set($msg) if $::Socket_Ports{'xpl_send'}{socka}; + print "db6 xPL heartbeat: $msg.\n" if $main::Debug{xpl} and $main::Debug{xpl} == 6; + } else { + print "Error in xPL_Item::send_heartbeat. xPL send socket not available.\n"; + print "Either disable xPL (xpl_disable = 1) or resolve system network problem (UDP port 3865).\n"; + } +} + +sub _handleStaleXplSockets { + + # check main sending socket + my $port_name = 'xpl_send'; + if (!($::Socket_Ports{$port_name}{socka})) { + if (&xPL::open_port($::Socket_Ports{$port_name}{port}, 'send', $port_name, 0, 1)) { + print "Notice. xPL socket ($port_name) had been closed and has been reopened\n"; + } else { + print "WARNING! xPL socket ($port_name) had been closed and can not be reopened\n"; + } + } + # check main listening socket + $port_name = 'xpl_listen'; + if (!($::Socket_Ports{$port_name}{socka})) { + if (&xPL::open_port($::Socket_Ports{$port_name}{port}, 'listen', $port_name, 0, 1)) { + print "Notice. xPL socket ($port_name) had been closed and has been reopened\n"; + } else { + print "WARNING! xPL socket ($port_name) had been closed and can not be reopened\n"; + } + } + + # check the hub listening socket if hub mode is enabled + if (!($::config_parms{xpl_nohub})) { + $port_name = 'xpl_hub_listen'; + if (!($::Socket_Ports{$port_name}{socka})) { + if (&xPL::open_port($::Socket_Ports{$port_name}{port}, 'listen', $port_name, 0, 1)) { + print "Notice. xPL socket ($port_name) had been closed and has been reopened\n"; + } else { + print "WARNING! xPL socket ($port_name) had been closed and can not be reopened\n"; + } + } + # no need to check each hub "responder" socket as it is automatically reopened on receipt + # of client's heartbeat + } +} + + +package xPL_Item; + +=head1 NAME + +xPL_Item - Misterhouse base xPL Item + +=head1 SYNOPSIS + + IMPORTANT: Mark uses of following methods if for init purposes w/ # noloop. Sample use follows: + + $mySqueezebox = new xPL_Item('slimdev-slimserv.squeezebox'); + $mySqueezebox->manage_heartbeat_timeout(360, "speak 'Squeezebox is not reporting'",1); # noloop + +=head1 DESCRIPTION +=begin comment + + + If # noloop is not used on manage_heartbeat_timeout, you will see many attempts to start the timer + + state_now(): returns all current section data using the following form (unless otherwise + set via state monitor): + : = | : = + + state_now(section_name): returns undef if not defined; otherwise, returns current data for + section name using the following form (unless otherwise set via state_monitor): + = | = + + current_section_names: returns the list of current section names delimitted by the pipe character + + tie_value_convertor(keyname, expr): ties the code reference in expr to keyname. The returned + value from expr is substituted into the key value. The reference in expr may use the variables + $section and $value for processing (where $section is the section name and $value is the + original value. + + e.g., $xpl_obj->tie_value_convertor('temp','$main::convert_c_to_f_degrees($value'); + note: the reference to '$main::' allows access to the user code sub - convert_c_to_f_degrees + + class_name(class_name): Sets/Gets the classname. Classname is actually the . + for xPL. It is also often referred to as the schema name. Used to filter + inbound messages. Except for generic "monitors", this shoudl be set. + + source(source): Sets/Gets the source (name). This is normally ... + It is used to filter inbound messages. Except for generic "monitors", this should be set. + + target_address(target_address): Sets/Gets the target (name). Syntax is similar to source. Used to direct (target) + the message to a specific device. Use "*" (default) for broadcast messages. + + manage_heartbeat_timeout(timeout, action, repeat). Sets the timeout interval (in secs) and action to be performed + on expiration of a timer w/ no corresponding heart-beat messages. Used to enable warnings/notices + of absent heart-beats. See comments on using # noloop above. Timeout should be set to a value + greater than the actual device heartbeat interval. Action/timer is not repeated unless + repeat is 1 or true. + + dead_action(action). Sets/gets the action to be applied on receipt of a "dead" heartbeat (the app + indicates that it is stopping/dying). Not all devices supply a "dead" heartbeat message; + therefore, use manage_heartbeat_timeout as the primary safeguard. + + app_status(). Gets the app status. Initially, set to "unknown" until receipt of first "alive" + heartbeat (then, set to "alive"). Set to "dead" on first dead heart-beat. + + send_cmnd(data). Sends xPL message to target device using data hash. + + device_monitor(deviceinfo): constrains state updates to only messages w/ a devicekey=devicevalue + pair. A common example is where deviceinfo is set to 'someid'. In this case, state updates + are constrained to occur only when a message constains "device=someid". deviceinfo can also + take the literal 'somekey = someid' for messages that use a key other than the literal: 'device'. + + +=cut + + +@xPL_Item::ISA = ('Generic_Item'); + +=item $h = xPL_Item->new('tag', 'attrname' => 'value',...) + +The object constructor. Takes a tag name as argument. Optionally, +allows you to specify initial attributes at object creation time. + +=cut + + + # Support both send and receive objects +sub new { + my ($object_class, $xpl_source, @data, $xpl_class) = @_; + my $self = {}; + bless $self, $object_class; + + $xpl_source = '*' if !$xpl_source or $xpl_source eq '*'; + + $$self{state} = ''; + $$self{address} = $xpl_source; # left in place for legacy + $$self{address} = '*' if !$xpl_source; + $$self{target_address} = '*'; + $$self{class} = $xpl_class unless !$xpl_class; + $$self{m_timeoutHeartBeat} = 0; + $$self{m_appStatus} = 'unknown'; + $$self{m_timerHeartBeat} = new Timer(); + $$self{m_state_now_msg_type} = 'unknown'; + $$self{m_allow_empty_state} = 0; + + &xPL_Item::store_data($self, @data); + + $self->state_overload('off'); # By default, do not process ~;: strings as substate/multistate + + return $self; +} + +sub source { + my ($self, $p_strSource) = @_; + $$self{address} = $p_strSource if defined $p_strSource; + return $$self{address}; +} + +sub class_name { + + my ($self, $p_strClassName) = @_; + $$self{class} = $p_strClassName if defined $p_strClassName; + return $$self{class}; +} + +sub target_address { + my ($self, $p_strTarget) = @_; + $$self{target_address} = $p_strTarget if defined $p_strTarget; + return $$self{target_address}; +} + +sub device_name { + my ($self, $p_strDeviceName) = @_; + $$self{m_device_name} = $p_strDeviceName if $p_strDeviceName; + return $$self{m_device_name}; +} + +sub on_set_message { + my ($self, @data) = @_; + while (@data) { + my $section = shift @data; + my $ptr = shift @data; + my %parms = %$ptr; + for my $key (sort keys %parms) { + my $value = $parms{$key}; + $$self{_on_set_message}{$section}{$key} = $value; + } + } + return $$self{_on_set_message}; +} + +sub allow_empty_state { + my ($self, $p_allowEmptyState) = @_; + $$self{m_allow_empty_state} = $p_allowEmptyState if defined($p_allowEmptyState); + return $$self{m_allow_empty_state}; +} + +sub manage_heartbeat_timeout { + my ($self, $p_timeoutHeartBeat, $p_actionHeartBeat, $p_repeatAction) = @_; + if (defined($p_timeoutHeartBeat) and defined($p_actionHeartBeat)) { + my $m_repeatAction = 0; + $m_repeatAction = $p_repeatAction if $p_repeatAction; + $$self{m_actionHeartBeat} = $p_actionHeartBeat; + $$self{m_timeoutHeartBeat} = $p_timeoutHeartBeat; + $$self{m_timerHeartBeat}->set($$self{m_timeoutHeartBeat},$$self{m_actionHeartBeat}, $m_repeatAction); + $$self{m_timerHeartBeat}->start(); + } +} + +sub dead_action { + my ($self, $p_actionDeadApp) = @_; + $$self{m_app_Status} = 'dead'; + if (defined $p_actionDeadApp) { + $$self{m_actionDeadApp} = $p_actionDeadApp; + } + return $$self{m_actionDeadApp}; +} + +sub _handle_dead_app { + my ($self) = @_; + return eval $$self{m_actionDeadApp} if defined($$self{m_actionDeadApp}); +} + +sub _handle_alive_app { + my ($self) = @_; + $$self{m_appStatus} = 'alive'; + if ($$self{m_timeoutHeartBeat} != 0) { + $$self{m_timerHeartBeat}->restart() unless $$self{m_timerHeartBeat}->inactive(); + return 1; + } else { + $$self{m_timerHeartBeat}->stop() unless $$self{m_timerHeartBeat}->inactive(); + return 0; + } +} + +sub app_status { + my ($self) = @_; + return $$self{m_appStatus}; +} + +sub store_data { + my ($self, @data) = @_; + while (@data) { + my $section = shift @data; + $$self{class} = $section; + $$self{sections}{$section} = 'send'; + my $ptr = shift @data; + my %parms = %$ptr; + for my $key (sort keys %parms) { + my $value = $parms{$key}; + $$self{$section}{$key} = $value; + $$self{state_monitor} = "$section : $key" if $value eq '$state'; + } + } +} + +sub state_now { + my ($self, $section_name) = @_; + my $state_now = $self->SUPER::state_now(); + if ($section_name) { + # default section_state_now to undef unless it actually exists + my $section_state_now = undef; + for my $section (split(/\s+\|\s+/,$state_now)) { + my @section_data = split(/\s+:\s+/,$section); + my $section_ref = $section_data[0]; + next if $section_ref eq ''; + if ($section_ref eq $section_name) { + if (defined($section_state_now)) { + $section_state_now .= " | $section_data[1]"; + } else { + $section_state_now = $section_data[1]; + } + } + } + print "db xPL_Item:state_now: section data for $section_name is: $section_state_now\n" + if $main::Debug{xpl} and $section_state_now; + $state_now = $section_state_now; + } + return $state_now; +} + +sub current_section_names { + my ($self) = @_; + my $changed = $$self{changed}; + my $current_section_names = undef; + if ($changed) { + for my $section (split(/\s+\|\s+/,$changed)) { + my @section_data = split(/\s+:\s+/,$section); + if (defined($current_section_names)) { + $current_section_names .= " | $section_data[0]"; + } else { + $current_section_names = $section_data[0]; + } + } + + } + print "db xPL_Item:current_section_names : $current_section_names\n" if $main::Debug{xpl}; + return $current_section_names; +} + +sub tie_value_convertor { + my ($self, $key_name, $convertor) = @_; + $$self{_value_convertors}{$key_name} = $convertor if (defined($key_name) && defined($convertor)); + +} + + +sub device_monitor { + my ($self, $monitor_info) = @_; + if ($monitor_info) { + my ($key,$value) = $monitor_info =~ /(\S+)\s*=\s*(\S+)/; + if (!($value or $value =~ /^0/)) { + $value = ($key) ? $key : $monitor_info; + $key = 'device'; + } + $$self{_device_id} = lc $value; + $$self{_device_id_key} = lc $key; + } + if (defined $$self{_device_id}) { + return (($$self{_device_id_key}) ? $$self{_device_id_key} : 'device') . $$self{_device_id}; + } else { + return; + } +} + +sub default_setstate { + my ($self, $state, $substate, $set_by) = @_; + + # Send data, unless we are processing incoming data + return if $set_by =~ /^xpl/i; + + my @parms; + + if ($$self{_on_set_message}) { + for my $class_name (sort keys %{$$self{_on_set_message}}) { + my $block; + for my $msg_key (sort keys %{$$self{_on_set_message}{$class_name}}) { + my $field_value = eval($$self{_on_set_message}{$class_name}{$msg_key}); + $block->{$msg_key} = $field_value; + } + push @parms, $class_name, $block; + } + } else { + if ($$self{state_monitor}) { + foreach my $state_monitor (split(/\|/,$$self{state_monitor})) { + my ($section, $key) = $$self{state_monitor} =~ /(\S+)\s*[:=]\s*(\S+)/; + $$self{$section}{$key} = $state; + } + } + for my $section (sort keys %{$$self{sections}}) { + next unless $$self{sections}{$section} eq 'send'; # Do not echo received data + push @parms, $section, $$self{$section}; + } + } + + if (@parms) { + # sending stat info about ourselves? + if (lc $$self{source} eq &xPL::get_xpl_mh_source_info()) { + $self->send_trig(@parms); + } else { + # must be cmnd info to another device addressed by address + $self->send_cmnd(@parms); + } + } +} + +sub state_now_msg_type { + my ($self, $p_msgType) = @_; + $$self{m_state_now_msg_type} = $p_msgType if defined($p_msgType); + return $$self{m_state_now_msg_type}; +} + +# DO NOT use the following sub +# Instead, DO use either send_cmnd, send_trig or send_stat +sub send_message { + my ($self, $p_strTarget, @p_data) = @_; + $self->send_cmnd(@p_data); +} + +sub send_cmnd { + my ($self, @p_data) = @_; + if (defined $$self{_device_id}) { + my $classname = shift @p_data; + my $ptr = shift @p_data; + my @new_data = (); + $ptr->{$$self{_device_id_key}} = $$self{_device_id}; + push @new_data, $classname, $ptr; + &xPL::sendXpl($self->source, 'cmnd', @new_data); + } else { + &xPL::sendXpl($self->source, 'cmnd', @p_data); + } +} + +sub send_stat { + my ($self, @p_data) = @_; + if (defined $$self{_device_id}) { + my $classname = shift @p_data; + my $ptr = shift @p_data; + my @new_data = (); + $ptr->{$$self{_device_id_key}} = $$self{_device_id}; + push @new_data, $classname, $ptr; + &xPL::sendXpl('*', 'stat', @new_data); + } else { + &xPL::sendXpl('*', 'stat', @p_data); + } +} + +sub send_trig { + my ($self, @p_data) = @_; + if (defined $$self{_device_id}) { + my $classname = shift @p_data; + my $ptr = shift @p_data; + my @new_data = (); + $ptr->{$$self{_device_id_key}} = $$self{_device_id}; + push @new_data, $classname, $ptr; + &xPL::sendXpl('*', 'trig', @new_data); + } else { + &xPL::sendXpl('*', 'trig', @p_data); + } +} + +sub ignore_message { + my ($self, $p_data) = @_; + my $ignore_message = 0; + if ($$self{_device_id_key} and $self->class_name) { + print "Device monitoring enabled: key=$$self{_device_id_key}, id=$$self{_device_id}, tested value=" + . $$p_data{$self->class_name}{$$self{_device_id_key}} . "\n" if $main::Debug{xpl}; + $ignore_message = ($$self{_device_id} ne lc $$p_data{$self->class_name}{$$self{_device_id_key}}) ? 1 : 0; + } + return $ignore_message; +} + +package xPL_Sensor; + +@xPL_Sensor::ISA = ('xPL_Item'); + +sub new { + my ($class, $p_source, $p_type, $p_statekey) = @_; + my ($source,$deviceid) = $p_source =~ /(\S+)?:([\S ]+)/; + $source = $p_source unless $source; + my $self = $class->SUPER::new($source); + $$self{sensor_type} = $p_type if $p_type; + my $statekey = 'current'; + $statekey = $p_statekey if $p_statekey; + $self->SUPER::class_name('sensor.basic'); + $$self{state_monitor} = "sensor.basic : $statekey"; + $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; + return $self; +} + +sub type { + my ($self, $p_type) = @_; + $$self{sensor_type} = $p_type if $p_type; + return $$self{sensor_type}; +} + +sub current { + my ($self) = @_; + return $$self{'sensor.basic'}{current}; +} + +sub units { + my ($self) = @_; + return $$self{'sensor.basic'}{units}; +} + +sub lowest { + my ($self) = @_; + return $$self{'sensor.basic'}{lowest}; +} + +sub highest { + my ($self) = @_; + return $$self{'sensor.basic'}{highest}; +} + + +sub ignore_message { + my ($self, $p_data) = @_; + return 1 if $self->SUPER::ignore_message($p_data); # user xPL_Item's filter against deviceid + return ($$p_data{'sensor.basic'}{type} ne $$self{sensor_type}) ? 1 : 0; +} + +sub request_stat { + my ($self) = @_; + $self->SUPER::send_cmnd('sensor.request' => { 'request' => 'current', 'type' => "'$$self{sensor_type}'"}); +} + +package xPL_UPS; + +@xPL_UPS::ISA = ('xPL_Item'); + +sub new { + my ($class, $p_source, $p_statekey) = @_; + my ($source,$deviceid) = $p_source =~ /(\S+):(\S+)/; + $source = $p_source unless $source; + my $self = $class->SUPER::new($source); + my $statekey = $p_statekey; + $statekey = 'status'; +# $self->SUPER::class_name('ups.basic'); + $$self{state_monitor} = "ups.basic : $statekey|hbeat.app : $statekey"; + $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; + return $self; +} + +sub status { + my ($self, $p_status) = @_; + return ($$self{'ups.basic'}{status}) ? $$self{'ups.basic'}{status} : $$self{'hbeat.app'}{status}; +} + +sub event { + my ($self) = @_; + return $$self{'ups.basic'}{event}; +} + +sub ignore_message { + my ($self, $p_data) = @_; + return 1 if $self->SUPER::ignore_message($p_data); # user xPL_Item's filter against deviceid + return ($$p_data{'ups.basic'} or $$p_data{'hbeat.app'}) ? 0 : 1; +} + +package xPL_X10Security; + +@xPL_X10Security::ISA = ('xPL_Item'); + +sub new { + my ($class, $p_source, $p_type, $p_statekey) = @_; + my ($source,$deviceid) = $p_source =~ /(\S+):(\S+)/; + $source = $p_source unless $source; + my $self = $class->SUPER::new($source); + $$self{type} = $p_type if $p_type; + my $statekey = $p_statekey; + $statekey = 'command'; + $self->SUPER::class_name('x10.security'); + $$self{state_monitor} = "x10.security : $statekey"; + $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; + return $self; +} + +sub type { + my ($self, $p_type) = @_; + $$self{type} = $p_type if $p_type; + return $$self{type}; +} + +sub command { + my ($self) = @_; + return $$self{'x10.security'}{command}; +} + +sub tamper { + my ($self) = @_; + return $$self{'x10.security'}{tamper}; +} + +sub low_battery { + my ($self) = @_; + return $$self{'x10.security'}{'low-battery'}; +} + +sub delay { + my ($self) = @_; + return $$self{'x10.security'}{delay}; +} + +sub ignore_message { + my ($self, $p_data) = @_; + return 1 if $self->SUPER::ignore_message($p_data); # user xPL_Item's filter against deviceid + if ($$self{type}) { + return ($$p_data{'x10.security'}{type} ne $$self{type}) ? 1 : 0; + } else { + return 0; + } +} + + +package xPL_Rio; + +@xPL_Rio::ISA = ('xPL_Item'); + + # Support both send and receive objects +sub new { + my ($object_class, $xpl_source, $xpl_target) = @_; + my $self = {}; + bless $self, $object_class; + + $$self{state} = ''; + $$self{source} = $xpl_source; + $$self{target_address} = $xpl_target unless !$xpl_target; + + &xPL_Item::store_data($self, 'rio.basic' => {sel => '$state'}); + + @{$$self{states}} = ('play', 'stop', 'mute' , 'volume +20' , 'volume -20', 'volume 100' , + 'skip', 'back', 'random' ,'power on', 'power off', 'light on', 'light off'); + + return $self; + +} + +1; \ No newline at end of file From 9b073948750c0ca910b12894a313df71f735813c Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 5 Jan 2011 22:00:58 +0000 Subject: [PATCH 016/150] Refactor code specific to KeyPadLinc out of BaseController. Add set_with_timer to BaseController. --- lib/Insteon/BaseInsteon.pm | 182 +++++++++++++++++++++++++------------ lib/Insteon/Lighting.pm | 70 ++++++++++++++ 2 files changed, 193 insertions(+), 59 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index bd217e2b7..8728678be 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -40,6 +40,24 @@ our %message_types = ( off => 0x13 ); +sub derive_link_state +{ + my ($p_state) = @_; + + my $link_state = 'on'; + if ($p_state eq 'off') + { + $link_state = 'off'; + } + elsif ($p_state =~ /\d+%?/) + { + my ($dim_state) = $p_state =~ /(\d+)%?/; + $link_state = 'off' if $dim_state == 0; + } + + return $link_state; +} + sub new { my ($class,$p_deviceid,$p_interface) = @_; @@ -1214,75 +1232,94 @@ sub set { my ($self, $p_state, $p_setby, $p_respond) = @_; # prevent reciprocal setby loops - return if (ref $p_setby and ($p_setby ne $self) and $p_setby->can('get_set_by') and + return -1 if (ref $p_setby and ($p_setby ne $self) and $p_setby->can('get_set_by') and $p_setby->{set_by} eq $self); - return if &main::check_for_tied_filters($self, $p_state); + return -1 if &main::check_for_tied_filters($self, $p_state); # prevent setby internal Insteon_Device timers - return if $p_setby eq $$self{ping_timer}; + return -1 if $p_setby eq $$self{ping_timer}; - my $link_state = 'on'; - if ($p_state eq 'off') { - $link_state = 'off'; - } elsif ($p_state =~ /\d+%?/) { - my ($dim_state) = $p_state =~ /(\d+)%?/; - $link_state = 'off' if $dim_state == 0; - } -# if ($self->isa('Insteon::InterfaceController') or !($self->is_root)) { - # iterate over the members - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my $member = $$self{members}{$member_ref}{object}; - my $on_state = $$self{members}{$member_ref}{on_level}; - $on_state = '100%' unless $on_state; - my $local_state = $on_state; - $local_state = 'on' if $local_state eq '100%' - && $member->isa('Insteon::BaseDevice') && !($member->is_root); - $local_state = 'off' if $local_state eq '0%' or $link_state eq 'off'; - if ($member->isa('Light_Item')) { - # if they are Light_Items, then set their on_dim attrib to the member on level - # and then "blank" them via the manual method for a tad over the ramp rate - # In addition, locate the Light_Item's Insteon_Device member and do the - # same as if the member were an Insteon_Device - my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $ramp_rate = 0 unless defined $ramp_rate; - $ramp_rate = $ramp_rate + 2; - my @lights = $member->find_members('Insteon::BaseDevice'); - if (@lights) { - my $light = @lights[0]; - # remember the current state to support resume - $$self{members}{$member_ref}{resume_state} = $light->state; - $member->manual($light, $ramp_rate); - $light->set_receive($local_state,$self); - } else { - $member->manual(1, $ramp_rate); - } - $member->set_on_state($local_state) unless $link_state eq 'off'; - } elsif ($member->isa('Insteon::BaseDevice')) { - # remember the current state to support resume - $$self{members}{$member_ref}{resume_state} = $member->state; - # if they are Insteon_Device objects, then simply set_receive their state to - # the member on level - $member->set_receive($local_state,$self); + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + $self->set_linked_devices($link_state); + + return 0; +} + +sub set_linked_devices +{ + my ($self, $link_state) = @_; + # iterate over the members + if ($$self{members}) + { + foreach my $member_ref (keys %{$$self{members}}) + { + my $member = $$self{members}{$member_ref}{object}; + my $on_state = $$self{members}{$member_ref}{on_level}; + $on_state = '100%' unless $on_state; + my $local_state = $on_state; + $local_state = 'on' if $local_state eq '100%' + && $member->isa('Insteon::BaseDevice') && !($member->is_root); + $local_state = 'off' if $local_state eq '0%' or $link_state eq 'off'; + if ($member->isa('Light_Item')) + { + # if they are Light_Items, then set their on_dim attrib to the member on level + # and then "blank" them via the manual method for a tad over the ramp rate + # In addition, locate the Light_Item's Insteon_Device member and do the + # same as if the member were an Insteon_Device + my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $ramp_rate = 0 unless defined $ramp_rate; + $ramp_rate = $ramp_rate + 2; + my @lights = $member->find_members('Insteon::BaseDevice'); + if (@lights) + { + my $light = @lights[0]; + # remember the current state to support resume + $$self{members}{$member_ref}{resume_state} = $light->state; + $member->manual($light, $ramp_rate); + $light->set_receive($local_state,$self); + } + else + { + $member->manual(1, $ramp_rate); } + $member->set_on_state($local_state) unless $link_state eq 'off'; + } + elsif ($member->isa('Insteon::BaseDevice')) + { + # remember the current state to support resume + $$self{members}{$member_ref}{resume_state} = $member->state; + # if they are Insteon_Device objects, then simply set_receive their state to + # the member on level + $member->set_receive($local_state,$self); } } -# } - if (($self->isa("Insteon::KeyPadLinc") or $self->isa("Insteon::KeyPadLincRelay"))and !($self->is_root)) { - if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) { - $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); - } elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) { - $$self{surrogate}->set($link_state, $p_setby, $p_respond) - unless ref $p_setby and $p_setby eq $self; - } else { - &::print_log("[Insteon::BaseController] You may not directly attempt to set a keypadlinc's button " - . " unless you have defined a reverse link with the \"surrogate\" keyword"); - } - } else { - $self->Insteon::BaseObject::set((($self->is_root) ? $p_state : $link_state), $p_setby, $p_respond); } + + } +sub set_with_timer { + my ($self, $state, $time, $return_state, $additional_return_states) = @_; + return if &main::check_for_tied_filters($self, $state); + + $self->set($state) unless $state eq ''; + + return unless $time; + + my $state_change = ($state eq 'off') ? 'on' : 'off'; + $state_change = $return_state if defined $return_state; + $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; + + $state_change .= ';' . $additional_return_states if $additional_return_states; + + $$self{set_timer} = &Timer::new() unless $$self{set_timer}; + my $object_name = $self->{object_name}; + my $action = "$object_name->set('$state_change')"; + $$self{set_timer}->set($time, $action); +} + + sub update_members { my ($self) = @_; @@ -1387,6 +1424,21 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + $self->Insteon::BaseObject::set((($self->is_root) ? $p_state : $link_state), $p_setby, $p_respond); + + return 0; +} + + sub request_status { my ($self,$requestor) = @_; @@ -1486,6 +1538,18 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + + return 0; +} + sub is_root { return 0; diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index 9ba9e4e94..92d9cf136 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -246,6 +246,42 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + if (!($self->is_root)) + { + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) + { + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + } + elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) + { + $$self{surrogate}->set($link_state, $p_setby, $p_respond) + unless ref $p_setby and $p_setby eq $self; + } + else + { + &::print_log("[Insteon::KeyPadLinc] You may not directly attempt to set a keypadlinc's button " + . "unless you have defined a reverse link with the \"surrogate\" keyword"); + } + } + else + { + return $self->Insteon::DeviceController::set($link_state, $p_setby, $p_respond); + } + + return 0; + +} + + package Insteon::KeyPadLinc; use strict; @@ -262,5 +298,39 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + if (!($self->is_root)) + { + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) + { + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + } + elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) + { + $$self{surrogate}->set($link_state, $p_setby, $p_respond) + unless ref $p_setby and $p_setby eq $self; + } + else + { + &::print_log("[Insteon::KeyPadLinc] You may not directly attempt to set a keypadlinc's button " + . "unless you have defined a reverse link with the \"surrogate\" keyword"); + } + } + else + { + return $self->Insteon::DeviceController::set($p_state, $p_setby, $p_respond); + } + + return 0; + +} 1 From 69b2d4e601a4ce423fbd83760f0c4ca7be7fe27b Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 5 Jan 2011 22:31:04 +0000 Subject: [PATCH 017/150] Change broken references to convert_ramp --- lib/Insteon/BaseInsteon.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 8728678be..9e51818da 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -969,7 +969,7 @@ sub local_ramprate { my ($self, $p_ramprate) = @_; if (defined $p_ramprate) { - $$self{_ramprate} = &Insteon::BaseDevice::convert_ramp($p_ramprate); + $$self{_ramprate} = &Insteon::DimmableLight::convert_ramp($p_ramprate); } return $$self{_ramprate}; @@ -1134,7 +1134,7 @@ sub sync_links $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; my $link_on_level = hex($$member{adlb}{$adlbkey}{data1})/2.55; my $raw_ramp_rate = $$member{adlb}{$adlbkey}{data2}; - my $raw_tgt_ramp_rate = &Insteon::BaseDevice::convert_ramp($tgt_ramp_rate); + my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); if ($raw_ramp_rate != $raw_tgt_ramp_rate) { $requires_update = 1; } elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) { From 7ad4080eeb82c3b914704dc14416850cf0b716b8 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 6 Jan 2011 19:04:59 +0000 Subject: [PATCH 018/150] Send xAP messages via a queue to throttle send rates. --- lib/Insteon.pm | 22 +++++--------- lib/xAP_Items.pm | 77 ++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 72 insertions(+), 27 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 45bbba62a..4575282a2 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -34,22 +34,9 @@ sub _get_next_linkscan my $current_obj = $_scan_devices[0]; my $next_obj = $current_obj; -# my @devices = (); -# push @devices,@_insteon_plm; -# push @devices,@_insteon_device; -# push @devices,@_scannable_link; -# my $dev_cnt = @devices; -# my $return_next = ($current_name) ? 0 : 1; -# my $next_name = undef; - -# if ($current_name) { -# for (my $i=0; $i<$dev_cnt; $i++) { -# if ($devices[$i] eq $current_name) { - if ($_scan_failure_cnt == 0) { + if ($_scan_failure_cnt == 0) { # get the next -# $next_name = $devices[$i+1] if $i+1 < $dev_cnt; $next_obj = shift @_scan_devices; -# $_scan_cnt = $i + 2; $_scan_cnt += 1; # remove the queue_timer_callback # my $current_obj = &main::get_object_by_name($current_name); @@ -57,7 +44,6 @@ sub _get_next_linkscan # $current_obj->queue_timer_callback(''); } # don't try to scan devices that are not responders -# my $next_obj = &main::get_object_by_name($next_name); while (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { &main::print_log("[Scan all link tables] " . $next_obj->get_object_name . " is not a candidate for scanning. Moving to next"); @@ -208,6 +194,11 @@ sub init { @_insteon_device = (); @_insteon_link = (); +} + +sub generate_voice_commands +{ + my $insteon_menu_states = $main::config_parms{insteon_menu_states} if $main::config_parms{insteon_menu_states}; &main::print_log("Generating Voice commands for all Insteon objects"); my $object_string; @@ -386,6 +377,7 @@ sub _active_interface &main::Reload_post_add_hook(\&Insteon::BaseInterface::poll_all, 1); $Insteon::init_complete = 0; &main::MainLoop_pre_add_hook(\&Insteon::init, 1); + &main::Reload_post_add_hook(\&Insteon::generate_voice_commands, 1); } $$self{active_interface} = $interface if $interface; return $$self{active_interface}; diff --git a/lib/xAP_Items.pm b/lib/xAP_Items.pm index 3c6d6284b..362f19d14 100644 --- a/lib/xAP_Items.pm +++ b/lib/xAP_Items.pm @@ -28,7 +28,7 @@ package xAP; #se IO::Socket::INET; # Gives us the INADDR constants, but not in perl 5.0 :( -my (@xap_item_names, $started, $xap_listen, $xap_hub_listen, $xap_send, %hub_ports, %xap_uids, %xap_virtual_devices, $xap_hbeat_interval, $xap_hbeat_counter); +my (@xap_item_names, $started, $xap_listen, $xap_hub_listen, $xap_send, %hub_ports, %xap_uids, %xap_virtual_devices, $xap_hbeat_interval, $xap_hbeat_counter, @send_queue, %timeouts, $send_queue_timeout); use vars '$xap_data'; # XAP_REAL_DEVICE_NAME is the default device name that appears in the last field of the primary source address @@ -40,6 +40,8 @@ sub startup { return if $started++; # Allows us to call with $Reload or with xap_module mh.ini parm @xap_item_names = (); + @send_queue = (); + %timeouts = {}; # In case you don't want xap for some reason return if $::config_parms{xap_disable}; @@ -51,6 +53,11 @@ sub startup { $xap_hbeat_counter = $xap_hbeat_interval; if (!($::config_parms{xap_disable})) { + + $send_queue_timeout = $::config_parms{xap_send_interval}; + $send_queue_timeout = 50 unless $send_queue_timeout; + &_set_timeout('send_queue',$send_queue_timeout); + #$last_xap_subaddress_uid = 0; $port = $::config_parms{xap_port}; $port = 3639 unless $port; @@ -192,7 +199,7 @@ sub main::display_xap_osd_display_tivo my ($text_block, @xap_data); my $text = ($args{raw_text}) ? $args{raw_text} : $args{text}; $text =~ s/[\n\r ]+/ /gm; # strip out new lines and extra space - $text_block->{text} = + $text_block->{text} = $duration = $args{duration}; $duration = $args{display} unless $duration; # this apparently is the original param? $duration = 10 unless $duration; # default to 10 sec display @@ -262,7 +269,7 @@ sub open_port { PeerAddr => $dest_address, Broadcast => 1); } else { - my $listen_address = $::config_parms{'ipaddress_xap'}; + my $listen_address = $::config_parms{'ipaddress_xap'}; if ($main::OS_win) { $listen_address = $::Info{IPAddress_local} unless $listen_address; } else { @@ -321,6 +328,21 @@ sub check_for_data { } } } + + # check to see if any xAP message need to be sent + if (&_check_timeout('send_queue') == 1) + { + my $message_count = @send_queue; + if ($xap_send && $message_count) { + # check to see if the socket is still valid + my $msg = shift @send_queue; + if (!($::Socket_Ports{'xap_send'}{socka})) { + &xAP::_handleStaleXapSockets(); + } + $xap_send->set($msg) if $::Socket_Ports{'xap_send'}{socka}; + } + &_set_timeout('send_queue',$send_queue_timeout); + } } # Parse incoming xAP records @@ -766,13 +788,15 @@ sub sendXapWithHeaderVars { $msg .= "}\n"; } print "db5 xap msg: $msg" if $main::Debug{xap} and $main::Debug{xap} == 5; - if ($xap_send) { +# if ($xap_send) { # check to see if the socket is still valid - if (!($::Socket_Ports{'xap_send'}{socka})) { - &xAP::_handleStaleXapSockets(); - } - $xap_send->set($msg) if $::Socket_Ports{'xap_send'}{socka}; - } +# if (!($::Socket_Ports{'xap_send'}{socka})) { +# &xAP::_handleStaleXapSockets(); +# } +# $xap_send->set($msg) if $::Socket_Ports{'xap_send'}{socka}; +# } + push @send_queue, $msg; + } else { print "WARNING! xAP is disabled and you are trying to send xAP data!! (xAP::sendXapWIthHeaderVars())\n"; } @@ -792,12 +816,41 @@ sub send_xap_heartbeat { $msg .= "source=" . &xAP::get_xap_mh_source_info($base_ref) . "\n"; $msg .= "interval=$xap_hbeat_interval_in_secs\nport=$port\npid=$$\n}\n"; # check to see if all of the sockets are still valid - &xAP::_handleStaleXapSockets(); - $xap_send->set($msg) if $::Socket_Ports{'xap_send'}{socka}; +# &xAP::_handleStaleXapSockets(); +# $xap_send->set($msg) if $::Socket_Ports{'xap_send'}{socka}; + push @send_queue, $msg; print "db6 xap heartbeat: $msg.\n" if $main::Debug{xap} and $main::Debug{xap} == 6; } } + ################################# + ### INTERNAL METHODS/FUNCTION ### +################################# + +sub _set_timeout +{ + my ($timeout_name, $timeout_in_millis) = @_; + my $tickcount = &main::get_tickcount + $timeout_in_millis; + $tickcount += 2**32 if $tickcount < 0; # force a wrap; to be handleded by check timeout + $timeouts{$timeout_name} = $tickcount; +} + +sub _check_timeout +{ + my ($timeout_name) = @_; + return 0 unless $timeout_name; + return -1 unless defined $timeouts{$timeout_name}; + my $current_tickcount = &main::get_tickcount; + return 0 if (($current_tickcount >= 2**16) and ($timeouts{$timeout_name} < 2**16)); + return ($current_tickcount > $timeouts{$timeout_name}) ? 1 : 0; +} + +sub _clear_timeout +{ + my ($timeout_name) = @_; + $timeouts{$timeout_name} = undef; +} + sub _handleStaleXapSockets { # check main sending socket @@ -1115,4 +1168,4 @@ sub tie_value_convertor { } -1; +1; \ No newline at end of file From ac72395f924cb9b261ac04ee4f377286aa263fbc Mon Sep 17 00:00:00 2001 From: jduda Date: Sun, 9 Jan 2011 19:24:51 +0000 Subject: [PATCH 019/150] Merge changes from trunk to insteon-branch. --- bin/ical2vsdb | 57 +- bin/mh | 984 +------ bin/mh.ini | 28 +- bin/update_docs | 288 +- bin/update_docs.bat | 28 +- code/common/internet_earthquakes.pl | 25 +- code/common/internet_im.pl | 5 + code/common/internet_mail.pl | 280 +- code/common/internet_weather.pl | 8 +- code/common/mh_control.pl | 733 ++--- code/common/monitor_actiontec_mi424wr.pl | 603 ++-- code/common/monitor_memory.pl | 85 +- code/common/organizer.pl | 1 + code/common/photo_index.pl | 35 +- code/common/proxy_client_server.pl | 4 +- code/common/tk_widgets.pl | 3 +- code/common/weather_metar.pl | 6 +- code/common/weather_weatherbug.pl | 8 +- code/public/Brian/klier.pl | 1025 +++++-- code/public/Brian/pageme.pl | 68 +- code/public/Brian/statuspanel.pl | 54 +- code/public/Brian/statuspanel.shtml | 2 +- code/public/Brian/tracking.nam | 12 +- code/public/Brian/tracking.pl | 470 ++- code/public/Brian/tracking.pos | 64 +- code/public/cbus.pl | 39 +- code/public/hvac_brian_newhvac.pl | 2 +- code/public/internet_usgs.pl | 2 +- code/public/v4l_radio.pl | 4 +- code/support/README | 4 + code/support/hai-omnistat/INSTALL | 9 + docs/mh.pod | 2513 ++-------------- docs/updates.pod | 6 +- lib/File_Item.pm | 213 +- lib/Generic_Item.pm | 1163 ++++++-- lib/Insteon.pm | 1 + lib/Insteon_Irrigation.pm | 11 +- lib/Light_Item.pm | 48 +- lib/Omnistat.pm | 14 +- lib/UPBPIM.pm | 54 +- lib/Voice_Text.pm | 6 +- lib/Weather_Common.pm | 32 +- lib/X10_RF.pm | 34 +- lib/X10_RF_rfxsensor.pm | 115 +- lib/handy_net_utilities.pl | 15 +- lib/handy_tk_utilities.pl | 1301 +++++++++ lib/handy_utilities.pl | 135 +- lib/http_server.pl | 12 +- lib/site/HTML/TableExtract.pm | 2568 ++++++++--------- lib/site/MIME/Lite.pm | 3309 ++++++++++++++++------ lib/site/OW.pm | 13 +- lib/trigger_code.pl | 327 ++- lib/xml_server.pl | 55 +- web/bin/button_action.pl | 5 +- web/bin/floorplan.pl | 35 +- web/bin/floorplan_svg.pl | 153 +- web/bin/iniedit.pl | 3 +- web/default.css | 4 + web/mh4/top.shtml | 2 +- web/misc/alarms.shtml | 2 +- web/misc/empty.html | 4 +- web/misc/mp3.html | 6 +- web/misc/mplist.html | 5 +- web/misc/mpnowplay.html | 4 +- web/misc/timers.shtml | 2 +- 65 files changed, 9577 insertions(+), 7529 deletions(-) create mode 100644 lib/handy_tk_utilities.pl diff --git a/bin/ical2vsdb b/bin/ical2vsdb index 7063ff57f..591549c59 100755 --- a/bin/ical2vsdb +++ b/bin/ical2vsdb @@ -13,6 +13,10 @@ use strict; ## All other libs should exist w/i the core mh lib/site dir structure ## +## Changelog 3.4 10-04-06: for some reason ical parser is adding an 'ical' level in the +## ical parse hash from a Darwin Calendar Server. Added a dcsfix option + + use lib '../lib', '../lib/site'; use iCal::Parser; use DateTime; @@ -31,7 +35,7 @@ use vsLock; my $progname = "ical2vsdb"; -my $progver = "v3.1 08-07-14"; +my $progver = "v3.4 10-04-06"; my $DB = 0; my $days_before = 180; # defaults to avoid large vsdb databases, can be overriden @@ -164,6 +168,10 @@ while (1) { $data =~ s/CREATED:(.*)\n/CREATED:$1\nDTSTAMP:$1\n/g; } +# Ical:DateTime chokes on trigger appointments with 0 time + $data =~ s/TRIGGER:P(.*)0(.*)\n/TRIGGER:-PT1M\n/g; +#print "\n\n$data\n"; + my $digest = md5_hex($data); # print "Debug: MD5=$digest\n"; @@ -172,21 +180,27 @@ while (1) { if (!(defined $ical_data[$loop]->{hash}) or ($ical_data[$loop]->{hash} ne $digest)) { print "New Calendar entries. Processing iCal..."; if ($ical_data[$loop]->{method} ne "dir") { - $parser->parse_strings($data); - $parser = $parser->calendar; + eval {$parser->parse_strings($data); }; } - print "."; - $ical_data[$loop]->{hash} = $digest; - my ($data_info, $data_cals, $data_todos) = parse_cal($parser, $ical_data[$loop]->{options}); - push (@changed_icals, @$data_info[0]); - push (@master_cal, @$data_cals); - push (@master_todo, @$data_todos); - print "."; - &cache_local($data,$ical_data[$loop]->{options}->{name}) if $local_cache; - print "done\n"; - print "Calendar Info:" if $DB; - print @$data_info[0] . "," . @$data_info[1] . "\n" if $DB; + if ($@) { + print "Error parsing strings. ICal ignored\n"; + print "Error: $@\n"; } else { + $parser = $parser->calendar unless $ical_data[$loop]->{method} ne "dir"; + print "."; +#print Dumper $parser; + $ical_data[$loop]->{hash} = $digest; + my ($data_info, $data_cals, $data_todos) = parse_cal($parser, $ical_data[$loop]->{options}); + push (@changed_icals, @$data_info[0]); + push (@master_cal, @$data_cals); + push (@master_todo, @$data_todos); + print "."; + &cache_local($data,$ical_data[$loop]->{options}->{name}) if $local_cache; + print "done\n"; + print "Calendar Info:" if $DB; + print @$data_info[0] . "," . @$data_info[1] . "\n" if $DB; + } + } else { print "iCal unchanged, no processing required.\n"; } } @@ -291,7 +305,8 @@ sub parse_cal { $opt_holiday = 1 if (exists $options->{holiday}); $opt_vacation = 1 if (exists $options->{vacation}); my ($opt_sourcename) = $options->{name} if (defined $options->{name}); - + $cal = $cal->{ical} if (exists $options->{dcsfix}); + print "Fixing Darwin Calendar Server Settings...\n" if ($DB and (exists $options->{dcsfix})); my $calname = $cal->{cals}->[0]->{'X-WR-CALNAME'}; $calname = $opt_sourcename if $opt_sourcename; @@ -312,6 +327,7 @@ sub parse_cal { push @out_info, $caldesc; my $count = 0; +#print Dumper $cal; while (my $year = each %{$cal->{events}}) { while (my $month = each %{$cal->{events}->{$year}}) { while (my $day = each %{$cal->{events}->{$year}->{$month}}) { @@ -400,7 +416,16 @@ sub parse_cal { $count = 0; foreach my $todo (@{$cal->{todos}}) { my $completed = "No"; - $completed = "Yes" if ($todo->{STATUS} && $todo->{STATUS} eq "COMPLETED"); + if (defined $todo->{STATUS}) { + $completed = "Yes" if ($todo->{STATUS} eq "COMPLETED"); + } + $completed = "Yes" if (defined $todo->{COMPLETED}); #some older ical servers don't have status + print "db: task=" . $todo->{SUMMARY} . " status=" if ($DB); + print $todo->{STATUS} if ((defined $todo->{STATUS}) and ($DB)); + print " complete=" if ($DB); + print $todo->{COMPLETED} if ((defined $todo->{COMPLETED}) and ($DB)); + print " completed=$completed\n" if ($DB); + my $duedate = ''; my $duetime = ''; my $startdate = ''; diff --git a/bin/mh b/bin/mh index 6bf3d516e..eec9d1b34 100755 --- a/bin/mh +++ b/bin/mh @@ -115,6 +115,7 @@ 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); +use vars qw(%Run_Members); my ($Pgm_PathU); my ($Loop_Speed, @Loop_Speeds, $Loop_Sleep_Time, $Loop_Tk_Passes); @@ -685,7 +686,9 @@ sub setup { use constant MOTION => 'motion'; use constant STILL => 'still'; - require 'handy_net_utilities.pl'; # For misc. net functions (e.g. net_mail_read) + # For misc. net functions (e.g. net_mail_read) + require 'handy_net_utilities.pl'; + require 'handy_tk_utilities.pl'; # require 'console_utils.pl'; require 'http_server.pl'; require 'xml_server.pl'; @@ -4072,7 +4075,7 @@ sub process_external_command { return 1; } -my (@prev_x10_events, %prev_x10_units, $prev_x10_units_reset); +my (@prev_x10_events, %prev_x10_units, $prev_x10_units_reset, %x10_dim_bright_last_housecode_device); sub process_serial_data { my ($event_data, $prev_pass, $source) = @_; @@ -4197,7 +4200,8 @@ sub process_serial_data { 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"; + #print "db et=$event_type ed=$event_data o=$ref->{object_name}\n"; + #outputs: db et=X ed=XA1AK o=$testx10 if ($state = $$ref{state_by_id}{$event_data}) { set_receive $ref $state, $source; print "Serial event=$event_data state=$state\n" if $Debug{serial}; @@ -4223,16 +4227,51 @@ sub process_serial_data { 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 + + # X10RF remotes/senders like HR12A and SS13A do not actually send XA2AL unfortunately, + # they only send XAL/XAM and this code has to remember which device was last used and assign + # the dim/brighten command to that code (Excellent design, isn't it? :( ) -- merlin 2010/10/10 + # If the code below captured the last device for this housecode, we use this partial + # dim/brighten code and pretend we got a full XA2AL instead of XA2AK some time in the past + # and then XAL now. + # Note that this will NOT work if your X10 device isn't defined as an X10SL or some other X10 + # device that defines XA1A[LM] codes. + if ($event_data =~ /^X([A-P])([LM])$/) { + my ($housecode, $dim_bright_c) = ($1, $2); + my $dim_bright = ($dim_bright_c eq "M") ? "dim" : "brighten"; + my $device = $x10_dim_bright_last_housecode_device{$housecode}; + my $X10_device = "X$housecode$device"; + + if ($device) { + $event_data = "$X10_device$housecode$dim_bright_c"; + + print_log "X10: House code $housecode got $dim_bright for reconstituted last used device $device from $source, pretending we received $event_data" if $config_parms{x10_errata} >= 2; + } + else + { + print_log "X10: Got $event_data, but cannot $dim_bright anything because no prior device was actuated for house code $housecode" if $config_parms{x10_errata} >= 2; + } + } + + # As mentionned above, the simple X10 dim/bright commands from X10RF remotes only send a house code and + # dim (L) or bright (M) like so: XAL to dim the last device used on house code A. + # So, we keep track of the last device used on each house code in case we get dim/bright later. -- merlin + if ($event_data =~ /^X([A-P])([0-9A-G])[A-P][JK]$/) { + my ($housecode, $device) = ($1, $2); + + $x10_dim_bright_last_housecode_device{$housecode} = $device + } + + # 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); + 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; @@ -4290,7 +4329,6 @@ sub process_serial_data { } } - # Check for multi-key X10 commands (e.g. XA1 XAJ -> XA1AJ) # Optional, to allow for external code to take care of this @@ -4302,6 +4340,14 @@ sub process_serial_data { $prev_x10_event = $prev_x10_events[$i]{data} . $prev_x10_event; } } + + + # items_by_id isn't very documented, but depending on which kind of X10 device is defined, it + # contains a bunch of keys for which X10 commands that device can be responsible for (since you + # can have more than one device linked to the same X10 code). + # For instance, if you have an X10 device defined as X10SL, device_Item defines a lot of keys like these: + # XA2 XA2AJAJ XA2AKAK XA2AJAJAJ XA2AKAKAK XA2AM XA2ASTATUS XA2ASTATUS_ON XA2ASTATUS_OFF (...) + # A device that can't emit dimmable codes for instance would be missing those keys: XA2AL XA2AM 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; @@ -4858,7 +4904,7 @@ sub read_user_code { # 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 =~ /#\s*noloop\s*$/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' @@ -4981,9 +5027,9 @@ sub read_user_code_loopcode { " if (\$Run_Members{'$member_name'} > $allowed_errors) { # 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 }". - " elsif (\$Run_Members{'$member_name'} > 2 and \$Run_Members{'$member_name'} != \$Run_Members_Error_Count{$member_name} ) {\n". + " elsif (\$Run_Members{'$member_name'} > 2 and \$Run_Members{'$member_name'} != \$Run_Members_Error_Count{'$member_name'} ) {\n". " display(\$Run_Members{'$member_name'}.' eval errors in $member_name out of $allowed_errors allowed before disable') }\n". - " \$Run_Members_Error_Count{$member_name} = \$Run_Members{'$member_name'};\n". + " \$Run_Members_Error_Count{'$member_name'} = \$Run_Members{'$member_name'};\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 . @@ -6387,210 +6433,6 @@ 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('' => sub{ play 'fun/service.wav'}); - - $win->activate(); - } -} - -sub tk_setup_windows { - # See perl/bin/widget.bat for lots of examples - print " - setting up the main window\n"; - eval { $MW = MainWindow->new(); }; - if ($@) { - print " - WARN: failed to setup main window. This may be a x-windows permissions problem,\n"; - print " - a ssh forwarding problem or some other x-windows related problem.\n"; - print " - You may wish to try \"wish\" to debug. If using ssh, look into ForwardX11Trusted option\n"; - return; - } - $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? @@ -6707,711 +6549,6 @@ respond "target=$target app=control no_chime=1 No recent actions can be undone." } -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('' => sub{ - # $list->selectionClear(0, 'end'); - # my ($file, $cmd) = $_[0]->get('active') =~ /(.+)\: *(.+)/; - # &run_voice_cmd($cmd, undef, 'tk'); - #}); - - $Tk_objects{command}->bind('', 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('', 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('', 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) = @_; @@ -8118,3 +7255,4 @@ __END__ # - add Revision to header # # +# vim:sts=4:sw=4 diff --git a/bin/mh.ini b/bin/mh.ini index 10d30feeb..2e579a6ab 100644 --- a/bin/mh.ini +++ b/bin/mh.ini @@ -660,33 +660,31 @@ button_button_type = jpeg # possible choice are png, jpeg # # Before you can use the photo slideshow facility, you must activate the # photo_index.pl common code script. Then you can optionally resize your -# photos and then index them. +# photos and then index them. This is only required for slow browsers, +# like the Audrey. -@ html_alias_photos points to the location of your photos. Usually, -@ these photos have been resized to the desired display size (see below). +@ html_alias_photos points to the location of your photos. For slow browsers, +@ these photos should be resized to the desired display size (see below). +# The resizing is done in javascript now (see web/slideshow/index.shtml). @ The string "photos" in html_alias_photos is arbitrary, but should match @ one of the directories listed in the photo_dirs parameter. -html_alias_photos = $Pgm_Root/data/photos +html_alias_photos = $config_parms{data_dir}/photos @ html_alias_photos_big points to the location of your full size original -@ photos. These photos can be automatically resized to the desired display -@ size using the "Resize new photo album pictures" voice command. -@ The string "photos_big" in photos_originals is arbitrary, but should match -@ one of the directories listed in the photo_big_dir parameters. +@ photos. Unless you have a slow browser and need to resize your photos in +@ advance, don't change this. These photos can be automatically resized to the +@ photo_size ini var using the "Resize new photo album pictures" voice command. +@ The string "photos_big" in html_alias_photos_big is arbitrary, but should +@ match one of the directories listed in the photo_big_dir parameters. @ This is so you can setup multiple photo sets. -@ The photo slideshow web interface also includes a link to the high res -@ version. -@ The string "photos" in html_alias_photos is arbitrary, but should match -@ one of the directories listed in the photo_dirs parameter. -html_alias_photos_big = $Pgm_Root/data/photos +html_alias_photos_big = $config_parms{html_alias_photos} @ photo_index is the file where photo_index.pl will store @ the list of photos found under photo_dirs. -@ It's recommended you set this to $config_parms{data_dir}/photo_index.txt. -photo_index = $Pgm_Root/data/photo_index.txt +photo_index = $config_parms{data_dir}/photo_index.txt @ photo_dirs is a list of web alias dirs (not actual dirs) you have photos in. @ This can be a list of dirs (e.g. /photos/87,photos/88) diff --git a/bin/update_docs b/bin/update_docs index 9a89d10fb..57bbee559 100755 --- a/bin/update_docs +++ b/bin/update_docs @@ -1,28 +1,284 @@ -#!/bin/sh -cd ../docs +#!/usr/bin/perl -pod2html mh.pod > mh.html -pod2text mh.pod > mh.txt +=head1 NAME -pod2html install.pod > install.html -pod2text install.pod > install.txt +update_docs - convert Misterhouse's documentation to html -pod2html faq.pod > faq.html -pod2text faq.pod > faq.txt +=head1 DESCRIPTION -pod2html faq_frs.pod > faq_frs.html -pod2text faq_frs.pod > faq_frs.txt +Converts the Misterhouse pod format documentation into html. It is +recommended that documentation be created along side the code it relates to. -pod2html faq_ia.pod > faq_ia.html -pod2text faq_ia.pod > faq_ia.txt +=head1 INI PARAMETERS -pod2text faq_mhmedia.pod > faq_mhmedia.txt -pod2html faq_mhmedia.pod > faq_mhmedia.html +=over -pod2html updates.pod > updates.html -pod2text updates.pod > updates.txt +=item html_alias_docs + +This script will write its output to the directory specified in +C, otherwise it will write to C<../docs>. + +=back + +=head1 TODO + +- Move some of the information that is better suited to the wiki out of +the mh/docs directory. This includes most of the html files in that +directory. Hopefully, this will inspire users to keep them up to date. + +- Try to standardize on pod format in mh/docs and make sure everything is +linked from someplace else. Many of the files in mh/docs are orphans. + +- Perhaps we should move some of the other documentation (like for global +variables and functions) out of the pod files and into the actual scripts +where they exist. The idea here is it is more likely the documentation +will be more up to date if it's close to the source code. Does anyone +know if there is a performance hit including documentation in-line? + +- Create an items.xml file that contains all the information required by +read_table_A.pl, read_table_xml.pl, and the item editor web interface. +Currently, it's a pain to add support for new items to these scripts and +often only read_table_A.pl gets updated. This should make it easier add +new items and improve the documentation of items. + +=head1 AUTHOR + +David Norwood + +=cut + +# get our name and path, set library path +my ( $Pgm_Path, $Pgm_Name ); + +BEGIN { + ( $Pgm_Path, $Pgm_Name ) = $0 =~ /(.*)[\\\/](.*)\.?/; + ($Pgm_Name) = $0 =~ /([^.]+)/, $Pgm_Path = '.' unless $Pgm_Name; + eval + "use lib '$Pgm_Path/../lib', '$Pgm_Path/../lib/site'"; # So perl2exe works +} + +use strict; +use warnings; +use Pod::Html; + +# Get parms from mh.ini +require 'handy_utilities.pl'; +my ( %config_parms, %parms ); +&main::read_mh_opts( \%config_parms, $Pgm_Path ); + +my $docdir = "../docs"; +my $outdir = $config_parms{html_alias2_docs}; +my $libdir = '../lib'; +$outdir = '../docs' unless $outdir and -d $outdir; + +-d $docdir || die "directory $docdir doesn't exist"; +-d $outdir || die "directory $outdir doesn't exist"; +-d $libdir || die "directory $libdir doesn't exist"; +-r $docdir || die "directory $docdir isn't readable"; +-r $outdir || die "directory $outdir isn't readable"; +-r $libdir || die "directory $libdir isn't readable"; +-w $outdir || die "directory $outdir isn't writeable"; +mkdir "$outdir/lib" unless -d "$outdir/lib"; + +# make list of module and script files in lib so we can extract pod doc later +my %libfiles; +opendir LIB, $libdir || die "can't open $libdir directory: $!"; + +foreach ( readdir LIB ) { + $libfiles{$_}{exists} = 1 if /\.p[lm]$/i; +} + +closedir LIB; + +# make list of lib html files so we can delete obsolete ones +my %htmlfiles; +opendir OUT, "$outdir/lib" || die "can't open $outdir/lib directory: $!"; + +foreach ( readdir OUT ) { + $htmlfiles{$_}{exists} = 1 if /\.html$/i; +} + +closedir OUT; + +# convert the pod doc in each changed pl or pm file into html +my $changes = 0; +foreach my $lib ( keys %libfiles ) { + my $libfile = "$libdir/$lib"; + my $htmlfile = "$outdir/lib/$lib"; + $htmlfile =~ s/\.p[lm]$/.html/i; + $libfiles{$lib}{html} = $htmlfile; + + my $mdate = ( stat($libfile) )[9]; + my $hdate = ( stat($htmlfile) )[9]; + + #print "mdate $mdate hdate $hdate $libfile\n"; + if ( !-e $htmlfile or $mdate > $hdate ) { + print "converting $libfile to $htmlfile\n"; + $changes++; + pod2html( + "--title=$lib", "--infile=$libfile", + "--outfile=$htmlfile", "--header", + "--htmlroot=/docs", "--htmldir=$outdir/..", + "--podroot=$docdir", "--podpath=.", + "--css=/lib/pod.css", + ); + } +} + +# check for deleted lib files +foreach ( keys %htmlfiles ) { + my $htmlfile = "$outdir/lib/$_"; + my $pm = $_; + my $pl = $_; + $pm =~ s/\.html$/.pm/i; + $pl =~ s/\.html$/.pl/i; + $changes++, print "deleting $htmlfile\n", unlink $htmlfile + unless ( $libfiles{$pm}{exists} or $libfiles{$pl}{exists} ); +} + +# write out items and modules lists if any pm files changed +my ( $ipod, $mpod ); +if ($changes) { + my %packages; + foreach my $pm ( keys %libfiles ) { + next unless $pm =~ /.+\.pm$/i; + my $html = $pm; + $html =~ s/\.pm$/.html/i; + my $noext = $pm; + $noext =~ s/\.pm$//i; + my $modfile = "$libdir/$pm"; + my $htmlfile = "$outdir/lib/$html"; + + open( my $fh, $modfile ) or die "can't open $modfile: $!"; + my $current_p; + while ( my $l = <$fh> ) { + if ( $l =~ /^package ([^;]+);/ ) { + $current_p = $1; + + #print "found package $current_p in $pm\n"; + $packages{$current_p}{pm} = $pm; + $packages{$current_p}{html} = $html; + $packages{$current_p}{noext} = $noext; + } + elsif ( $l =~ /^sub new / ) { + + #print "found 'new' method in package $current_p in $pm\n"; + $packages{$current_p}{isitem} = 1 if $current_p; + } + elsif ( $l =~ /^=head/ ) { + + #print "found pod directive in package $current_p in $pm\n"; + $packages{$current_p}{haspod} = 1 if $current_p; + } + } + print "didn't find any packages in $pm\n" unless $current_p; + close $fh; + } + + foreach ( sort keys %packages ) { + + #print "package: $_\n"; + s/\//::/g; + my $pod = "=item $_\n\n"; + if ( $packages{$_}{haspod} ) { + $pod .= "L<$_|lib::" . $packages{$_}{noext} . "/$_>\n\n"; + } + else { + $pod .= "package $_ in $packages{$_}{pm} isn't documented yet\n\n"; + } + if ( $packages{$_}{isitem} ) { + $ipod .= $pod; + } + else { + $mpod .= $pod; + } + } +} + +if ($ipod) { + print "writing $outdir/items.pod file\n"; + open TAR, "> $outdir/items.pod"; + print TAR "\n=head1 Items\n\n=over\n\n$ipod\n=back\n\n=cut\n"; + close TAR; +} + +if ($mpod) { + print "writing $outdir/modules.pod file\n"; + open TAR, "> $outdir/modules.pod"; + print TAR "\n=head1 Modules\n\n=over\n\n$mpod\n=back\n\n=cut\n"; + close TAR; +} + +# make list of pod files so we can convert them to html +my %podfiles; +opendir POD, $docdir || die "can't open $docdir directory: $!"; + +foreach ( readdir POD ) { + $podfiles{$_}{exists} = 1 if /\.pod$/i; +} + +$podfiles{'items.pod'}{exists} = 1 if -f "$outdir/items.pod"; +$podfiles{'modules.pod'}{exists} = 1 if -f "$outdir/modules.pod"; +closedir POD; + +# delete html files from docs dir if out dir is diff and pod ex +my $docsi = ( stat($docdir) )[1]; +my $outi = ( stat($outdir) )[1]; +if ( $docsi eq $outi ) { + print "you should set the html_alias_docs directory to a place outside" + . " the mh distribution\n"; +} +else { + foreach ( keys %podfiles ) { + s/\.pod$/.html/i; + print("deleting $docdir/$_\n"), unlink "$docdir/$_" if -e "$docdir/$_"; + } + foreach ( keys %libfiles ) { + s/\.p[lm]$/.html/i; + print("deleting $docdir/lib/$_\n"), unlink "$docdir/lib/$_" + if -e "$docdir/lib/$_"; + } + print("deleting $docdir/lib/\n"), rmdir "$docdir/lib" if -d "$docdir/lib"; + print("deleting $docdir/modules.pod\n"), unlink "$docdir/modules.pod" + if -w "$docdir/modules.pod"; + print("deleting $docdir/items.pod\n"), unlink "$docdir/items.pod" + if -w "$docdir/items.pod"; +} + +# convert any modified pod files to html +foreach my $doc ( keys %podfiles ) { + my $podfile = "$docdir/$doc"; + my $ind = ""; + if ( $doc eq "items.pod" or $doc eq "modules.pod" ) { + $podfile = "$outdir/$doc"; + $ind = "--noindex"; + } + $doc =~ s/\.pod$//i; + my $htmlfile = "$outdir/$doc.html"; + my $pdate = 0; + my $hdate = 0; + $pdate = ( stat($podfile) )[9] if -f $podfile; + $hdate = ( stat($htmlfile) )[9] if -f $htmlfile; + + #print "pdate $pdate hdate $hdate : $doc\n"; + if ( !-e "$outdir/$doc.html" or $pdate > $hdate ) { + print "pod2html $podfile > $htmlfile\n"; + + #`pod2html --htmlroot $outdir $docdir/$doc.pod > $outdir/$doc.html`; + pod2html( + "--infile=$podfile", "--outfile=$htmlfile", + "--noheader", "--htmlroot=/docs", + "--htmldir=$outdir/..", "--podroot=$docdir", + "--podpath=.", "--css=/lib/pod.css", + $ind + ); + } +} + +=begin comment perl ../bin/authors updates.pod > authors.html # mh_users_table.pl is currently missing # perl ../bin/mh_users_table.pl mh_usage.txt > mh_usage_table.html +=end diff --git a/bin/update_docs.bat b/bin/update_docs.bat index 9a8696a52..22d215879 100755 --- a/bin/update_docs.bat +++ b/bin/update_docs.bat @@ -1,27 +1 @@ -cd ..\docs - -call pod2html mh.pod > mh.html -call pod2text mh.pod > mh.txt - -call pod2html install.pod > install.html -call pod2text install.pod > install.txt - -call pod2html faq.pod > faq.html -call pod2text faq.pod > faq.txt - -call pod2html faq_frs.pod > faq_frs.html -call pod2text faq_frs.pod > faq_frs.txt - -call pod2html faq_ia.pod > faq_ia.html -call pod2text faq_ia.pod > faq_ia.txt - -call pod2text faq_mhmedia.pod > faq_mhmedia.txt -call pod2html faq_mhmedia.pod > faq_mhmedia.html - -call pod2html updates.pod > updates.html -call pod2text updates.pod > updates.txt - -perl ..\bin\authors updates.pod > authors.html - -@rem copy \data\mh_usage.txt . -@rem perl ..\bin\mh_users_table.pl mh_usage.txt > mh_usage_table.html +@mh -run update_docs diff --git a/code/common/internet_earthquakes.pl b/code/common/internet_earthquakes.pl index 410d8aea6..27c0745b4 100644 --- a/code/common/internet_earthquakes.pl +++ b/code/common/internet_earthquakes.pl @@ -205,26 +205,13 @@ sub calc_earthquake_age { $qmnth += 1; #Merge it again - this is now local time, not UTC my $qtime = timelocal($qseco,$qminu,$qhour,$qdate,$qmnth-1,$qyear); - my $midnight = timelocal(0, 0, 0, $Mday, $Month - 1, $Year - 1900); - - my $diff = (time() - $qtime); - - return int($diff/60) . " minutes ago " if ($diff < 60*120); - return int($diff/(60*60)) . " hours ago " if ($qtime > $midnight); - my $hour; - $qhour =~ s!^0!!; - if ($qhour == 0) {$hour = "12 AM"} - elsif ($qhour < 12) {$hour = "$qhour AM"} - elsif ($qhour == 12) {$hour = "12 PM"} - else {$hour = $qhour - 12 . " PM"} - return "Yesterday at $hour " if ($qtime > $midnight - 60*60*24); - my $days_ago = int($diff/(60*60*24) + .5); - return "$days_ago day" . (($days_ago > 1)?'s':'') . " ago at $hour"; + return time_date_stamp( 23, $qtime ); } # lets allow the user to control via triggers -if ($Reload) { - &trigger_set('$New_Hour and net_connect_check', "run_voice_cmd 'Get recent earthquakes'", 'NoExpire', 'get earthquakes') - unless &trigger_get('get earthquakes'); -} +# noloop=start +&trigger_set('$New_Hour and net_connect_check', + "run_voice_cmd 'Get recent earthquakes'", 'NoExpire', 'get earthquakes') + unless &trigger_get('get earthquakes'); +# noloop=stop diff --git a/code/common/internet_im.pl b/code/common/internet_im.pl index 3ee96e3b2..690cfb893 100644 --- a/code/common/internet_im.pl +++ b/code/common/internet_im.pl @@ -161,6 +161,11 @@ sub im_message { $authority = $Password_Allow{$text} unless $authority; + if ($text eq "") { + print "IM: received empty text, discarding\n" if $main::Debug{im}; + return; + } + print "IM: RUN a=$authority,$im_data{password_allow}{$from} from=$from text=$text\n" if $main::Debug{im}; return if $text =~ /^i\'m away/i; return if $text =~ /^Sorry, I ran out for a bit/i; diff --git a/code/common/internet_mail.pl b/code/common/internet_mail.pl index 5e9b67c8c..c760b6d29 100644 --- a/code/common/internet_mail.pl +++ b/code/common/internet_mail.pl @@ -3,25 +3,31 @@ # $Date$ # $Revision$ -#@ This code will periodically scan and announce when you -#@ receive new email. This code also has some test examples for sending email. +#@ This code will periodically scan and announce when you receive new email. +#@ Messages will not be deleted from the server. +#@ This code also has some test examples for sending email. -#@ Point to your accounts with mh.ini net_mail_account* parms. -#@ You can customize the parms to have other accounts besides the _account_1_ settings. +#@

Point to your accounts with mh.ini net_mail_account* parms. +#@ You can customize the parms to have other accounts besides the +#@ _account_1_ settings. #@ For example you can replace the '_account_1_' string with '_my_home_email_'. -#@ It's a nice way to get MH to announce 'my home email has 3 new messages from ...' -#@ rather than the generic 'account 1 has 3 new messages from ...' +#@ It's a way to get MH to announce 'my home email has 3 new messages from ...' +#@ rather than the generic 'account 1 has 3 new messages from ...'. - # Example on how to send an email command - # - This string can be in either the subject or the body of the email - # Subject line is: command:x y z code:xyz +#@

The config param net_mail_scan_timeout_cycles prevents the process item +#@ being killed if it didn't complete within a scan interval. -## added config param net_mail_scan_timeout_cycles to prevent process item being killed if it -## didn't complete within a scan interval. +#@

Check here after you have enabled and configured +#@ this script to see your email messages. -#noloop=start -$v_send_email_test = new Voice_Cmd('Send test e mail [1,2,3,4,5,6,7,8,9,10,11]'); -$v_send_email_test-> set_info('Send commands to test remote email commands'); +# noloop=start + +# Example on how to send an email command +# - This string can be in either the subject or the body of the email +# Subject line is: command:x y z code:xyz +$v_send_email_test = new Voice_Cmd( + 'Send test e mail [1,2,3,4,5,6,7,8,9,10,11,12]'); +$v_send_email_test->set_info('Send commands to test remote email commands'); $v_cell_phone_test = new Voice_Cmd 'Send test e mail to the cell phone'; $v_cell_phone_test-> set_info("Send a test message to the cell phone"); @@ -33,72 +39,90 @@ # List or read unread email $v_unread_email = new Voice_Cmd('[List,Read] unread e mail'); -$v_unread_email-> set_info('Summarize unread email headers and optionally call Outlook to read the mail'); +$v_unread_email-> set_info( + 'Summarize unread email headers and optionally call Outlook to read the mail'); my $get_email_scan_file = "$config_parms{data_dir}/get_email.scan"; my $get_email_timeout_cycles = 0; -$get_email_timeout_cycles = $config_parms{net_mail_scan_timeout_cycles} if $config_parms{net_mail_scan_timeout_cycles}; +$get_email_timeout_cycles = $config_parms{net_mail_scan_timeout_cycles} + if $config_parms{net_mail_scan_timeout_cycles}; my $get_email_timeout_current = 0; #$email_flag = new Generic_Item; -#tk_mlabel($email_flag, 'email flag'); ... this quit working in 2.88. Tk does not like the Generic_Item Tie update - -# This belongs in noloop block else it calls this sub every time! -# tk subs return if not $Reload, which is a crutch (and obscure.) +#tk_mlabel($email_flag, 'email flag'); ... this quit working in 2.88. +# Tk does not like the Generic_Item Tie update - -#noloop=stop +# noloop=stop &tk_label_new(3, \$Save{email_flag}); if (said $v_send_email_test) { my $state = $v_send_email_test->{state}; if (&net_connect_check) { - # Use to => 'user@xyz.com', or default to your own address (from net_mail_account_address in mh.ini) - &net_mail_send(subject => "test 1", text => "Test email 1 sent at $Time_Date", -# to => 'bruce@misterhouse.net ; winter@chartermi.net', - debug => 1) if $state == 1; - - # Send a command in the subject - &net_mail_send(subject => "command:What time is it code:$config_parms{net_mail_command_code}", - text => "I have been running for " . &time_diff($Time_Startup_time, time)) if $state == 2; - - # Send a command in the body + # Use to => 'user@xyz.com', or default to your own address + # (from net_mail_account_address in mh.ini) + &net_mail_send( + subject => "test 1", text => "Test email 1 sent at $Time_Date", + debug => 1) if $state == 1; + + # Send a command in the subject + &net_mail_send( + subject => "command:What time is it code:" + . $config_parms{net_mail_command_code}, + text => "I have been running for " + . &time_diff($Time_Startup_time, time)) if $state == 2; + + # Send a command in the body &net_mail_send(subject => "test command in body of text", - text => "command:get this weeks new dvds \ncode:$config_parms{net_mail_command_code}") if $state == 3; + text => "command:get this weeks new dvds \ncode:" + . $config_parms{net_mail_command_code} ) if $state == 3; + + # Send attachements of different types + # - Note mime parm is optional if file ends with that extension + &net_mail_send( + subject => 'test an html attachement', + baseref => "localhost:$config_parms{http_port}", + file => '../web/mh4/widgets.html', mime => 'html') + if $state == 4; - # Send attachements of different types - # - Note mime parm is optional if file ends with that extension - &net_mail_send(subject => 'test an html attachement', - baseref => "localhost:$config_parms{http_port}", - file => '../web/mh4/widgets.html', mime => 'html') if $state == 4; + &net_mail_send( + subject => 'test a zip file attachement', + file => 'c:/temp/test1.zip') if $state == 5; - &net_mail_send(subject => 'test a zip file attachement', - file => 'c:/temp/test1.zip') if $state == 5; + &net_mail_send( + subject => 'test a tar.gz file attachement', + file => 'c:/temp/test.tar.gz', mime => 'bin') if $state == 6; - &net_mail_send(subject => 'test a tar.gz file attachement', - file => 'c:/temp/test.tar.gz', mime => 'bin') if $state == 6; + &net_mail_send( + subject => 'test a gif file attachement', + file => '../web/graphics/goofy.gif') if $state == 7; - &net_mail_send(subject => 'test a gif file attachement', - file => '../web/graphics/goofy.gif') if $state == 7; + &net_mail_send( + subject => 'test a txt file', + file => '../docs/faq.txt') if $state == 8; - &net_mail_send(subject => 'test a txt file', - file => '../docs/faq.txt') if $state == 8; + &net_mail_send( + subject => 'test an html file', + file => '../docs/faq.html') if $state == 9; - &net_mail_send(subject => 'test an html file', - file => '../docs/faq.html') if $state == 9; + # Test a request file via email + &net_mail_send( + subject => "command:request $config_parms{caller_id_file} code:" + . $config_parms{net_mail_command_code} ) if $state == 10; - # Test a request file via email - &net_mail_send(subject => "command:request $config_parms{caller_id_file} code:$config_parms{net_mail_command_code}") if $state == 10; - &net_mail_send(subject => "command:set \$camera_light TOGGLE code:$config_parms{net_mail_command_code}") if $state == 11; + &net_mail_send( + subject => "command:set \$camera_light TOGGLE code: + $config_parms{net_mail_command_code}") if $state == 11; - run 'send_mail -subject "test" -text "Test background send_mail"' if $state == 11; + run 'send_mail -subject "test" -text "Test background send_mail"' + if $state == 12; $v_send_email_test->respond("app=email Test message has been sent."); } else { - $v_send_email_test->respond("app=email I am not logged on to the internet, so I can not send mail."); + $v_send_email_test->respond( + "app=email I am not logged on to the internet, so can't send mail."); } } @@ -109,32 +133,37 @@ $v_cell_phone_test->respond("app=email Test email sent to cell phone"); } - # Check for recent email since last received by mail program - # Do it with a get_email process, so mh will not pause +# Check for recent email since last received by mail program +# Do it with a get_email process, so mh will not pause #&tk_radiobutton('Check email', \$Save{email_check}, ['no', 'yes']); # *** Should be a trigger instead of config parm -if (said $v_recent_email or ($Save{email_check} ne 'no' and new_minute $config_parms{net_mail_scan_interval} and &net_connect_check)) { +if (said $v_recent_email or ($Save{email_check} ne 'no' and new_minute + $config_parms{net_mail_scan_interval} and &net_connect_check)) { $v_recent_email->respond('Checking email...') if said $v_recent_email; set $p_get_email 'get_email -quiet'; set $p_get_email 'get_email -debug' if $Debug{email}; -# New functionality added, if config_param exists, then wait x cycles before blindly killing process + # New functionality added, if config_param exists, then wait x cycles + # before blindly killing process if ((! ($get_email_timeout_cycles)) or (done $p_get_email)) { $get_email_timeout_current = 0; start $p_get_email; } else { - if ($get_email_timeout_cycles == $get_email_timeout_current) { - print_log "Internet_mail: Timeout expired on getting email, killing process..."; - $get_email_timeout_current = 0; - start $p_get_email; - } else { - $get_email_timeout_current++; - my $cycles_left = $get_email_timeout_cycles - $get_email_timeout_current; - print_log "Internet_mail: Request to check mail but process still running. $cycles_left scan intervals remain"; - } + if ($get_email_timeout_cycles == $get_email_timeout_current) { + print_log + "Internet_mail: Timeout expired getting email, killing process."; + $get_email_timeout_current = 0; + start $p_get_email; + } else { + $get_email_timeout_current++; + my $cycles_left = $get_email_timeout_cycles + - $get_email_timeout_current; + print_log "Internet_mail: Request to check mail but process still" + . " running. $cycles_left scan intervals remain"; + } } } @@ -144,11 +173,11 @@ # set $email_flag $data; # *** Missing? $Save{email_flag} = $data; # Used in web/bin/status_line.pl - # Turn on an 'new mail indicator' - # - could be modified for different lights for different accounts. +# Turn on an 'new mail indicator' +# - could be modified for different lights for different accounts. # set $new_mail_light ($data =~ /[1-9]/) ? ON : OFF); - # Once an hour, summarize all email, otherwise just new mail + # Once an hour, summarize all email, otherwise just new mail if ($Minute < 10) { $text = &unread_mail(); } @@ -157,33 +186,32 @@ } &scan_subjects($get_email_scan_file); - # *** Change to respond once logic is untangled (needs trigger) - # *** As of now, there is no telling what called this. + # *** Change to respond once logic is untangled (needs trigger) + # *** As of now, there is no telling what called this. speak "app=email $text" if $text; } - # Delete file after the done_now pass (gives other code - # like news_email_breaking.pl a chance to scan it) +# Delete file after the done_now pass (gives other code +# like news_email_breaking.pl a chance to scan it) elsif ($p_get_email->{done} and -e $get_email_scan_file) { unlink $get_email_scan_file; } if ($state = said $v_unread_email) { if ($state eq 'Read') { - $v_unread_email->respond("app=email Loading email client..."); - # *** Look up path in registry! This is clearly Windows-only too... + $v_unread_email->respond("app=email Loading email client..."); + # *** Look up path in registry! This is clearly Windows-only too... - if (my $window = &sendkeys_find_window('Outlook', 'C:\Program Files\Microsoft Office\Office\OUTLOOK.EXE')) { -# if (my $window = &sendkeys_find_window('Outlook', 'D:\msOffice\Office\OUTLOOK.EXE')) { -# my $keys = '\\alt+\\tss\\alt-\\'; # For Outlook Express + if (my $window = &sendkeys_find_window('Outlook', + 'C:\Program Files\Microsoft Office\Office\OUTLOOK.EXE')) { my $keys = '\\alt\\te\\ret\\'; # For Outlook &SendKeys($window, $keys, 1, 500); } } else { - my $text = unread_mail(); - $v_unread_email->respond("app=email $text"); + my $text = unread_mail(); + $v_unread_email->respond("app=email $text"); } } @@ -199,22 +227,26 @@ sub unread_mail { return $text; } - # Allow for email send commands, IF the secret command code matches - # - someday we need to allow for better, more secure mail commands +# Allow for email send commands, IF the secret command code matches +# - someday we need to allow for better, more secure mail commands sub scan_subjects { my ($file) = @_; return unless -e $file; for my $line (file_read $file) { - my ($from, $to, $subject_body) = $line =~ /From: *(.+) To: *(.+) Subject: *(.*)/; - if (my($command, $code) = $subject_body =~ /command:(.+?)\s+code:(\S+)/i) { + my ($from, $to, $subject_body) = $line =~ + /From: *(.+) To: *(.+) Subject: *(.*)/; + if (my($command, $code) = $subject_body =~ + /command:(.+?)\s+code:(\S+)/i) { my $results; - if ($config_parms{net_mail_command_code} and $config_parms{net_mail_command_code} eq $code) { + if ($config_parms{net_mail_command_code} + and $config_parms{net_mail_command_code} eq $code) { if (my ($file_request) = $command =~ /request_file\s(.+)/i) { $file_request =~ s|\\|\/|g; if (-e $file_request) { speak "Sending email request file: $file_request"; $results = "Sending $file_request"; - &net_mail_send(to => $from, subject => $results, file => $file_request, mime => 'bin'); + &net_mail_send(to => $from, subject => $results, + file => $file_request, mime => 'bin'); } else { speak "Email requested file not found:$file_request"; @@ -222,9 +254,10 @@ sub scan_subjects { } } else { - # The mh respond_email function will mail back the results - if (&process_external_command($command, 1, "email [$from]", "email to='$from' subject='Results for: $command'")) { -# if (run_voice_cmd $command) { + # The mh respond_email function will mail back the results + if (&process_external_command( + $command, 1, "email [$from]", + "email to='$from' subject='Results for: $command'")) { speak "Running email command: $command"; $results = "Command was run: $command"; } @@ -238,7 +271,8 @@ sub scan_subjects { speak "An unauthorized email command received: $command"; $results = "Command not authorized: $command code:$code"; } - logit("$config_parms{data_dir}/logs/email_command.log", "From:$from " . $results); + logit("$config_parms{data_dir}/logs/email_command.log", + "From:$from " . $results); &net_mail_send(to => $from, subject => $results); } } @@ -246,46 +280,48 @@ sub scan_subjects { } sub email_message_window_closing { - + } sub email_message_window_saving { - my $p_win = shift; - - my $msg = $$p_win{t1}->get('0.0', 'end'); - my $re = $$p_win{re}->get; - chomp $msg; # stupid tk entry widget appends a CR - - if ($msg) { - &net_mail_send(text => $msg, subject => $re, to => undef); - return 0; - } - else { - display('app=email time=0 Enter a message to send.'); - return 1; - } + my $p_win = shift; + + my $msg = $$p_win{t1}->get('0.0', 'end'); + my $re = $$p_win{re}->get; + chomp $msg; # stupid tk entry widget appends a CR + + if ($msg) { + &net_mail_send(text => $msg, subject => $re, to => undef); + return 0; + } + else { + display('app=email time=0 Enter a message to send.'); + return 1; + } } # *** Change OK to Send and add "To" field sub open_email_message_window { - my %parms = @_; - $parms{title} = "Send Message"; - $parms{app} = "email"; - $parms{text} = "Dear,"; - $parms{window_name} = "message"; - $parms{buttons} = 2; - $parms{help} = 'Enter a message to send to the default email account.'; - my $w_window = &load_child_window(%parms); - if (defined $w_window) { - unless ($w_window->{activated}) { - $w_window->{MW}{top_frame}->Label(-text => 'Re:')->pack(qw/-side left/); - $w_window->{re} = $w_window->{MW}{top_frame}->Entry()->pack(qw/-expand yes -fill both -side left/); - $w_window->activate(); - $w_window->{re}->focus(); - } - return $w_window; - } + my %parms = @_; + $parms{title} = "Send Message"; + $parms{app} = "email"; + $parms{text} = "Dear,"; + $parms{window_name} = "message"; + $parms{buttons} = 2; + $parms{help} = 'Enter a message to send to the default email account.'; + my $w_window = &load_child_window(%parms); + if (defined $w_window) { + unless ($w_window->{activated}) { + $w_window->{MW}{top_frame}->Label(-text => 'Re:')->pack( + qw/-side left/); + $w_window->{re} = $w_window->{MW}{top_frame}->Entry()->pack( + qw/-expand yes -fill both -side left/); + $w_window->activate(); + $w_window->{re}->focus(); + } + return $w_window; + } } #®ister_echo('email'); diff --git a/code/common/internet_weather.pl b/code/common/internet_weather.pl index 775ffebb5..d641a9ce7 100644 --- a/code/common/internet_weather.pl +++ b/code/common/internet_weather.pl @@ -160,7 +160,7 @@ sub normalize_conditions { } $w{WindGustSpeed}=$w{WindAvgSpeed}; $w{WindGustSpeed} = $1 if $conditions =~ /gusts\s+up\s+to\s+(\d+)\s+mph/; - $w{DewOutdoor}=convert_humidity_to_dewpoint($w{HumidOutdoor},convert_f2c($w{TempOutdoor})); # DewOutdoor is in Celsius at this point + $w{DewOutdoor}=&Weather_Common::convert_humidity_to_dewpoint($w{HumidOutdoor},convert_f2c($w{TempOutdoor})); # DewOutdoor is in Celsius at this point # Who needs a sun sensor? @@ -173,7 +173,7 @@ sub normalize_conditions { $w{Clouds} = lc($1); } - $w{WindAvgDir}=convert_wind_dir_text_to_num($w{WindAvgDir}); + $w{WindAvgDir}=&Weather_Common::convert_wind_dir_text_to_num($w{WindAvgDir}); $w{WindGustDir}=$w{WindAvgDir}; if ($config_parms{weather_uom_wind} eq 'kph') { @@ -210,8 +210,8 @@ sub normalize_conditions { } } - &populate_internet_weather(\%w, $config_parms{weather_internet_elements_noaa}); - &weather_updated; + &Weather_Common::populate_internet_weather(\%w, $config_parms{weather_internet_elements_noaa}); + &Weather_Common::weather_updated; } if (done_now $p_weather_data) { $v_get_internet_weather_data->respond('app=weather connected=0 Weather data retrieved.'); diff --git a/code/common/mh_control.pl b/code/common/mh_control.pl index 7044745ce..403f03382 100644 --- a/code/common/mh_control.pl +++ b/code/common/mh_control.pl @@ -3,140 +3,153 @@ # $Date$ # $Revision$ -#@ Core MisterHouse commands e.g. reload code, list x10 items. - -$v_listen = new Voice_Cmd("[Start,Stop] listening",0); - -$v_reload_code = new Voice_Cmd("[Reload,re load] code"); -$v_reload_code2= new Voice_Cmd("Force [Reload,re load] code"); -$v_reload_code -> set_info('Load mh.ini, icon, and/or code changes'); -$v_reload_code2-> set_info('Force a code reload of all modules'); - -push(@Nextpass_Actions, \&read_code) if state_now $v_reload_code; -push(@Nextpass_Actions, \&read_code_forced) if state_now $v_reload_code2; - -#if ($state = state_now $v_reload_code) { -# # Must be done before the user code eval -# push @Nextpass_Actions, ($state eq 'Force') ? \&read_code_forced : \&read_code; -# read_code(); -# $Run_Members{mh_control} = 2; # Reset, so the mh_temp.user_code decrement works -#} - -if ($state = said $v_listen) { - if ($state eq 'Start') { - if ($v_listen->{set_by} =~ '^vr') { - &Voice_Cmd::wait_for_command(0); - } - $v_listen->respond('app=control I am listening.'); - } - else { - &Voice_Cmd::wait_for_command('Start listening'); - $v_listen->respond('app=control I am not listening.'); - } +#@ Core MisterHouse commands e.g. reload code, list x10 items, rotate logs, +#@ update docs. + +# Reload MisterHouse +$v_reload_code = new Voice_Cmd("[Reload,re load] code"); +$v_reload_code->set_info('Load mh.ini, icon, and/or code changes'); +$v_reload_code->tie_event('push(@Nextpass_Actions, \&read_code)'); # noloop + +# Force reload MisterHouse +$v_reload_code2 = new Voice_Cmd("Force [Reload,re load] code"); +$v_reload_code2->set_info('Force a code reload of all modules'); +$v_reload_code2->tie_event('push(@Nextpass_Actions, # noloop + \&read_code_forced)'); # noloop + +# Start/stop voice recognition +$v_listen = new Voice_Cmd( "[Start,Stop] listening", 0 ); +$v_listen->tie_event('&handle_listen_state()'); # noloop +sub handle_listen_state() { + if ( $state eq 'Start' ) { + if ( $v_listen->{set_by} =~ '^vr' ) { + &Voice_Cmd::wait_for_command(0); + } + $v_listen->respond('app=control I am listening.'); + } + else { + &Voice_Cmd::wait_for_command('Start listening'); + $v_listen->respond('app=control I am not listening.'); + } } - - +# Read and process mht files $v_read_tables = new Voice_Cmd 'Read table files'; -read_table_files if said $v_read_tables; +$v_read_tables->tie_event('&read_table_files()'); # noloop -$v_set_password = new Voice_Cmd("Set the [guest,family,admin] password"); -if ($state = said $v_set_password) { - @ARGV = (-user => $state); +# Set one of the passwords +$v_set_password = new Voice_Cmd("Set the [guest,family,admin] password"); +$v_set_password->tie_event('&handle_set_password_state()'); # noloop +sub handle_set_password_state() { + @ARGV = ( -user => $state ); print_log "Setting $state password with: @ARGV"; do "set_password"; - &password_read; # Re-read new password data + &password_read; # Re-read new password data } -$v_uptime = new Voice_Cmd("What is your up time", 0); -$v_uptime-> set_info('Check how long the comuter and MisterHouse have been running'); -$v_uptime-> set_authority('anyone'); - -if (said $v_uptime) { - my $uptime_pgm = &time_diff($Time_Startup_time, time); - my $uptime_computer = &time_diff($Time_Boot_time, $Time); -# speak("I was started on $Time_Startup\n"); - respond("I was started $uptime_pgm ago. The computer was booted $uptime_computer ago."); +# Display program and system uptime +$v_uptime = new Voice_Cmd( "What is your up time", 0 ); +$v_uptime->set_info( + 'Check how long the comuter and MisterHouse have been running'); +$v_uptime->set_authority('anyone'); +$v_uptime->tie_event('&handle_uptime_state()'); # noloop +sub handle_uptime_state() { + my $uptime_pgm = &time_diff( $Time_Startup_time, time ); + my $uptime_computer = &time_diff( $Time_Boot_time, $Time ); + respond( + "I was started $uptime_pgm ago." . + "The computer was booted $uptime_computer ago." + ); } - # Control and monitor the http server +# Control and monitor the http server $v_http_control = new Voice_Cmd '[Open,Close,Restart,Check] the http server'; -if ($state = said $v_http_control) { -# print_log "${state}ing the http server"; - socket_open 'http' if $state eq 'Open'; - socket_close 'http' if $state eq 'Close'; +$v_http_control->tie_event('&handle_http_control_state()'); # noloop +$http_monitor = new Socket_Item( undef, undef, + "$config_parms{http_server}:$config_parms{http_port}" ); +sub handle_http_control_state() { + # print_log "${state}ing the http server"; + socket_open 'http' if $state eq 'Open'; + socket_close 'http' if $state eq 'Close'; socket_restart 'http' if $state eq 'Restart'; -} - - # Check the http port, so we can restart it if down. -run_voice_cmd 'Check the http server', undef, 'time', 1 if new_minute 1; - -$http_monitor = new Socket_Item(undef, undef, "$config_parms{http_server}:$config_parms{http_port}"); -if ((said $v_http_control eq 'Check')) { - unless (start $http_monitor) { - my $msg = "The http server $config_parms{http_server}:$config_parms{http_port} is down. Restarting"; - print_log $msg; - display text => "$Time_Date: $msg\n", time => 0, window_name => 'http down log', append => 'bottom'; - socket_close 'http'; # Somehow this gets it going again? - stop $http_monitor if active $http_monitor; # Need this? - } - else { - print_log "The http server is up" unless get_set_by $v_http_control eq 'time'; - stop $http_monitor; + # Check the http port, so we can restart it if down. + if ($state eq 'Check') { + unless ( start $http_monitor) { + my $msg = "The http server $config_parms{http_server}:" . + "$config_parms{http_port} is down. Restarting"; + print_log $msg; + display + text => "$Time_Date: $msg\n", + time => 0, + window_name => 'http down log', + append => 'bottom'; + socket_close 'http'; # Somehow this gets it going again? + stop $http_monitor if active $http_monitor; # Need this? + } + else { + print_log "The http server is up" + unless get_set_by $v_http_control eq 'time'; + stop $http_monitor; + } } } +run_voice_cmd 'Check the http server', undef, 'time', 1 if new_minute 1; - - +# Restart MisterHouse $v_restart_mh = new Voice_Cmd 'Restart Mister House'; -$v_restart_mh-> set_info('Restarts Misterhouse. This will only work if you are start with mh/bin/mhl') if !$OS_win; -$v_restart_mh-> set_info('Restarts Misterhouse.') if $OS_win; - -&exit_pgm(1) if said $v_restart_mh; - -# This will be abend. Allow for no msg on first time use where this flag is not set yet. -if ($Startup and $Save{mh_exit} and $Save{mh_exit} ne 'normal' and $Save{mh_exit} ne 'restart') { - # May not be "auto" at all. Often it is just ran manually after the last abend. - +$v_restart_mh->set_info( 'Restarts Misterhouse. This will only work if ' . + 'you start with mh/bin/mhl') if !$OS_win; +$v_restart_mh->set_info('Restarts Misterhouse.') if $OS_win; +$v_restart_mh->tie_event('&exit_pgm(1)'); # noloop + +# This will be abend. +# Allow for no msg on first time use where this flag is not set yet. +if ( + $Startup and + $Save{mh_exit} and + $Save{mh_exit} ne 'normal' and + $Save{mh_exit} ne 'restart' ) { + # May not be "auto" at all. + # Often it is just ran manually after the last abend. my $exit_condition = $Save{mh_exit}; $exit_condition = 'unexpectedly!' if $exit_condition eq 'abend'; - display "MisterHouse restarted $exit_condition", 0; } -$v_reboot = new Voice_Cmd '[Reboot,Shut Down] the computer'; -$v_reboot-> set_info('Do this only if you really mean it! Windows only'); - -if ($state = said $v_reboot and $OS_win) { +# Reboot/shutdown the computer (windows only) +$v_reboot = new Voice_Cmd '[Reboot,Shut Down] the computer'; +$v_reboot->set_info('Do this only if you really mean it! Windows only'); +$v_reboot->tie_event('&handle_reboot_state()'); # noloop +sub handle_reboot_state() { + return unless $OS_win; respond "$state the computer"; - if ($Info{OS_name} eq 'Win95') { + if ( $Info{OS_name} eq 'Win95' ) { run 'RUNDLL USER.EXE,ExitWindows'; } - # In theory, either of these work for Win98/WinMe - elsif ($Info{OS_name} eq 'WinMe') { + # In theory, either of these work for Win98/WinMe + elsif ( $Info{OS_name} eq 'WinMe' ) { respond "The house computer will reboot in 15 seconds"; run 'start c:\\windows\\system\\runonce.exe -q'; - sleep 5; # Give it a chance to get started + sleep 5; # Give it a chance to get started &exit_pgm; } - elsif ($Info{OS_name} eq 'NT') { + elsif ( $Info{OS_name} eq 'NT' ) { my $machine = $ENV{COMPUTERNAME}; respond "The computer $machine will reboot in 1 minute."; - my $reboot = ($state eq 'Reboot') ? 1 : 0; - Win32::InitiateSystemShutdown($machine, 'Rebooting in 1 minute', 60, 1, $reboot); -# &exit_pgm; + my $reboot = ( $state eq 'Reboot' ) ? 1 : 0; + Win32::InitiateSystemShutdown( $machine, 'Rebooting in 1 minute', + 60, 1, $reboot ); } - elsif ($Info{OS_name} eq 'XP') { + elsif ( $Info{OS_name} eq 'XP' ) { my $machine = $ENV{COMPUTERNAME}; respond "The computer $machine will reboot in 1 minute."; - my $reboot = ($state =~ /^reboot$/i) ? '-r' : '-s'; + my $reboot = ( $state =~ /^reboot$/i ) ? '-r' : '-s'; + # *** Need 60 second timer to exit program! run "SHUTDOWN $reboot -f -t 60"; - # *** Need 60 second timer to exit program! } else { run 'rundll32.exe shell32.dll,SHExitWindowsEx 6 '; -# run 'RUNDLL32 KRNL386.EXE,exitkernel'; - sleep 5; # Give it a chance to get started + sleep 5; # Give it a chance to get started &exit_pgm; } } @@ -151,12 +164,16 @@ #4 - FORCE #8 - POWEROFF #The above options can be combined into one value to achieve different results. -#For example, to restart Windows forcefully, without querying any running programs, use the following command line: +#For example, to restart Windows forcefully, without querying any running +#programs, use the following command line: #rundll32.exe shell32.dll,SHExitWindowsEx 6 -$v_reboot_abort = new Voice_Cmd("Abort the reboot"); -if (said $v_reboot_abort and $OS_win) { - if ($Info{OS_name} eq 'XP') { +# Abort a reboot that has been initiated +$v_reboot_abort = new Voice_Cmd("Abort the reboot"); +$v_reboot_abort->tie_event('&handle_reboot_abort_state()'); # noloop +sub handle_reboot_abort_state() { + return unless $OS_win; + if ( $Info{OS_name} eq 'XP' ) { run "SHUTDOWN -a"; respond "app=pc The reboot has been aborted."; } @@ -167,115 +184,130 @@ } } -$v_debug = new Voice_Cmd("Set debug for [" . (($config_parms{debug_options})?$config_parms{debug_options}:"X10,serial,http,misc,startup,socket,password,user_code,weather") . ',none]'); -$v_debug-> set_info('Adds the given module to the current set of debug flags'); -if ($state = said $v_debug) { - if ($state eq 'none') { - $config_parms{debug}=''; - undef %Debug; - $v_debug->respond ("Debugging completely turned off"); - } else { - $Debug{$state} = 1; - &update_config_parms_debug; - $state =~ s/_/\x20/g; - $v_debug->respond ("Debugging turned on for $state"); - } +# Turn on selected debug options, or turn off completely +my $debug_str = + $config_parms{debug_options} ? $config_parms{debug_options} : + "X10,serial,http,misc,startup,socket,password,user_code,weather"; +$v_debug = new Voice_Cmd("Set debug for [$debug_str,none]"); +$v_debug->set_info('Adds the given module to the current set of debug flags'); +$v_debug->tie_event('&handle_debug_state()'); # noloop +sub handle_debug_state() { + if ( $state eq 'none' ) { + $config_parms{debug} = ''; + undef %Debug; + $v_debug->respond("Debugging completely turned off"); + } + else { + $Debug{$state} = 1; + &update_config_parms_debug; + $state =~ s/_/\x20/g; + $v_debug->respond("Debugging turned on for $state"); + } } -$v_debug_toggle = new Voice_Cmd("Toggle debug for [" . (($config_parms{debug_options})?$config_parms{debug_options}:"X10,serial,http,misc,startup,socket,password,user_code,weather") . ']'); -$v_debug_toggle-> set_info('Toggles what kind of debugging information is logged'); - -if ($state = said $v_debug_toggle) { - if ($Debug{$state}) { - $Debug{$state} = 0; - &update_config_parms_debug; - $state =~ s/_/\x20/g; - $v_debug_toggle->respond("Debugging turned off for $state"); - } else { - $Debug{$state} = 1; - &update_config_parms_debug; - $state =~ s/_/\x20/g; - $v_debug_toggle->respond("Debugging turned on for $state"); - } +# Toggle selected debug options +$v_debug_toggle = new Voice_Cmd "Toggle debug for [$debug_str]"; +$v_debug_toggle->set_info( + 'Toggles what kind of debugging information is logged'); +$v_debug_toggle->tie_event('&handle_debug_toggle_state()'); # noloop +sub handle_debug_toggle_state() { + if ( $Debug{$state} ) { + $Debug{$state} = 0; + &update_config_parms_debug; + $state =~ s/_/\x20/g; + $v_debug_toggle->respond("Debugging turned off for $state"); + } + else { + $Debug{$state} = 1; + &update_config_parms_debug; + $state =~ s/_/\x20/g; + $v_debug_toggle->respond("Debugging turned on for $state"); + } } +# Display currently active debug flags $v_show_debug = new Voice_Cmd('Show debug'); $v_show_debug->set_info('Shows the currently active debug flags'); - -if ($state = said $v_show_debug) { - &update_config_parms_debug; - if ($config_parms{debug} eq '') { - $v_show_debug->respond('There are no active debug flags'); - } else { - $v_show_debug->respond('The currently active debug flags are '.$config_parms{debug}); - } +$v_show_debug->tie_event('&handle_show_debug_state()'); # noloop +sub handle_show_debug_state() { + &update_config_parms_debug; + if ( $config_parms{debug} eq '' ) { + $v_show_debug->respond('There are no active debug flags'); + } + else { + $v_show_debug->respond( + 'The currently active debug flags are ' . $config_parms{debug} ); + } } sub update_config_parms_debug { - my @currentDebugs=(); - foreach my $key (keys(%Debug)) { - next if $key eq 'debug_previous'; - push (@currentDebugs,$key.':'.$Debug{$key}) if $Debug{$key}; - } - $config_parms{debug}=join(';',@currentDebugs); + my @currentDebugs = (); + foreach my $key (keys %Debug) { + next if $key eq 'debug_previous'; + push(@currentDebugs, $key . ':' . $Debug{$key}) if $Debug{$key}; + } + $config_parms{debug} = join(';', @currentDebugs); } +# Set the house mode $v_mode = new Voice_Cmd("Put house in [normal,mute,offline] mode"); -$v_mode-> set_info('mute mode disables all speech and sound. offline disables all serial control'); -if ($state = said $v_mode) { - $Save{mode} = $state; - set $mode_mh $state, $v_mode; - +$v_mode->set_info( 'mute mode disables all speech and sound. ' . + 'offline disables all serial control'); +$v_mode->tie_event('&handle_mode_state()'); # noloop +sub handle_mode_state() { + # this next line shouldn't be neccessary, but it is + my $state = state $v_mode; + $Save{mode} = $state; + set $mode_mh $state, $v_mode; $v_mode->respond("Setting house to $state mode."); } +# Toggle the house mode $v_mode_toggle = new Voice_Cmd("Toggle the house mode"); -if (said $v_mode_toggle) { - if ($Save{mode} eq 'mute') { +$v_mode_toggle->tie_event('&handle_mode_toggle_state()'); # noloop +sub handle_mode_toggle_state() { + if ( $Save{mode} eq 'mute' ) { $Save{mode} = 'offline'; } - elsif ($Save{mode} eq 'offline') { + elsif ( $Save{mode} eq 'offline' ) { $Save{mode} = 'normal'; } else { $Save{mode} = 'mute'; } - set $mode_mh $Save{mode}, $v_mode_toggle; - - # mode => unmuted cause speech even in mute or offline mode + set $mode_mh $Save{mode}, $v_mode_toggle; + # mode => unmuted cause speech even in mute or offline mode $v_mode_toggle->respond("mode=unmuted app=control Now in $Save{mode} mode"); } - - # Search for strings in user code -#&tk_entry('Code Search', $search_code_string) if $Run_Members{mh_control}; - -$search_code_string = new Generic_Item; # Set from web menu mh/web/ia5/house/search.shtml - -if ($temp = state_now $search_code_string) { - print "Searching for code $temp\n"; - my ($results, $count, %files); +# Allow tk and web users to search the user code for strings + # Set from web menu mh/web/ia5/house/search.shtml +$search_code_string = new Generic_Item; +$search_code_string->set_icon('mh.jpg'); # noloop +$search_code_string->tie_event('&handle_search_code_string_state()'); # noloop +sub handle_search_code_string_state() { + # this next line shouldn't be neccessary, but it is + my $state = state $search_code_string; + print "Searching for code $state\n"; + my ( $results, $count, %files ); $count = 0; - $temp =~ s/ /.+/; # Let 'reload code' match 'reload xyz code' - - - # quotemeta function? - $temp =~ s/\//\\\//g; - $temp =~ s/\\/\\\\/g; - $temp =~ s/\(/\\\(/g; - $temp =~ s/\)/\\\)/g; - $temp =~ s/\$/\\\$/; - $temp =~ s/\*/\\\*/g; - - - for my $file (sort keys %User_Code) { + $state =~ s/ /.+/; # Let 'reload code' match 'reload xyz code' + # quotemeta function? + $state =~ s/\//\\\//g; + $state =~ s/\\/\\\\/g; + $state =~ s/\(/\\\(/g; + $state =~ s/\)/\\\)/g; + $state =~ s/\$/\\\$/; + $state =~ s/\*/\\\*/g; + for my $file ( sort keys %User_Code ) { my $n = 0; - for (@{$User_Code{$file}}) { + for ( @{ $User_Code{$file} } ) { $n++; - if (/$temp/i) { + if (/$state/i) { $count++; - $results .= "\nFile: $file:\n------------------------------\n" unless $files{$file}++; - $results .= sprintf("%4d: %s", $n, $_); + $results .= "\nFile: $file:\n------------------------------\n" + unless $files{$file}++; + $results .= sprintf( "%4d: %s", $n, $_ ); } } } @@ -284,127 +316,144 @@ sub update_config_parms_debug { display $results, 60, 'Code Search Results', 'fixed' if $count; } - - # Create a list of all Voice_Cmd texts +# Create a list of all Voice_Cmd texts $v_list_voice_cmds = new Voice_Cmd 'List voice commands'; -$v_list_voice_cmds ->set_info('Display a list of valid voice commands'); +$v_list_voice_cmds->set_info('Display a list of valid voice commands'); display join "\n", &Voice_Cmd::voice_items if said $v_list_voice_cmds; - - # Create a list by X10 Addresses +# Create a list by X10 Addresses $v_list_x10_items = new Voice_Cmd 'List {X 10,X10} items', 0; -$v_list_x10_items-> set_info('Generates a report fo all X10 items, sorted by device code'); -if (said $v_list_x10_items) { +$v_list_x10_items->set_info( + 'Generates a report fo all X10 items, sorted by device code'); +$v_list_x10_items->tie_event('&handle_list_x10_items_state()'); # noloop +sub handle_list_x10_items_state() { print_log "Listing X10 items"; - my @object_list = (&list_objects_by_type('X10_Item'), - &list_objects_by_type('X10_Appliance'), - &list_objects_by_type('X10_Garage_Door')); - my @objects = map{&get_object_by_name($_)} @object_list; + my @object_list = ( + &list_objects_by_type('X10_Item'), + &list_objects_by_type('X10_Appliance'), + &list_objects_by_type('X10_Garage_Door') + ); + my @objects = map { &get_object_by_name($_) } @object_list; my $results; - for my $object (sort {$a->{x10_id} cmp $b->{x10_id}} @objects) { - $results .= sprintf("Address:%-2s File:%-15s Object:%-30s State:%s\n", - substr($object->{x10_id}, 1), $object->{filename}, $object->{object_name}, $object->{state}); + for my $object ( sort { $a->{x10_id} cmp $b->{x10_id} } @objects ) { + $results .= sprintf( + "Address:%-2s File:%-15s Object:%-30s State:%s\n", + substr( $object->{x10_id}, 1 ), $object->{filename}, + $object->{object_name}, $object->{state} + ); } -# display $results, 60, 'X10 Items', 'fixed'; - respond text => $results, time => 60, title => 'X10 Items', font => 'fixed' if $results; + # display $results, 60, 'X10 Items', 'fixed'; + respond + text => $results, + time => 60, + title => 'X10 Items', + font => 'fixed' + if $results; respond 'No items found' if !$results; } - # Create a list by Serial States +# Create a list by Serial States $v_list_serial_items = new Voice_Cmd 'List serial items'; -$v_list_serial_items-> set_info('Generates a report of all Serial_Items, sorted by serial state'); -if (said $v_list_serial_items) { +$v_list_serial_items->set_info( + 'Generates a report of all Serial_Items, sorted by serial state'); +$v_list_serial_items->tie_event('&handle_list_serial_items_state()'); # noloop +sub handle_list_serial_items_state() { print_log "Listing serial items"; my @object_list = &list_objects_by_type('Serial_Item'); - my @objects = map{&get_object_by_name($_)} @object_list; + my @objects = map { &get_object_by_name($_) } @object_list; my @results; - - # Sort object by the first id + # Sort object by the first id for my $object (@objects) { -# my ($first_id, $states); - for my $id (sort keys %{$$object{state_by_id}}) { - push @results, sprintf("ID:%-5s File:%-15s Object:%-15s states: %s", - $id, $object->{filename}, $object->{object_name}, $$object{state_by_id}{$id}); -# $first_id = $id unless $first_id; -# $states .= "$id=$$object{state_by_id}{$id}, "; + # my ($first_id, $states); + for my $id ( sort keys %{ $$object{state_by_id} } ) { + push @results, + sprintf( + "ID:%-5s File:%-15s Object:%-15s states: %s", + $id, $object->{filename}, + $object->{object_name}, + $$object{state_by_id}{$id} + ); + # $first_id = $id unless $first_id; + # $states .= "$id=$$object{state_by_id}{$id}, "; } -# push @results, sprintf("ID:%-5s File:%-15s Object:%-15s states: %s", -# $first_id, $object->{filename}, $object->{object_name}, $states); +# push @results, sprintf("ID:%-5s File:%-15s Object:%-15s states: %s", +# $first_id, $object->{filename}, $object->{object_name}, $states); } my $results = join "\n", sort @results; -# display $results, 60, 'Serial Items', 'fixed'; - respond text => $results, time => 60, title => 'Serial Items', font => 'fixed'; -} - - - # Find a list of debug options code for $Debug{xyz} -$v_list_debug_options = new Voice_Cmd 'List debug options'; -$v_list_debug_options -> set_info('Generates a list of the various -debug options you can use to get debug errata'); - -if (said $v_list_debug_options) { - - my (%debug_options, $debug_string, $prev_index); - + # display $results, 60, 'Serial Items', 'fixed'; + respond + text => $results, + time => 60, + title => 'Serial Items', + font => 'fixed'; +} + +# Find a list of debug options code for $Debug{xyz} +$v_list_debug_options = new Voice_Cmd 'List debug options'; +$v_list_debug_options->set_info('Generates a list of the various -debug ' . + 'options you can use to get debug errata'); +$v_list_debug_options->tie_event('&handle_list_debug_options_state()'); # noloop +sub handle_list_debug_options_state() { + my ( %debug_options, $debug_string, $prev_index ); my %files = &file_read_dir('../lib/'); - my @files = grep(/\.(pl|pm)$/i, values %files); - - for my $file ('mh', @files) { + my @files = grep( /\.(pl|pm)$/i, values %files ); + for my $file ( 'mh', @files ) { print "reading $file\n"; - for (&file_read($file, 2)) { + for ( &file_read( $file, 2 ) ) { $debug_options{$1}++ if /Debug\{['"]?(\S+?)['"]?\}/; } } - print "Reading user code\n"; for (@Sub_Code) { - $debug_options{$1}++ if /Debug\{['"]?(\S+?)['"]?\}/; + $debug_options{$1}++ if /Debug\{['"]?(\S+?)['"]?\}/; } - - for my $key (sort keys %debug_options) { - if ($prev_index ne substr($key, 0, 1)) { - $prev_index = substr($key, 0, 1); + for my $key ( sort keys %debug_options ) { + if ( $prev_index ne substr( $key, 0, 1 ) ) { + $prev_index = substr( $key, 0, 1 ); $debug_string .= "\n"; } $debug_string .= "$key "; } -# display "List of debug options:\n$debug_string"; + # display "List of debug options:\n$debug_string"; respond text => "List of debug options:\n$debug_string"; } - - # Echo serial matches -&Serial_match_add_hook(\&serial_match_log) if $Reload; +# Echo serial matches +&Serial_match_add_hook( \&serial_match_log ) if $Reload; sub serial_match_log { - my ($ref, $state, $event) = @_; - return unless $event =~ /^X/; # Echo only X10 events - my ($prefix,$name) = $$ref{object_name} =~ /^(.)(.+)/g; + my ( $ref, $state, $event ) = @_; + return unless $event =~ /^X/; # Echo only X10 events + my ( $prefix, $name ) = $$ref{object_name} =~ /^(.)(.+)/g; + # don't log a message if being generated by an X10_Item contained object # see lib/X10_Items for more info return if $prefix eq '#'; - print_log "$event: $name $state" if $config_parms{x10_errata} > 1 and !$$ref{no_log}; + print_log "$event: $name $state" + if $config_parms{x10_errata} > 1 and !$$ref{no_log}; } - # Allow for keyboard control +# Allow for keyboard control if ($Keyboard) { - if ($Keyboard eq 'F1') { + if ( $Keyboard eq 'F1' ) { print "Key F1 pressed. Reloading code\n"; - # Must be done before the user code eval + + # Must be done before the user code eval push @Nextpass_Actions, \&read_code; } - elsif ($Keyboard eq 'F2') { + elsif ( $Keyboard eq 'F2' ) { print "Key F2 pressed. Toggling pause mode.\n"; - &toggle_pause; # Leaving pause mode is still done in mh code + &toggle_pause; # Leaving pause mode is still done in mh code } - elsif ($Keyboard eq 'F3') { + elsif ( $Keyboard eq 'F3' ) { print "Key F3 pressed. Exiting.\n"; &exit_pgm; } - elsif ($Keyboard eq 'F4') { - print "Key F4 pressed. Toggling debug.\n"; # defunct + elsif ( $Keyboard eq 'F4' ) { + print "Key F4 pressed. Toggling debug.\n"; # defunct &toggle_debug; } - elsif ($Keyboard eq 'F5') { + elsif ( $Keyboard eq 'F5' ) { print "Key F3 pressed. Toggling console logging.\n"; &toggle_log; } @@ -413,13 +462,13 @@ sub serial_match_log { } } - # Monitor if web password was set or unset +# Monitor if web password was set or unset speak 'app=notice Web password was just set' if $Cookies{password_was_set}; -speak 'app=notice Notice, an invalid Web password was just specified' if $Cookies{password_was_not_set}; - +speak 'app=notice Notice, an invalid Web password was just specified' + if $Cookies{password_was_not_set}; - # Those with ups devices can set this seperatly - # Those without a CM11 ... this will not hurt any +# Those with ups devices can set this seperatly +# Those without a CM11 ... this will not hurt any $Power_Supply = new Generic_Item; if ($ControlX10::CM11::POWER_RESET) { @@ -428,36 +477,39 @@ sub serial_match_log { print_log 'CM11 power reset detected'; } - # Set back to normal 1 pass after restored -if (state_now $Power_Supply eq 'Restored') { +# Set back to normal 1 pass after restored +if ( state_now $Power_Supply eq 'Restored' ) { speak 'Power has been restored'; set $Power_Supply 'Normal'; display time => 0, text => "Detected a power reset"; } - - # Process any backlogged X10 data +# Process any backlogged X10 data $x10_backlog_timer = new Timer; if ($ControlX10::CM11::BACKLOG) { print "X10:scheduling backlog\n"; - set $x10_backlog_timer 1, "process_serial_data('X$ControlX10::CM11::BACKLOG',1,undef)"; + set $x10_backlog_timer 1, + "process_serial_data('X$ControlX10::CM11::BACKLOG',1,undef)"; $ControlX10::CM11::BACKLOG = ""; } - - - # Repeat last spoken -$v_repeat_last_spoken = new Voice_Cmd '{Repeat your last message,What did you say}', ''; -if (said $v_repeat_last_spoken) { +# Repeat last spoken +$v_repeat_last_spoken = new Voice_Cmd + '{Repeat your last message, What did you say}', ''; +$v_repeat_last_spoken->tie_event('&handle_repeat_last_spoken_state()'); # noloop +sub handle_repeat_last_spoken_state() { ($temp = $Speak_Log[0]) =~ s/^.+?: //s; - ($temp = $temp) =~ s/^I said //s; # In case we run this more than once in a row - $temp = lcfirst($temp); - respond "I said $temp"; + $temp =~ s/^I said //s; # In case we run this more than once in a row + $temp = lcfirst($temp); + respond "I said $temp"; } +# Clear the web cache directory $v_clear_cache = new Voice_Cmd 'Clear the web cache directory', ''; -$v_clear_cache-> set_info('Delete all the auto-generated .jpg files in mh/web/cache'); -if (said $v_clear_cache) { +$v_clear_cache->set_info( + 'Delete all the auto-generated .jpg files in mh/web/cache'); +$v_clear_cache->tie_event('&handle_clear_cache_state()'); # noloop +sub handle_clear_cache_state() { my $cmd = ($OS_win) ? 'del' : 'rm'; $cmd .= " $config_parms{html_dir}/cache/*.jpg"; $cmd =~ s|/|\\|g if $OS_win; @@ -469,102 +521,101 @@ sub serial_match_log { respond "Web cache directory has been cleared."; } - # Archive old logs +# Archive old logs if ($New_Month) { - print_log "Archiving old print/speak logs: $config_parms{data_dir}/logs/print.log.old"; + print_log +"Archiving old print/speak logs: $config_parms{data_dir}/logs/print.log.old"; file_backup "$config_parms{data_dir}/logs/print.log.old", 'force'; file_backup "$config_parms{data_dir}/logs/speak.log.old", 'force'; file_backup "$config_parms{data_dir}/logs/error.log.old", 'force'; } - - # Allow for commands to be entered via tk or web -$run_command = new Generic_Item; # Set from web menu mh/web/ia5/house/search.shtml -#&tk_entry('Run Command', $run_command) if $Run_Members{mh_control}; - -if ($temp = state_now $run_command) { +# Allow for commands to be entered via tk or web + # Set from web menu mh/web/ia5/house/search.shtml +$run_command = new Generic_Item; +$run_command->tie_event('&handle_run_command_state()'); # noloop +sub handle_run_command_state() { my $set_by = get_set_by $run_command; - print_log "Running External $set_by command: $temp"; - &process_external_command($temp, 1, $set_by); -} - -$search_command_string = new Generic_Item; # Set from web menu mh/web/ia5/house/search.shtml -if ($temp = state_now $search_command_string) { - my @match = &phrase_match($temp); - my $results = "Matches for $temp:\n"; - my $i = 1; + print_log "Running External $set_by command: $state"; + &process_external_command( $state, 1, $set_by ); +} + +# Allow web users to search the code + # Set from web menu mh/web/ia5/house/search.shtml +$search_command_string = new Generic_Item; +$search_command_string->tie_event( # noloop + '&handle_search_command_string_state()'); # noloop +sub handle_search_command_string_state() { + my @match = &phrase_match($state); + my $results = "Matches for $state:\n"; + my $i = 1; for my $cmd2 (@match) { $results .= " $i: $cmd2\n"; $i++; } -# respond $results; + # respond $results; $search_command_string->respond($results); } +# Undo the last action $v_undo_last_change = new Voice_Cmd 'Undo the last action'; -$v_undo_last_change-> set_info('Changes the most recently changed item back to its previous state'); - -if (said $v_undo_last_change) { - &undo_last_action($v_undo_last_change); +$v_undo_last_change->set_info( + 'Changes the most recently changed item back to its previous state'); +$v_undo_last_change->tie_event('&handle_undo_last_change_state()'); # noloop +sub handle_undo_last_change_state() { + &undo_last_action($v_undo_last_change); } - # Add a short command for testing -$test_command_yo = new Text_Cmd 'yo'; -$test_command_yo-> set_info('A short text command for quick tests'); -$test_command_yo-> set_authority('anyone'); - -$test_command_yo2 = new Text_Cmd 'yo2'; -$test_command_yo2-> set_info('A short text authorization required command for quick tests'); - -respond "Hi to $test_command_yo->{set_by}, $test_command_yo->{target}." if said $test_command_yo; -respond "Hi to authorized $test_command_yo2->{set_by}, $test_command_yo2->{target}." if said $test_command_yo2; - - -# Set up core MisterHouse modes like mode_mh (normal/mute/offline), mode_vacation (on/off), -# mode_security (armed/unarmed), mode_sleep (awake/sleeping parents/sleeping kids). +# Set up core MisterHouse modes like mode_mh (normal/mute/offline), +# mode_vacation (on/off), mode_security (armed/unarmed), +# mode_sleep (awake/sleeping parents/sleeping kids). # These modes can be controlled via the modes menu. -$mode_mh = new Generic_Item; -$mode_mh -> set_states('normal', 'mute', 'offline'); - - - - - -$mode_security = new Generic_Item; -$mode_security -> set_states('armed', 'unarmed'); - -$mode_occupied = new Generic_Item; -$mode_occupied -> set_states('home', 'work', 'vacation'); - -$mode_sleeping = new Generic_Item; -$mode_sleeping -> set_states('nobody', 'parents', 'kids', 'all'); - - # Grandfather in the $Save{mode} versions -if (state_now $mode_mh) { - my $state = $mode_mh->{state}; +# Grandfather in the $Save{mode} versions +$mode_mh = new Generic_Item; +$mode_mh->set_states( 'normal', 'mute', 'offline' ); +$mode_mh->tie_event('&handle_mode_mh_state()'); # noloop +sub handle_mode_mh_state() { + # this next line shouldn't be neccessary, but it is + my $state = state $mode_mh; $Save{mode} = $state; $mode_mh->respond("mode=unmuted app=control Changed to $Save{mode} mode."); } -if (state_now $mode_sleeping) { - my $state = $mode_sleeping->{state}; - $Save{sleeping_parents} = ($state eq 'parents' or $state eq 'all') ? 1 : 0; - $Save{sleeping_kids} = ($state eq 'kids' or $state eq 'all') ? 1 : 0; - $state = ucfirst($state); - $mode_sleeping->respond("mode=unmuted app=control $state are sleeping."); -} - -if (state_now $mode_security) { - my $state = $mode_security->{state}; +$mode_security = new Generic_Item; +$mode_security->set_states( 'armed', 'unarmed' ); +$mode_security->tie_event('&handle_mode_security_state()'); # noloop +sub handle_mode_security_state() { + # this next line shouldn't be neccessary, but it is + my $state = state $mode_mh; $Save{security} = $state; $mode_security->respond("mode=unmuted app=control Security $state."); } -#if ($Reload) { -# my $tk = &tk_label_new(3, \$Save{mode}); -# $tk->bind('' => \&toggle_house_mode) if $MW; +$mode_occupied = new Generic_Item; +$mode_occupied->set_states( 'home', 'work', 'vacation' ); + +$mode_sleeping = new Generic_Item; +$mode_sleeping->set_states( 'nobody', 'parents', 'kids', 'all' ); +$mode_sleeping->tie_event('&handle_mode_sleeping_state()'); # noloop +sub handle_mode_sleeping_state() { + # this next line shouldn't be neccessary, but it is + my $state = state $mode_mh; + $Save{sleeping_parents} = + ( $state eq 'parents' or $state eq 'all' ) ? 1 : 0; + $Save{sleeping_kids} = ( $state eq 'kids' or $state eq 'all' ) ? 1 : 0; + $state = ucfirst($state); + $mode_sleeping->respond("mode=unmuted app=control $state are sleeping."); +} -# $tk = &tk_label_new(3, \$Save{security}); -# $tk->bind('' => \&toggle_security_mode) if $MW; -#} +# Convert any updated pod documentation to html +$v_update_docs = new Voice_Cmd "Update the Documentation"; +$p_update_docs = new Process_Item "update_docs"; +$v_update_docs->tie_event('start $p_update_docs'); # noloop +$v_update_docs->set_icon('mh.jpg'); # noloop +# noloop=start + &trigger_set("time_cron('5 4 * * *')", + "run_voice_cmd 'Update the Documentation'", 'NoExpire', + 'update the documentation') + unless &trigger_get('update the documentation'); +# noloop=stop diff --git a/code/common/monitor_actiontec_mi424wr.pl b/code/common/monitor_actiontec_mi424wr.pl index b26579af9..86fdd6c72 100755 --- a/code/common/monitor_actiontec_mi424wr.pl +++ b/code/common/monitor_actiontec_mi424wr.pl @@ -1,290 +1,313 @@ -# Category = Internet - -#@ This script collects and graphs traffic data from an actiontec mi424 wr router used by Verizon FIOS. -#@ Once this script is activated, -#@ this graph or -#@ this page will show your Internet traffic. - -# 09/11/08 created by David Norwood - -use HTML::TableExtract; -use RRDs; - -my $actiontec_host = '192.168.1.1'; -my $actiontec_username = 'admin'; -my $actiontec_password = 'password1'; -my $actiontec_download_mbps = 10.0; -my $actiontec_upload_mbps = 2.0; -my $actiontec_url; -my $f_actiontec = "$config_parms{data_dir}/web/actiontec.html"; -$v_get_actiontec = new Voice_Cmd 'Get actiontec info'; -$v_read_actiontec = new Voice_Cmd 'What is the internet bit rate?'; -$p_get_actiontec = new Process_Item; -my $RRD = "$config_parms{data_dir}/rrd/actiontec.rrd"; -my $debug = $Debug{actiontec}; -my $quiet = $debug ? "" : "-quiet"; -my $stage = 'authen'; - -if ($Reload) { - $actiontec_username = $config_parms{'actiontec_username'} if $config_parms{'actiontec_username'}; - $actiontec_password = $config_parms{'actiontec_password'} if $config_parms{'actiontec_password'}; - $actiontec_download_mbps = $config_parms{'actiontec_download_mbps'} if $config_parms{'actiontec_download_mbps'}; - $actiontec_upload_mbps = $config_parms{'actiontec_upload_mbps'} if $config_parms{'actiontec_upload_mbps'}; - mkdir "$config_parms{data_dir}/rrd/" unless -d "$config_parms{data_dir}/rrd/"; - &create_actiontec_rrd($Time) unless -e $RRD; - $Included_HTML{'Internet'} .= qq(

Actiontec Throughput

\n\n\n); - $actiontec_host = $config_parms{'actiontec_host'} if $config_parms{'actiontec_host'}; - $actiontec_url = "http://$actiontec_host"; - set $p_get_actiontec qq|get_url $quiet $actiontec_url $f_actiontec|; - $p_get_actiontec->start; -} - -if (new_minute and ($stage eq 'ready' or $stage eq 'authen') and $p_get_actiontec->done) { - unlink $f_actiontec; - $p_get_actiontec->start; -} - -if (said $v_read_actiontec) { - my $state = $v_read_actiontec->{state}; - my $text = "Internet download bit rate: " . $Save{actiontec_rx} . " Mbps upload: " . $Save{actiontec_tx} . " Mbps" ; - $v_read_actiontec->respond("app=network $text"); -} - -use Digest::MD5; -if (done_now $p_get_actiontec) { - my $html = file_read $f_actiontec; - my $post_data = "bla=foo"; - my %hidden = $html =~ m|\|g; - my ($url) = $html =~ m|f.action=\"(/cache/\d+/index.cgi)\"|; - - if ($stage eq 'authen') { - $stage = 'get_main'; - print_log "actiontec stage $stage url $url"; - $hidden{mimic_button_field} = "submit_button_login_submit: .."; - if ($html =~ m|$hidden{mimic_button_field}|) { - $hidden{user_name} = $actiontec_username; - $hidden{"passwordmask_$hidden{session_id}"} = $actiontec_password; - $hidden{md5_pass} = Digest::MD5::md5_hex($hidden{"passwordmask_$hidden{session_id}"} . $hidden{auth_key}); - $hidden{passwd1} = " "; - foreach my $key (keys %hidden) { - $hidden{$key} = &escape($hidden{$key}); - $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; - } - print_log "actiontec post data: $post_data" if $debug; - set $p_get_actiontec qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; - $p_get_actiontec->start; - } else { - $stage = 'authen'; - print_log "actiontec: didnt see expected html"; - set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; - } - } - elsif ($stage eq 'get_main') { - $stage = 'get_monitoring'; - print_log "actiontec stage $stage url $url"; - $hidden{mimic_button_field} = "sidebar: actiontec_topbar_status.."; - if ($html =~ m|$hidden{mimic_button_field}|) { - foreach my $key (keys %hidden) { - $hidden{$key} = &escape($hidden{$key}); - $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; - } - print_log "actiontec post data: $post_data" if $debug; - set $p_get_actiontec qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; - $p_get_actiontec->start; - } else { - $stage = 'authen'; - print_log "actiontec: didnt see expected html"; - set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; - } - } - elsif ($stage eq 'get_monitoring') { - $stage = 'get_nag'; - print_log "actiontec stage $stage url $url"; - $hidden{mimic_button_field} = "btn_tab_goto: 755.."; - if ($html =~ m|goto: 755..|) { - foreach my $key (keys %hidden) { - $hidden{$key} = &escape($hidden{$key}); - $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; - } - print_log "actiontec post data: $post_data" if $debug; - set $p_get_actiontec qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; - $p_get_actiontec->start; - } else { - $stage = 'authen'; - print_log "actiontec: didnt see expected html"; - set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; - } - } - elsif ($stage eq 'get_nag') { - $stage = 'get_adv_monitoring'; - print_log "actiontec stage $stage url $url"; - $hidden{mimic_button_field} = "submit_button_yes: .."; - if ($html =~ m|$hidden{mimic_button_field}|) { - foreach my $key (keys %hidden) { - $hidden{$key} = &escape($hidden{$key}); - $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; - } - print_log "actiontec post data: $post_data" if $debug; - set $p_get_actiontec qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; - $p_get_actiontec->start; - } else { - $stage = 'authen'; - print_log "actiontec: didnt see expected html"; - set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; - } - } - elsif ($stage eq 'get_adv_monitoring') { - $stage = 'ready'; - print_log "actiontec stage $stage url $url"; - $hidden{mimic_button_field} = "btn_tab_goto: 6022.."; - if ($html =~ m|goto: 6022..|) { - foreach my $key (keys %hidden) { - $hidden{$key} = &escape($hidden{$key}); - $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; - } - print_log "actiontec post data: $post_data" if $debug; - set $p_get_actiontec qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; - $p_get_actiontec->start; - } else { - $stage = 'authen'; - print_log "actiontec: didnt see expected html"; - set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; - } - } - elsif ($stage eq 'ready') { - my $te = HTML::TableExtract->new( headers => ["1 Minute"]); - $te->parse($html); - my @cell = $te->rows; - $Save{actiontec_rx} = $cell[1][0] / 1000; - $Save{actiontec_tx} = $cell[0][0] / 1000; - - if ($Save{actiontec_rx} and $Save{actiontec_tx}) { - &update_actiontec_rrd($Time, $Save{actiontec_rx}, $Save{actiontec_tx}); - print_log "Internet download bit rate: " . $Save{actiontec_rx} . - " Mbps upload: " . $Save{actiontec_tx} . " Mbps" if $debug; - } else { - $stage = 'authen'; - print_log "actiontec: didnt see expected html"; - set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; - } - } -} - - - -=begin - my $te = new HTML::TableExtract(); - $te->parse($html); - - foreach my $ts ($te->table_states) { - print "Table (", join(',', $ts->coords), "):\n"; - my $i = 0; - foreach my $row ($ts->rows) { - my $j = 0; - foreach my $col (@$row) { - print "$i,$j $col\n"; - $j++; - } - $i++; - } - } -=cut - -# Create database - -sub create_actiontec_rrd { - my $err; - print "Create RRD database : $RRD\n"; - - RRDs::create $RRD, - '-b', $_[0], '-s', 60, - "DS:rxmbps:GAUGE:300:U:U", - "DS:txmbps:GAUGE:300:U:U", - 'RRA:AVERAGE:0.5:1:801', # details for 6 hours (agregate 1 minute) - - 'RRA:MIN:0.5:2:801', # 1 day (agregate 2 minutes) - 'RRA:AVERAGE:0.5:2:801', - 'RRA:MAX:0.5:2:801', - - 'RRA:MIN:0.5:5:641', # 2 day (agregate 5 minutes) - 'RRA:AVERAGE:0.5:5:641', - 'RRA:MAX:0.5:5:641', - - 'RRA:MIN:0.5:18:623', # 1 week (agregate 18 minutes) - 'RRA:AVERAGE:0.5:18:623', - 'RRA:MAX:0.5:18:623', - - 'RRA:MIN:0.5:35:618', # 2 weeks (agregate 35 minutes) - 'RRA:AVERAGE:0.5:35:618', - 'RRA:MAX:0.5:35:618', - - 'RRA:MIN:0.5:75:694', # 1 month (agregate 1h15mn) - 'RRA:AVERAGE:0.5:75:694', - 'RRA:MAX:0.5:75:694', - - 'RRA:MIN:0.5:150:694', # 2 months (agregate 2h30mn) - 'RRA:AVERAGE:0.5:150:694', - 'RRA:MAX:0.5:150:694', - - 'RRA:MIN:0.5:1080:268', # 6 months (agregate 18 hours) - 'RRA:AVERAGE:0.5:1080:268', - 'RRA:MAX:0.5:1080:268', - - 'RRA:MIN:0.5:2880:209', # 12 months (agregate 2 days) - 'RRA:AVERAGE:0.5:2880:209', - 'RRA:MAX:0.5:2880:209', - - 'RRA:MIN:0.5:4320:279', # 2 years (agregate 3 days) - 'RRA:AVERAGE:0.5:4320:279', - 'RRA:MAX:0.5:4320:279', - - 'RRA:MIN:0.5:8640:334', # 5 years (agregate 6 days) - 'RRA:AVERAGE:0.5:8640:334', - 'RRA:MAX:0.5:8640:334'; - ; - - my $err = RRDs::error; - print_log "actiontec create error $err\n" if $err; -} - -# Update database - -sub update_actiontec_rrd { - my ($time, @data) = @_; - - print_log "actiontec update time = $time data = @data\n" if $debug; - RRDs::update $RRD, "$time:" . join ':', @data; # add current data - - my $err = RRDs::error; - print_log "actiontec update error $err\n" if $err; -} - -# Create graph PNG image - -sub graph_actiontec_rrd { - my ($seconds, $width, $height) = @_; - $seconds = 3600 * 6 unless $seconds; - my $ago = $Time - $seconds; - $width = 800 unless $width and $height; - $height = 100 unless $width and $height; - my $thumb = $height < 86 ? "--only-graph" : "--lazy"; - - unlink "$config_parms{data_dir}/rrd/actiontec.png"; - my ($graph, $x, $y) = RRDs::graph("$config_parms{data_dir}/rrd/actiontec.png", - "--start=$ago", "--end=$Time", - "--width=$width", "--height=$height", - "--lower-limit=-$actiontec_upload_mbps", "--upper-limit=$actiontec_download_mbps", - "--vertical-label=Mb/s", - "DEF:rxmbps=$RRD:rxmbps:AVERAGE", - "AREA:rxmbps#2000FF:In traffic", - "DEF:txmbps=$RRD:txmbps:AVERAGE", - "CDEF:itxmbps=txmbps,-1,*", - "AREA:itxmbps#AFAF00:Out traffic", - $thumb - ); - my $err = RRDs::error; - print_log "actiontec graph error $err\n" if $err; - unlink "$config_parms{data_dir}/rrd/actiontec.jpg"; - `convert $config_parms{data_dir}/rrd/actiontec.png $config_parms{data_dir}/rrd/actiontec.jpg`; - return file_read "$config_parms{data_dir}/rrd/actiontec.jpg"; -} +# Category = Internet + +#@ This script collects and graphs traffic data from an actiontec mi424 wr router used by Verizon FIOS. +#@ Once this script is activated, +#@ this graph or +#@ this page will show your Internet traffic. + +# 09/11/08 created by David Norwood + +use HTML::TableExtract; +use RRDs; + +my $actiontec_host = '192.168.1.1'; +my $actiontec_username = 'admin'; +my $actiontec_password = 'password1'; +my $actiontec_download_mbps = 10.0; +my $actiontec_upload_mbps = 2.0; +my $actiontec_url; +my $f_actiontec = "$config_parms{data_dir}/web/actiontec.html"; +$v_get_actiontec = new Voice_Cmd 'Get actiontec info'; +$v_read_actiontec = new Voice_Cmd 'What is the internet bit rate?'; +$p_get_actiontec = new Process_Item; +my $RRD = "$config_parms{data_dir}/rrd/actiontec.rrd"; +my $debug = $Debug{actiontec}; +my $quiet = $debug ? "" : "-quiet"; +my $stage = 'authen'; + +if ($Reload) { + $actiontec_username = $config_parms{'actiontec_username'} + if $config_parms{'actiontec_username'}; + $actiontec_password = $config_parms{'actiontec_password'} + if $config_parms{'actiontec_password'}; + $actiontec_download_mbps = $config_parms{'actiontec_download_mbps'} + if $config_parms{'actiontec_download_mbps'}; + $actiontec_upload_mbps = $config_parms{'actiontec_upload_mbps'} + if $config_parms{'actiontec_upload_mbps'}; + mkdir "$config_parms{data_dir}/rrd/" + unless -d "$config_parms{data_dir}/rrd/"; + &create_actiontec_rrd($Time) unless -e $RRD; + $Included_HTML{'Internet'} .= +qq(

Actiontec Throughput

\n\n\n); + $actiontec_host = $config_parms{'actiontec_host'} + if $config_parms{'actiontec_host'}; + $actiontec_url = "http://$actiontec_host"; + set $p_get_actiontec qq|get_url $quiet $actiontec_url $f_actiontec|; + $p_get_actiontec->start; +} + +if ( new_minute + and ( $stage eq 'ready' or $stage eq 'authen' ) + and $p_get_actiontec->done ) +{ + unlink $f_actiontec; + $p_get_actiontec->start; +} + +if ( said $v_read_actiontec) { + my $state = $v_read_actiontec->{state}; + my $text = + "Internet download bit rate: " + . $Save{actiontec_rx} + . " Mbps upload: " + . $Save{actiontec_tx} . " Mbps"; + $v_read_actiontec->respond("app=network $text"); +} + +use Digest::MD5; +if ( done_now $p_get_actiontec) { + my $html = file_read $f_actiontec; + my $post_data = "bla=foo"; + my %hidden = + $html =~ m|\|g; + my ($url) = $html =~ m|f.action=\"(/cache/\d+/index.cgi)\"|; + + if ( $stage eq 'authen' ) { + $stage = 'get_main'; + print_log "actiontec stage $stage url $url"; + $hidden{mimic_button_field} = "submit_button_login_submit: .."; + if ( $html =~ m|$hidden{mimic_button_field}| ) { + $hidden{user_name} = $actiontec_username; + $hidden{"passwordmask_$hidden{session_id}"} = $actiontec_password; + $hidden{md5_pass} = + Digest::MD5::md5_hex( $hidden{"passwordmask_$hidden{session_id}"} + . $hidden{auth_key} ); + $hidden{passwd1} = " "; + foreach my $key ( keys %hidden ) { + $hidden{$key} = &escape( $hidden{$key} ); + $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; + } + print_log "actiontec post data: $post_data" if $debug; + set $p_get_actiontec +qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; + $p_get_actiontec->start; + } + else { + $stage = 'authen'; + print_log "actiontec: didnt see expected html"; + set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; + } + } + elsif ( $stage eq 'get_main' ) { + $stage = 'get_monitoring'; + print_log "actiontec stage $stage url $url"; + $hidden{mimic_button_field} = "sidebar: actiontec_topbar_status.."; + if ( $html =~ m|$hidden{mimic_button_field}| ) { + foreach my $key ( keys %hidden ) { + $hidden{$key} = &escape( $hidden{$key} ); + $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; + } + print_log "actiontec post data: $post_data" if $debug; + set $p_get_actiontec +qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; + $p_get_actiontec->start; + } + else { + $stage = 'authen'; + print_log "actiontec: didnt see expected html"; + set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; + } + } + elsif ( $stage eq 'get_monitoring' ) { + $stage = 'get_nag'; + print_log "actiontec stage $stage url $url"; + $hidden{mimic_button_field} = "btn_tab_goto: 755.."; + if ( $html =~ m|goto: 755..| ) { + foreach my $key ( keys %hidden ) { + $hidden{$key} = &escape( $hidden{$key} ); + $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; + } + print_log "actiontec post data: $post_data" if $debug; + set $p_get_actiontec +qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; + $p_get_actiontec->start; + } + else { + $stage = 'authen'; + print_log "actiontec: didnt see expected html"; + set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; + } + } + elsif ( $stage eq 'get_nag' ) { + $stage = 'get_adv_monitoring'; + print_log "actiontec stage $stage url $url"; + $hidden{mimic_button_field} = "submit_button_yes: .."; + if ( $html =~ m|$hidden{mimic_button_field}| ) { + foreach my $key ( keys %hidden ) { + $hidden{$key} = &escape( $hidden{$key} ); + $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; + } + print_log "actiontec post data: $post_data" if $debug; + set $p_get_actiontec +qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; + $p_get_actiontec->start; + } + else { + $stage = 'authen'; + print_log "actiontec: didnt see expected html"; + set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; + } + } + elsif ( $stage eq 'get_adv_monitoring' ) { + $stage = 'ready'; + print_log "actiontec stage $stage url $url"; + $hidden{mimic_button_field} = "btn_tab_goto: 6022.."; + if ( $html =~ m|goto: 6022..| ) { + foreach my $key ( keys %hidden ) { + $hidden{$key} = &escape( $hidden{$key} ); + $post_data .= "&$key=$hidden{$key}" if defined $hidden{$key}; + } + print_log "actiontec post data: $post_data" if $debug; + set $p_get_actiontec +qq|get_url $quiet -post "$post_data" $actiontec_url$url $f_actiontec|; + $p_get_actiontec->start; + } + else { + $stage = 'authen'; + print_log "actiontec: didnt see expected html"; + set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; + } + } + elsif ( $stage eq 'ready' ) { + my $te = HTML::TableExtract->new( headers => ["1 Minute"] ); + $te->parse($html); + my @cell = $te->rows; + $Save{actiontec_rx} = $cell[1][0] / 1000; + $Save{actiontec_tx} = $cell[0][0] / 1000; + + if ( $Save{actiontec_rx} and $Save{actiontec_tx} ) { + &update_actiontec_rrd( $Time, $Save{actiontec_rx}, + $Save{actiontec_tx} ); + print_log "Internet download bit rate: " + . $Save{actiontec_rx} + . " Mbps upload: " + . $Save{actiontec_tx} . " Mbps" + if $debug; + } + else { + $stage = 'authen'; + print_log "actiontec: didnt see expected html"; + set $p_get_actiontec qq|get_url $actiontec_url $f_actiontec|; + } + } +} + +=begin + my $te = new HTML::TableExtract(); + $te->parse($html); + + foreach my $ts ($te->table_states) { + print "Table (", join(',', $ts->coords), "):\n"; + my $i = 0; + foreach my $row ($ts->rows) { + my $j = 0; + foreach my $col (@$row) { + print "$i,$j $col\n"; + $j++; + } + $i++; + } + } +=cut + +# Create database + +sub create_actiontec_rrd { + my $err; + print "Create RRD database : $RRD\n"; + + RRDs::create $RRD, + '-b', $_[0], '-s', 60, + "DS:rxmbps:GAUGE:300:U:U", + "DS:txmbps:GAUGE:300:U:U", + 'RRA:AVERAGE:0.5:1:801', # details for 6 hours (agregate 1 minute) + + 'RRA:MIN:0.5:2:801', # 1 day (agregate 2 minutes) + 'RRA:AVERAGE:0.5:2:801', 'RRA:MAX:0.5:2:801', + + 'RRA:MIN:0.5:5:641', # 2 day (agregate 5 minutes) + 'RRA:AVERAGE:0.5:5:641', 'RRA:MAX:0.5:5:641', + + 'RRA:MIN:0.5:18:623', # 1 week (agregate 18 minutes) + 'RRA:AVERAGE:0.5:18:623', 'RRA:MAX:0.5:18:623', + + 'RRA:MIN:0.5:35:618', # 2 weeks (agregate 35 minutes) + 'RRA:AVERAGE:0.5:35:618', 'RRA:MAX:0.5:35:618', + + 'RRA:MIN:0.5:75:694', # 1 month (agregate 1h15mn) + 'RRA:AVERAGE:0.5:75:694', 'RRA:MAX:0.5:75:694', + + 'RRA:MIN:0.5:150:694', # 2 months (agregate 2h30mn) + 'RRA:AVERAGE:0.5:150:694', 'RRA:MAX:0.5:150:694', + + 'RRA:MIN:0.5:1080:268', # 6 months (agregate 18 hours) + 'RRA:AVERAGE:0.5:1080:268', 'RRA:MAX:0.5:1080:268', + + 'RRA:MIN:0.5:2880:209', # 12 months (agregate 2 days) + 'RRA:AVERAGE:0.5:2880:209', 'RRA:MAX:0.5:2880:209', + + 'RRA:MIN:0.5:4320:279', # 2 years (agregate 3 days) + 'RRA:AVERAGE:0.5:4320:279', 'RRA:MAX:0.5:4320:279', + + 'RRA:MIN:0.5:8640:334', # 5 years (agregate 6 days) + 'RRA:AVERAGE:0.5:8640:334', 'RRA:MAX:0.5:8640:334'; + + my $err = RRDs::error; + print_log "actiontec create error $err\n" if $err; +} + +# Update database + +sub update_actiontec_rrd { + my ( $time, @data ) = @_; + + print_log "actiontec update time = $time data = @data\n" if $debug; + RRDs::update $RRD, "$time:" . join ':', @data; # add current data + + my $err = RRDs::error; + print_log "actiontec update error $err\n" if $err; +} + +# Create graph PNG image + +sub graph_actiontec_rrd { + my ( $seconds, $width, $height ) = @_; + $seconds = 3600 * 6 unless $seconds; + my $ago = $Time - $seconds; + $width = 800 unless $width and $height; + $height = 100 unless $width and $height; + my $thumb = $height < 86 ? "--only-graph" : "--lazy"; + + unlink "$config_parms{data_dir}/rrd/actiontec.png"; + my ( $graph, $x, $y ) = RRDs::graph( + "$config_parms{data_dir}/rrd/actiontec.png", + "--start=$ago", + "--end=$Time", + "--width=$width", + "--height=$height", + "--lower-limit=-$actiontec_upload_mbps", + "--upper-limit=$actiontec_download_mbps", + "--vertical-label=Mb/s", + "DEF:rxmbps=$RRD:rxmbps:AVERAGE", + "AREA:rxmbps#2000FF:In traffic", + "DEF:txmbps=$RRD:txmbps:AVERAGE", + "CDEF:itxmbps=txmbps,-1,*", + "AREA:itxmbps#AFAF00:Out traffic", + $thumb + ); + my $err = RRDs::error; + print_log "actiontec graph error $err\n" if $err; + unlink "$config_parms{data_dir}/rrd/actiontec.jpg"; +`convert $config_parms{data_dir}/rrd/actiontec.png $config_parms{data_dir}/rrd/actiontec.jpg`; + return file_read "$config_parms{data_dir}/rrd/actiontec.jpg"; +} diff --git a/code/common/monitor_memory.pl b/code/common/monitor_memory.pl index 94b29c7f4..a36c10655 100644 --- a/code/common/monitor_memory.pl +++ b/code/common/monitor_memory.pl @@ -1,36 +1,43 @@ # Category = MisterHouse -#@ Monitors for memory leaks +#@ Monitors for memory leaks -# Monitor memory usage (unix and NT/2K only. +# Monitor memory usage (unix and NT/2K only. # Win95/98 has no way to monitor memory :( - #noloop=start + my $memory_leak_log = "$config_parms{data_dir}/logs/monitor_memory_leak.log"; -logit $memory_leak_log, "-- Restarted --. Perl version: $Info{Perl_version}" if $Startup; +logit $memory_leak_log, "-- Restarted --. Perl version: $Info{Perl_version}" + if $Startup; + +logit $memory_leak_log, ' ReLoad'; + #noloop=stop - # Ignore startup memory stats -if ($Time_Uptime_Seconds > 600) { - if (!$Info{memory_virtual_prev}) { +# Ignore startup memory stats +if ( $Time_Uptime_Seconds > 600 ) { + if ( !$Info{memory_virtual_prev} ) { $Info{memory_virtual_startup} = $Info{memory_virtual}; $Info{memory_virtual_prev} = $Info{memory_virtual}; $Info{memory_virtual_time} = $Time; } - logit $memory_leak_log, ' ReLoad' if ($Reload); - - if (new_minute 10) { + if ( new_minute 10 ) { my $memory_diff = $Info{memory_virtual} - $Info{memory_virtual_prev}; - my $memory_time = round ($Time - $Info{memory_virtual_time})/3600 if $Info{memory_virtual_time}; - if ($memory_diff > .5) { + my $memory_time = round( $Time - $Info{memory_virtual_time} ) / 3600 + if $Info{memory_virtual_time}; + if ( $memory_diff > .5 ) { my $time_startup = $Time_Uptime_Seconds / 3600; - my $memory_diff_rate = $memory_diff / $memory_time if $memory_time; - my $memory_diff_total = ($Info{memory_virtual} - $Info{memory_virtual_startup}) / $time_startup; - my $msg = sprintf "%5.1f hours: %4.1f MB in %4.1f hours. %5.1f -> %5.1f at %5.2f MB/hour. Total: %5.2f MB/hour", - $time_startup, $memory_diff, $memory_time, $Info{memory_virtual_prev}, $Info{memory_virtual}, - $memory_diff_rate, $memory_diff_total; + my $memory_diff_rate = $memory_diff / $memory_time if $memory_time; + my $memory_diff_total = + ( $Info{memory_virtual} - $Info{memory_virtual_startup} ) / + $time_startup; + my $msg = sprintf "%5.1f hours: %4.1f MB in %4.1f hours." + . " %5.1f -> %5.1f at %5.2f MB/hour. Total: %5.2f MB/hour", + $time_startup, $memory_diff, $memory_time, + $Info{memory_virtual_prev}, $Info{memory_virtual}, + $memory_diff_rate, $memory_diff_total; print_log "Warning, memory leak detected: $msg"; logit $memory_leak_log, $msg; $Info{memory_virtual_prev} = $Info{memory_virtual}; @@ -43,43 +50,51 @@ display font => 'fixed', text => $memory_leak_log if said $v_memory_leak_log; $v_memory_check = new Voice_Cmd '[Start,Stop] the memory leak checker'; -$v_memory_check-> set_info('This will disable each code file for a while, to determine which is causing a memory leak'); +$v_memory_check->set_info( 'This will disable each code file for a while,' + . ' to determine which is causing a memory leak' ); $t_memory_check = new Timer; -my (@memory_leak_members, $memory_leak_index, $memory_leak_member); -if ('Start' eq said $v_memory_check) { +my ( @memory_leak_members, $memory_leak_index, $memory_leak_member ); +if ( 'Start' eq said $v_memory_check) { $v_memory_check->respond('app=memory Starting memory check...'); - @memory_leak_members = grep !/(monitor_memory)|(tk_)/, sort keys %Run_Members; - print "These members will be tested: @memory_leak_members\n" if $Debug{memory}; + @memory_leak_members = grep !/(monitor_memory)|(tk_)/, + sort keys %Run_Members; + print "These members will be tested: @memory_leak_members\n" + if $Debug{memory}; $memory_leak_index = 0; - set $t_memory_check 1; # Set to start next pass + set $t_memory_check 1; # Set to start next pass } -if ('Stop' eq said $v_memory_check) { +if ( 'Stop' eq said $v_memory_check) { $v_memory_check->respond('Memory leak check has been stopped.'); unset $t_memory_check; } -if (expired $t_memory_check) { +if ( expired $t_memory_check) { print "Memory leak timer expired\n" if $Debug{memory}; if ($memory_leak_member) { $Run_Members{$memory_leak_member} = 1; - print "Memory leak test: re-enabled $memory_leak_member\n" if $Debug{memory}; + print "Memory leak test: re-enabled $memory_leak_member\n" + if $Debug{memory}; $memory_leak_index++; - my $memory_diff = round $Info{memory_virtual} - $Info{memory_virtual_test}, 2; + my $memory_diff = + round $Info{memory_virtual} - $Info{memory_virtual_test}, 2; print "Memory leak amount: $memory_diff\n" if $Debug{memory}; - logit "$config_parms{data_dir}/logs/monitor_memory.log", "Leaked $memory_diff MB with $memory_leak_member disabled"; + logit "$config_parms{data_dir}/logs/monitor_memory.log", + "Leaked $memory_diff MB with $memory_leak_member disabled"; } - if ($memory_leak_member = $memory_leak_members[$memory_leak_index]) { + if ( $memory_leak_member = $memory_leak_members[$memory_leak_index] ) { $Run_Members{$memory_leak_member} = 0; - print "Memory leak test: disabled $memory_leak_member\n" if $Debug{memory}; - set $t_memory_check 20*60; -# set $t_memory_check 5; + print "Memory leak test: disabled $memory_leak_member\n" + if $Debug{memory}; + set $t_memory_check 20 * 60; + + # set $t_memory_check 5; $Info{memory_virtual_test} = $Info{memory_virtual}; } else { - $v_memory_check->respond("app=memory connected=0 Memory leak test finished"); + $v_memory_check->respond( + "app=memory connected=0 Memory leak test finished"); } } - - + diff --git a/code/common/organizer.pl b/code/common/organizer.pl index e0d5760bd..162fbd818 100644 --- a/code/common/organizer.pl +++ b/code/common/organizer.pl @@ -52,6 +52,7 @@ holiday calendar entries should be treated as holiday time vacation calendar entries should be treated as vacation time name=XXXX set source name to XXX rather than parse it from inside the ical +dcsfix might be needed to parse calendars using the Darwin Calendar Server ie ical2vsdb_account1 = http://house/holical.ics diff --git a/code/common/photo_index.pl b/code/common/photo_index.pl index f32a211b0..bf45e928c 100644 --- a/code/common/photo_index.pl +++ b/code/common/photo_index.pl @@ -3,10 +3,15 @@ #@ This code reads directories of photos to create an index which is #@ used by web browsers working as picture frames. #@ -#@ Review and update the html_alias_photos and photo_* parameters in your private ini -#@ file, and run the command 'Reindex the photo album'. Then point -#@ your web browser to http://localhost:8080/bin/photos.pl. -#@ You can also use this link to set the photo_dirs parm to a specific dir. +#@ Review and update the html_alias_photos and photo_* parameters in your +#@ private.ini file, and run the command 'Reindex the photo album'. Then point +#@ your web browser to +#@ http://localhost:8080/bin/photos.pl +#@ or http://localhost:8080/slideshow. +#@ You can also use this link to set the +#@ photo_dirs parm to a specific dir. +#@ If you have a slow browser (like the Audrey) you will want to resize your +#@ photos so they display quickly. See mh/bin/mh.ini for more information. @@ -41,10 +46,9 @@ $photo_subdir = new Generic_Item; set_casesensitive $photo_subdir; - # Add form to Entertainment page + # Add form to Photos page # The include will take too long if there are lots of files/dirs, so use a link instead -#$Included_HTML{Entertainment} .= '' . "\n" if $Reload; -$Included_HTML{Entertainment} .= '
Pick a photo subdirectory to index' . "\n"; +$Included_HTML{Photos} .= '
Pick a photo subdirectory to index' . "\n"; #noloop=stop # Search for photos from console @@ -68,7 +72,7 @@ sub photo_index { &photo_dir($dir); } - # Do a fisher yates shuffle (Perl cookbook 4.17 pg 121) + # Do a fisher yates shuffle (Perl cookbook 4.17 pg 121) if ($sequence eq 'random') { for (my $i = @photos; --$i; ) { my $j = int rand($i + 1); @@ -151,14 +155,7 @@ sub photo_dir { $v_photo_resize->respond('app=photos connected=0 Photo resizing done') if done_now $p_photo_resize; -# My resize_images.bat file has entries like this: -# call image_resize -r 0 -p sm2 --size 800x600 -d school -# call image_resize -r 0 -p sm2 --size 800x600 -d home - - - - # Add a small form to the Entertainment category page to pick a subdirectory to index - +# Add a small form to the Photos category page to pick a subdirectory to index sub photo_html { my $dir = '/photos'; # TODO, Add support for multiple subdirectories @@ -168,19 +165,19 @@ sub photo_html { &photo_subdirs($dir, ''); return '' unless @subdirs > 1; my $html; - # Create a form to pick which photo subdirectories to index + # Create a form to pick which photo subdirectories to index $html .= '
Pick which photo subdirectory to index' . "\n"; $html .= &html_form_select('$photo_subdir', 1, $selected, @subdirs) . "
\n"; return $html; } - # Process form submit +# Process form submit if (my $state = state_now $photo_subdir) { &write_mh_opts({'photo_dirs' => $state}, undef, 1); &photo_index; } - # Recurse through subdirectories +# Recurse through subdirectories sub photo_subdirs { my ($dir, $subdir) = @_; my ($dir2) = &http_get_local_file($dir); diff --git a/code/common/proxy_client_server.pl b/code/common/proxy_client_server.pl index 82cda8c44..f5a9c07cb 100644 --- a/code/common/proxy_client_server.pl +++ b/code/common/proxy_client_server.pl @@ -122,7 +122,7 @@ sub proxy_speak_play { # Filter out the blank parms %parms = map {$_, $parms{$_}} grep $parms{$_} =~ /\S+/, keys %parms; undef $parms{room}; - undef $parms{voice}; # MY ADD HERE +# undef $parms{voice}; # MY ADD HERE &main::proxy_send($address, $mode, %parms); } } @@ -214,7 +214,7 @@ sub proxy_speak_play { my (%parms) = &parse_func_parms(@data); $parms{room} = ''; $parms{rooms} = $config_parms{speak_mh_room}; - $parms{voice} = $config_parms{speak_voice}; + $parms{voice} = $config_parms{speak_voice} if !defined($parms{voice}); speak %parms; } elsif ($function eq 'play') { diff --git a/code/common/tk_widgets.pl b/code/common/tk_widgets.pl index 98cd87e3e..4339c408f 100644 --- a/code/common/tk_widgets.pl +++ b/code/common/tk_widgets.pl @@ -3,7 +3,8 @@ # $Date$ # $Revision$ -#@ Adds mh widgets to the tk interface +#@ Adds mh widgets to the tk and web interfaces. You must enable the +#@ mh_control.pl script if you enable this one. # Position=2 Load after tk_frames diff --git a/code/common/weather_metar.pl b/code/common/weather_metar.pl index 4817e2880..d69080367 100644 --- a/code/common/weather_metar.pl +++ b/code/common/weather_metar.pl @@ -187,7 +187,7 @@ sub process_metar { grep {$metar{$_}=convert_nm2km($metar{$_})} qw(WindAvgSpeed WindGustSpeed); } - $metar{Barom}=convert_sea_barom_to_local_mb($metar{BaromSea}); + $metar{Barom}=&Weather_Common::convert_sea_barom_to_local_mb($metar{BaromSea}); if ($config_parms{weather_uom_baro} eq 'in') { grep {$metar{$_}=convert_mb2in($metar{$_})} qw(Barom BaromSea); @@ -208,8 +208,8 @@ sub process_metar { } } - &populate_internet_weather(\%metar, $config_parms{weather_internet_elements_metar}); - &weather_updated; + &Weather_Common::populate_internet_weather(\%metar, $config_parms{weather_internet_elements_metar}); + &Weather_Common::weather_updated; } # useful for debugging diff --git a/code/common/weather_weatherbug.pl b/code/common/weather_weatherbug.pl index fe68519af..6ec5be5bd 100755 --- a/code/common/weather_weatherbug.pl +++ b/code/common/weather_weatherbug.pl @@ -150,7 +150,7 @@ if (done_now $p_weather_weatherbug_liveweather) { $Weather{weatherbug_obsv_valid} = 0; #Set to not valid unless proven my $weatherbug_xml=file_read $weatherbug_obs_file; - print_log "Weatherbug location liveweather\n"; + print_log "Weatherbug location liveweather."; # should do a check on the api version my $pattern= '(.*?)'; my($f_observation)= $weatherbug_xml =~ /$pattern/; @@ -404,10 +404,10 @@ my($f_zipcode)= $weatherbug_location =~ /$pattern/; my $pattern= 'citycode="(\d+)"'; my($f_citycode)= $weatherbug_location =~ /$pattern/; - print_log "Citycode=$f_citycode for $f_cityname,$f_statename,$f_countryname.\n" if ($f_citycode!=0); - print_log "Zipcode=$f_zipcode for $f_cityname,$f_statename,$f_countryname.\n" if ($f_zipcode!=0); + print_log "Citycode=$f_citycode for $f_cityname,$f_statename,$f_countryname." if ($f_citycode!=0); + print_log "Zipcode=$f_zipcode for $f_cityname,$f_statename,$f_countryname." if ($f_zipcode!=0); } - print_log "Weatherbug location search result \n"; + print_log "Weatherbug location search result."; } else { # the test for locations failed print_log "weatherbug: Error Did not find locations."; diff --git a/code/public/Brian/klier.pl b/code/public/Brian/klier.pl index 7bec0b859..668515af5 100644 --- a/code/public/Brian/klier.pl +++ b/code/public/Brian/klier.pl @@ -1,226 +1,323 @@ ########################## -# Klier Home Automation # +# Klier Home Automation # ########################## -#-----> Define Different States +####################>>> Define Different States -my $light_states = 'on,+90,+50,+10,-10,-50,-90,off'; +my $house_status_speech; +my $light_states = 'on,+90,+70,+50,+30,+10,-10,-30,-50,-70,-90,off'; my $appl_states = 'on,off'; my $state; +my $af; +my $atx; +my $camera_cycle; -$timer_goodnight = new Timer; - -#-----> All Available X10 Codes -$unused_xcvr = new X10_Item('A1'); # A1 (unused) -$motion_detector_backdoor = new X10_Appliance('A2'); # A2 -$motion_detector_kitchen = new X10_Appliance('A5'); # A5 -$low_light_kitchen = new X10_Appliance('A6'); # A6 -$motion_detector_frontdoor = new X10_Appliance('A7'); # A7 -$motion_detector_living_room = new X10_Appliance('A9'); # A9 (unused) -$low_light_living_room = new X10_Appliance('AA'); # A10 -$living_room = new X10_Item('B1'); # B1 -$bedroom_lamp = new X10_Item('B2'); # B2 -$front_entryway = new X10_Item('B3'); # B3 -$request_time_stuff = new X10_Appliance('B4'); # B4 (voice) -$boombox_bedroom = new X10_Appliance('B5'); # B5 - # B6 (Caller ID) -$request_music_stuff = new X10_Appliance('B7'); # B7 -$request_wx_stuff = new X10_Appliance('B8'); # B8 -$circ_fan = new X10_Appliance('B9'); # B9 -$kitchen_light = new X10_Item('BA'); # B10 -$bed_heater = new X10_Appliance('BB'); # B11 -$whats_on_tv = new X10_Appliance('BC'); # B12 (voice) -$projector = new X10_Appliance('BD'); # B13 -$air_cond_fan = new X10_Appliance('BE'); # B14 -$back_porch_light = new X10_Appliance('BF'); # B15 -$come_home_stuff = new X10_Appliance('BG'); # B16 +$timer_alarm = new Timer; +$current_away_mode = new Generic_Item; +$timer_away = new Timer; -# Category=Informational +$alarmactive = new Generic_Item; + +if ($Reload) {$camera_cycle = '1'}; +if ($Startup) {$camera_cycle = '1'}; + +if (state_now $Power_Supply eq 'Restored') { + #speak 'Power has been restored'; + play('file' => 'c:\mh\sounds\voices\powerrestored.wav'); + if (state $current_away_mode eq 'away') {$page_email = "Power has been restored."}; +} + +# Category=HVAC + +####################>>> Thermostat Setback + +if ($state = said $v_thermostat_setback) { + print_log "Thermostat Setback is $state."; +} + +if (state_now $thermostat_setback eq 'on') { + print_log "REMOTE - Thermostat Setback on."; +} + +if (state_now $thermostat_setback eq 'off') { + print_log "REMOTE - Thermostat Setback off."; +} + +# Category=Security -#-----> Weather Information (B8) +####################>>> Cycle Security Cameras / Recite weather Information + +$v_cycle_cams = new Voice_Cmd("Cycle Security Cameras"); + +if ($state = said $v_cycle_cams) { + set $request_wx_stuff 'on'; +} + +if (state_now $request_wx_stuff eq 'on') { + #run_voice_cmd 'Read a weather forecast'; + + $camera_cycle = $camera_cycle + 1; + if ($camera_cycle > '4') {$camera_cycle = '1'}; + + if ($camera_cycle eq '1') { + print_log "SECURITY - Manual Cycle to Back Door"; + set $security_cameras 'off'; + set $security_camera_backdoor 'on'; + } + + if ($camera_cycle eq '2') { + print_log "SECURITY - Manual Cycle to Driveway"; + set $security_cameras 'off'; + set $security_camera_driveway 'on'; + } + + if ($camera_cycle eq '3') { + print_log "SECURITY - Manual Cycle to Garage"; + set $security_cameras 'off'; + set $security_camera_garage 'on'; + } + + if ($camera_cycle eq '4') { + print_log "SECURITY - Manual Cycle to Front Door"; + set $security_cameras 'off'; + set $security_camera_frontdoor 'on'; + } + +} -if (state_now $request_wx_stuff eq 'on') {run_voice_cmd 'Read a weather forecast'}; if (state_now $request_wx_stuff eq 'off') {run_voice_cmd 'Last Weather Report'}; -#-----> Come Home/Goodnight Macros (B16) +# Category=Modes + +####################>>> Come Home/Goodnight Macros $v_come_home = new Voice_Cmd('Come Home Mode'); if ((said $v_come_home) || (state_now $come_home_stuff eq 'on')) { + set $current_away_mode 'home'; + set $alarmactive 'off'; + set $timer_alarm 0; + set $thermostat_setback 'off'; print_log "Come Home Macro Activated"; - speak "Welcome Home!"; - -# if (time_greater_than($Time_Sunset)) { - set $living_room 'on'; - set $living_room 'off'; - set $living_room 'on'; - set $living_room 'off'; - set $living_room 'on'; - set $living_room 'off'; -# } -} - -$v_good_night = new Voice_Cmd('Goodnight Mode'); -if ((said $v_good_night) || (state_now $come_home_stuff eq 'off')) { - set $timer_goodnight 10; - print_log "Goodnight Macro Activated"; - speak "Good Night!"; - run_voice_cmd "Stop Music"; + speak "Come home mode is now activated."; + #play('file' => 'c:\mh\sounds\voices\comehomemode.wav'); +} + +$v_away_mode = new Voice_Cmd('Away Mode'); +if ((said $v_away_mode) || (state_now $come_home_stuff eq 'off')) { + set $current_away_mode 'away'; + set $thermostat_setback 'on'; + set $timer_away 10; + print_log "Away/Goodnight Macro Activated"; + speak "Away mode is now activated. Goodbye!"; + #play('file' => 'c:\mh\sounds\voices\awaymode.wav'); } -if (expired $timer_goodnight) { - set $living_room '-90'; - set $front_entryway '-90'; - set $bedroom_lamp '-90'; - set $living_room 'off'; - set $front_entryway 'off'; +if (expired $timer_away) { + set $All_Lights 'off'; + #set $alarmactive 'on'; set $boombox_bedroom 'off'; - set $bedroom_lamp 'off'; - set $kitchen_light 'off'; - set $back_porch_light 'off'; set $projector 'off'; - set $timer_goodnight 0; + set $timer_away 0; } -# Category=Lights - -#-----> Kitchen Light (A2) +####################>>> Morning Alarm Buttons -$v_kitchen_light = new Voice_Cmd("Kitchen Light [$appl_states]"); - -if ($state = said $v_kitchen_light) { - set $kitchen_light $state; - print_log "Kitchen Light is $state."; - speak "Kitchen Light is $state."; +if (state_now $morning_alarm_buttons eq 'on') { + run_voice_cmd 'Alarm Clock On'; } -if (state_now $kitchen_light eq 'on') { - print_log "REMOTE - Kitchen Light on."; +if (state_now $morning_alarm_buttons eq 'off') { + run_voice_cmd 'Alarm Clock Off'; } -if (state_now $kitchen_light eq 'off') { - print_log "REMOTE - Kitchen Light off."; -} +# Category=Lights -#-----> Living Room Lamp (B1) +####################>>> All Lights -$v_living_room = new Voice_Cmd("Living Room Lamp [$light_states]"); +#$v_all_lights = new Voice_Cmd("All Lights [$appl_states]"); +# +#if ($state = said $v_all_lights) { +# set $All_Lights $state; +# print_log "All Lights $state."; +# speak "All Lights $state."; +#} -if ($state = said $v_living_room) { - set $living_room $state; - print_log "Living Room Lamp is $state."; - speak "Living Room Lamp is $state."; -} +$v_ambient_lights = new Voice_Cmd("Ambient Lights"); -if (state_now $living_room eq 'on') { +# Turn entryway and living room lamp on at sunset +if (($state = said $v_ambient_lights) or (time_now "$Time_Sunset - 1:00")) { + set $ambient_lights 'off'; + set $ambient_lights 'on'; + set $computer_room_light '-50'; + set $living_room_light '-60'; + set $bedroom_light '-40'; + set $christmas_lights 'on'; + #set $christmas_lights '-20'; +} + +####################>>> Kitchen Light + +#$v_kitchen_light = new Voice_Cmd("Kitchen Light [$appl_states]"); +# +#if ($state = said $v_kitchen_light) { +# set $kitchen_light $state; +# print_log "Kitchen Light is $state."; +# speak "Kitchen Light is $state."; +#} + +if (state_now $kitchen_light eq 'on') {print_log "REMOTE - Kitchen Light on."}; +if (state_now $kitchen_light eq 'off') {print_log "REMOTE - Kitchen Light off."}; + +####################>>> Living Room Light + +#$v_living_room_light = new Voice_Cmd("Living Room Light [$light_states]"); +# +#if ($state = said $v_living_room_light) { +# set $living_room_light $state; +# print_log "Living Room Light is $state."; +# speak "Living Room Light is $state."; +#} + +if (state_now $living_room_light eq 'on') { + play('file' => 'c:\mh\sounds\tap.wav'); print_log "REMOTE - Living Room Light on."; } -if (state_now $living_room eq 'off') { +if (state_now $living_room_light eq 'off') { + play('file' => 'c:\mh\sounds\tap.wav'); print_log "REMOTE - Living Room Light off."; } -#-----> Front Entryway Lamp (B3) +####################>>> Computer Room Light -$v_front_entryway = new Voice_Cmd("Front Entryway Lamp [$light_states]"); +#$v_computer_room_light = new Voice_Cmd("Computer Room Light [$light_states]"); +# +#if ($state = said $v_computer_room_light) { +# set $computer_room_light $state; +# print_log "Computer Room Light is $state."; +# speak "Computer Room Light is $state."; +#} -if ($state = said $v_front_entryway) { - set $front_entryway $state; - print_log "Front Entryway Lamp is $state."; - speak "Front Entryway Lamp is $state."; -} +if (state_now $computer_room_light eq 'on') {print_log "REMOTE - Computer Room Light on."}; +if (state_now $computer_room_light eq 'off') {print_log "REMOTE - Computer Room Light off."}; -if (state_now $front_entryway eq 'on') { - print_log "REMOTE - Front Entryway Light on."; -} +####################>>> Bedroom Light -if (state_now $front_entryway eq 'off') { - print_log "REMOTE - Front Entryway Light off."; -} +#$v_bedroom_light = new Voice_Cmd("Bedroom Lamp [$light_states]"); +# +#if ($state = said $v_bedroom_light) { +# set $bedroom_light $state; +# print_log "Bedroom Lamp is $state."; +# speak "Bedroom Lamp is $state."; +#} -#-----> Bedroom (B5) +if (state_now $bedroom_light eq 'on') {print_log "REMOTE - Bedroom Lamp on."}; +if (state_now $bedroom_light eq 'off') {print_log "REMOTE - Bedroom Lamp off."}; -$v_bedroom_lamp = new Voice_Cmd("Bedroom Lamp [$light_states]"); +####################>>> Back Porch Light -if ($state = said $v_bedroom_lamp) { - set $bedroom_lamp $state; - print_log "Bedroom Lamp is $state."; - speak "Bedroom Lamp is $state."; -} +#$v_back_porch_light = new Voice_Cmd("Back Porch Light [$appl_states]"); +# +#if ($state = said $v_back_porch_light) { +# set $back_porch_light $state; +# print_log "Back Porch Light is $state."; +# speak "Back Porch Light is $state."; +#} -if (state_now $bedroom_lamp eq 'on') { - print_log "REMOTE - Bedroom Lamp on."; -} +if (state_now $back_porch_light eq 'on') {print_log "REMOTE - Back Porch Light on."}; +if (state_now $back_porch_light eq 'off') {print_log "REMOTE - Back Porch Light off."}; -if (state_now $bedroom_lamp eq 'off') { - print_log "REMOTE - Bedroom Lamp off."; -} +####################>>> Garage Light -#-----> Back Porch Light (B15) +#$v_back_porch_light = new Voice_Cmd("Back Porch Light [$appl_states]"); +# +#if ($state = said $v_back_porch_light) { +# set $back_porch_light $state; +# print_log "Back Porch Light is $state."; +# speak "Back Porch Light is $state."; +#} -$v_back_porch_light = new Voice_Cmd("Back Porch Light [$appl_states]"); +if (state_now $garage_light eq 'on') {print_log "REMOTE - Garage Light on."}; +if (state_now $garage_light eq 'off') {print_log "REMOTE - Garage Light off."}; -if ($state = said $v_back_porch_light) { - set $back_porch_light $state; - print_log "Back Porch Light is $state."; - speak "Back Porch Light is $state."; -} +####################>>> Christmas Lights -if (state_now $back_porch_light eq 'on') { - print_log "REMOTE - Back Porch Light on."; -} +#$v_christmas_lights = new Voice_Cmd("Christmas Lights [$light_states]"); +# +#if ($state = said $v_christmas_lights) { +# set $christmas_lights $state; +# print_log "Christmas Lights are $state."; +#} -if (state_now $back_porch_light eq 'off') { - print_log "REMOTE - Back Porch Light off."; -} +if (state_now $christmas_lights eq 'on') {print_log "REMOTE - Christmas Lights on."}; +if (state_now $christmas_lights eq 'off') {print_log "REMOTE - Christmas Lights off."}; -# Category=Appliances +####################>>> Christmas Tree -#-----> Unused Transceiver (A1) +#$v_christmas_tree = new Voice_Cmd("Christmas Tree [$light_states]"); +# +#if ($state = said $v_christmas_tree) { +# set $christmas_tree $state; +# print_log "Christmas Tree is $state."; +#} -$v_unused_xcvr = new Voice_Cmd("Unused Transceiver [$appl_states]"); +if (state_now $christmas_tree eq 'on') {print_log "REMOTE - Christmas Tree on."}; +if (state_now $christmas_tree eq 'off') {print_log "REMOTE - Christmas Tree off."}; -if ($state = said $v_unused_xcvr) { - set $unused_xcvr $state; - print_log "Unused Transceiver is $state."; - speak "Unused Transceiver is $state."; -} +####################>>> Christmas Light Macro -if (state_now $unused_xcvr eq 'on') { - print_log "REMOTE - Unused Xcvr on."; -} +$v_xmas_light_macro = new Voice_Cmd("Christmas Light Macro"); -if (state_now $unused_xcvr eq 'off') { - print_log "REMOTE - Unused Xcvr off."; +if ($state = said $v_xmas_light_macro) { + set $christmas_lights 'on'; + #set $christmas_lights '-20'; } +# Category=Appliances -#-----> Boombox (B2) +####################>>> Unused Transceiver (A) -$v_boombox_bedroom = new Voice_Cmd("Boombox [$appl_states]"); +#$v_unused_xcvr = new Voice_Cmd("Unused Transceiver [$appl_states]"); +# +#if ($state = said $v_unused_xcvr) { +# set $unused_xcvr $state; +# print_log "Unused Transceiver is $state."; +#} -if ($state = said $v_boombox_bedroom) { - set $boombox_bedroom $state; - print_log "Boombox is $state."; - speak "Boombox is $state."; +if (state_now $unused_xcvr eq 'on') { + print_log "REMOTE - Unused Xcvr on."; } -if (state_now $boombox_bedroom eq 'on') { - print_log "REMOTE - Boombox on."; +if (state_now $unused_xcvr eq 'off') { + print_log "REMOTE - Unused Xcvr off."; } -if (state_now $boombox_bedroom eq 'off') { - print_log "REMOTE - Boombox off."; -} -#-----> Circulation Fan (B9) +####################>>> Boombox -$v_circ_fan = new Voice_Cmd("Circulation Fan [$appl_states]"); +#$v_boombox_bedroom = new Voice_Cmd("Boombox [$appl_states]"); +# +#if ($state = said $v_boombox_bedroom) { +# set $boombox_bedroom $state; +# print_log "Boombox is $state."; +#} +# +#if (state_now $boombox_bedroom eq 'on') { +# print_log "REMOTE - Boombox on."; +#} +# +#if (state_now $boombox_bedroom eq 'off') { +# print_log "REMOTE - Boombox off."; +#} -if ($state = said $v_circ_fan) { - set $circ_fan $state; - print_log "Circulation Fan is $state."; - speak "Circulation Fan is $state."; -} +####################>>> Circulation Fan + +#$v_circ_fan = new Voice_Cmd("Circulation Fan [$appl_states]"); +# +#if ($state = said $v_circ_fan) { +# set $circ_fan $state; +# print_log "Circulation Fan is $state."; +#} if (state_now $circ_fan eq 'on') { print_log "REMOTE - Circulation Fan on."; @@ -230,10 +327,10 @@ print_log "REMOTE - Circulation Fan off."; } -#-----> Motion Detector Warning (B10) +####################>>> Motion Detector Warning (Back Door) -if (state_now $motion_detector_backdoor eq 'on') { - print_log "Motion detected near Back Door - $Time_Now"; +if (state_now $motion_detector_backdoor eq 'motion') { + print_log "Motion - Back Door"; # Turn on Light if a presence is detected after dusk. if (time_greater_than($Time_Sunset) or time_less_than($Time_Sunrise)) { @@ -241,15 +338,25 @@ } logit("$Pgm_Path/../web/mh/motion.log", "Motion Detected Back Door
"); - play('file' => 'C:\MH\SOUNDS\OUTERMK.WAV'); - #play('file' => 'C:\MH\SOUNDS\INNERMK.WAV'); + set $cctv_record_alarm 'on'; + play('file' => 'c:\mh\sounds\voices\motionbackdoor.wav'); + + if (state $security_camera_backdoor ne 'on') { + set $security_cameras 'off'; + set $security_camera_backdoor 'on'; + } + + if (state $current_away_mode eq 'away') { + $page_email = "Motion at Back Door."; + } + } -if (state_now $motion_detector_backdoor eq 'off') { +if (state_now $motion_detector_backdoor eq 'still') { print_log "ALL CLEAR at Back Door"; - + set $cctv_record_alarm 'off'; # And cut light when motion is cleared. - if (time_greater_than($Time_Sunset) or time_less_than($Time_Sunrise)) { + if (state $back_porch_light ne 'off') { set $back_porch_light 'off'; } @@ -257,16 +364,56 @@ #speak "Back Door Clear."; } -#-----> Bed Heater (B11) +####################>>> Motion Detector Warning (Trailer) -$v_bed_heater = new Voice_Cmd("Bed Heater [$appl_states]"); +if (state_now $motion_detector_trailer eq 'motion') { + print_log "Motion - Trailer"; -if ($state = said $v_bed_heater) { - set $bed_heater $state; - print_log "Bed Heater is $state."; - speak "Bed Heater is $state."; + # Turn on Light if a presence is detected after dusk. + if (time_greater_than($Time_Sunset) or time_less_than($Time_Sunrise)) { + set $back_porch_light 'on'; + #play('file' => 'c:\mh\sounds\sit.wav'); + } + + logit("$Pgm_Path/../web/mh/motion.log", "Motion Detected Trailer
"); + set $cctv_record_alarm 'on'; + play('file' => 'c:\mh\sounds\OUTERMK.WAV'); + + # speak "Motion has been detected in the trailer."; + + if (state $security_camera_driveway ne 'on') { + set $security_cameras 'off'; + set $security_camera_driveway 'on'; + } + + if (state $current_away_mode eq 'away') { +# $page_email = "Motion in Trailer."; + } + +} + +if (state_now $motion_detector_trailer eq 'still') { + print_log "ALL CLEAR in Trailer"; + set $cctv_record_alarm 'off'; + # And cut light when motion is cleared. + if (state $back_porch_light ne 'off') { + set $back_porch_light 'off'; + } + + logit("$Pgm_Path/../web/mh/motion.log", "ALL CLEAR Trailer
"); + #speak "Back Door Clear."; } +####################>>> Bed Heater + +#$v_bed_heater = new Voice_Cmd("Bed Heater [$appl_states]"); +# +#if ($state = said $v_bed_heater) { +# set $bed_heater $state; +# print_log "Bed Heater is $state."; +# speak "Bed Heater is $state."; +#} + if (state_now $bed_heater eq 'on') { print_log "REMOTE - Bed Heater on."; } @@ -275,68 +422,170 @@ print_log "REMOTE - Bed Heater off."; } -#-----> Motion Detector Warning (B12) +####################>>> Motion Detector Warning (Front Door) -if (state_now $motion_detector_frontdoor eq 'on') { +if (state_now $motion_detector_frontdoor eq 'motion') { print_log "Motion - Front Door"; logit("$Pgm_Path/../web/mh/motion.log", "Motion Detected Front Door
"); - play('file' => 'C:\MH\SOUNDS\MRSDITH.WAV'); + set $cctv_record_alarm 'on'; + play('file' => 'c:\mh\sounds\voices\motionfrontdoor.wav'); + + if (state $security_camera_frontdoor ne 'on') { + set $security_cameras 'off'; + set $security_camera_frontdoor 'on'; + } + + if (state $current_away_mode eq 'away') { + $page_email = "Motion at Front Door."; + } + } -if (state_now $motion_detector_frontdoor eq 'off') { +if (state_now $motion_detector_frontdoor eq 'still') { print_log "ALL CLEAR - Front Door"; + set $cctv_record_alarm 'off'; logit("$Pgm_Path/../web/mh/motion.log", "ALL CLEAR Front Door
"); #speak "Front Door Clear."; } -#-----> Motion Detector Warning (A5) +####################>>> Low Light (Front Door) -if (state_now $motion_detector_kitchen eq 'on') { +if (state_now $low_light_frontdoor eq 'dark') { + print_log "Low Light - Front Door"; + logit("$Pgm_Path/../web/mh/motion.log", "Low Light Front Door
"); +} + +if (state_now $low_light_frontdoor eq 'light') { + print_log "Normal Light - Front Door"; + logit("$Pgm_Path/../web/mh/motion.log", "Normal Light Front Door
"); +} + +####################>>> Motion Detector Warning (Kitchen) + +if (state_now $motion_detector_kitchen eq 'motion') { print_log "Motion - Kitchen"; + if ((state $alarmactive eq 'on') and (seconds_remaining_now $timer_alarm == '0')) { + set $timer_alarm 30; + speak "Alarm is on. 30 seconds to enter disable code."; + } + # Turn on Light if a presence is detected after dusk. - if (state $low_light_kitchen eq 'on') { - # if (time_greater_than($Time_Sunset) or time_less_than($Time_Sunrise)) { + if ((state $low_light_kitchen eq 'dark') or (time_greater_than($Time_Sunset)) or (time_less_than($Time_Sunrise))) { set $kitchen_light 'on'; } logit("$Pgm_Path/../web/mh/motion.log", "Motion Detected Kitchen
"); } -if (state_now $motion_detector_kitchen eq 'off') { +if (state_now $motion_detector_kitchen eq 'still') { print_log "ALL CLEAR - Kitchen"; # And cut light when motion is cleared. - #if (state $low_light_kitchen eq 'off') { - # if (time_greater_than($Time_Sunset) or time_less_than($Time_Sunrise)) { + if (state $kitchen_light ne 'off') { set $kitchen_light 'off'; - #} + } logit("$Pgm_Path/../web/mh/motion.log", "ALL CLEAR Kitchen
"); } -#-----> Motion Detector Warning (A9) +####################>>> Low Light (Kitchen) + +if (state_now $low_light_kitchen eq 'dark') { + print_log "Low Light - Kitchen"; + logit("$Pgm_Path/../web/mh/motion.log", "Low Light Kitchen
"); +} + +if (state_now $low_light_kitchen eq 'light') { + print_log "Normal Light - Kitchen"; + logit("$Pgm_Path/../web/mh/motion.log", "Normal Light Kitchen
"); +} -if (state_now $motion_detector_living_room eq 'on') { +####################>>> Motion Detector Warning (Living Room) + +if (state_now $motion_detector_living_room eq 'motion') { print_log "Motion - Living Room"; logit("$Pgm_Path/../web/mh/motion.log", "Motion Detected Living Room
"); + + if ((state $alarmactive eq 'on') and (seconds_remaining_now $timer_alarm == '0')) { + set $timer_alarm 30; + speak "Alarm is on. 30 seconds to enter disable code."; + } } -if (state_now $motion_detector_living_room eq 'off') { +if (state_now $motion_detector_living_room eq 'still') { print_log "ALL CLEAR - Living Room"; logit("$Pgm_Path/../web/mh/motion.log", "ALL CLEAR Living Room
"); } -#-----> Projector (B13) +####################>>> Low Light (Living Room) -$v_projector = new Voice_Cmd("Projector [$appl_states]"); +if (state_now $low_light_living_room eq 'dark') { + print_log "Low Light - Living Room"; + logit("$Pgm_Path/../web/mh/motion.log", "Low Light Living Room
"); +} -if ($state = said $v_projector) { - set $projector $state; - print_log "Projector is $state."; - speak "Projector is $state."; +if (state_now $low_light_living_room eq 'light') { + print_log "Normal Light - Living Room"; + logit("$Pgm_Path/../web/mh/motion.log", "Normal Light Living Room
"); } +####################>>> Motion Detector Warning (Garage) + +if (state_now $motion_detector_garage eq 'motion') { + print_log "Motion - Garage"; + + # Turn on Light if a presence is detected after dusk. + if ((state $low_light_garage eq 'dark') or (time_greater_than($Time_Sunset)) or (time_less_than($Time_Sunrise))) { + set $garage_light 'on'; + } + + logit("$Pgm_Path/../web/mh/motion.log", "Motion Detected Garage
"); + set $cctv_record_alarm 'on'; + play('file' => 'c:\mh\sounds\voices\motiongarage.wav'); + + if (state $security_camera_garage ne 'on') { + set $security_cameras 'off'; + #set $security_camera_driveway 'on'; + set $security_camera_garage 'on'; + } + + if (state $current_away_mode eq 'away') { + $page_email = "Motion in Garage."; + } +} + +if (state_now $motion_detector_garage eq 'still') { + print_log "ALL CLEAR - Garage"; + set $cctv_record_alarm 'off'; + # And cut light when motion is cleared. + if (state $garage_light ne 'off') { + set $garage_light 'off'; + } + logit("$Pgm_Path/../web/mh/motion.log", "ALL CLEAR Garage
"); +} + +####################>>> Low Light (Garage) + +if (state_now $low_light_garage eq 'dark') { + print_log "Low Light - Garage"; + logit("$Pgm_Path/../web/mh/motion.log", "Low Light Garage
"); +} + +if (state_now $low_light_garage eq 'light') { + print_log "Normal Light - Garage"; + logit("$Pgm_Path/../web/mh/motion.log", "Normal Light Garage
"); +} + +####################>>> Projector + +#$v_projector = new Voice_Cmd("Projector [$appl_states]"); +# +#if ($state = said $v_projector) { +# set $projector $state; +# print_log "Projector is $state."; +#} + if (state_now $projector eq 'on') { print_log "REMOTE - Projector on."; } @@ -345,15 +594,14 @@ print_log "REMOTE - Projector off."; } -#-----> Air Conditioner Fan (B14) +####################>>> Air Conditioner Fan -$v_air_cond_fan = new Voice_Cmd("Air Conditioner Fan [$appl_states]"); - -if ($state = said $v_air_cond_fan) { - set $air_cond_fan $state; - print_log "Air Conditioner Fan is $state."; - speak "Air Conditioner Fan is $state."; -} +#$v_air_cond_fan = new Voice_Cmd("Air Conditioner Fan [$appl_states]"); +# +#if ($state = said $v_air_cond_fan) { +# set $air_cond_fan $state; +# print_log "Air Conditioner is $state."; +#} if (state_now $air_cond_fan eq 'on') { print_log "REMOTE - Air Conditioner on."; @@ -363,95 +611,162 @@ print_log "REMOTE - Air Conditioner off."; } -#-----> Low Light (A6) +####################>>> Master Alarm Procedure +# Category=Security -if (state_now $low_light_kitchen eq 'on') { - print_log "Low Light - Kitchen"; - logit("$Pgm_Path/../web/mh/motion.log", "Low Light Kitchen
"); +$v_masteralarm = new Voice_Cmd("Master Alarm [$appl_states]"); + +if ($state = said $v_masteralarm eq 'on') { + logit("$Pgm_Path/../web/mh/motion.log", "MASTER ALARM!
"); + speak "Master Alarm!"; + for (my $i = 0; $i != 3; ++$i) { + play('file' => 'C:\MH\SOUNDS\STALLHRN.WAV'); + set $timer_alarm 0; + set $All_Lights 'on'; + set $All_Lights 'off'; + } } -if (state_now $low_light_kitchen eq 'off') { - print_log "Normal Light - Kitchen"; - logit("$Pgm_Path/../web/mh/motion.log", "Normal Light Kitchen
"); +if ($state = said $v_masteralarm eq 'off') { + speak "Master Alarm Off."; } -#-----> Low Light (A10) +if (expired $timer_alarm) { + run_voice_cmd "Master Alarm on"; +} -if (state_now $low_light_living_room eq 'on') { - print_log "Low Light - Living Room"; - logit("$Pgm_Path/../web/mh/motion.log", "Low Light Living Room
"); +if (state_now $alarm_lights eq 'on') { + logit("$Pgm_Path/../web/mh/motion.log", "Security - All Lights On
"); + print_log "SECURITY - All Lights On!!!"; + speak "Security. All Lights On."; + #play('file' => 'C:\MH\SOUNDS\STALLHRN.WAV'); + set $computer_room_light 'on'; + #set $All_Lights 'on'; } -if (state_now $low_light_living_room eq 'off') { - print_log "Normal Light - Living Room"; - logit("$Pgm_Path/../web/mh/motion.log", "Normal Light Living Room
"); +if (state_now $alarm_lights eq 'off') { + logit("$Pgm_Path/../web/mh/motion.log", "Security - All Lights Off
"); + print_log "SECURITY - All Lights Off!!!"; + speak "Security. All Lights Off."; + #play('file' => 'C:\MH\SOUNDS\STALLHRN.WAV'); + set $computer_room_light 'off'; } -# Category=Informational +if (state_now $alarm_detected eq 'on') { + logit("$Pgm_Path/../web/mh/motion.log", "MASTER ALARM!
"); + print_log "SECURITY - MASTER ALARM!!!"; + speak "Master Alarm!"; + play('file' => 'C:\MH\SOUNDS\STALLHRN.WAV'); + #set $All_Lights 'on'; + #set $All_Lights 'off'; +} -#-----> Information Requests +if (state_now $alarm_detected eq 'off') { + play('file' => 'C:\MH\SOUNDS\STALLHRN.WAV'); + #set $All_Lights 'off'; +} -# Respond if asked "What's on TV?" -if (state_now $whats_on_tv eq 'on') {run_voice_cmd 'Whats on TV?'}; +####################>>> Security Cameras -# Respond if asked "Time and Temperature?" -$v_request_time = new Voice_Cmd('Time and Temperature'); -if ((said $v_request_time) || (state_now $request_time_stuff eq 'on')) { - speak "It's $Time_Now on $Date_Now. Sunrise is at $Time_Sunrise, - sunset is at $Time_Sunset. Current Temperature is $CurrentTemp - degrees."; +$v_security_camera_backdoor = new Voice_Cmd("Security Camera Back Door"); +if ($state = said $v_security_camera_backdoor) { + play('file' => 'c:\mh\sounds\voices\securitybackdoor.wav'); + set $security_cameras 'off'; + set $security_camera_backdoor 'on'; + print_log "SECURITY - Back Door Camera."; } -# Respond if asked "House Status" -$v_house_status = new Voice_Cmd('House Status'); -if ((said $v_house_status) || (state_now $request_time_stuff eq 'off')) { - speak "Living Room Lamp is $living_room->{state}. - Front Entryway Lamp is $front_entryway->{state}. - Bedroom Lamp is $bedroom_lamp->{state}. - Back Porch Light is $back_porch_light->{state}. - Kitchen Light is $kitchen_light->{state}. - Bed Heater is $bed_heater->{state}. - Projector is $projector->{state}. - Air Conditioner is $air_cond_fan->{state}. - Circulation Fan is $circ_fan->{state}. - Front Door Motion is $motion_detector_frontdoor->{state}. - Back Door Motion is $motion_detector_backdoor->{state}. - Kitchen Motion is $motion_detector_kitchen->{state}. - Living Room Motion is $motion_detector_living_room->{state}."; +$v_security_camera_garage = new Voice_Cmd("Security Camera Garage"); +if ($state = said $v_security_camera_garage) { + speak "The security monitor is now viewing the garage."; + #play('file' => 'c:\mh\sounds\voices\securityfrontdoor.wav'); + set $security_cameras 'off'; + set $security_camera_garage 'on'; + print_log "SECURITY - Garage Camera."; } -$v_reload_code = new Voice_Cmd('Reload code'); -if (said $v_reload_code) { - read_code(); +$v_security_camera_frontdoor = new Voice_Cmd("Security Camera Front Door"); +if ($state = said $v_security_camera_frontdoor) { + play('file' => 'c:\mh\sounds\voices\securitycfrontdoor.wav'); + set $security_cameras 'off'; + set $security_camera_frontdoor 'on'; + print_log "SECURITY - Front Door Camera."; } -$v_reboot = new Voice_Cmd("Reboot the computer"); -if (said $v_reboot and $OS_win) { - speak("The house computer will reboot in 5 minutes."); - Win32::InitiateSystemShutdown('HOUSE', 'Rebooting in 5 minutes', 300, 1, 1); +$v_security_camera_driveway = new Voice_Cmd("Security Camera Driveway"); +if ($state = said $v_security_camera_driveway) { + speak "The security monitor is now viewing the drive way."; + #play('file' => 'c:\mh\sounds\voices\securityfrontdoor.wav'); + set $security_cameras 'off'; + set $security_camera_driveway 'on'; + print_log "SECURITY - Driveway Camera."; } -$v_reboot_abort = new Voice_Cmd("Abort the reboot"); -if (said $v_reboot_abort and $OS_win) { - Win32::AbortSystemShutdown('HOUSE'); - speak("OK, the reboot has been aborted."); +$v_security_camera_off = new Voice_Cmd("All Security Cameras Off"); +if ($state = said $v_security_camera_off) { + set $security_cameras 'off'; + print_log "SECURITY - All Cameras Off."; } -$v_uptime = new Voice_Cmd("What is your up time?"); -if (said $v_uptime) { - my $uptime_pgm = &time_diff($Time_Startup_time, time); - my $uptime_computer = &time_diff(0, (get_tickcount)/1000); - speak("I was started $uptime_pgm ago. The computer was booted $uptime_computer ago."); -} +# Category=Informational + +####################>>> Information Requests + +# Respond if asked "What's on TV?" +if (state_now $whats_on_tv eq 'on') {run_voice_cmd 'Whats on TV?'}; -$v_mode = new Voice_Cmd("Speech mode [normal,mute]"); -if ($state = said $v_mode) { - $Save{mode} = $state; - speak "The house voice mode is now $state."; - print_log "The house voice mode is now $state."; +# Respond if asked "Time and Temperature?" +$v_request_time = new Voice_Cmd('Time and Temperature'); +if ((said $v_request_time) || (state_now $request_time_stuff eq 'on')) { + speak "It's $Time_Now on $Date_Now. Sunrise is at $Time_Sunrise, + sunset is at $Time_Sunset. Temperature is $Weather{TempOutdoor}."; } -#-----> Timed Events +# Respond if asked "House Status" +$v_house_status = new Voice_Cmd('House Status'); +if ((said $v_house_status) || (state_now $request_time_stuff eq 'off')) { + $house_status_speech = ''; + if (state $living_room_light ne 'off') {$house_status_speech .= "The living room light is currently on."}; + if (state $computer_room_light ne 'off') {$house_status_speech .= "The computer room light is on right now."}; + if (state $bedroom_light ne 'off') {$house_status_speech .= "The light in the bedroom is on."}; + if (state $back_porch_light ne 'off') {$house_status_speech .= "The back porch light is currently on."}; + if (state $kitchen_light ne 'off') {$house_status_speech .= "The kitchen light is on right now."}; + if (state $bed_heater ne 'off') {$house_status_speech .= "The bed heater is warming up."}; +# if (state $projector ne 'off') {$house_status_speech .= "The home theater projector is on."}; + if (state $air_cond_fan ne 'off') {$house_status_speech .= "The air conditioner fan is currently on."}; + if (state $circ_fan ne 'off') {$house_status_speech .= "The circulation fan is on right now."}; + if (state $motion_detector_garage ne 'still') {$house_status_speech .= "There is somebody in the garage."}; + if (state $motion_detector_kitchen ne 'still') {$house_status_speech .= "There is somebody in the kitchen."}; + if (state $motion_detector_trailer ne 'still') {$house_status_speech .= "There is somebody near the trailer."}; + + if ($house_status_speech eq '') {$house_status_speech = 'Everything is off at the moment.'}; + + speak $house_status_speech; +} + +$v_set_wakeup_alarm_on = new Voice_Cmd("Alarm Clock On"); +if ($state = said $v_set_wakeup_alarm_on) { + &trigger_set("time_cron '0 6 * * 1,2,3,4,5'", + "run_voice_cmd 'Play Music from Upstairs'", + "NoExpire", + "ALARM ON", 1); + speak "Alarm now active for tomorrow morning."; + print_log "Alarm now active for tomorrow morning."; +} + +$v_set_wakeup_alarm_off = new Voice_Cmd("Alarm Clock Off"); +if ($state = said $v_set_wakeup_alarm_off) { + &trigger_set("time_cron '0 6 * * 1,2,3,4,5'", + "run_voice_cmd 'Play Music from Upstairs'", + "Disabled", + "ALARM ON", 1); + speak "Alarm clock now off."; + print_log "Alarm clock now off."; +} + +# Category=Time + +####################>>> Timed Events # TIME_CRON EVENTS - 1st digit = Minute(s) separated by commas # 2nd digit = Hour(s) separated by commas # 3rd digit = Day(s) separated by commas @@ -459,69 +774,165 @@ # 5th digit = Day of week(s) 0=Sun 1=Mon 2=Tue, etc. # * = Ignore this field -# Turn entryway and living room lamp on at sunset -if (time_now($Time_Sunset)) { - set $front_entryway 'on'; - set $front_entryway '-60'; - set $living_room 'on'; - set $living_room '-60'; - set $bedroom_lamp 'on'; - set $bedroom_lamp '-50'; -} - -# Turn the lights off at 11:30 PM -if (time_cron('30 23 * * *')) { - set $living_room '-90'; - set $front_entryway '-90'; - set $bedroom_lamp '-90'; - set $front_entryway 'off'; - set $living_room 'off'; - set $bedroom_lamp 'off'; - set $kitchen_light 'off'; -} -speak("Merry Christmas.") if time_cron('0 10,14,18,22 25 12 *'); -speak("Happy New Year!") if time_cron('0 10,14,18,22 1 1 *'); -speak("Remember to take out the garbage!") if time_cron('45 6 * * 4'); +####################>>> Speak a reminder if the alarm is off -play('file' => 'C:\MH\SOUNDS\M_CLK.WAV') if time_cron('0 7,8,9,10,11,12,13,14,15,16,17,18,19,20,21 * * 1,2,3,4,5'); -play('file' => 'C:\MH\SOUNDS\M_CLK.WAV') if time_cron('0 10,11,12,13,14,15,16,17,18,19,20,21 * * 0,6'); +if (time_cron('33 20,21 * * 0,1,2,3,4')) { + ($af, $af, $atx, $af) = &trigger_get('ALARM ON'); + if ($atx eq 'Disabled') { + speak "Notice: Please be aware that the alarm clock for tomorrow morning is off."; + print_log "Alarm Clock Reminder Sent."; + } +} -set $boombox_bedroom 'on' if time_cron('0 6 * * 1,2,3,4,5'); -set $boombox_bedroom 'off' if time_cron('30 6 * * 1,2,3,4,5'); +$Save{email_check} = 'yes' if time_cron('59 9 * * *'); +$Save{email_check} = 'no' if time_cron('59 21 * * *'); -set $bed_heater 'on' if (time_cron('30 20 * * *') and $CurrentTemp < '50'); -set $bed_heater 'off' if time_cron('30 21 * * *'); +####################>>> Turn Christmas Lights on in the morning until 7:30 -set $bed_heater 'on' if (time_cron('0 5 * * *') and $CurrentTemp < '50'); -set $bed_heater 'off' if time_cron('20 5 * * *'); +#if (time_cron('30 5 * * *')) { +# set $christmas_lights 'on'; +# #set $christmas_lights '-20'; +#} -if ($CurrentTemp eq $CurrentChill) { - speak("It's $Time_Now. Temp is $CurrentTemp.") if time_cron('30 6,7,8,9,10,11,12,13,14,15,16,17,18,19,20 * * 1,2,3,4,5'); - speak("It's $Time_Now. Temp is $CurrentTemp.") if time_cron('30 10,11,12,13,14,15,16,17,18,19,20 * * 0,6'); -} +#if (time_cron('30 7 * * *')) { +# set $christmas_lights 'off'; +#} -if ($CurrentTemp ne $CurrentChill) { - speak("It's $Time_Now. Temp is $CurrentTemp. Winnd Chill is $CurrentChill.") if time_cron('30 6,7,8,9,10,11,12,13,14,15,16,17,18,19,20 * * 1,2,3,4,5'); - speak("It's $Time_Now. Temp is $CurrentTemp. Winnd Chill is $CurrentChill.") if time_cron('30 10,11,12,13,14,15,16,17,18,19,20 * * 0,6'); +# Turn the lights and music off at 11:30 PM +if (time_cron('30 23 * * *')) { + set $All_Lights 'off'; + set $christmas_lights 'off'; + run_voice_cmd "Stop Music"; } -#-----> Play a Collection of Music +speak("Merry Christmas.") if time_cron('0 10,14,18,22 25 12 *'); +speak("Happy New Year!") if time_cron('0 10,14,18,22 1 1 *'); -$v_play_music = new Voice_Cmd('Play Music'); -if (($state = said $v_play_music) || (state_now $request_music_stuff eq 'on')) { - $Save{mode} = 'mute'; - run qq[winamp E:\\mp3s]; +#if (time_cron('0 10,11,12,13,14,15,16,17,18,19,20,21 * * *')) { +# my $ChimeHour = $Hour; +# if ($Hour > 12) {$ChimeHour = $Hour - 12}; +# +# if ($ChimeHour eq '1') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '2') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '3') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '4') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '5') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '6') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '7') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '8') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '9') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '10') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '11') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +# if ($ChimeHour eq '12') {play('mode' => 'wait', 'file' => 'LARGEWESTMINSTER.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONG.WAV,WESTDONGEND.WAV')}; +#} + +#play('file' => 'M_CLK.WAV') if time_cron('0 10,11,12,13,14,15,16,17,18,19,20,21 * * *'); +##### 12/23/07 play('file' => 'LARGEWESTMINSTER.WAV') if time_cron('0 10,11,12,13,14,15,16,17,18,19,20,21 * * *'); + +#run_voice_cmd "Play KQ92" if time_cron('0 6 * * 1,2,3,4'); + +set $bed_heater 'on' if (time_cron('30 19 * * *') and $Weather{TempOutdoor} < '50'); +if (state $computer_room_light eq 'off') { + set $bed_heater 'off' if time_cron('29 23 * * *'); +} + +# Set Back the Thermostat from 5:55 a.m. to 3:10 p.m. Monday-Thursday +# only if the Alarm is off + +if (time_cron('55 5 * * 1,2,3,4,5')) { + ($af, $af, $atx, $af) = &trigger_get('ALARM ON'); + if ($atx ne 'Disabled') { + set $thermostat_setback 'on'; + } } +set $thermostat_setback 'off' if time_cron('10 15 * * 1,2,3,4,5'); + +# Set Back the Thermostat from 9:30 p.m. to 5:45 a.m. Everyday +set $thermostat_setback 'on' if time_cron('30 21 * * *'); +set $thermostat_setback 'off' if time_cron('45 5 * * *'); + +if ($Weather{TempOutdoor} eq $Weather{WindChill}) { + speak("It's $Time_Now. Temp is $Weather{TempOutdoor}.") if time_cron('0,30 10,11,12,13,14,15,16,17,18,19,20 * * *'); + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('10:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('11:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('12:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('13:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('14:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('15:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('16:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('17:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('18:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('19:30', 05)}; + if ($Weather{TempOutdoor} < 11) {play('file' => 'c:\mh\sounds\voices\coldone.wav') if time_now('20:30', 05)}; + + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('10:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('11:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('12:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('13:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('14:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('15:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('16:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('17:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('18:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('19:30', 05)}; + if ($Weather{TempOutdoor} > 89) {play('file' => 'c:\mh\sounds\voices\hotone.wav') if time_now('20:30', 05)}; +} + +if ($Weather{TempOutdoor} ne $Weather{WindChill}) { + speak("It's $Time_Now. Temp is $Weather{TempOutdoor}. Winnd Chill is $Weather{WindChill}.") if time_cron('30 10,11,12,13,14,15,16,17,18,19,20 * * *'); +} + +# Category=Entertainment + +####################>>> Play a Collection of Music + +##$v_play_music = new Voice_Cmd('Play Music'); +##if ($state = said $v_play_music) { +## play('file' => 'c:\mh\sounds\voices\letmestartsomemusic.wav'); +### $Save{mode} = 'mute'; +## run qq[winamp E:\\mp3s]; +##} + +$v_play_music_up = new Voice_Cmd('Play Music from Upstairs'); +if (($state = said $v_play_music_up) || (state_now $request_music_stuff eq 'on')) { +#if ($state = said $v_play_music_up) { + play('file' => 'c:\mh\sounds\voices\letmestartsomemusic.wav'); +# $Save{mode} = 'mute'; +# run qq[winamp H:\\]; + run qq[winamp C:\\DOCUME~1\\ADMINI~1\\MYDOCU~1\\MYMUSI~1]; +} + +$v_play_cassette = new Voice_Cmd('Play Cassette Tape'); +if ($state = said $v_play_cassette) { +#if (($state = said $v_play_cassette) || (state_now $request_music_stuff eq 'on')) { +# $Save{mode} = 'mute'; + run qq[winamp I:\\]; +} + +##$v_play_kq92 = new Voice_Cmd('Play KQ92'); +##if ($state = said $v_play_kq92) { +### $Save{mode} = 'mute'; +## run qq[kq92]; +##} + +##$v_stop_kq92 = new Voice_Cmd('Stop WMPLAYER'); +##if ($state = said $v_stop_kq92) { +### $Save{mode} = 'mute'; +## run qq[kq92stop]; +##} + $v_play_xmas_music = new Voice_Cmd('Play Christmas Music'); if ($state = said $v_play_xmas_music) { - $Save{mode} = 'mute'; - run qq[winamp E:\\mp3s\\christmas]; + # $Save{mode} = 'mute'; + run qq[winamp H:\\christ~1]; } $v_stop_music = new Voice_Cmd('Stop Music'); if (($state = said $v_stop_music) || (state_now $request_music_stuff eq 'off')) { - run qq[winamp /stop]; - $Save{mode} = 'normal'; +# run_voice_cmd "Set house mp3 player to Stop"; + run qq[winamp /stop]; +### run qq[kq92stop]; +### $Save{mode} = 'normal'; } diff --git a/code/public/Brian/pageme.pl b/code/public/Brian/pageme.pl index 65870db4b..0df1b2d91 100644 --- a/code/public/Brian/pageme.pl +++ b/code/public/Brian/pageme.pl @@ -16,42 +16,60 @@ # Declare Variables -my ($page_status); +my ($page_status, $page_email); $timer_hangup_pager = new Timer; # Setup Phone Hangup Info -if (expired $timer_hangup_pager) { - set $phone_modem 'ATH'; - set $timer_hangup_pager 0; - print_msg "Page Sent Successfully..."; - print_log "Page Sent Successfully..."; - speak "Page Sent Successfully."; -} +#if (expired $timer_hangup_pager) { +# set $phone_modem 'ATH'; +# set $timer_hangup_pager 0; +# print_msg "Page Sent Successfully..."; +# print_log "Page Sent Successfully..."; +# speak "Page Sent Successfully."; +#} # Set up Phone Item to Page Me -$v_page_me = new Voice_Cmd('Page Me'); -if (said $v_page_me) { - - speak "Sending out Manual Page."; - $page_status = "ATDT3329999,,,123454321#"; - - set $timer_hangup_pager 30; - set $phone_modem "$page_status"; - - $page_status = ''; -} +#$v_page_me = new Voice_Cmd('Page Me on Pager'); +#if (said $v_page_me) { +# +# speak "Sending out Manual Page."; +# $page_status = "ATDT3329999,,,123454321#"; +# +# set $timer_hangup_pager 30; +# set $phone_modem "$page_status"; +# +# $page_status = ''; +#} # Send the Page... -if ($page_status ne '') { +#if ($page_status ne '') { +# +# speak "Sending out Page."; +# $page_status = "ATDT3329999,,," . $page_status . "#"; +# +# set $timer_hangup_pager 30; +# set $phone_modem "$page_status"; +# +# $page_status = ''; +#} + +# Category=Internet - speak "Sending out Page."; - $page_status = "ATDT3329999,,," . $page_status . "#"; +# Set up Phone Item to Page Me - set $timer_hangup_pager 30; - set $phone_modem "$page_status"; +$v_page_me_email = new Voice_Cmd('Test Page Me On Phone'); +if (said $v_page_me_email) { + speak "Sending out Manual E-Mail Page."; + $page_email = "Test Page"; +} - $page_status = ''; +# Send an E-Mail Page +if ($page_email ne '') { + print_log "Sending out E-Mail Page - $page_email..."; + &net_mail_send(subject => "MH", text => "$page_email", + to => '507xxxxxxx@vtext.com', from => 'mh@klier.us'); + $page_email = ''; } diff --git a/code/public/Brian/statuspanel.pl b/code/public/Brian/statuspanel.pl index 45c734976..f85c8aa68 100644 --- a/code/public/Brian/statuspanel.pl +++ b/code/public/Brian/statuspanel.pl @@ -1,61 +1,65 @@ + +# Authority: anyone + return " -{state}.gif\"> + + - + --> Time: $Time_Now    -Temperature: $CurrentTemp° -
-Wind: $WXWindDirVoice at $WXWindSpeed MPH.
+Temperature: $Weather{TempOutdoor}°
+Wind: $Weather{Wind}. Wind Chill is $Weather{WindChill}°
+Dew Point: $Weather{DewOutdoor}° Humidity: $Weather{HumidOutdoor}%
+
- + + Last Tracked: $GPSSpeakString
-Last Weather: $WXSpeakString
-Last Incoming Call: $PhoneName ($PhoneNumber), at $PhoneTime on $PhoneDate
+ +Last Incoming Call: $PhoneName ($PhoneNumber), on $PhoneTime

-{state}.gif\"> -Living Room: $living_room->{state}    -{state}.gif\"> -Front Entryway: $front_entryway->{state}
-{state}.gif\"> -Bedroom: $bedroom_lamp->{state}    + + +{state}.gif\"> +Living Room: $living_room_light->{state}    +{state}.gif\"> +Computer Room: $computer_room_light->{state}
+{state}.gif\"> +Bedroom: $bedroom_light->{state}    {state}.gif\"> Back Porch: $back_porch_light->{state}
{state}.gif\"> Kitchen: $kitchen_light->{state}

- + + {state}.gif\"> Projector: $projector->{state}    {state}.gif\"> -Air Conditioner: $air_cond_fan->{state}    +A/C: $air_cond_fan->{state}    {state}.gif\"> -Floor Fan: $circ_fan->{state}
+Circ Fan: $circ_fan->{state}
{state}.gif\"> Boombox: $boombox_bedroom->{state}    {state}.gif\"> Bed Heater: $bed_heater->{state}    {state}.gif\"> Music: $request_music_stuff->{state}
+{state}.gif\"> +Thermostat Setback: $thermostat_setback->{state}   

{state}.gif\"> -Entryway Motion: $motion_detector_frontdoor->{state}    +Front Door Motion: $motion_detector_frontdoor->{state}    {state}.gif\"> Back Door Motion: $motion_detector_backdoor->{state}
{state}.gif\"> Kitchen Motion: $motion_detector_kitchen->{state}    {state}.gif\"> Kitchen Low Light: $low_light_kitchen->{state}
-{state}.gif\"> -Living Room Motion: $motion_detector_living_room->{state}    -{state}.gif\"> -Living Room Low Light: $low_light_living_room->{state}
{state}.gif\"> Garage Motion: $motion_detector_garage->{state}    {state}.gif\"> Garage Low Light: $low_light_garage->{state} "; - diff --git a/code/public/Brian/statuspanel.shtml b/code/public/Brian/statuspanel.shtml index 7b93f3ddc..e8c9c2c72 100644 --- a/code/public/Brian/statuspanel.shtml +++ b/code/public/Brian/statuspanel.shtml @@ -1,7 +1,7 @@ Main Status - + diff --git a/code/public/Brian/tracking.nam b/code/public/Brian/tracking.nam index 5cc480a6e..c1bbe34be 100644 --- a/code/public/Brian/tracking.nam +++ b/code/public/Brian/tracking.nam @@ -1,5 +1,13 @@ N0QVC,Brian -N0PCD,Marv Nelms +N0EST,Bob +N0PCD,Marv KB0PYR,Phil -WA0SSN,Dad +WA0SSN,Don KF0ZH,Scott +AA0SM,Tony +KC0EQV,Bruce +WB0NKX,Denny +KC0UUV,Justin +KC0UUA,Borgstahl +N0ZXH,Larry +KC0OUZ,Adam diff --git a/code/public/Brian/tracking.pl b/code/public/Brian/tracking.pl index 447e61f98..9a45e5aca 100644 --- a/code/public/Brian/tracking.pl +++ b/code/public/Brian/tracking.pl @@ -1,40 +1,24 @@ - ###################################################### # Klier Home Automation - Tracking Module # -# Version 4.92 (release for MH 2.??) # +# Version 7.00 # # By: Brian J. Klier, N0QVC # -# June 16, 2001 # +# November 13, 2010 # # E-Mail: brian@kliernetwork.net # # Webpage: http://www.kliernetwork.net # ###################################################### - -=begin comment - -mh.ini parms: - -tracking_trackself=1 # This parameter should equal "1" if - # GPS Speaking is off and you still want - # to hear tracking from your own mobile -tracking_shortannounce=1 # 0 = When Speaking Tracking - # Information, this will - # announce both distance from - # this station and distance - # from waypoint. - # 1 = Only Distance from waypoint. -tracking_withname=1 # 0 = If tracking.nam available, - # announce callsign instead - # of given name. - # 1 = Announce Given name instead - # of callsign. - # 2 = Announce given name AND - # callsign. - -=cut - +# # For more information on hardware needed for this system to function: # - Check out http://www.kliernetwork.net/aprs and # http://www.kliernetwork.net/aprs/mine # +# New in Version 7.00: +# - No TNC Necessary! Now uses APRS-IS to connect and communicate with the APRS network +# - Fixed bearing of mobile/weather stations from our own +# - System to execute commands when my station is close to home +# +# New in Version 6.00: +# - Added numerous position and operational fixes +# # New in Version 4.92: # - Added Roger Bille's "Longitude Hundreds" Fix # @@ -77,10 +61,14 @@ # Next Version Wishlist: # - Check for duplicate messages in a row (like when they pass through # a digipeater to make sure an X10 command isn't sent twice) -# - System to execute X-10 commands when a station is a certain distance from home + +# Category=Vehicles # Declare Variables +$timer_email_digipeat = new Timer; +$timer_myvehicle_process = new Timer; +$enable_transmit = new Generic_Item; use vars '$GPSSpeakString', '$GPSSpeakString2', '$WXSpeakString', '$WXSpeakString2', '$CurrentTemp', '$CurrentChill', '$WXWindDirVoice', '$WXWindSpeed', '$WXHrPrecip'; my ($APRSFoundAPRS, $APRSPacketDigi, $GPSTime, $APRSStatus, $MsgLine); @@ -93,7 +81,6 @@ my ($GPSCompPlace, $GPSCompLat, $GPSCompLong, $GPSCompDist); my ($GPSCompLstBr, $GPSCompLstBrLat, $GPSCompLstBrLon); -# Added 4.7 my ($WXTempCompPlace, $WXTempCompDist, $WXTempCompLine); my ($WXTempCompLat, $WXTempCompLong); my ($WXCompPlace, $WXCompLat, $WXCompLong, $WXCompDist); @@ -101,12 +88,6 @@ my (@namelines, $TempName, $TempNameCall, $TempNameName); -my (@wxgraphinlines, $WXTempGraphLine, $WXTempGraphTime); -my ($WXTempGraphDOW, $WXTempGraphDaytime, $WXTempGraphDate, $WXTempGraphTemp); -my ($WXTempGraphWindDir, $WXTempGraphWindSpeed, $WXTempGraphHrPrecip); -my ($WXTempGraph24HrPrecip, $WXTempGraphHour, $WXTempGraphMin); -my ($WXTempGraphAMPM); - my ($i, $j, $k, $CallsignPart, $PacketPart, $GPSSpeed, $GPSCourse, $GPSCourseVoice); my ($ToCallsignPart, $LastGPSCallsign, $LastGPSDistance, $LastGPSLstBr); my ($APRSCallsign, $APRSStringLength, $APRSString, $MessageX10Command); @@ -123,32 +104,36 @@ # Setup TELNET Server 2 (port 14439) to output what the TNC hears -$server2 = new Socket_Item('#Welcome to MisterHouse APRS Tracking!', 'APRSWelcome', 'server2'); +$telnet = new Socket_Item('#Welcome to MisterHouse APRS Tracking!', 'APRSWelcome', 'server_aprs'); # Send Welcome Message out port 2 if connected. -set $server2 'APRSWelcome' if active_now $server2; -set $server2 'APRSERVE>APRS:javaTITLE:N0QVC MisterHouse - tracking.pl - Brian Klier, N0QVC' if active_now $server2; +set $telnet 'APRSWelcome' if active_now $telnet; +set $telnet 'APRSERVE>APRS:javaTITLE:N0QVC MisterHouse - tracking.pl - Brian Klier, N0QVC' if active_now $telnet; my $socket_speak_loop; -if (my $telnetdata = said $server2) { +if (my $telnetdata = said $telnet) { print_log "Data Transmitted from Telnet Port: $telnetdata"; set $tnc_output $telnetdata; } # TNC Output Lines -$tnc_output = new Serial_Item ('CONV','converse','serial1'); -$tnc_output -> add ('?WX?','wxquery','serial1'); -$tnc_output -> add (sprintf("=%2d%05.02fN/0%2d%05.02fW- *** %s MisterHouse Tracking System - ICQ#659962 ***", +$tnc_output = new Socket_Item ('user MYCALL pass MYPASS vers Misterhouse Win32 filter f/N0QVC-1/75', 'login', 'midwest.aprs2.net:14580', undef, 'tcp', 'records' ); +$tnc_output -> add ('?WX?','wxquery'); +$tnc_output -> add (sprintf("MYCALL>APRSMH,TCPIP*:=%2d%05.02fN/0%2d%05.02fW- *** %s MisterHouse Tracking System ***", int($config_parms{latitude}), abs ($config_parms{latitude} - int($config_parms{latitude}))*60, - int($config_parms{longitude}), - abs ($config_parms{longitude} -int($config_parms{longitude}))*60, + abs (int($config_parms{longitude})), + abs ($config_parms{longitude} - int($config_parms{longitude}))*60, $config_parms{tracking_callsign}), - ,'position','serial1'); + ,'position'); +set_casesensitive $tnc_output; # Set TNC to Converse and send position on Startup if ($Reload) { + set $timer_email_digipeat 1; + set $timer_myvehicle_process 1; + set $enable_transmit 'yes'; $HamCall = $config_parms{tracking_callsign}; # Feed in my Tracking Callsign open(GPSCOMP, "$config_parms{code_dir}/tracking.pos"); # Open for input @gpscomplines = ; # Open array and @@ -163,19 +148,32 @@ if ($Startup) { mkdir "$Pgm_Root/web/javAPRS",777 unless -d "$Pgm_Root/web/javAPRS"; - + set $timer_email_digipeat 1; + set $timer_myvehicle_process 1; + set $enable_transmit 'yes'; open(APRSLOG, ">$Pgm_Root/web/javAPRS/aprs.tnc"); # CLEAR Log close APRSLOG; - -# set $tnc_output pack('C',3); -# set $tnc_output 'MRPT OFF'; # Do NOT Show Digipeater Path -# set $tnc_output 'HEADERLN OFF'; # Keep Header and data on the same line - set $tnc_output 'converse'; + $tnc_output->start; + sleep 1; + set $tnc_output 'login'; + print_log "Starting connection to APRS-IS Server"; set $tnc_output 'position'; print_msg "Tracking Interface has been Initialized...Callsign $HamCall"; print_log "Tracking Interface has been Initialized...Callsign $HamCall"; } +if (active_now $tnc_output) { + print_log "Sending Login"; + set $tnc_output 'login'; + set $tnc_output 'position'; +} + +if (inactive_now $tnc_output) { + print_log "Telnet: session closed"; + $tnc_output->start; + print_log "Starting connection to APRS-IS Server"; +} + # Voice Responses $v_send_position = new Voice_Cmd("Send my Position"); @@ -188,7 +186,7 @@ $v_send_status = new Voice_Cmd("Send my Status Report"); if ($state = said $v_send_status) { - $APRSStatus = ">Frnt Move $motion_detector_frontdoor->{state}-Bck Move $motion_detector_backdoor->{state}-Kitc Move $motion_detector_kitchen->{state}-Garg Move $motion_detector_garage->{state}-Temp: $CurrentTemp"; + $APRSStatus = "$HamCall>APRSMH,TCPIP*:>Frnt Move $motion_detector_frontdoor->{state}-Bck Move $motion_detector_backdoor->{state}-Kitc Move $motion_detector_kitchen->{state}-Garg Move $motion_detector_garage->{state}-Temp: $CurrentTemp"; set $tnc_output $APRSStatus; print_log "Status Sent."; speak "Status Sent."; @@ -277,28 +275,6 @@ } } -$v_send_test_email = new Voice_Cmd("Send test email to myself"); - -if ($state = said $v_send_test_email) { - $i = ":EMAIL :$config_parms{net_mail_user}\@$config_parms{net_mail_server} Test E-Mail - " . $CurrentTemp . "deg.{0"; - set $tnc_output $i; -} - -$v_send_test_icq = new Voice_Cmd("Send test ICQ msg to myself"); - -if ($state = said $v_send_test_icq) { - $i = ":ICQSERVE :659962 Test Message - " . $CurrentTemp . " degrees.{1"; - set $tnc_output $i; -} - -# Added 4.7 -$v_register_icqserve = new Voice_Cmd("Register on ICQServe (Do Once)"); - -if ($state = said $v_register_icqserve) { - $i = ":ICQSERVE :REGISTER 659962 {1"; - set $tnc_output $i; -} - # Procedure to Log Temperature and Stats every 10 minutes if (time_cron('0,10,20,30,40,50 * * * *') or $Startup) { @@ -306,7 +282,7 @@ logit("$Pgm_Path/../data/logs/weather.log", ",$CurrentTemp,$LastWXWindDir,$LastWXWindSpeed,$WXHrPrecip,$WX24HrPrecip"); } -# Daily Weather Log Backup +# Daily Weather and Tracking Log Backup if (time_cron('0 0 * * *')) { print_log "Backing up Weather Log."; @@ -314,79 +290,33 @@ close WXGRAPHIN; open(WXGRAPHIN, ">$Pgm_Path/../web/mh/weather.html"); # CLEAR Log close WXGRAPHIN; - #copy("$Pgm_Path/../data/logs/weather.log", "$Pgm_Path/../data/logs/weather.bak.log") or print_log "Error in copying: $!"; + open(NEWDAY, ">$config_parms{html_dir}/mh/tracking/today.html"); + close NEWDAY; + my $html = qq[\n\n]; + $html .= qq[\n]; + logit "$config_parms{html_dir}/mh/tracking/today.html", $html, 0, 1; + logit "$config_parms{html_dir}/mh/tracking/week1.html", "
\n", 0, 1; } -# Procedure to Make a series of Graphs with Temperature and Stats - -$v_make_graph = new Voice_Cmd("Make Weather Graph Now"); -if (time_cron('15 * * * *') or $Startup or $Reload or $state = said $v_make_graph) { - open(WXGRAPHOUT, ">$Pgm_Path/../web/mh/wxgraph.html"); # Log it - print WXGRAPHOUT "\nWeather Graphs\n"; - print WXGRAPHOUT "\n"; - print WXGRAPHOUT "\n"; - print WXGRAPHOUT "; # Open array and - # read in data - close WXGRAPHIN; # Close the file - - foreach $WXTempGraphLine (@wxgraphinlines) { - ($WXTempGraphDOW, $WXTempGraphDaytime, $WXTempGraphTemp, $WXTempGraphWindDir, $WXTempGraphWindSpeed, $WXTempGraphHrPrecip, $WXTempGraph24HrPrecip) = (split(',', $WXTempGraphLine))[0, 1, 2, 3, 4, 5, 6]; - $WXTempGraphDate = substr($WXTempGraphDaytime, 5, 2); # Day - $WXTempGraphHour = substr($WXTempGraphDaytime, 8, 2); # Hour - $WXTempGraphMin = substr($WXTempGraphDaytime, 11, 2); # Minute - $WXTempGraphAMPM = substr($WXTempGraphDaytime, 14, 1); # A/P - - if ($WXTempGraphAMPM eq 'A' and $WXTempGraphHour eq '12') {$WXTempGraphHour = '0'}; - if ($WXTempGraphAMPM eq 'P' and $WXTempGraphHour ne '12') {$WXTempGraphHour = $WXTempGraphHour + 12}; - $WXTempGraphMin = $WXTempGraphMin / 60; - $WXTempGraphTime = $WXTempGraphHour + $WXTempGraphMin; - - if ($WXTempGraphTemp ne '') { # If the Temp isn't blank, - print WXGRAPHOUT "$WXTempGraphTime,$WXTempGraphTemp "; - } - } - - print WXGRAPHOUT "\">\n\n"; - print WXGRAPHOUT "\n"; - print WXGRAPHOUT "\n"; - print WXGRAPHOUT "; # Open array and - # read in data - close WXGRAPHIN; # Close the file - - foreach $WXTempGraphLine (@wxgraphinlines) { - ($WXTempGraphDOW, $WXTempGraphDaytime, $WXTempGraphTemp, $WXTempGraphWindDir, $WXTempGraphWindSpeed, $WXTempGraphHrPrecip, $WXTempGraph24HrPrecip) = (split(',', $WXTempGraphLine))[0, 1, 2, 3, 4, 5, 6]; - $WXTempGraphDate = substr($WXTempGraphDaytime, 5, 2); # Day - $WXTempGraphHour = substr($WXTempGraphDaytime, 8, 2); # Hour - $WXTempGraphMin = substr($WXTempGraphDaytime, 11, 2); # Minute - $WXTempGraphAMPM = substr($WXTempGraphDaytime, 14, 1); # A/P - - if ($WXTempGraphAMPM eq 'A' and $WXTempGraphHour eq '12') {$WXTempGraphHour = '0'}; - if ($WXTempGraphAMPM eq 'P' and $WXTempGraphHour ne '12') {$WXTempGraphHour = $WXTempGraphHour + 12}; - $WXTempGraphMin = $WXTempGraphMin / 60; - $WXTempGraphTime = $WXTempGraphHour + $WXTempGraphMin; - - if ($WXTempGraphWindSpeed ne '') { # If the Speed isn't blank, - print WXGRAPHOUT "$WXTempGraphTime,$WXTempGraphWindSpeed "; - } - } - - print WXGRAPHOUT "\">\n\n"; - close WXGRAPHOUT; +if (time_cron('0 0 * * 0')) { + open(NEWWEEK, ">$config_parms{html_dir}/mh/tracking/week1.html"); + close NEWWEEK; + #file_cat "$config_parms{html_dir}/mh/tracking/week2.html", "$config_parms{html_dir}/mh/tracking/old/${Year_Month_Now}.html"; + #rename "$config_parms{html_dir}/mh/tracking/week1.html", "$config_parms{html_dir}/mh/tracking/week2.html" or print_log "Error in aprs rename 2: $!"; + my $html = qq[\n
Date TimeVehicle Heading and SpeedLocationNew Location
\n]; + $html .= qq[\n]; + logit "$config_parms{html_dir}/mh/tracking/week1.html", $html, 1; } -# Procedure to occasionally send out APRS Position Report and Status String +# Procedure to occasionally send out APRS Position Report and Status String, +##### 7/29/05: and update Current Temp with Internet Temp from KFBL -if (time_cron('0,30 * * * *')) { - set $tnc_output 'converse'; +if (state $enable_transmit eq 'yes' and time_cron('0 * * * *')) { set $tnc_output 'position'; - $APRSStatus = ">Frnt Move $motion_detector_frontdoor->{state}-Bck Move $motion_detector_backdoor->{state}-Kitc Move $motion_detector_kitchen->{state}-Garg Move $motion_detector_garage->{state}-Temp: $CurrentTemp"; + $APRSStatus = "$HamCall>APRSMH,TCPIP*:>Frnt Move $motion_detector_frontdoor->{state}-Bck Move $motion_detector_backdoor->{state}-Kitc Move $motion_detector_kitchen->{state}-Garg Move $motion_detector_garage->{state}-Temp: $CurrentTemp"; set $tnc_output $APRSStatus; +##### +# $CurrentTemp = $Weather{TempInternet}; } # Main TNC Parse Procedure @@ -404,7 +334,7 @@ $APRSStringLength = (length($APRSString)); # Save Length of Ser # Send the packet out TELNET if connected... - set $server2 $APRSString if active $server2; + set $telnet $APRSString if active $telnet; # Decode the Callsign and different parts from the Packet @@ -461,7 +391,7 @@ # Find out the user defined "name" for this callsign. $j = '0'; - + foreach $TempName (@namelines) { if ($j eq '0') { ($TempNameCall, $TempNameName) = (split(',', $TempName))[0, 1]; @@ -477,7 +407,7 @@ if ($j eq '0') { $HamName = $APRSCallsign; - print_msg "$APRSString -> No callsign Found\n"; + #print_msg "$APRSString -> No callsign Found\n"; } @@ -519,10 +449,8 @@ # Added Lines from Roger $GPSLongitudeMinutes100 = (substr($PacketPart, 3, 1)); $GPSLongitudeMinutes100 = (unpack('C', $GPSLongitudeMinutes100)) - 28; - # $GPSLongitude = ($GPSLongitudeDegrees + ($GPSLongitudeMinutes / 60)+ ($GPSLongitudeMinutes100 / 6000)); - # old -> $GPSLongitude = ($GPSLongitudeDegrees + ($GPSLongitudeMinutes / 60)); $GPSSpeed = (substr($PacketPart, 4, 1)); $GPSSpeed = ((unpack('C', $GPSSpeed)) - 28) * 10; @@ -595,10 +523,7 @@ # --- Do the following for all received GPS Strings # Calculate distance station is away - $GPSDistance = &great_circle_distance($GPSLatitude, $GPSLongitude, $config_parms{latitude}, $config_parms{longitude}); - #$GPSDistance = (sin $GPSLatitude) * (sin $config_parms{latitude}) + (cos $GPSLatitude) * (cos $config_parms{latitude}) * (cos ($config_parms{longitude}-$GPSLongitude)); - #$GPSDistance = 1.852 * 60 * atan2(sqrt(1 - $GPSDistance * $GPSDistance), $GPSDistance); - #$GPSDistance = $GPSDistance / 1.6093440; + $GPSDistance = &great_circle_distance($GPSLatitude, $GPSLongitude, abs $config_parms{latitude}, abs $config_parms{longitude}); $GPSDistance = round($GPSDistance, 1); # Calculate bearing from the Position file @@ -606,10 +531,7 @@ ($GPSTempCompPlace, $GPSTempCompLat, $GPSTempCompLong) = (split(',', $GPSTempCompLine))[0, 1, 2]; # Calculate distance station is away from pos file - $GPSTempCompDist = &great_circle_distance($GPSLatitude, $GPSLongitude, $GPSTempCompLat, $GPSTempCompLong); - #$GPSTempCompDist = (sin $GPSLatitude) * (sin $GPSTempCompLat) + (cos $GPSLatitude) * (cos $GPSTempCompLat) * (cos ($GPSTempCompLong-$GPSLongitude)); - #$GPSTempCompDist = 1.852 * 60 * atan2(sqrt(1 - $GPSTempCompDist * $GPSTempCompDist), $GPSTempCompDist); - #$GPSTempCompDist = $GPSTempCompDist / 1.6093440; + $GPSTempCompDist = &great_circle_distance($GPSLatitude, $GPSLongitude, $GPSTempCompLat, abs $GPSTempCompLong); $GPSTempCompDist = round($GPSTempCompDist, 1); if ($GPSTempCompDist < 15 and $GPSTempCompDist < $GPSCompDist) { @@ -627,53 +549,54 @@ if ($GPSCompLstBrLat > 0 and $GPSCompLstBrLon < 0) {$GPSCompLstBr = 'southwest'}; if ($GPSCompLstBrLat < 0 and $GPSCompLstBrLon > 0) {$GPSCompLstBr = 'northeast'}; if ($GPSCompLstBrLat > 0 and $GPSCompLstBrLon > 0) {$GPSCompLstBr = 'southeast'}; - if ($GPSCompLstBrLat <= 0 and (abs($GPSCompLstBrLon) * 2) < abs($GPSCompLstBrLat)) {$GPSCompLstBr = 'north'}; - if ($GPSCompLstBrLat >= 0 and (abs($GPSCompLstBrLon) * 2) < abs($GPSCompLstBrLat)) {$GPSCompLstBr = 'south'}; - if ($GPSCompLstBrLon <= 0 and (abs($GPSCompLstBrLat) * 2) < abs($GPSCompLstBrLon)) {$GPSCompLstBr = 'west'}; - if ($GPSCompLstBrLon >= 0 and (abs($GPSCompLstBrLat) * 2) < abs($GPSCompLstBrLon)) {$GPSCompLstBr = 'east'}; + if ($GPSCompLstBrLat <= 0 and ($GPSCompLstBrLon * 2) < $GPSCompLstBrLat) {$GPSCompLstBr = 'north'}; + if ($GPSCompLstBrLat >= 0 and ($GPSCompLstBrLon * 2) < $GPSCompLstBrLat) {$GPSCompLstBr = 'south'}; + if ($GPSCompLstBrLon <= 0 and ($GPSCompLstBrLat * 2) < $GPSCompLstBrLon) {$GPSCompLstBr = 'west'}; + if ($GPSCompLstBrLon >= 0 and ($GPSCompLstBrLat * 2) < $GPSCompLstBrLon) {$GPSCompLstBr = 'east'}; # Calculate if station is north/west/east/south of ours $GPSLstBrLat = ($config_parms{latitude} - $GPSLatitude); $GPSLstBrLon = ($config_parms{longitude} - $GPSLongitude); + if ($GPSLstBrLat < 0 and $GPSLstBrLon < 0) {$GPSLstBr = 'northwest'}; if ($GPSLstBrLat > 0 and $GPSLstBrLon < 0) {$GPSLstBr = 'southwest'}; if ($GPSLstBrLat < 0 and $GPSLstBrLon > 0) {$GPSLstBr = 'northeast'}; if ($GPSLstBrLat > 0 and $GPSLstBrLon > 0) {$GPSLstBr = 'southeast'}; - if ($GPSLstBrLat <= 0 and (abs($GPSLstBrLon) * 2) < abs($GPSLstBrLat)) {$GPSLstBr = 'north'}; - if ($GPSLstBrLat >= 0 and (abs($GPSLstBrLon) * 2) < abs($GPSLstBrLat)) {$GPSLstBr = 'south'}; - if ($GPSLstBrLon <= 0 and (abs($GPSLstBrLat) * 2) < abs($GPSLstBrLon)) {$GPSLstBr = 'west'}; - if ($GPSLstBrLon >= 0 and (abs($GPSLstBrLat) * 2) < abs($GPSLstBrLon)) {$GPSLstBr = 'east'}; + if ($GPSLstBrLat <= 0 and ($GPSLstBrLon * 2) < $GPSLstBrLat) {$GPSLstBr = 'north'}; + if ($GPSLstBrLat >= 0 and ($GPSLstBrLon * 2) < $GPSLstBrLat) {$GPSLstBr = 'south'}; + if ($GPSLstBrLon <= 0 and ($GPSLstBrLat * 2) < $GPSLstBrLon) {$GPSLstBr = 'west'}; + if ($GPSLstBrLon >= 0 and ($GPSLstBrLat * 2) < $GPSLstBrLon) {$GPSLstBr = 'east'}; # Add bearing from station in position file IF it's a new position report if ((($GPSCallsign ne $LastGPSCallsign) || ($GPSDistance ne $LastGPSDistance)) and ($GPSCompDist ne '9999')) { $GPSSpeakString2 = "Currently $GPSCompDist miles $GPSCompLstBr of $GPSCompPlace."; # and form a special speak string just for on the air - $GPSSpeakString3 = ">$RealAPRSCallsign $GPSCompDist mi $GPSCompLstBr of $GPSCompPlace."; + $GPSSpeakString3 = "$HamCall>APRSMH,TCPIP*:>$RealAPRSCallsign $GPSCompDist mi $GPSCompLstBr of $GPSCompPlace."; -### # Added in 4.9 if ($GPSDistance <= 0.2) { $GPSSpeakString2 = "Currently near $GPSCompPlace."; - $GPSSpeakString3 = ">$RealAPRSCallsign near $GPSCompPlace."; + $GPSSpeakString3 = "$HamCall>APRSMH,TCPIP*:>$RealAPRSCallsign near $GPSCompPlace."; } if ((substr($PacketPart, 0, 6) eq '$GPRMC') and ($GPSDistance <= 0.1) and ($GPSSpeed <= 1)) { $GPSSpeakString2 = "Currently parked at $GPSCompPlace."; - $GPSSpeakString3 = ">$RealAPRSCallsign parked at $GPSCompPlace."; + $GPSSpeakString3 = "$HamCall>APRSMH,TCPIP*:>$RealAPRSCallsign parked at $GPSCompPlace."; } if ((substr($PacketPart, 0, 6) eq '$GPGGA') and ($GPSDistance <= 0.1)) { $GPSSpeakString2 = "Currently at $GPSCompPlace."; - $GPSSpeakString3 = ">$RealAPRSCallsign at $GPSCompPlace."; + $GPSSpeakString3 = "$HamCall>APRSMH,TCPIP*:>$RealAPRSCallsign at $GPSCompPlace."; } -## - set $tnc_output $GPSSpeakString3; +### *** ### REMARKED OUT, DON'T TRANSMIT WHERE PEOPLE ARE AT +# if (state $enable_transmit eq 'yes') {set $tnc_output $GPSSpeakString3}; } # If It's a $GPRMC or Mic-E String, if ((substr($PacketPart, 0, 6) eq '$GPRMC') || + (substr($PacketPart, 0, 1) eq "'") || (substr($PacketPart, 0, 1) eq '`')) { # Only Calculate Course & Speed if it's a $GPRMC string, @@ -720,6 +643,7 @@ } print_log "$GPSSpeakString"; + set $telnet "# $GPSSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 1) || ($config_parms{tracking_speakflag} == 3)) @@ -743,6 +667,7 @@ } print_log "$GPSSpeakString"; + set $telnet "# $GPSSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 1) || ($config_parms{tracking_speakflag} == 3)) @@ -760,7 +685,7 @@ if ($config_parms{tracking_withname} == 1) {$GPSCallsign = $HamName}; - + if (($GPSCallsign ne $LastGPSCallsign) || ($GPSDistance ne $LastGPSDistance)) { if ($config_parms{tracking_shortannounce} == 0) @@ -772,6 +697,7 @@ } print_log "$GPSSpeakString"; + set $telnet "# $GPSSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 1) || ($config_parms{tracking_speakflag} == 3)) @@ -787,45 +713,30 @@ $LastGPSDistance = $GPSDistance; $LastGPSLstBr = $GPSLstBr; - # NEW IN 4.8 - # Prototype Log File Procedure for Tracking + # Procedure to Complete a process when my vehicle is close to home + # But only every 5 minutes, we don't want this process happening every time a position is received. + + if ((substr($RealAPRSCallsign, 0, (length($HamCall))) eq $HamCall) and ($GPSDistance < 0.2) and expired $timer_myvehicle_process) { + print_log "*** MY VEHICLE IS NEARBY ***"; + set $timer_myvehicle_process 5; + } + + # Log File Procedure for Tracking $i = -$GPSLongitude; $j = $GPSLatitude; - - my $html = qq[\n]; + + my $html = qq[\n]; + $html .= qq[\n]; $html .= qq[\n|; $html .= qq[\n\n]; - #$k = qq[
  • $Date_Now $Time_Now: ]; - #$k .= qq[\n$GPSSpeakString\n\n]; logit "$config_parms{html_dir}/mh/tracking/today.html", $html, 0; logit "$config_parms{html_dir}/mh/tracking/week1.html", $html, 0; - if ($New_Day) { - open(NEWDAY, ">$config_parms{html_dir}/mh/tracking/today.html"); - close NEWDAY; - my $html = qq[\n
    • Date TimeVehicle Heading and SpeedLocationNew Location
    $Date_Now $Time_Now$GPSSpeakString
    $Date_Now $Time_Now $GPSSpeakString$GPSSpeakString2\n]; - $i = -$i; # For logging form data in .pos + $i = -$i; # For logging form data in .pos $html .= qq[
    \n]; - $html .= qq[\n]; - logit "$config_parms{html_dir}/mh/tracking/today.html", $html, 0, 1; - logit "$config_parms{html_dir}/mh/tracking/week1.html", "
    \n", 0, 1; - } - - if ($New_Week) { - open(NEWWEEK, ">$config_parms{html_dir}/mh/tracking/week1.html"); - close NEWWEEK; - #file_cat "$config_parms{html_dir}/mh/tracking/week2.html", "$config_parms{html_dir}/mh/tracking/old/${Year_Month_Now}.html"; - #rename "$config_parms{html_dir}/mh/tracking/week1.html", "$config_parms{html_dir}/mh/tracking/week2.html" or print_log "Error in aprs rename 2: $!"; - my $html = qq[\n
    Date TimeVehicle Heading and SpeedLocationNew Location
    \n]; - $html .= qq[\n]; - logit "$config_parms{html_dir}/mh/tracking/week1.html", $html, 1; - } - # Add an index entry for the new months entry in aprs/old #if ($New_Month) { @@ -836,12 +747,12 @@ # Send E-Mail from APRS messages with "EMAIL2" - if (substr($MsgLine, 0, 6) eq 'EMAIL2') { + if ((substr($MsgLine, 0, 6) eq 'EMAIL2') and expired $timer_email_digipeat) { $APRSFoundAPRS = 1; ($MsgLine, $MessageAck) = (split('{', $MsgLine))[0, 1]; ($CallsignPart, $PacketPart) = (split(':', $MsgLine))[0, 1]; - ($CallsignPart, $PacketPart) = (split(' ', $PacketPart))[0, 1]; + ($CallsignPart, $PacketPart) = (split('>', $PacketPart))[0, 1]; # Let $i equals the number of spaces to put before :ack $i = (9 - length($RealAPRSCallsign)); @@ -849,20 +760,24 @@ $k = ($k x $i); print_log "Email gateway: Callsign=$RealAPRSCallsign, to=$CallsignPart data=$PacketPart\n"; + set $timer_email_digipeat 10; # ensure it doesn't send twice # Send the mail!! #if (&net_connect_check) { - $i = $RealAPRSCallsign . $k . ":ack" . $MessageAck; - set $tnc_output $i; - &net_mail_send(to => $CallsignPart, subject => "APRS Gateway", - text => "From $HamCall APRS Gateway\n$PacketPart"); - $i = ":" . $RealAPRSCallsign . $k . ":Your E-Mail Message has been sent.{7"; - set $tnc_output $i; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":ack" . $MessageAck; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; + + &net_mail_send(to => $CallsignPart, + subject => "A message from $RealAPRSCallsign (APRS)", + text => "The following is an E-Mail sent to you through the $HamCall MisterHouse APRS Radio Gateway\n\n$PacketPart"); + + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":Your E-Mail Message has been sent.{7"; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; #} #else { # $i = $RealAPRSCallsign . $k . ":ack" . $MessageAck; # set $tnc_output $i; - # $i = ":" . $RealAPRSCallsign . $k . ":Sorry, Gateway is currently closed.{8"; + # $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":Sorry, Gateway is currently closed.{8"; # set $tnc_output $i; #} } @@ -872,11 +787,8 @@ if (substr($MsgLine, 0, 3) eq 'BLN') { $APRSFoundAPRS = 1; -# ($CallsignPart, $PacketPart) = (split(':', $MsgLine))[0, 1]; ($CallsignPart, $CallsignPart, $PacketPart) = (split(':', $APRSString))[0, 1, 2]; print_log "Incoming Bulletin from $APRSCallsign: $PacketPart"; - ## REMMED THIS NEXT STATEMENT OUT FOR SANITY - #speak "Incoming Bulletin from $APRSCallsign. $PacketPart"; } # If It's an APRS Message, either say it or process the voice command: @@ -885,6 +797,8 @@ $APRSFoundAPRS = 1; ($MsgLine, $MessageAck) = (split('{', $MsgLine))[0, 1]; + # $CallsignPart simply used as a temp variable in next line + ($MessageAck, $CallsignPart) = (split('}', $MessageAck))[0, 1]; ($CallsignPart, $PacketPart) = (split(':', $MsgLine))[0, 1]; # Let $i equals the number of spaces to put before :ack @@ -896,7 +810,7 @@ if (substr($PacketPart, 0, 4) eq 'X10-' and substr($RealAPRSCallsign, 0, length($HamCall)) eq $HamCall) { - + # Split the line so $PacketPart is actually the message received to process. ($CallsignPart, $PacketPart) = (split('-', $PacketPart))[0, 1]; @@ -904,36 +818,36 @@ print_log "X10 received from APRS: $PacketPart"; speak "X10 received from A P R S: $PacketPart"; - $i = $RealAPRSCallsign . $k . ":ack" . $MessageAck; - set $tnc_output $i; - $i = ":" . $RealAPRSCallsign . $k . ":X-10 Message Received.{9"; - set $tnc_output $i; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":ack" . $MessageAck; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":X-10 Message Received.{9"; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; $MsgLine = ""; } - # NEW in 4.52 - Check to see if its an ack. If so, don't speak it. + # Check to see if its an ack. If so, don't speak it. elsif (substr($PacketPart, 0, 3) eq 'ack') { print_log "Acknowledgement received from $RealAPRSCallsign"; } - # NEW in 4.62 - Respond to ?WX? requests with the temperature. + # Respond to ?WX? requests with the temperature. elsif (substr($PacketPart, 0, 4) eq '?WX?') { - $i = $RealAPRSCallsign . $k . ":ack" . $MessageAck; - set $tnc_output $i; - $i = ":" . $RealAPRSCallsign . $k . ": Current Temperature: $CurrentTemp.{4"; - set $tnc_output $i; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":ack" . $MessageAck; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ": Current Temperature: $CurrentTemp.{4"; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; $MsgLine = ""; } - # NEW in 4.62 - Respond to ?PHONE? requests with last call. + # Respond to ?PHONE? requests with last call. elsif (substr($PacketPart, 0, 7) eq '?PHONE?') { - $i = $RealAPRSCallsign . $k . ":ack" . $MessageAck; - set $tnc_output $i; - $i = ":" . $RealAPRSCallsign . $k . ": Last Call: $PhoneName ($DisplayPhoneNumber){6"; - set $tnc_output $i; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":ack" . $MessageAck; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ": Last Call: $PhoneName ($PhoneNumber){6"; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; $MsgLine = ""; } @@ -941,28 +855,27 @@ else { print_log "Incoming Message from $APRSCallsign: $PacketPart"; - #speak "Incoming Message from $APRSCallsign. $PacketPart"; - # THIS IS A STATUS PAGE EVENT - #if (time_greater_than("22:00") and time_less_than("15:00")) { - #$page_icq = "$PacketPart"; - #} - - $i = $RealAPRSCallsign . $k . ":ack" . $MessageAck; - set $tnc_output $i; - set $tnc_output $i; - #$i = ":" . $RealAPRSCallsign . $k . ":Message Received.{2"; - #set $tnc_output $i; - + speak "Incoming Message from $APRSCallsign. $PacketPart"; + $i = "$HamCall>APRSMH,TCPIP*::" . $RealAPRSCallsign . $k . ":ack" . $MessageAck; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; + if (state $enable_transmit eq 'yes') {set $tnc_output $i}; $MsgLine = ""; } } # If it's a U2k or UII Weather Station, # AA0SM>APRSW,N0EST,WIDE*,WIDE:_02050122c168s005g010t011r000p000P000h91b10224wU2K + # N0QV>APRS,TCPIP*,qAC,FIRST:@131334z4407.94N/09359.39W_000/013g022t031r000p009P002h00b10143 + # At miles of us, temperature is 31 degrees. Winnd is out of the north at 4N/ miles an hour. if ((substr($APRSString, ($APRSStringLength - 4), 2) eq 'dU') || (substr($APRSString, ($APRSStringLength - 6), 6) eq 'dU2kFM') - || (substr($APRSString, ($APRSStringLength - 4), 2) eq 'wU')) { + || (substr($APRSString, ($APRSStringLength - 4), 2) eq 'wU') + || (substr($APRSString, ($APRSStringLength - 4), 4) eq 'DsVP') + || (substr($PacketPart, 38, 1) eq 't' and substr($PacketPart, 42, 1) eq 'r') + || (substr($APRSString, ($APRSStringLength - 2), 2) eq 'WD') + || (substr($APRSString, ($APRSStringLength - 3), 2) eq 'WX') + || (substr($APRSString, ($APRSStringLength - 5), 2) eq 'WD')) { $APRSFoundAPRS = 1; $WXCallsign = $APRSCallsign; # Reset Variables $WXTime = ""; @@ -979,7 +892,6 @@ $WXWindChill = ""; $WXHrPrecip = ""; $WX24HrPrecip = ""; - # Added in 4.7 $WXLstBr = ""; $WXLstBrLat = ""; $WXLstBrLon = ""; @@ -1013,28 +925,32 @@ $WXLongitudeMinutes = (substr($PacketPart, 20, 5)); $WXLongitude = ($WXLongitudeDegrees + ($WXLongitudeMinutes / 60)); - $WXDistance = &great_circle_distance($WXLatitude, $WXLongitude, $config_parms{latitude}, $config_parms{longitude}); - #$WXDistance = (sin $WXLatitude) * (sin $config_parms{latitude}) + (cos $WXLatitude) * (cos $config_parms{latitude}) * (cos ($config_parms{longitude}-$WXLongitude)); - #$WXDistance = 1.852 * 60 * atan2(sqrt(1 - $WXDistance * $WXDistance), $WXDistance); - #$WXDistance = $WXDistance / 1.6093440; + $WXDistance = &great_circle_distance($WXLatitude, $WXLongitude, abs $config_parms{latitude}, abs $config_parms{longitude}); $WXDistance = round($WXDistance, 1); # Calculate if station is north/west/east/south of ours - $WXLstBrLat = ($config_parms{latitude} - $WXLatitude); - $WXLstBrLon = ($config_parms{longitude} - $WXLongitude); + $WXLstBrLat = (abs $config_parms{latitude} - $WXLatitude); + $WXLstBrLon = (abs $config_parms{longitude} - $WXLongitude); if ($WXLstBrLat < 0 and $WXLstBrLon < 0) {$WXLstBr = 'northwest'}; if ($WXLstBrLat > 0 and $WXLstBrLon < 0) {$WXLstBr = 'southwest'}; if ($WXLstBrLat < 0 and $WXLstBrLon > 0) {$WXLstBr = 'northeast'}; if ($WXLstBrLat > 0 and $WXLstBrLon > 0) {$WXLstBr = 'southeast'}; - if ($WXLstBrLat <= 0 and (abs($WXLstBrLon) * 2) < abs($WXLstBrLat)) {$WXLstBr = 'north'}; - if ($WXLstBrLat >= 0 and (abs($WXLstBrLon) * 2) < abs($WXLstBrLat)) {$WXLstBr = 'south'}; - if ($WXLstBrLon <= 0 and (abs($WXLstBrLat) * 2) < abs($WXLstBrLon)) {$WXLstBr = 'west'}; - if ($WXLstBrLon >= 0 and (abs($WXLstBrLat) * 2) < abs($WXLstBrLon)) {$WXLstBr = 'east'}; + if ($WXLstBrLat <= 0 and ($WXLstBrLon * 2) < $WXLstBrLat) {$WXLstBr = 'north'}; + if ($WXLstBrLat >= 0 and ($WXLstBrLon * 2) < $WXLstBrLat) {$WXLstBr = 'south'}; + if ($WXLstBrLon <= 0 and ($WXLstBrLat * 2) < $WXLstBrLon) {$WXLstBr = 'west'}; + if ($WXLstBrLon >= 0 and ($WXLstBrLat * 2) < $WXLstBrLon) {$WXLstBr = 'east'}; } # For New Windows UII/U2000 String Only - if (substr($APRSString, ($APRSStringLength - 4), 2) eq 'wU') { + if ((substr($APRSString, ($APRSStringLength - 4), 2) eq 'wU') + || (substr($APRSString, ($APRSStringLength - 2), 2) eq 'WD') + || (substr($APRSString, ($APRSStringLength - 5), 2) eq 'WD') + || (substr($APRSString, ($APRSStringLength - 3), 2) eq 'WX') + || (substr($PacketPart, 38, 1) eq 't' and substr($PacketPart, 42, 1) eq 'r') + || (substr($APRSString, ($APRSStringLength - 4), 4) eq 'DsVP')) { + + $WXTime = (substr($PacketPart, 5, 4)); # Time of WX Report $WXWindDir = (substr($PacketPart, 10, 3)); # Wind Direction $WXWindSpeed = (substr($PacketPart, 14, 3)); # Wind Speed @@ -1066,18 +982,12 @@ $WXWindDirVoice = "north-northwest" if ($WXWindDir >= 320 and $WXWindDir <= 341); $WXWindDirVoice = "north" if ($WXWindDir >= 342 and $WXWindDir <= 360); -####### -# Added 4.7 - # Calculate bearing from the Position file foreach $WXTempCompLine (@gpscomplines) { ($WXTempCompPlace, $WXTempCompLat, $WXTempCompLong) = (split(',', $WXTempCompLine))[0, 1, 2]; # Calculate distance station is away from pos file - $WXTempCompDist = &great_circle_distance($WXLatitude, $WXLongitude, $WXTempCompLat, $WXTempCompLong); - #$WXTempCompDist = (sin $WXLatitude) * (sin $WXTempCompLat) + (cos $WXLatitude) * (cos $WXTempCompLat) * (cos ($WXTempCompLong-$WXLongitude)); - #$WXTempCompDist = 1.852 * 60 * atan2(sqrt(1 - $WXTempCompDist * $WXTempCompDist), $WXTempCompDist); - #$WXTempCompDist = $WXTempCompDist / 1.6093440; + $WXTempCompDist = &great_circle_distance($WXLatitude, $WXLongitude, abs $WXTempCompLat, abs $WXTempCompLong); $WXTempCompDist = round($WXTempCompDist, 1); if ($WXTempCompDist < 150 and $WXTempCompDist < $WXCompDist) { @@ -1095,18 +1005,16 @@ if ($WXCompLstBrLat > 0 and $WXCompLstBrLon < 0) {$WXCompLstBr = 'southwest'}; if ($WXCompLstBrLat < 0 and $WXCompLstBrLon > 0) {$WXCompLstBr = 'northeast'}; if ($WXCompLstBrLat > 0 and $WXCompLstBrLon > 0) {$WXCompLstBr = 'southeast'}; - if ($WXCompLstBrLat <= 0 and (abs($WXCompLstBrLon) * 2) < abs($WXCompLstBrLat)) {$WXCompLstBr = 'north'}; - if ($WXCompLstBrLat >= 0 and (abs($WXCompLstBrLon) * 2) < abs($WXCompLstBrLat)) {$WXCompLstBr = 'south'}; - if ($WXCompLstBrLon <= 0 and (abs($WXCompLstBrLat) * 2) < abs($WXCompLstBrLon)) {$WXCompLstBr = 'west'}; - if ($WXCompLstBrLon >= 0 and (abs($WXCompLstBrLat) * 2) < abs($WXCompLstBrLon)) {$WXCompLstBr = 'east'}; + if ($WXCompLstBrLat <= 0 and ($WXCompLstBrLon * 2) < $WXCompLstBrLat) {$WXCompLstBr = 'north'}; + if ($WXCompLstBrLat >= 0 and ($WXCompLstBrLon * 2) < $WXCompLstBrLat) {$WXCompLstBr = 'south'}; + if ($WXCompLstBrLon <= 0 and ($WXCompLstBrLat * 2) < $WXCompLstBrLon) {$WXCompLstBr = 'west'}; + if ($WXCompLstBrLon >= 0 and ($WXCompLstBrLat * 2) < $WXCompLstBrLon) {$WXCompLstBr = 'east'}; # Add bearing from station in position file IF it's a new position report if ((($WXCallsign ne $LastWXCallsign) || ($WXDistance ne $LastWXDistance)) and ($GPSCompDist ne '9999')) { $WXSpeakString2 = "Station is located $WXCompDist miles $WXCompLstBr of $WXCompPlace."; } -####### - if (substr($PacketPart, 35, 1) eq 'T') { # If a traditional, $WXTemp = (substr($PacketPart, 36, 3)); # Get rid of those damn 0's in the Temperature @@ -1118,7 +1026,7 @@ # Calculate Wind Chill if temp is less than 45 degrees if ($WXTemp <= 45) { $WXWindChill = .0817 * (3.71 * sqrt($WXWindSpeed) + 5.81 - .25 * $WXWindSpeed) * ($WXTemp - 91.4) + 91.4; - $WXWindChill = round($WXWindChill, 0); + $WXWindChill = round($WXWindChill, 0); if ($WXWindSpeed <= 5) {$WXWindChill = $WXTemp}; } @@ -1126,7 +1034,7 @@ if ($WXTemp >= 46) { $WXWindChill = $WXTemp; } - + # Add Readings for Last Hour Precip and Last 24 Hour Precip $WXHrPrecip = (substr($PacketPart, 41, 3)); # Get rid of those damn 0's in the Precip @@ -1151,10 +1059,10 @@ $WXSpeakString = "At $WXDistance miles $WXLstBr of us, temperature is $WXTemp degrees. Winnd is out of the $WXWindDirVoice at $WXWindSpeed miles an hour."; if ($WXTemp <= 45 and $WXTemp ne $WXWindChill) {$WXSpeakString = $WXSpeakString . " The winnd chill is $WXWindChill."}; if ($WXHrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WXHrPrecip inches of rain in the last hour."}; - # NEW in 4.7 - Add bearing from POSFILE $WXSpeakString = $WXSpeakString . " $WXSpeakString2"; print_log "$WXSpeakString"; + set $telnet "# $WXSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 2) || ($config_parms{tracking_speakflag} == 3)) @@ -1166,10 +1074,10 @@ if ((($WXCallsign ne $LastWXCallsign) || ($WXDistance ne $LastWXDistance) || ($WXTemp ne $LastWXTemp)) and ($WXWindSpeed eq '0')) { $WXSpeakString = "At $WXDistance miles $WXLstBr of us, temperature is $WXTemp degrees. Winnd is calm."; if ($WXHrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WXHrPrecip inches of rain in the last hour."}; - # NEW in 4.7 - Add bearing from POSFILE $WXSpeakString = $WXSpeakString . " $WXSpeakString2"; print_log "$WXSpeakString"; + set $telnet "# $WXSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 2) || ($config_parms{tracking_speakflag} == 3)) @@ -1184,7 +1092,6 @@ $LastWXWindChill = $WXWindChill; $LastWXHrPrecip = $WXHrPrecip; $LastWX24HrPrecip = $WX24HrPrecip; - } elsif (substr($PacketPart, 38, 1) eq 't') { # If a new format, @@ -1198,7 +1105,7 @@ # Calculate Wind Chill if temp is less than 45 degrees if ($WXTemp <= 45) { $WXWindChill = .0817 * (3.71 * sqrt($WXWindSpeed) + 5.81 - .25 * $WXWindSpeed) * ($WXTemp - 91.4) + 91.4; - $WXWindChill = round($WXWindChill, 0); + $WXWindChill = round($WXWindChill, 0); if ($WXWindSpeed <= 5) {$WXWindChill = $WXTemp}; } @@ -1206,7 +1113,7 @@ if ($WXTemp >= 46) { $WXWindChill = $WXTemp; } - + # Add Readings for Last Hour Precip and Last 24 Hour Precip $WXHrPrecip = (substr($PacketPart, 43, 3)); # Get rid of those damn 0's in the Precip @@ -1231,10 +1138,11 @@ $WXSpeakString = "At $WXDistance miles $WXLstBr of us, temperature is $WXTemp degrees. Winnd is out of the $WXWindDirVoice at $WXWindSpeed miles an hour."; if ($WXTemp <= 45 and $WXTemp ne $WXWindChill) {$WXSpeakString = $WXSpeakString . " The winnd chill is $WXWindChill."}; if ($WXHrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WXHrPrecip inches of rain in the last hour."}; - # NEW in 4.7 - Add bearing from POSFILE + if ($WX24HrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WX24HrPrecip inches of rain total today."}; $WXSpeakString = $WXSpeakString . " $WXSpeakString2"; print_log "$WXSpeakString"; + set $telnet "# $WXSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 2) || ($config_parms{tracking_speakflag} == 3)) @@ -1246,10 +1154,11 @@ if ((($WXCallsign ne $LastWXCallsign) || ($WXDistance ne $LastWXDistance) || ($WXTemp ne $LastWXTemp)) and ($WXWindSpeed eq '0')) { $WXSpeakString = "At $WXDistance miles $WXLstBr of us, temperature is $WXTemp degrees. Winnd is calm."; if ($WXHrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WXHrPrecip inches of rain in the last hour."}; - # NEW in 4.7 - Add bearing from POSFILE + if ($WX24HrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WX24HrPrecip inches of rain total today."}; $WXSpeakString = $WXSpeakString . " $WXSpeakString2"; print_log "$WXSpeakString"; + set $telnet "# $WXSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 2) || ($config_parms{tracking_speakflag} == 3)) @@ -1280,7 +1189,7 @@ # Calculate Wind Chill if temp is less than 45 degrees if ($WXTemp <= 45) { $WXWindChill = .0817 * (3.71 * sqrt($WXWindSpeed) + 5.81 - .25 * $WXWindSpeed) * ($WXTemp - 91.4) + 91.4; - $WXWindChill = round($WXWindChill, 0); + $WXWindChill = round($WXWindChill, 0); if ($WXWindSpeed <= 5) {$WXWindChill = $WXTemp}; } @@ -1306,28 +1215,32 @@ } # Divide Precip by 10 $WX24HrPrecip = $WX24HrPrecip / 10; - + # If It's not the same as the last report, say it. if ((($WXCallsign ne $LastWXCallsign) || ($WXDistance ne $LastWXDistance) || ($WXTemp ne $LastWXTemp)) and ($WXWindSpeed ne '0')) { $WXSpeakString = "$APRSCallsign reports temperature of $WXTemp degrees. Winnd is out of the $WXWindDirVoice at $WXWindSpeed miles an hour."; if ($WXTemp <= 45 and $WXTemp ne $WXWindChill) {$WXSpeakString = $WXSpeakString . " The winnd chill is $WXWindChill."}; if ($WXHrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WXHrPrecip inches of rain in the last hour."}; + if ($WX24HrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WX24HrPrecip inches of rain total today."}; print_log "$WXSpeakString"; + set $telnet "# $WXSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 2) || ($config_parms{tracking_speakflag} == 3)) {speak $WXSpeakString}; } - + # If the wind is calm, say the following. - + if ((($WXCallsign ne $LastWXCallsign) || ($WXDistance ne $LastWXDistance) || ($WXTemp ne $LastWXTemp)) and ($WXWindSpeed eq '0')) { $WXSpeakString = "$APRSCallsign reports temperature of $WXTemp degrees. Winnd is calm."; if ($WXHrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WXHrPrecip inches of rain in the last hour."}; + if ($WX24HrPrecip != 0) {$WXSpeakString = $WXSpeakString . " $WX24HrPrecip inches of rain total today."}; print_log "$WXSpeakString"; + set $telnet "# $WXSpeakString" if active $telnet; if (($config_parms{tracking_speakflag} == 2) || ($config_parms{tracking_speakflag} == 3)) @@ -1346,7 +1259,7 @@ else { - print_log "A funny weather station."; + print_log "*** Unknown Weather Station Format Detected."; } if ($CurrentTempDist >= $WXDistance) { # If a closer rpt, @@ -1384,7 +1297,6 @@ sub great_circle_distance { my $d = (sin(($lat2 - $lat1) / 2)) ** 2 + cos($lat1) * cos($lat2) * (sin(($lon2 - $lon1) / 2)) ** 2; $d = $radius * 2 * atan2(sqrt($d), sqrt(1 - $d)); -# print "db d=$d l=$lat1,$lon1,$lat2,$lon2\n"; return round($d, 1); } diff --git a/code/public/Brian/tracking.pos b/code/public/Brian/tracking.pos index 9a908e500..0e6d91292 100644 --- a/code/public/Brian/tracking.pos +++ b/code/public/Brian/tracking.pos @@ -1,33 +1,31 @@ -Brian's House,44.29805,93.27944 -First United Bank,44.29418,93.27524 -McDonalds,44.29438,93.27628 -Minnicks,44.29782,93.28647 -Lincoln School,44.29545,93.28612 -McKinley School,44.3007,93.27451 -Kwik Trip North,44.30317,93.27154 -District Office,44.31982,93.27016 -Faribo West Mall,44.29748,93.30265 -Spikes,44.29047,93.29115 -Community Services,44.29023,93.26835 -Garfield School,44.2862,93.27245 -Middle School,44.26966,93.27743 -Caron Motors,44.30018,93.31544 -Le Mieux's Resort,44.30145,93.41595 -Kilkenny,44.3131,93.57427 -Faribo Airport,44.322,93.30717 -Glenn's,44.29713,93.2684 -Wimpy's,44.29628,93.26837 -Basilleo's,44.29468,93.2708 -Truax Muffler,44.28877,93.26663 -Dave's Electronics,44.2873,93.27123 -Southside Liquor,44.27972,93.27364 -Our Saviors,44.27615,93.28741 -Jefferson Elementary,44.28065,93.28487 -Boldt Funeral Home,44.28746,93.28751 -Roberts Lake Resort,44.32169,93.33283 -Montgomery,44.43333,93.60333 -Northfield,44.435,93.22334 -Cannon City,44.33484,93.21883 -Nerstrand,44.345,93.0565 -Nerstrand State Park,44.34417,93.10767 -Dundas,44.426,93.20417 +Brian's House,44.29805,-93.27944 +First United Bank,44.29418,-93.27524 +McDonalds,44.29438,-93.27628 +Lincoln School,44.29545,-93.28612 +McKinley School,44.3007,-93.27451 +Kwik Trip North,44.30317,-93.27154 +District Office,44.31982,-93.27016 +Faribo West Mall,44.29748,-93.30265 +Spikes,44.29047,-93.29115 +Community Services,44.29023,-93.26835 +Garfield Park,44.2862,-93.27245 +Middle School,44.26966,-93.27743 +Caron Motors,44.30018,-93.31544 +Le Mieux's Resort,44.30145,-93.41595 +Kilkenny,44.3131,-93.57427 +Faribo Airport,44.322,-93.30717 +Glenn's,44.29713,-93.2684 +Basilleo's,44.29468,-93.2708 +Truax Muffler,44.28877,-93.26663 +Dave's Electronics,44.2873,-93.27123 +Southside Liquor,44.27972,-93.27364 +Our Saviors,44.27615,-93.28741 +Jefferson Elementary,44.28065,-93.28487 +Boldt Funeral Home,44.28746,-93.28751 +Roberts Lake Resort,44.32169,-93.33283 +Montgomery,44.43333,-93.60333 +Northfield,44.435,-93.22334 +Cannon City,44.33484,-93.21883 +Nerstrand,44.345,-93.0565 +Nerstrand State Park,44.34417,-93.10767 +Dundas,44.426,-93.20417 \ No newline at end of file diff --git a/code/public/cbus.pl b/code/public/cbus.pl index f3aaea968..af913bd00 100755 --- a/code/public/cbus.pl +++ b/code/public/cbus.pl @@ -120,7 +120,7 @@ # # When MH starts up, the cbus code will automatically attempt to sync MH to the current # state of CGate. CGate of course, will reflect the physical state of the CBus network. -# When the sync is complete, the $CBus_Sync will be set true. +# When the sync is complete, the $CBus_Sync will be set ON. # # mh.private.ini Settings # =============== @@ -186,7 +186,7 @@ my $cmd_counter = 0; my @cmd_list = (); -my $CBus_Sync = 0; +my $CBus_Sync = new Generic_Item; my $sync_in_progress = 0; my %addr_not_sync = (); my $cbus_def_filename; @@ -400,6 +400,7 @@ sub write_def_file { category => "CBus Lights", type => "relay", speak_name => "AAA is example", + label => "Label Name (->set_label) used by iPhone interface", log_label => "AAA Example", announce => "1", web_icon => "Some icon specification", @@ -487,13 +488,17 @@ sub build_cbus_file { or print_log "CBus: Builder - Could not open $cbus_file: $!"; print CF "# Category=CBus_Items\n#\n#\n"; - print CF "# Created: $Time_Now, from cbus.xml file: \"". - "$config_parms{cbus_dat_file}\"\n"; - print CF "# This file is automatically created with the CBus command ". - "RUN_BUILDER"; - print CF "#\n#\n# ---- DO NOT EDIT ----\n\n"; - - print CF "#\n# Cbus Device Summary List\n#\n"; + print CF "# Created: $Time_Now, from cbus.xml file: \"$config_parms{cbus_dat_file}\"\n"; + print CF "#\n"; + print CF "# This file is automatically created with the CBus command RUN_BUILDER\n"; + print CF "#\n"; + print CF "#\n"; + print CF "# -------------- DO NOT EDIT --------------\n"; + print CF "# ---- CHANGES WILL BE LOST ON REBUILD ----\n"; + print CF "#\n"; + print CF "\n"; + print CF "\n"; + print CF "# Cbus Device Summary List\n#\n"; my $cbus_prefix = $config_parms{cbus_category_prefix}; my %item_name = (); foreach my $address (sort keys %{ $cbus_def->{group} } ) { @@ -512,11 +517,19 @@ sub build_cbus_file { $item = $item_name{$address}; next if not defined $item; $name = $cbus_def->{group}{$address}{name}; + my $pretty_name = $cbus_def->{group}{$address}{label}; + if (not defined $pretty_name) { + $pretty_name = $name; + $pretty_name =~ s/(\w)([A-Z])/$1 $2/g; + } my $v_item = '$v_' . $item; # Create CBus_Item print CF "\$$item = new Generic_Item;\n"; + # Set label for CBus group + print CF "\$$item -> set_label('$pretty_name');\n"; + # Determine type of CBus group my $type = $cbus_def->{group}{$address}{type}; $type = 'dimmer' if not defined $type; @@ -896,7 +909,7 @@ sub cbus_talker_start { speak("C-Bus talker is already running"); } else { - $CBus_Sync = 0; + set $CBus_Sync OFF; $cbus_talker_retry = 0; if (start $cbus_talker) { print_log "CBus: Talker started"; @@ -910,7 +923,7 @@ sub cbus_talker_start { sub cbus_talker_stop { # Stops the CBus command driver (Talker) - $CBus_Sync = 0; + set $CBus_Sync OFF; return if not active $cbus_talker; print_log "CBus: Talker stopping"; stop $cbus_talker; @@ -995,7 +1008,7 @@ sub start_level_sync { print_log "CBus: Syncing MisterHouse to CBus (Off groups not displayed)"; - $CBus_Sync = 0; + set $CBus_Sync OFF; $sync_in_progress = 1; %addr_not_sync = %{ $cbus_def->{group} }; @@ -1011,7 +1024,7 @@ sub attempt_level_sync { if (not %addr_not_sync) { print_log "CBus: Sync to CGate complete"; - $CBus_Sync = 1; + set $CBus_Sync ON; $sync_in_progress = 0; } else { diff --git a/code/public/hvac_brian_newhvac.pl b/code/public/hvac_brian_newhvac.pl index e5edd4d87..27f7af06c 100644 --- a/code/public/hvac_brian_newhvac.pl +++ b/code/public/hvac_brian_newhvac.pl @@ -176,7 +176,7 @@ print "\n\n"; print "\n"; print "
    \n"; -#print "\n] if $html_info_overlib; + qq[\n] if $html_info_overlib; for my $category (&list_code_webnames('Voice_Cmd')) { next if $category =~ /^none$/; @@ -1786,12 +1786,8 @@ sub html_find_icon_image { $state = lc $object->state(); $state = lc $object->state_level() if ($type eq 'x10_item' or $type eq 'x10_switchlinc') ; - if ($type eq 'insteon_device' or $type eq 'insteon_link') { - $state = lc $object->level(); - $state = 'off' unless $state; - $state = 'on' if $state == 100; - $state = 'dim' if $state > 0 and $state < 100; - } + $state = 'on' if $state eq '100%'; + $state = 'dim' if $state =~ /^\d\d?%$/; $name =~ s/^\$//; # remove $ at front of objects $name =~ s/^v_//; # remove v_ in voice commands # Use on/off icons for conditional Weather_Items @@ -2300,7 +2296,7 @@ sub html_command_table { # moved the target option down to form and a tags to be compatible with IE7, dn # $html = "\n"; $html = qq[
    \n] . - qq[\n] . + qq[\n] . $html if $html_info_overlib; if ($Http{'User-Agent'} =~ /^MS/ and $Cookies{msagent} and $main::config_parms{'html_msagent_script_vr' . $Http{format}}) { diff --git a/lib/site/HTML/TableExtract.pm b/lib/site/HTML/TableExtract.pm index 45e456c95..a2f5cd1e2 100644 --- a/lib/site/HTML/TableExtract.pm +++ b/lib/site/HTML/TableExtract.pm @@ -1,8 +1,9 @@ package HTML::TableExtract; -# This package extracts tables from HTML. Tables of interest may be -# specified using header information, depth, order in a depth, or some -# combination of the three. See the POD for more information. +# This package extracts tables from HTML. Tables of interest may be +# specified using header information, depth, order in a depth, table tag +# attributes, or some combination of the four. See the POD for more +# information. # # Author: Matthew P. Sisk. See the POD for copyright information. @@ -11,29 +12,59 @@ use Carp; use vars qw($VERSION @ISA); -$VERSION = '1.05'; +$VERSION = '2.10'; use HTML::Parser; @ISA = qw(HTML::Parser); use HTML::Entities; +# trickery for subclassing from HTML::TreeBuilder rather than the +# default HTML::Parser. (use HTML::TableExtract qw(tree);) Also installs +# a mode constant TREE(). + +BEGIN { *TREE = sub { 0 } } + +sub import { + my $class = shift; + no warnings; + *TREE = @_ ? sub { 1 } : sub { 0 }; + return unless @_; + my $mode = shift; + croak "Unknown mode '$mode'\n" unless $mode eq 'tree'; + eval "use HTML::TreeBuilder"; + croak "Problem loading HTML::TreeBuilder : $@\n" if $@; + eval "use HTML::ElementTable 1.17"; + croak "problem loading HTML::ElementTable : $@\n" if $@; + @ISA = qw(HTML::TreeBuilder); + $class; +} + +# Backwards compatibility for deprecated methods +*table_state = *table; +*table_states = *tables; +*first_table_state_found = *first_table_found; + +### + my %Defaults = ( - headers => undef, - depth => undef, - count => undef, - chain => undef, - subtables => undef, - gridmap => 1, - decode => 1, - automap => 1, - head_include => 0, - elastic => 1, - keep => 0, - keepall => 0, - debug => 0, - ); -my $Dpat = join('|', keys %Defaults); + headers => undef, + depth => undef, + count => undef, + attribs => undef, + subtables => undef, + gridmap => 1, + decode => 1, + automap => 1, + slice_columns => 1, + keep_headers => 0, + br_translate => 1, + error_handle => \*STDOUT, + debug => 0, + keep_html => 0, + strip_html_on_match => 1, + ); +my $Dpat = join('|', sort keys %Defaults); ### Constructor @@ -43,16 +74,12 @@ sub new { my(%pass, %parms, $k, $v); while (($k,$v) = splice(@_, 0, 2)) { - if ($k eq 'headers' || $k eq 'chain') { + if ($k eq 'headers') { ref $v eq 'ARRAY' - or croak "Param '$k' must be passed in ref to array\n"; - if ($k eq 'chain') { - # Filter out non-links (has refs...allows for extra commas, etc) - @$v = grep(ref eq 'HASH', @$v); - } + or croak "Param '$k' must be passed in ref to array\n"; $parms{$k} = $v; } - elsif ($k =~ /^$Dpat$/o) { + elsif ($k =~ /^$Dpat$/) { $parms{$k} = $v; } else { @@ -63,20 +90,18 @@ sub new { my $self = $class->SUPER::new(%pass); bless $self, $class; foreach (keys %parms, keys %Defaults) { - $self->{$_} = exists $parms{$_} ? $parms{$_} : $Defaults{$_}; + $self->{$_} = exists $parms{$_} && defined $parms{$_} ? + $parms{$_} : $Defaults{$_}; } if ($self->{headers}) { - print STDERR "TE here, headers: ", join(',', @{$self->{headers}}),"\n" + $self->_emsg("TE here, headers: ", join(',', @{$self->{headers}}), "\n") if $self->{debug}; $self->{gridmap} = 1; } + # Initialize counts and containers - $self->{_cdepth} = -1; - $self->{_tablestack} = []; - $self->{_tables} = {}; - $self->{_ts_sequential} = []; - $self->{_table_mapback} = {}; - $self->{_counts} = {}; + $self->_reset_state; + $self; } @@ -84,44 +109,51 @@ sub new { sub start { my $self = shift; + my @res; + + @res = $self->SUPER::start(@_) if TREE(); # Create a new table state if entering a table. if ($_[0] eq 'table') { - $self->_enter_table; + my $ts = $self->_enter_table(@_); + $ts->tree($res[0]) if @res; } - # Rows and cells are next. We obviously need not bother checking any - # tags if we aren't in a table. + # Rows and cells are next. if ($self->{_in_a_table}) { - my $ts = $self->_current_table_state; + my $ts = $self->current_table; + my $skiptag = 0; if ($_[0] eq 'tr') { $ts->_enter_row; + ++$skiptag; } elsif ($_[0] eq 'td' || $_[0] eq 'th') { - if (!$ts->{in_row}) { - # Go ahead and try to recover from mangled HTML, because we - # care. - $ts->_enter_row; - print STDERR "Mangled HTML in table ($ts->{depth},$ts->{count}), inferring
    as row $ts->{rc}\n" if $self->{debug}; - } - $ts->_enter_cell; - # Inspect rowspan/colspan attributes, record as necessary for - # future column count transforms. - if ($self->{gridmap}) { - my %attrs = ref $_[1] ? %{$_[1]} : {}; - if (exists $attrs{rowspan} || exists $attrs{colspan}) { - $ts->_skew($attrs{rowspan} || 1, $attrs{colspan} || 1); - } - } + $ts->_enter_cell(@_); + my %attrs = ref $_[1] ? %{$_[1]} : {}; + my $rspan = $attrs{rowspan} || 1; + my $cspan = $attrs{colspan} || 1; + $ts->_rasterizer->($ts->row_count, $rspan, $cspan); + $ts->_anchor_item(@res); + ++$skiptag; + } + if ($self->{keep_html} && !$skiptag) { + $self->text($_[3]); } } + + # Replace
    with newlines if requested + if ($_[0] eq 'br' && $self->{br_translate} && !$self->{keep_html}) { + $self->text("\n"); + } + + @res; } # end start sub end { my $self = shift; - # Don't bother if we're not actually in a table. + my @res = $self->SUPER::end(@_) if TREE(); if ($self->{_in_a_table}) { - my $ts = $self->_current_table_state; + my $ts = $self->current_table; if ($_[0] eq 'td' || $_[0] eq 'th') { $ts->_exit_cell; } @@ -131,20 +163,27 @@ sub end { elsif ($_[0] eq 'table') { $self->_exit_table; } + unless (TREE()) { + $self->text($_[1]) if $self->{keep_html} && $ts->{in_cell}; + } } + @res; } sub text { my $self = shift; - # Don't bother unless we are in a table - if ($self->{_in_a_table}) { - my $ts = $self->_current_table_state; - # Don't bother unless we are in a row or cell + my @res = $self->SUPER::text(@_) if TREE(); + if ($self->{_in_a_table} && !TREE()) { + my $ts = $self->current_table; return unless $ts->{in_cell}; - if ($ts->_text_hungry) { - $ts->_taste_text($self->{decode} ? decode_entities($_[0]) : $_[0]); + if ($self->{decode} && !$self->{keep_html}) { + $ts->_add_text(decode_entities($_[0])); + } + else { + $ts->_add_text($_[0]); } } + @res; } ### End HTML::Parser overrides @@ -162,15 +201,11 @@ sub counts { # Given a depth, return the counts of all valid tables found therein. my($self, $depth) = @_; defined $depth or croak "Depth required\n"; + return () unless exists $self->{_tables}{$depth}; sort { $a <=> $b } keys %{$self->{_tables}{$depth}}; } sub table { - # Return the table content for a particular depth and count - shift->table_state(@_)->{content}; -} - -sub table_state { # Return the table state for a particular depth and count my($self, $depth, $count) = @_; defined $depth or croak "Depth required\n"; @@ -181,180 +216,155 @@ sub table_state { $self->{_tables}{$depth}{$count}; } -sub rows { - # Return the rows for a table. First table found if no table specified. - my($self, $table) = @_; - my @tc; - if (!$table) { - $table = $self->first_table_found; - } - return () unless ref $table; - my $ts = $self->{_table_mapback}{$table}; - $ts->rows; -} - sub first_table_found { - shift->first_table_state_found(@_)->{content}; -} - -sub first_table_state_found { my $self = shift; - ref $self->{_ts_sequential}[0] ? $self->{_ts_sequential}[0] : {}; + ref $self->{_ts_sequential}[0] ? $self->{_ts_sequential}[0] : undef; } +sub rows { shift->first_table_found->rows(@_) } + sub tables { - # Return content of all valid tables found, in the order that - # they were seen. - map([$_->rows], shift->table_states(@_)); -} - -sub table_states { - # Return all valid table records found, in the order that - # they were seen. + # Return all valid table records found, in the order that they + # were seen. my $self = shift; + while ($self->{_in_a_table}) { + my $ts = $self->current_table; + $self->_emsg("Mangled HTML in table ($ts->{depth},$ts->{count}), inferring closing table tag.\n") + if $self->{debug}; + $self->_exit_table; + } @{$self->{_ts_sequential}}; } -sub table_coords { - # Return the depth and count of a table - my($self, $table) = @_; - ref $table or croak "Table reference required\n"; - my $ts = $self->{_table_mapback}{$table}; - return () unless ref $ts; - $ts->coords; +# in tree mode, we already are an HTML::TreeBuilder, which is an +# HTML::Element structure after parsing...but we provide this for +# consistency with the table object method for accessing the tree +# structures. + +sub tree { shift } + +sub tables_report { + # Print out a summary of extracted tables, including depth/count + my $self = shift; + my $str; + foreach my $ts ($self->tables) { + $str .= $ts->report(@_); + } + $str; +} + +sub tables_dump { + my $self = shift; + $self->_emsg($self->tables_report(@_)); } -sub column_map { - # Return the column numbers of a particular table in the same order - # as the provided headers. - my($self, $table) = @_; - if (! defined $table) { - $table = $self->first_table_found; +# for testing/debugging +sub _attribute_purge { + my $self = shift; + foreach (keys %Defaults) { + delete $self->{$_}; } - my $ts = $self->{_table_mapback}{$table}; - return () unless ref $ts; - $ts->column_map; } ### Runtime sub _enter_table { - my $self = shift; + my($self, @args) = @_; ++$self->{_cdepth}; ++$self->{_in_a_table}; my $depth = $self->{_cdepth}; - # Table states can come and go on the stack...here we retrieve the - # table state for the table surrounding the current table tag - # (parent table state). If the current table tag belongs to a top - # level table, then this will be undef. - my $pts = $self->_current_table_state; - - # Counts are tracked for each depth. Depth count hashes are - # maintained for each of the table state objects; descendant - # tables accumulate a list of these hashes, all of which track - # counts relative to the point of view of that table state. - my $counts = ref $pts ? $pts->{counts} : [$self->{_counts}]; - foreach (@{$counts}) { - my $c = $_; - if (exists $_->{$depth}) { - ++$_->{$depth}; - } - else { - $_->{$depth} = 0; - } - } - my $count = $self->{_counts}{$depth} || 0; + # Table tag attributes, if present + my $attribs = $args[1] || {}; - print STDERR "TABLE: cdepth $depth, ccount $count, it: $self->{_in_a_table}\n" + # Table states can come and go on the stack...here we retrieve the + # table state for the table surrounding the current table tag (parent + # table state). If the current table tag belongs to a top level table, + # then this will be undef. + my $pts = $self->current_table; + + # Counts are tracked for each depth. + my $counts = $self->{_counts}; + $counts->[$depth] = -1 unless defined $counts->[$depth]; + ++$counts->[$depth]; + my $count = $counts->[$depth]; + + $self->_emsg("TABLE: cdepth $depth, ccount $count, it: $self->{_in_a_table}\n") if $self->{debug} >= 2; # Umbrella status means that this current table and all of its - # descendant tables will be harvested. This can happen when there - # exist target conditions with no headers, depth, or count, or - # when a particular table has been selected and the subtables - # parameter was initially specified. + # descendant tables will be harvested. my $umbrella = 0; - if (ref $pts) { - # If the subtables parameter was specified and the last table was - # being harvested, the upcoming table (and therefore all of it's - # descendants) is under an umbrella. - ++$umbrella if $self->{subtables} && $pts->_active; - } - if (! defined $self->{depth} && !defined $self->{count} - && !$self->{headers} && !$self->{chain}) { + if (! defined $self->{depth} && ! defined $self->{count} && + ! $self->{attribs} && ! $self->{headers}) { ++$umbrella; } # Basic parameters for the soon-to-be-created table state. my %tsparms = ( - depth => $depth, - count => $count, - umbrella => $umbrella, - automap => $self->{automap}, - elastic => $self->{elastic}, - counts => $counts, - keep => $self->{keep}, - keepall => $self->{keepall}, - debug => $self->{debug}, - ); - - # Target constraints. There is no point in passing any of these - # along if we are under an umbrella. Notice that with table states, - # "depth" and "count" are absolute coordinates recording where this - # table was created, whereas "tdepth" and "tcount" are the target - # constraints. Headers and chain have no "absolute" meaning, - # therefore are passed by the same name. + depth => $depth, + count => $count, + attribs => $attribs, + umbrella => $umbrella, + automap => $self->{automap}, + slice_columns => $self->{slice_columns}, + keep_headers => $self->{keep_headers}, + counts => $counts, + error_handle => $self->{error_handle}, + debug => $self->{debug}, + keep_html => $self->{keep_html}, + strip_html_on_match => $self->{strip_html_on_match}, + parent_table => $pts, + ); + + # Target constraints. There is no point in passing any of these along + # if we are under an umbrella. Notice that with table states, "depth" + # and "count" are absolute coordinates recording where this table was + # created, whereas "tdepth" and "tcount" are the target constraints. + # Headers have "absolute" meaning, therefore are passed by the + # same name. if (!$umbrella) { - $tsparms{tdepth} = $self->{depth} if defined $self->{depth}; - $tsparms{tcount} = $self->{count} if defined $self->{count}; - foreach (qw(headers chain head_include)) { - $tsparms{$_} = $self->{$_} if defined $self->{$_}; - } + $tsparms{tdepth} = $self->{depth}; + $tsparms{tcount} = $self->{count}; + $tsparms{tattribs} = $self->{attribs}; + $tsparms{headers} = $self->{headers}; } # Abracadabra - my $ts = HTML::TableExtract::TableState->new(%tsparms); - - # Inherit lineage - unshift(@{$ts->{lineage}}, @{$pts->{lineage}}) if ref $pts; - - # Chain evolution from parent table state. Once again, however, - # there is no point in passing the chain info along if we are under - # an umbrella. These frames are just *potential* matches from the - # chain. If no match occurs for a particular frame, then that frame - # will simply be passed along to the next generation of table states - # unchanged (assuming elastic behavior has not been disabled). Note: - # frames based on top level constraints, as opposed to chain - # specifications, are formed during TableState instantiation above. - $pts->_spawn_frames($ts) if ref $self->{chain} && !$umbrella && ref $pts; - - # Inform the new table state that there will be no more constraints - # forthcoming. - $ts->_pre_latch; - - # Push the newly created and configured table state onto the - # stack. This will now be the _current_table_state(). + my $ts = HTML::TableExtract::Table->new(%tsparms); + + # Push the newly created and configured table state onto the stack. + # This will now be the current_table(). push(@{$self->{_tablestack}}, $ts); + + $ts; } sub _exit_table { my $self = shift; - my $ts = $self->_current_table_state; + my $ts = $self->current_table; - if ($ts->_active) { - # Retain our newly captured table, assuming we bothered with it. - $self->_add_table_state($ts); - print STDERR "Captured table ($ts->{depth},$ts->{count})\n" - if $self->{debug} >= 2; + # Last ditch fix for HTML mangle + if ($ts->{in_cell}) { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), forcing exit of cell ($ts->{rc},$ts->{cc}) due to table exit\n") if $self->{debug}; + $ts->_exit_cell; + } + if ($ts->{in_row}) { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), forcing exit of row $ts->{rc} due to table exit\n") if $self->{debug}; + $ts->_exit_row; } + # transform from tree to grid using our rasterized template + $ts->_grid_map(); + + $self->_capture_table($ts) if $ts->_check_triggers; + # Restore last table state pop(@{$self->{_tablestack}}); --$self->{_in_a_table}; - my $lts = $self->_current_table_state; + my $lts = $self->current_table; if (ref $lts) { $self->{_cdepth} = $lts->{depth}; } @@ -362,69 +372,91 @@ sub _exit_table { # Back to the top level $self->{_cdepth} = -1; } - print STDERR "LEAVE: cdepth: $self->{_cdepth}, ccount: $ts->{count}, it: $self->{_in_a_table}\n" if $self->{debug} >= 2; + $self->_emsg("LEAVE: cdepth: $self->{_cdepth}, ccount: $ts->{count}, it: $self->{_in_a_table}\n") + if $self->{debug} >= 2; } -sub _add_table_state { - my($self, $ts) = @_; +sub _capture_table { + my($self, $ts, $type) = @_; croak "Table state ref required\n" unless ref $ts; - # Preliminary init sweep to appease -w - # - # These undefs would exist for empty ignored after row $self->{rc}\n") + if $self->{debug}; } } sub _enter_cell { my $self = shift; + if ($self->{in_cell}) { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), forcing exit of cell ($self->{rc},$self->{cc}) due to new cell\n") if $self->{debug}; + $self->_exit_cell; + } + if (!$self->{in_row}) { + # Go ahead and try to recover from mangled HTML, because we care. + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), inferring as row $self->{rc}\n") + if $self->{debug}; + $self->_enter_row; + } ++$self->{cc}; ++$self->{in_cell}; + my %attrs = ref $_[1] ? %{$_[1]} : {}; + my $rspan = $attrs{rowspan} || 1; + my $cspan = $attrs{colspan} || 1; } sub _exit_cell { my $self = shift; - # Trigger taste_text just in case this was an empty cell. - $self->_taste_text(undef) if $self->_text_hungry; - $self->{in_cell} = 0; - $self->_hmatch; + if ($self->{in_cell}) { + $self->{in_cell} = 0; + } + else { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), extraneous ignored in row $self->{rc}\n") + if $self->{debug}; + } } - ### - - sub _add_frame { - # Add new frames to this table state. - my($self, @frames) = @_; - return 1 if $self->{umbrella}; - foreach my $f (@frames) { - ref $f or croak "Hash ref required\n"; - - if (! exists $f->{depth} && ! exists $f->{count} && ! $f->{headers}) { - # Special case. If there were no constraints, then umbrella - # gets set. Otherwise, with chains, we want all nodes to - # trigger but not become active due to the potential chain - # constraint. This is just a heads up. - ++$f->{null}; - } - - # Take the opportunity to prune frames that are out of their - # depth. Keep in mind, depths are specified in absolute terms - # for frames, as opposed to relative terms in chains. - if (defined $f->{depth} && $f->{depth} < $self->{depth}) { - print STDERR "Pruning frame for depth $f->{depth} at depth $self->{depth}\n" if $self->{debug} > 2; - next; - } - - # If we are an intermediary in a chain, we will never trigger a - # harvest (well, unless 'keep' was specified, anyway). Avoid - # autovivifying here, because $self->{chain} is used as a test - # many times. - if (ref $self->{chain}) { - if (defined $f->{chaindex} && $f->{chaindex} == $#{$self->{chain}}) { - ++$f->{terminus}; - } - } - elsif ($f->{global}) { - # If there is no chain, the global frame is a terminus. - ++$f->{terminus}; - } + # Header stuff - # Scoop all triggers if keepall has been asserted. - if ($self->{keepall}) { - ++$f->{terminus}; - } + sub _header_pattern { + my($self, @headers) = @_; + my $str = join('|', + map("($_)", + sort _header_string_sort keys %{$self->{hits_left}} + )); + my $hpat = qr/($str)/im; + $self->_emsg("HPAT: /$hpat/\n") if $self->{debug} >= 2; + $self->{hpat} = $hpat; + } - # Set up header pattern if we have headers. - if ($f->{headers}) { - my $hstring = '(' . join('|', map("($_)", @{$f->{headers}})) . ')'; - print STDERR "HPAT: /$hstring/\n" if $self->{debug} >= 2; - $f->{hpat} = $hstring; - $self->_reset_hits($f); - } + sub _header_string_sort { + # this ensures that supersets appear before subsets in our header + # search pattern, eg, '10' appears before '1' and 'hubbabubba' + # appears before 'hubba'. + if ($a =~ /^$b/) { + return -1; + } + elsif ($b =~ /^$a/) { + return 1; + } + else { + return $b cmp $a; + } + } - if ($self->{debug} > 3) { - print STDERR "Adding frame ($f):\n {\n"; - foreach (sort keys %$f) { - print STDERR " $_ => $f->{$_}\n"; - } - print STDERR " }\n"; - } + # Report methods - push(@{$self->{frames}}, $f); - } - # Activate header state if there were any header conditions in the - # frames. - $self->_scan_state('headers'); - # Arbitrary true return value. - scalar @{$self->{frames}}; + sub depth { shift->{depth} } + sub count { shift->{count} } + sub coords { + my $self = shift; + ($self->depth, $self->count); } - # Header stuff + sub row_count { shift->{rc} } + sub col_count { shift->{cc} } - sub _htxt { - # Accumulate or reset header text. This is shared across all - # frames. + sub tree { my $self = shift; - if (@_) { - if (defined $_[0]) { - $self->{htxt} .= $_[0] if $_[0] !~ /^\s*$/; - } - else { - $self->{htxt} = ''; - } - } - $self->{htxt}; + @_ ? $self->{_tree_ref} = shift : $self->{_tree_ref}; } - sub _hmatch { - # Given the current htxt, test all frames for matches. This - # *will* set state in the frames in the event of a match. + sub lineage { my $self = shift; - my @hits; - return 0 unless $self->_any_headers; - foreach my $f (@{$self->{frames}}) { - next unless $f->{hpat}; - if ($self->{htxt} =~ /$f->{hpat}/im) { - my $hit = $1; - print STDERR "HIT on '$hit' in $self->{htxt} ($self->{rc},$self->{cc})\n" if $self->{debug} >= 4; - ++$f->{scanning}; - # Get rid of the header segment that matched so we can tell - # when we're through with all header patterns. - foreach (keys %{$f->{hits_left}}) { - if ($hit =~ /$_/im) { - delete $f->{hits_left}{$_}; - $hit = $_; - last; - } - } - push(@hits, $hit); - # - my $cc = $self->_skew; - $f->{hits}{$cc} = $hit; - push(@{$f->{order}}, $cc); - if (!%{$f->{hits_left}}) { - # We have found all headers for this frame, but we won't - # start slurping until this row has ended - ++$f->{head_found}; - $f->{scanning} = undef; - } + $self->{lineage} ||= []; + if (@_) { + my $pts = shift; + my(@lineage, $pcoords); + if ($pts) { + foreach my $pcoord ($pts->lineage) { + push(@lineage, [@$pcoord]); + } + $pcoords = [$pts->depth, $pts->count, $pts->{rc}, $pts->{cc}]; + push(@lineage, $pcoords); } + $self->{lineage} = \@lineage; } - # Propogate relevant frame states to overall table state. - foreach (qw(head_found scanning)) { - $self->_scan_state($_); - } - # Reset htxt buffer - $self->_htxt(undef); - - wantarray ? @hits : scalar @hits; + @{$self->{lineage}}; } - # Header and header state booleans + sub rows { shift->_rows(0) } - sub _scan_state { - # This just sets analagous flags on a table state basis - # rather than a frame basis, for testing efficiency to - # reduce the number of method calls involved. - my($self, $state) = @_; - foreach (@{$self->{frames}}) { - ++$self->{$state} if $_->{state}; - } - $self->{$state}; + sub space_rows { + my $self = shift; + $self->_rows(1); } - sub _headers { shift->_check_state('headers' ) } - sub _head_found { shift->_check_state('head_found') } - sub _scanning { shift->_check_state('scanning') } - - # End header stuff - - sub _check_state { - my($self, $state) = @_; - defined $state or croak "State name required\n"; - my @frames_with_state; - foreach my $f (@{$self->{frames}}) { - push(@frames_with_state, $f) if $f->{$state}; + sub _rows { + my $self = shift; + my $alias = shift; + my @ri = $self->row_indices; + my @rows; + my $grid = $alias ? $self->_gridalias : $self->{grid}; + foreach ($self->row_indices) { + push(@rows, scalar $self->_slice_and_normalize_row($grid->[$_])); } - return () unless @frames_with_state; - wantarray ? @frames_with_state : $frames_with_state[0]; + wantarray ? @rows : \@rows; } - # Misc - - sub _evolve_frames { - # Retire frames that were triggered; integrate the next link in - # the chain if available. If it was the global frame, or the frame - # generated from the last in the chain sequence, then activate the - # frame and start a new chain. + sub columns { my $self = shift; - return if $self->{evolved}; - $self->{newframes} = [] unless $self->{newframes}; - foreach my $f (@{$self->{frames}}) { - # We're only interested in newly triggered frames. - next if !$f->{triggered} || $f->{retired}; - my %new; - if ($self->{chain}) { - if ($f->{global}) { - # We are the global frame, and we have a chain. Spawn a new - # chain. - $new{chaindex} = 0; - # Chain counts are always relative to the table state in - # which frame genisis occurred. Table states inherit the - # count contexts of parent table states, so that they can be - # updated (and therefore descendant frames get updated as - # well). Count contexts are represented as hashes with - # depths as keys. This frame-specific hash is shared amongst - # all frames descended from chains started in this table - # state. - $new{heritage} = "($self->{depth},$self->{count})"; - } - elsif (defined $f->{chaindex}) { - # Generate a new frame based on the next link in the chain - # (unless we are the global frame, in which case we initialize - # a new chain since there is no chain link for the global - # frame). - $new{chaindex} = $f->{chaindex} + 1; - # Relative counts always are inherited from chain genesis. We - # pass by reference so siblings can all update the depth - # counts for that chain. - $new{heritage} = $f->{heritage}; - } + my @cols; + my @rows = $self->rows; + foreach my $row (@rows) { + foreach my $c (0 .. $#$row) { + $cols[$c] ||= []; + push(@{$cols[$c]}, $row->[$c]); } + } + @cols; + } - if ($f->{terminus}) { - # This is a hit since we matched either in the global frame, - # the last link of the chain, or in a link specified as a - # keeper. - ++$f->{active} unless $f->{null}; - # If there is a chain, start a new one from this match if it - # was the global frame (if we ever decided to have chains - # spawn chains, this would be the place to do it. Currently - # only the global frame spawns chains). + sub row_indices { + my $self = shift; + my $start_index = 0; + if ($self->{headers}) { + $start_index = $self->hrow_index; + $start_index += 1 unless $self->{keep_headers}; + } + $start_index .. $#{$self->{grid}}; + } - } + sub col_indices { + my $self = shift; + my $row = $self->{grid}[0]; + 0 .. $#$row; + } - # Since we triggered, one way or the other this frame is retired. - ++$f->{retired}; - - # Frames always inherit the count context of the table state in - # which they were created. - $new{counts} = $self->{counts}[0]; - - if (defined $new{chaindex}) { - my $link = $self->{chain}[$new{chaindex}]; - # Tables immediately below the current table state are - # considered depth 0 as specified in chains...hence actual - # depth plus one forms the basis for depth 0 in relative - # terms. - $new{depth} = ($self->{depth} + 1) + $link->{depth} - if exists $link->{depth}; - $new{count} = $link->{count} if exists $link->{count}; - $new{headers} = $link->{headers} if exists $link->{headers}; - ++$new{terminus} if $link->{keep}; - if ($self->{debug} > 3) { - print STDERR "New proto frame (in ts $self->{depth},$self->{count}) for chain rule $new{chaindex}\n"; - print STDERR " {\n"; - foreach (sort keys %new) { - print STDERR " $_ => $new{$_}"; - if ($_ eq 'counts') { - print STDERR " ",join(' ', map("$_,$new{counts}{$_}", - sort { $a <=> $b } keys %{$new{counts}})); - } - print STDERR "\n"; - } - print STDERR " }\n"; - } - push(@{$self->{newframes}}, \%new); - } + sub row { + my $self = shift; + my $r = shift; + $r <= $#{$self->{grid}} + or croak "row $r out of range ($#{$self->{grid}})\n"; + my @ri = $self->row_indices; + my @row = $self->_slice_and_normalize_row( + $self->{grid}[($self->row_indices)[$r]] + ); + wantarray ? @row : \@row; + } + sub _slice_and_normalize_row { + my $self = shift; + my $rowref = shift; + my @row; + if ($self->{automap} && $self->_map_makes_a_difference) { + @row = @{$rowref}[$self->column_map]; } - # See if we're done evolving our frames. - foreach my $f (@{$self->{frames}}) { - return 0 unless $f->{retired}; - } - # If we are, then flag the whole table state as evolved. - ++$self->{evolved}; - } - - sub _spawn_frames { - # Build and pass new frames to a child table state. This involves - # retiring old frames and passing along untriggered and new - # frames. - my($self, $child) = @_; - ref $child or croak "Child table state required\n"; - if ($self->{umbrella}) { - # Don't mess with frames, just pass the umbrella. - ++$child->{umbrella}; - return; + else { + @row = @$rowref; } + @row = map($self->_cell_to_content($_), @row); + wantarray ? @row : \@row; + } - my @frames; - my @fields = qw(chaindex depth count headers counts heritage terminus); - - foreach my $f (@{$self->{frames}}) { - # Not interested in retired frames (which just matched), root - # frames (which get regenerated each time a frame is created), - # or in unmatched frames when not in elastic mode. - next if !$self->{elastic} || $f->{retired}; - my %new; - foreach (grep(exists $f->{$_}, @fields)) { - $new{$_} = $f->{$_}; - } - push(@frames, \%new); + sub column { + my $self = shift; + my $c = shift; + my @column; + foreach my $row ($self->rows) { + push(@column, $self->cell($row, $c)); } + wantarray ? @column : \@column; + } - # Always interested in newly created frames. Make sure and pass - # copies, though, so that siblings don't update each others frame - # sets. - foreach my $f (@{$self->{newframes}}) { - my %new; - foreach (grep(exists $f->{$_}, @fields)) { - $new{$_} = $f->{$_}; - } - push(@frames, \%new); - } + sub cell { + my $self = shift; + my($r, $c) = @_; + my $row = $self->row($r); + $c <= $#$row or croak "Column $c out of range ($#$row)\n"; + $self->_cell_to_content($row->[$c]); + } - $child->_add_frame(@frames) if @frames; + sub _cell_to_content { + my $self = shift; + @_ or croak "cell item required\n"; + my $cell = shift; + return $cell unless ref $cell; + return $cell if TREE(); + return $$cell; } - # Report methods + sub space { + my $self = shift; + my($r, $c) = @_; + my $gridalias = $self->_gridalias; + $r <= $#$gridalias + or croak "row $r out of range ($#$gridalias)\n"; + my $row = $gridalias->[$r]; + $c <= $#$row or croak "Column $c out of range ($#$row)\n"; + $self->_cell_to_content($row->[$c]); + } - sub depth { shift->{depth} } - sub count { shift->{count} } - sub coords { + sub source_coords { my $self = shift; - ($self->depth, $self->count); + my($r, $c) = @_; + $r <= $#{$self->{translation}} + or croak "row $r out of range ($#{$self->{translation}})\n"; + my $row = $self->{translation}[$r]; + $c <= $#$row or croak "Column $c out of range ($#$row)\n"; + split(/,/, $self->{translation}[$r][$c]); } - sub lineage { + sub hrow_index { my $self = shift; - map([split(',', $_)], @{$self->{lineage}}); + $self->{hrow_index}; } - sub rows { + sub hrow { my $self = shift; if ($self->{automap} && $self->_map_makes_a_difference) { - my @tc; - my @cm = $self->column_map; - foreach (@{$self->{content}}) { - my $r = [@{$_}[@cm]]; - # since there could have been non-existent
    Date TimeVehicle Heading and SpeedLocationNew Location
    since text() never got - # called. Don't want to blindly do this in a start('td') because - # headers might have vetoed. Also track max row length in case we - # need to pad the other rows in gridmap mode. - my $cmax = 0; - foreach my $r (@{$ts->{content}}) { - $cmax = $#$r if $#$r > $cmax; - foreach (0 .. $#$r) { - $r->[$_] = '' unless defined $r->[$_]; - } + if ($self->{debug} >= 2) { + my $msg = "Captured table (" . $ts->depth . ',' . $ts->count . ")"; + $msg .= " ($type)" if $type; + $msg .= "\n"; + $self->_emsg($msg); } - # Pad right side of columns if gridmap or header slicing - if ($self->{gridmap}) { - foreach my $r (@{$ts->{content}}) { - grep($r->[$_] = '', $#$r + 1 .. $cmax) if $#$r < $cmax; + $ts->tree(HTML::ElementTable->new_from_tree($ts->tree)) if TREE(); + if ($self->{subtables}) { + foreach my $child (@{$ts->{children}}) { + next if $child->{captured}; + $self->_capture_table($child, 'subtable'); + $child->{slice_columns} = 0; + $child->{keep_headers} = 1; + $child->{headers} = ''; } } - + $ts->{captured} = 1; $self->{_tables}{$ts->{depth}}{$ts->{count}} = $ts; - $self->{_table_mapback}{$ts->{content}} = $ts; push(@{$self->{_ts_sequential}}, $ts); } -sub _current_table_state { +sub current_table { my $self = shift; $self->{_tablestack}[$#{$self->{_tablestack}}]; } +sub _reset_state { + my $self = shift; + $self->{_cdepth} = -1; + $self->{_tablestack} = []; + $self->{_tables} = {}; + $self->{_ts_sequential} = []; + $self->{_counts} = []; + $self->{_in_a_table} = 0; +} + +sub _emsg { + my $self = shift; + my $fh = $self->{error_handle}; + return unless defined $_[0]; + print $fh @_; +} + ########## { - package HTML::TableExtract::TableState; + + package HTML::TableExtract::Table; use strict; use Carp; + *TREE = *HTML::TableExtract::TREE; + sub new { my $that = shift; my $class = ref($that) || $that; - # Note: 'depth' and 'count' are where this table were found. - # 'tdepth' and 'tcount' are target constraints on which to trigger. - # 'headers' represent a target constraint, location independent. + # Note: + # - 'depth' and 'count' are where this table were found. + # - 'tdepth' and 'tcount' are target constraints on which to trigger. + # - 'headers' represent a target constraint, location independent. + # - 'attribs' represent target table tag constraints my $self = { - umbrella => 0, - in_row => 0, - in_cell => 0, - rc => -1, - cc => -1, - frames => [], - content => [], - htxt => '', - order => [], - counts => [{}], - debug => 0, - }; + umbrella => 0, + in_row => 0, + in_cell => 0, + rc => -1, + cc => -1, + grid => [], + translation => [], + hrow => [], + order => [], + children => [], + captured => 0, + debug => 0, + }; + + $self->{_rastamon} = HTML::TableExtract::Rasterize->make_rasterizer(); bless $self, $class; my %parms = @_; @@ -432,874 +464,771 @@ sub _current_table_state { # Depth and Count -- this is the absolute address of the table. croak "Absolute depth required\n" unless defined $parms{depth}; croak "Count required\n" unless defined $parms{count}; - - # Inherit count contexts - if ($parms{counts}) { - push(@{$self->{counts}}, @{$parms{counts}}); - delete $parms{counts}; - } + croak "Counts required\n" unless defined $parms{counts}; foreach (keys %parms) { $self->{$_} = $parms{$_}; } # Register lineage - $self->{lineage} = [ "$self->{depth},$self->{count}" ]; - - # Umbrella is a short circuit. This table and all descendants will - # be harvested if the umbrella parameter was asserted. If it was - # not, then the initial conditions specified for the new table - # state are passed along as the first frame in the chain. - if (!$self->{umbrella}) { - # Frames are designed to be used when chains are specified. With - # no chains specified, there is only a single frame, the global - # frame, so frames become a bit redundant. We use the mechanisms - # anyway for consistency in the extraction engine. Each frame - # contains information that might be relative to a chain - # frame. Currently this means depth, count, and headers. - my %frame; - # Frame depth and count represent target depth and count, in - # absolute terms. If present, our initial frame takes these from - # the target values in the table state. Unlike frames generated - # by chains, the counts hash for the initial frame comes from - # the global level (this is necessary since the top-level HTML - # document has no table state from which to inherit!). Counts - # relative to this frame will be assigned and updated based on - # chain links, assuming there are any. - $frame{depth} = $self->{tdepth} if exists $self->{tdepth}; - $frame{count} = $self->{tcount} if exists $self->{tcount}; - $frame{headers} = $self->{headers} if exists $self->{headers}; - $frame{counts} = $self->{counts}[$#{$self->{counts}}]; - $frame{global} = 1; - $frame{terminus} = 1 if $self->{keep}; - $frame{heritage} = "($self->{depth},$self->{count})"; - $self->_add_frame(\%frame); - } - else { - # Short circuit since we are an umbrella. Activate table state. - $self->{active} = 1; - } + my $pts = $self->{parent_table}; + $self->lineage($pts || undef); + push(@{$pts->{children}}, $self) if ($pts); + delete $self->{parent_table}; + $self; } - sub _text_hungry { - # Text hungry only means that we are interested in gathering the - # text, whether it be for header scanning or harvesting. - my $self = shift; - return 1 if $self->{umbrella}; - return 0 if $self->{prune}; - $self->_any_dctrigger; - } - - sub _taste_text { - # Gather the provided text, either for header scanning or - # harvesting. - my($self, $text) = @_; - - # Calculate and track skew, regardless of whether we actually want - # this column or not. - my $sc = $self->_skew; - - # Harvest if trigger conditions have been met in a terminus - # frame. If headers have been found, and we are not beneath a - # header column, then ignore this text. - if ($self->_terminus_trigger && $self->_column_wanted || - $self->{umbrella}) { - print STDERR "Add text ",join(',', @_),"\n" if $self->{debug} > 3; - $self->_add_text($text, $sc); - } - # Regardless of whether or not we are harvesting, we still try to - # scan for headers in waypoint frames. - if (defined $text && $self->_any_headers && !$self->_any_htrigger) { - $self->_htxt($text); + sub _anchor_item { + # anchor the reference to a cell in our grid -- in TREE mode this is + # a reference to a data element, otherwise it's a reference to an + # empty scalar in which we will collect our text. + my($self, @res) = @_; + my $row = $self->{grid}[-1]; + my $item; + if (@res && ref $res[0]) { + $item = $res[0]; } - 1; - } - - ### Init - - sub _pre_latch { - # This should be called at some point soon after object creation - # to inform the table state that there will be no more constraints - # added. This way latches can be pre-set if possible for - # efficiency. - my $self = shift; - - $self->_trigger_frames; - return 0 if $self->{prune}; - - if ($self->{umbrella}) { - ++$self->{dc_trigger}; - ++$self->{head_trigger}; - ++$self->{trigger}; - ++$self->{active}; - return; + else { + my $scalar_ref; + $item = \$scalar_ref; } - # The following latches are detectable immediately for a - # particular table state. - $self->_terminus_dctrigger; - $self->_any_dctrigger; - $self->_terminus_headers; - $self->_any_headers; - - } - - ### Latch methods...'terminus' vs 'any' is an important distinction, - ### because conditions might only be satisifed for a waypoint - ### frame. In this case, the next frame in the chain will be - ### created, but the table itself will not be captured. - - sub _terminus_dctrigger { - my $self = shift; - return $self->{terminus_dctrigger} if defined $self->{terminus_dctrigger}; - $self->{terminus_dctrigger} = $self->_check_dctrigger($self->_terminus_frames); + push(@$row, $item); } - sub _any_dctrigger { + sub _gridalias { my $self = shift; - return $self->{any_dctrigger} if defined $self->{any_dctrigger}; - $self->{any_dctrigger} = $self->_check_dctrigger(@{$self->{frames}}); + $self->{gridalias} ||= $self->_make_gridalias; } - sub _terminus_headers { + sub _grid_map { + # using our rasterized template, flesh out our captured items which + # are still in 'tree' format my $self = shift; - return $self->{terminus_headers} if defined $self->{terminus_headers}; - $self->{terminus_headers} = $self->_check_headers($self->_terminus_frames); + my $template = $self->_rasterizer->(); + my $grid = $self->{grid}; + # drop empty rows + if ($self->{debug}) { + foreach (0 .. $#$grid) { + next if @{$grid->[$_]}; + $self->_emsg("Dropping empty row $_\n"); + } + } + @$grid = grep(@$_, @$grid); + foreach my $r (0 .. $#$template) { + my $row = $grid->[$r]; + my $trow = $template->[$r]; + $self->_emsg("Flesh row $r ($#$row) to $#$trow\n") if $self->{debug} > 1; + foreach my $c (0 .. $#$trow) { + print STDERR $trow->[$c] ? '1' : '0' if $self->{debug} > 1; + if ($trow->[$c]) { + if (! defined $row->[$c]) { + $row->[$c] = \undef; + } + next; + } + else { + my $scalar; + splice(@$row, $c, 0, \$scalar); + } + } + print STDERR "\n" if $self->{debug} > 1; + croak "row $r splice mismatch: $#$row vs $#$trow\n" + unless $#$row == $#$trow; + } + $grid; } - sub _any_headers { + sub _make_gridalias { + # our aliased grid will have references in masked cells to the same + # cell that is covering it via spanning. my $self = shift; - return $self->{any_headers} if defined $self->{any_headers}; - $self->{any_headers} = $self->_check_headers(@{$self->{frames}}); + my $grid = $self->{grid}; + my $template = $self->_rasterizer->(); + my(@gridalias, @translation); + $gridalias[$_] = [@{$grid->[$_]}] foreach 0 .. $#$grid; + foreach my $r (0 .. $#gridalias) { + my $row = $gridalias[$r]; + foreach my $c (0 .. $#$row) { + my $tcell = $template->[$r][$c] || next; + my($rspan, $cspan) = @$tcell; + foreach my $rs (0 .. $rspan-1) { + foreach my $cs (0 .. $cspan-1) { + $gridalias[$r + $rs][$c + $cs] = $grid->[$r][$c]; + $translation[$r + $rs][$c + $cs] = "$r,$c"; + } + } + } + } + $self->{translation} = \@translation; + $self->{gridalias} = \@gridalias; } - sub _terminus_htrigger { - # Unlike depth and count, this trigger should only latch on - # positive values since each row is to be examined. - my $self = shift; - return $self->{terminus_htrigger} if $self->{terminus_htrigger}; - $self->{terminus_htrigger} = $self->_check_htrigger($self->_terminus_frames); - } + ### Constraint tests - sub _any_htrigger { + sub _check_dtrigger { + # depth my $self = shift; - return $self->{any_htrigger} if defined $self->{any_htrigger}; - $self->{any_htrigger} = $self->_check_htrigger(@{$self->{frames}}); + return 1 unless defined $self->{tdepth}; + $self->{tdepth} == $self->{depth} ? 1 : 0; } - sub _terminus_trigger { - # This has to be the same frame reporting on dc/header - # success. First found is the hero. + sub _check_ctrigger { + # count my $self = shift; - return $self->{terminus_trigger} if $self->{terminus_trigger}; - $self->{terminus_trigger} = $self->_check_trigger($self->_terminus_frames); + return 1 unless defined $self->{tcount}; + return 1 if (exists $self->{counts}[$self->{depth}] && + $self->{tcount} == $self->{counts}[$self->{depth}]); + return 0; } - sub _any_trigger { - # This has to be the same frame reporting on dc/header - # success. First found is the hero. + sub _check_atrigger { + # attributes my $self = shift; - return $self->{any_trigger} if $self->{any_trigger}; - $self->{any_trigger} = $self->_check_trigger(@{$self->{frames}}); - } - - ### Latch engines - - sub _check_dctrigger { - my($self, @frames) = @_; - return @frames if $self->{umbrella}; - my @dctriggered; - foreach my $f (@frames) { - my $dc_hit = 1; - if ($f->{null}) { - # Special case... - $dc_hit = 0; + return 1 unless scalar keys %{$self->{tattribs}}; + return 0 unless scalar keys %{$self->{attribs}}; + my $a_hit = 1; + foreach my $attrib (keys %{$self->{tattribs}}) { + if (! defined $self->{attribs}{$attrib}) { + $a_hit = 0; last; + } + if (! defined $self->{tattribs}{$attrib}) { + # undefined, but existing, target attribs are wildcards + next; } - else { - if (defined $f->{depth} && $f->{depth} != $self->{depth}) { - $dc_hit = 0; - } - if (defined $f->{count}) { - $dc_hit = 0; - if (exists $f->{counts}{$self->{depth}} && - $f->{count} == $f->{counts}{$self->{depth}}) { - # Note: frame counts, though relative to chain genesis - # depth, are recorded in terms of absolute depths. A - # particular counts hash is shared among frames descended - # from the same chain instance. - $dc_hit = 1; - } - } + if ($self->{tattribs}{$attrib} ne $self->{attribs}{$attrib}) { + $a_hit = 0; last; } - push(@dctriggered, $f) if $dc_hit; } - return @dctriggered ? \@dctriggered : undef; + $self->_emsg("Matched attributes\n") if $self->{debug} > 3 && $a_hit; + $a_hit; } sub _check_htrigger { - my($self, @frames) = @_; - my @htriggered; - foreach my $f (@frames) { - if ($f->{headers}) { - push(@htriggered, $f) if $f->{head_found}; - } - else { - push(@htriggered, $f); + # headers + my $self = shift; + return 1 if $self->{umbrella}; + return 1 unless $self->{headers}; + ROW: foreach my $r (0 .. $#{$self->{grid}}) { + $self->_reset_hits; + my $hpat = $self->_header_pattern; + my @hits; + foreach my $c (0 .. $#{$self->{grid}[$r]}) { + my $ref = $self->{grid}[$r][$c]; + my $target = ''; + my $ref_type = ref $ref; + if ($ref_type) { + if ($ref_type eq 'SCALAR') { + my $item = $$ref; + if ($self->{keep_html} && $self->{strip_html_on_match}) { + my $stripper = HTML::TableExtract::StripHTML->new; + $target = $stripper->strip($item); + } + else { + $target = $item; + } + } + else { + if (($self->{keep_html} || TREE()) && + $self->{strip_html_on_match}) { + $target = $ref->as_text; + } + else { + $target = $ref->as_HTML; + } + } + } + $target = defined $target ? $target : ''; + $self->_emsg("attempt match on $target ($hpat): ") + if $self->{debug} >= 5; + if ($target =~ $hpat) { + my $hit = $1; + $self->_emsg("($hit)\n") if $self->{debug} >= 5; + # Get rid of the header segment that matched so we can tell + # when we're through with all header patterns. + my $real_hit; + foreach (sort _header_string_sort keys %{$self->{hits_left}}) { + if ($hit =~ /$_/im) { + delete $self->{hits_left}{$_}; + $real_hit = $_; + $hpat = $self->_header_pattern; + last; + } + } + if (defined $real_hit) { + if ($self->{debug} >= 4) { + my $str = $ref_type eq 'SCALAR' ? $$ref : $ref->as_HTML; + $self->_emsg("HIT on '$hit' ($real_hit) in $str ($r,$c)\n"); + } + push(@hits, $hit); + # + $self->{hits}{$c} = $real_hit; + push(@{$self->{order}}, $c); + if (!%{$self->{hits_left}}) { + # Successful header row match + ++$self->{head_found}; + $self->{hrow_index} = $r; + $self->{hrow} = $self->{grid}[$r]; + last ROW; + } + } + } + elsif ($self->{debug} >= 5) { + $self->_emsg("0\n"); + } } - } - @htriggered ? \@htriggered : undef; - } - - sub _check_trigger { - # This has to be the same frame reporting on dc/header - # success. First found is the hero. - my($self, @frames) = @_; - return () unless @frames; - my $tdct = $self->_check_dctrigger(@frames); - my $tht = $self->_check_htrigger(@frames); - my %tframes; - my %tdc_frames; - foreach (ref $tdct ? @$tdct : ()) { - $tdc_frames{$_} = $_; - $tframes{$_} = $_ unless $tframes{$_}; - } - my %th_frames; - foreach (ref $tht ? @$tht : ()) { - $th_frames{$_} = $_; - $tframes{$_} = $_ unless $tframes{$_}; - } - my @frame_order = grep($tframes{$_}, @frames); - my @triggered; - foreach (@frame_order) { - if ($tdc_frames{$_} && $th_frames{$_}) { - push(@triggered, $tframes{$_}); + if ($self->{debug} && @hits) { + my $str = "Incomplete header match "; + $str .= "(left: " . join(', ', sort keys %{$self->{hits_left}}) . ") "; + $str .= "in row $r, resetting scan"; + $str .= "\n"; + $self->_emsg($str); } } - @triggered ? \@triggered : undef; + $self->{head_found}; } - sub _check_headers { - my($self, @frames) = @_; - foreach my $f (@frames) { - return 1 if $f->{headers}; - } - 0; - } - - ### - - sub _terminus_frames { - # Return all frames that are at the end of a chain, or specified - # as a terminus. + sub _check_triggers { my $self = shift; - my @res; - foreach (@{$self->{frames}}) { - push(@res, $_) if $_->{terminus}; - } - @res; - } - - ### - - sub _trigger_frames { - # Trigger each frame whose conditions have been met (i.e., rather - # than merely detect conditions, set state in the affected frame - # as well). - my $self = shift; - if (!@{$self->{frames}}) { - ++$self->{prune}; - return 0; - } - my $t = 0; - foreach my $f (@{$self->{frames}}) { - if ($f->{triggered}) { - ++$t; - next; - } - if ($self->_check_trigger($f)) { - ++$t; - $f->{triggered} = 1; - } - } - $t; + return 1 if $self->{umbrella}; + $self->_check_dtrigger && + $self->_check_ctrigger && + $self->_check_atrigger && + $self->_check_htrigger; } ### Maintain table context sub _enter_row { my $self = shift; - $self->_exit_cell if $self->{in_cell}; + if ($self->{in_row}) { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), forcing exit of row $self->{rc} due to new row\n") if $self->{debug}; + $self->_exit_row; + } ++$self->{rc}; ++$self->{in_row}; - - # Reset next_col for gridmapping - $self->{next_col} = 0; - while ($self->{taken}{"$self->{rc},$self->{next_col}"}) { - ++$self->{next_col}; - } - - ++$self->{active} if $self->_terminus_trigger; - if ($self->{active}) { - # Add the new row, unless we're using headers and are still in - # the header row - push(@{$self->{content}}, []) - unless $self->_terminus_headers && $self->_still_in_header_row; - } - $self->_evolve_frames if $self->_trigger_frames; + push(@{$self->{grid}}, []) } sub _exit_row { my $self = shift; - $self->_exit_cell if $self->{in_cell}; - $self->{in_row} = 0; - $self->{cc} = -1; - $self->_reset_header_scanners; - if ($self->_terminus_headers && $self->_still_in_header_row) { - ++$self->{hslurp}; - # Store header row number so that we can adjust later (we keep - # it around for now in case of skew situations, which are in - # absolute row terms) - $self->{hrow} = $self->{rc}; + if ($self->{in_row}) { + if ($self->{in_cell}) { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), forcing exit of cell ($self->{rc}, $self->{cc}) due to new row\n") if $self->{debug}; + $self->_exit_cell; + } + $self->{in_row} = 0; + $self->{cc} = -1; + } + else { + $self->_emsg("Mangled HTML in table ($self->{depth},$self->{count}), extraneous
    we need - # to double check initilization to appease -w - foreach (0 .. $#$r) { - $r->[$_] = '' unless defined $r->[$_]; - } - push(@tc, $r); - } - return @tc; + return map(ref $_ ? $$_ : $_, @{$self->{hrow}}[$self->column_map]); + } + else { + return map(ref $_ ? $$_ : $_, @{$self->{hrow}}); } - # No remapping - @{$self->{content}}; } sub column_map { # Return the column numbers of this table in the same order as the # provided headers. my $self = shift; - my $tframes = $self->_terminus_trigger; - my $tframe = ref $tframes ? $tframes->[0] : undef; - if ($tframe && $tframe->{headers}) { - # First we order the original column counts by taking a hash - # slice based on the original header order. The resulting - # original column numbers are mapped to the actual content - # indicies since we could have a sparse slice. + if ($self->{headers}) { + # First we order the original column counts by taking a hash slice + # based on the original header order. The resulting original + # column numbers are mapped to the actual content indicies since + # we could have a sparse slice. my %order; - foreach (keys %{$tframe->{hits}}) { - $order{$tframe->{hits}{$_}} = $_; + foreach (keys %{$self->{hits}}) { + $order{$self->{hits}{$_}} = $_; } - return @order{@{$tframe->{headers}}}; + return @order{@{$self->{headers}}}; } else { - return 0 .. $#{$self->{content}[0]}; + return 0 .. $#{$self->{grid}[0]}; } } sub _map_makes_a_difference { my $self = shift; + return 0 unless $self->{slice_columns}; my $diff = 0; my @order = $self->column_map; my @sorder = sort { $a <=> $b } @order; ++$diff if $#order != $#sorder; - ++$diff if $#sorder != $#{$self->{content}[0]}; + ++$diff if $#sorder != $#{$self->{grid}[0]}; foreach (0 .. $#order) { if ($order[$_] != $sorder[$_]) { - ++$diff; - last; + ++$diff; + last; } } $diff; } sub _add_text { - my($self, $txt, $skew_column) = @_; - # We don't check for $txt being defined, sometimes we want to - # merely insert a placeholder in the content. - my $row = $self->{content}[$#{$self->{content}}]; - if (! defined $row->[$skew_column]) { - # Init to appease -w - $row->[$skew_column] = ''; - } - return unless defined $txt; - $row->[$skew_column] .= $txt; + my($self, $txt) = @_; + my $r = $self->{rc}; + my $c = $self->{cc}; + my $row = $self->{grid}[$r]; + ${$row->[$c]} .= $txt; $txt; } - sub _skew { - # Skew registers the effects of rowspan/colspan issues when - # gridmap is enabled. - - my($self, $rspan, $cspan) = @_; - my($r,$c) = ($self->{rc},$self->{cc}); - - if ($self->{debug} > 5) { - print STDERR "($self->{rc},$self->{cc}) Inspecting skew for ($r,$c)"; - print STDERR defined $rspan ? " (set with $rspan,$cspan)\n" : "\n"; + sub _reset_hits { + my $self = shift; + return unless $self->{headers}; + $self->{hits} = {}; + $self->{order} = []; + foreach (@{$self->{headers}}) { + ++$self->{hits_left}{$_}; } + 1; + } - my $sc = $c; - if (! defined $self->{skew_cache}{"$r,$c"}) { - $sc = $self->{next_col} if defined $self->{next_col}; - $self->{skew_cache}{"$r,$c"} = $sc; - my $next_col = $sc + 1; - while ($self->{taken}{"$r,$next_col"}) { - ++$next_col; + sub _rasterizer { shift->{_rastamon} } + + sub report { + # Print out a summary of this table, including depth/count + my($self, $include_content, $col_sep) = @_; + $col_sep ||= ':'; + my $str; + $str .= "TABLE(" . $self->depth . ", " . $self->count . ')'; + if ($include_content) { + $str .= ":\n"; + foreach my $row ($self->rows) { + $str .= join($col_sep, @$row) . "\n"; } - $self->{next_col} = $next_col; } else { - $sc = $self->{skew_cache}{"$r,$c"}; - } - - # If we have span arguments, set skews - if (defined $rspan) { - # Default span is always 1, even if not explicitly stated. - $rspan = 1 unless $rspan; - $cspan = 1 unless $cspan; - --$rspan; - --$cspan; - # 1,1 is a degenerate case, there's nothing to do. - if ($rspan || $cspan) { - foreach my $rs (0 .. $rspan) { - my $cr = $r + $rs; - # If we in the same row as the skewer, the "span" is one less - # because the skewer cell occupies the same row. - my $start_col = $rs ? $sc : $sc + 1; - my $fin_col = $sc + $cspan; - foreach ($start_col .. $fin_col) { - $self->{taken}{"$cr,$_"} = "$r,$sc" unless $self->{taken}{"$cr,$_"}; - } - if (!$rs) { - my $next_col = $fin_col + 1; - while ($self->{taken}{"$cr,$next_col"}) { - ++$next_col; - } - $self->{next_col} = $next_col; - } - } - } + $str .= "\n"; } - - # Grid column number - $sc; + $str; } - sub _reset_header_scanners { - # When a row ends, this should be called in order to reset frames - # who are in the midst of header scans. + sub dump { my $self = shift; - my @scanners; - foreach my $f (@{$self->{frames}}) { - next unless $f->{headers} && $f->{scanning}; - if ($self->{debug}) { - my $str = "Incomplete header match in row $self->{rc}, resetting scan"; - $str .= " link $f->{chaindex}" if defined $f->{chaindex}; - $str .= "\n"; - print STDERR $str; - } - push(@scanners, $f); - } - $self->_reset_hits(@scanners) if @scanners; + $self->_emsg($self->report(@_)); } - sub _header_quest { - # Loosely translated: "Should I even bother scanning for header - # matches?" + sub _emsg { my $self = shift; - return 0 unless $self->_any_headers && !$self->_head_found; - foreach my $f (@{$self->{frames}}) { - return 1 if $f->{headers} && $f->{dc_trigger}; - } - 0; + my $fh = $self->{error_handle}; + print $fh @_; } - sub _still_in_header_row { - my $self = shift; - return 0 unless $self->_terminus_headers; - !$self->{hslurp} && $self->_terminus_htrigger; - } +} + +########## - # Non waypoint answers +{ - sub _active { - my $self = shift; - return 1 if $self->{active}; - my @active; - foreach my $f (@{$self->{frames}}) { - push(@active, $f) if $f->{active}; + package HTML::TableExtract::Rasterize; + + # Provide a closure that will rasterize (turn into a grid) a table + # from a tree structure based on repeated data element calls with + # rowspan and colspan information. Not as straight forward as it + # seems...see test cases for an example bugaboo. + + my $DEBUG = 0; + + sub make_rasterizer { + my $pkg = shift; + my(@grid, @row_spinner, @col_spinner); + my $empty_row_offset = 0; + sub { + return \@grid unless @_; + my($row_num, $rspan, $cspan) = @_; + $rspan = 1 unless $rspan > 1; + $cspan = 1 unless $cspan > 1; + my($rspin_propogate, $row_added); + my $trigger = $#grid + $empty_row_offset; + if ($row_num > $trigger) { + # adjust for having been handed a row that skips a prior row, + # otherwise the next cell will land in a wrong row. Hopefully + # this doesn't happen too often but I've seen it in the wild! + if ($row_num - $trigger > 1) { + $empty_row_offset += $row_num - $trigger - 1; + } + # add new row + $row_added = 1; + my @new_row; + # first add new row spinner + if ($row_spinner[-1] && $col_spinner[-1]) { + push(@row_spinner, $row_spinner[-1]); + $rspin_propogate = 1; + } + else { + push(@row_spinner, $cspan - 1); + } + # spin columns + foreach (@col_spinner) { + if ($_) { + push(@new_row, 0); + --$_; + } + else { + push(@new_row, undef); + } + } + @new_row = (undef) unless @new_row; + push(@grid, \@new_row); + } + my $current_row = $grid[-1]; + # locate next available cell in row + my $col; + foreach my $ci (0 .. $#$current_row) { + if (! defined $current_row->[$ci]) { + $col = $ci; + last; + } + } + if (! defined $col) { + ADDCOL: while (! defined $col) { + # if no cells were available, add a column + foreach my $ri (0 .. $#grid) { + my $row = $grid[$ri]; + my $cspan_count = $row_spinner[$ri]; + if (!$cspan_count) { + push(@$row, undef); + } + else { + push(@$row, 0); + --$row_spinner[$ri]; + } + } + push(@col_spinner, $col_spinner[-1]); + foreach my $ci (0 .. $#$current_row) { + if (! defined $current_row->[$ci]) { + $col = $ci; + last ADDCOL; + } + } + } + $col_spinner[-1] = $rspan - 1 if $col == $#$current_row; + $row_spinner[$#grid] = $cspan - 1; + } + + # we now have correct coordinates for this element + $current_row->[$col] = [$rspan, $cspan]; + $col_spinner[$col] = $rspan - 1; + + # if this is an embedded placment (not a trailing element), use up + # the cspan + if ($col < $#$current_row) { + my $offset = 1; + my $row_span = $col_spinner[$col]; + if ($col + $row_spinner[-1] < $#$current_row && + $row_added && !$rspin_propogate) { + # cell is spun out -- clear spinner unless it inherited cspan + # from a cell above + $row_spinner[-1] = 0; + } + while ($offset < $cspan) { + my $cursor = $col + $offset; + $current_row->[$cursor] = 0; + $col_spinner[$cursor] = $row_span; + ++$offset; + if ($col + $offset > $#$current_row) { + $row_spinner[-1] = $cspan - $offset; + last; + } + } + } + + if ($DEBUG) { + foreach my $r (0 .. $#grid) { + my $row = $grid[$r]; + foreach my $c (0 .. $#$row) { + if (defined $row->[$c]) { + print STDERR $row->[$c] ? 1 : 0; + } + else { + print STDERR '?'; + } + } + print STDERR " $row_spinner[$r]\n"; + } + print STDERR "\n"; + foreach (@col_spinner) { + print STDERR defined $_ ? $_ : '?'; + } + print STDERR "\n\n-----\n\n"; + } + + return \@grid; } - return () unless @active; - ++$self->{active} if @active; - wantarray ? @active : $active[0]; } - sub _column_wanted { +} + +########## + +{ + + package HTML::TableExtract::StripHTML; + + use vars qw(@ISA); + + use HTML::Parser; + @ISA = qw(HTML::Parser); + + sub tag { + my($self, $tag, $num) = @_; + $self->{_htes_inside}{$tag} += $num; + } + + sub text { my $self = shift; - my $tframes = $self->_terminus_trigger; - my $tframe = ref $tframes ? $tframes->[0] : undef; - return 0 unless $tframe; - my $wanted = 1; - if ($self->_terminus_headers && $self->{hslurp}) { - # If we are using headers, veto the grab unless we are in an - # applicable column beneath one of the headers. - $wanted = 0 - unless exists $tframe->{hits}{$self->_skew}; - } - print STDERR "Want ($self->{rc},$self->{cc}): $wanted\n" - if $self->{debug} > 7; - $wanted; + return if $self->{_htes_inside}{script} || $self->{_htes_inside}{style}; + $self->{_htes_tidbit} .= $_[0]; } - sub _reset_hits { - # Reset hits in provided frames. WARNING!!! If you do not provide - # frames, all frames will be reset! - my($self, @frames) = @_; - foreach my $frame (@frames ? @frames : @{$self->{frames}}) { - next unless $frame->{headers}; - $frame->{hits} = {}; - $frame->{order} = []; - $frame->{scanning} = undef; - foreach (@{$frame->{headers}}) { - ++$frame->{hits_left}{$_}; - } - } - 1; + sub new { + my $class = shift; + my $self = HTML::Parser->new( + api_version => 3, + handlers => [start => [\&tag, "self, tagname, '+1'"], + end => [\&tag, "self, tagname, '-1'"], + text => [\&text, "self, dtext"], + ], + marked_sections => 1, + ); + bless $self, $class; + } + + sub strip { + my $self = shift; + $self->parse(shift); + $self->eof; + $self->{_htes_tidbit}; } } @@ -1310,372 +1239,332 @@ __END__ =head1 NAME -HTML::TableExtract - Perl extension for extracting the text contained in tables within an HTML document. +HTML::TableExtract - Perl module for extracting the content contained in tables within an HTML document, either as text or encoded element trees. =head1 SYNOPSIS - # Matched tables are returned as "table state" objects; tables can be - # matched using column headers, depth, count within a depth, or some - # combination of the three. + # Matched tables are returned as table objects; tables can be matched + # using column headers, depth, count within a depth, table tag + # attributes, or some combination of the four. - # Using column header information. Assume an HTML document with - # tables that have "Date", "Price", and "Cost" somewhere in a - # row. The columns beneath those headings are what you want to - # extract. They will be returned in the same order as you specified - # the headers since 'automap' is enabled by default. + # Example: Using column header information. + # Assume an HTML document with tables that have "Date", "Price", and + # "Cost" somewhere in a row. The columns beneath those headings are + # what you want to extract. They will be returned in the same order as + # you specified the headers since 'automap' is enabled by default. use HTML::TableExtract; - $te = new HTML::TableExtract( headers => [qw(Date Price Cost)] ); + $te = HTML::TableExtract->new( headers => [qw(Date Price Cost)] ); $te->parse($html_string); # Examine all matching tables - foreach $ts ($te->table_states) { + foreach $ts ($te->tables) { print "Table (", join(',', $ts->coords), "):\n"; foreach $row ($ts->rows) { print join(',', @$row), "\n"; } } - # Old style, using top level methods rather than table state objects. - foreach $table ($te->tables) { - print "Table (", join(',', $te->table_coords($table)), "):\n"; - foreach $row ($te->rows($table)) { - print join(',', @$row), "\n"; - } - } - - # Shorthand...top level rows() method assumes the first table found - # in the document if no arguments are supplied. + # Shorthand...top level rows() method assumes the first table found in + # the document if no arguments are supplied. foreach $row ($te->rows) { print join(',', @$row), "\n"; } - # Using depth and count information. Every table in the document has - # a unique depth and count tuple, so when both are specified it is a - # unique table. Depth and count both begin with 0, so in this case we - # are looking for a table (depth 2) within a table (depth 1) within a - # table (depth 0, which is the top level HTML document). In addition, - # it must be the third (count 2) such instance of a table at that - # depth. - - $te = new HTML::TableExtract( depth => 2, count => 2 ); - $te->parse($html_string); - foreach $ts ($te->table_states) { + # Example: Using depth and count information. + # Every table in the document has a unique depth and count tuple, so + # when both are specified it is a unique table. Depth and count both + # begin with 0, so in this case we are looking for a table (depth 2) + # within a table (depth 1) within a table (depth 0, which is the top + # level HTML document). In addition, it must be the third (count 2) + # such instance of a table at that depth. + + $te = HTML::TableExtract->new( depth => 2, count => 2 ); + $te->parse_file($html_file); + foreach $ts ($te->tables) { print "Table found at ", join(',', $ts->coords), ":\n"; foreach $row ($ts->rows) { print " ", join(',', @$row), "\n"; } } + # Example: Using table tag attributes. + # If multiple attributes are specified, all must be present and equal + # for match to occur. + + $te = HTML::TableExtract->new( attribs => { border => 1 } ); + $te->parse($html_string); + foreach $ts ($te->tables) { + print "Table with border=1 found at ", join(',', $ts->coords), ":\n"; + foreach $row ($ts->rows) { + print " ", join(',', @$row), "\n"; + } + } + + # Example: Extracting as an HTML::Element tree structure + # Rather than extracting raw text, the html can be converted into a + # tree of element objects. The HTML document is composed of + # HTML::Element objects and the tables are HTML::ElementTable + # structures. Using this, the contents of tables within a document can + # be edited in-place. + + use HTML::TableExtract qw(tree); + $te = HTML::TableExtract->new( headers => qw(Fee Fie Foe Fum) ); + $te->parse_file($html_file); + $table = $te->first_table_found; + $table_tree = $table->tree; + $table_tree->cell(4,4)->replace_content('Golden Goose'); + $table_html = $table_tree->as_HTML; + $table_text = $table_tree->as_text; + $document_tree = $te->tree; + $document_html = $document_tree->as_HTML; + =head1 DESCRIPTION -HTML::TableExtract is a subclass of HTML::Parser that serves to -extract the textual information from tables of interest contained -within an HTML document. The text from each extracted table is stored -in tabe state objects which hold the information as an array of arrays -that represent the rows and cells of that table. +HTML::TableExtract is a subclass of HTML::Parser that serves to extract +the information from tables of interest contained within an HTML +document. The information from each extracted table is stored in table +objects. Tables can be extracted as text, HTML, or HTML::ElementTable +structures (for in-place editing or manipulation). -There are three constraints available to specify which tables you -would like to extract from a document: I, I, and -I. +There are currently four constraints available to specify which tables +you would like to extract from a document: I, I, +I, and I. I, the most flexible and adaptive of the techniques, involves -specifying text in an array that you expect to appear above the data -in the tables of interest. Once all headers have been located in a -row of that table, all further cells beneath the columns that matched -your headers are extracted. All other columns are ignored: think of it -as vertical slices through a table. In addition, TableExtract -automatically rearranges each row in the same order as the headers you -provided. If you would like to disable this, set I to 0 -during object creation, and instead rely on the column_map() method to -find out the order in which the headers were found. Furthermore, -TableExtract will automatically compensate for cell span issues so -that columns are really the same columns as you would visually see in -a browser. This behavior can be disabled by setting the I -parameter to 0. HTML is stripped from the entire textual content of a -cell before header matches are attempted. +specifying text in an array that you expect to appear above the data in +the tables of interest. Once all headers have been located in a row of +that table, all further cells beneath the columns that matched your +headers are extracted. All other columns are ignored: think of it as +vertical slices through a table. In addition, TableExtract automatically +rearranges each row in the same order as the headers you provided. If +you would like to disable this, set I to 0 during object +creation, and instead rely on the column_map() method to find out the +order in which the headers were found. Furthermore, TableExtract will +automatically compensate for cell span issues so that columns are really +the same columns as you would visually see in a browser. This behavior +can be disabled by setting the I parameter to 0. HTML is +stripped from the entire textual content of a cell before header matches +are attempted -- unless the I parameter was enabled. I and I are more specific ways to specify tables in -relation to one another. I represents how deeply a table -resides in other tables. The depth of a top-level table in the -document is 0. A table within a top-level table has a depth of 1, and -so on. Each depth can be thought of as a layer; tables sharing the +relation to one another. I represents how deeply a table +resides in other tables. The depth of a top-level table in the +document is 0. A table within a top-level table has a depth of 1, and +so on. Each depth can be thought of as a layer; tables sharing the same depth are on the same layer. Within each of these layers, I represents the order in which a table was seen at that depth, starting with 0. Providing both a I and a I will uniquely specify a table within a document. -Each of the I, I, and I specifications are -cumulative in their effect on the overall extraction. For instance, -if you specify only a I, then you get all tables at that depth -(note that these could very well reside in separate higher-level -tables throughout the document since depth extends across tables). If -you specify only a I, then the tables at that I from all -depths are returned (i.e., the Ith occurrence of a table at each -depth). If you only specify I, then you get all tables in -the document containing those column headers. If you have specified -multiple constraints of I, I, and I, then each -constraint has veto power over whether a particular table is +I match based on the attributes of the html EtableE +tag, for example, boder widths or background color. + +Each of the I, I, I, and I +specifications are cumulative in their effect on the overall extraction. +For instance, if you specify only a I, then you get all tables at +that depth (note that these could very well reside in separate higher- +level tables throughout the document since depth extends across tables). +If you specify only a I, then the tables at that I from +all depths are returned (i.e., the Ith occurrence of a table at each +depth). If you only specify I, then you get all tables in the +document containing those column headers. If you have specified multiple +constraints of I, I, I, and I, then +each constraint has veto power over whether a particular table is extracted. -If no I, I, or I are specified, then all -tables match. +If no I, I, I, or I are specified, +then all tables match. -Text that is gathered from the tables is decoded with HTML::Entities -by default; this can be disabled by setting the I parameter to -0. +When extracting only text from tables, the text is decoded with +HTML::Entities by default; this can be disabled by setting the I +parameter to 0. + +=head2 Extraction Modes + +The default mode of extraction for HTML::TableExtract is raw text or +HTML. In this mode, embedded tables are completely decoupled from one +another. In this case, HTML::TableExtract is a subclass of HTML::Parser: -=head2 Chains - -Make sure you fully understand the notions of I and I -before proceeding, because it is about to become a bit more involved. - -Table matches using I, I, or I can be chained -together in order to further specify tables relative to one -another. Links in chains are successively applied to tables within -tables. Top level constraints (i.e., I
    , I, and I -parameters for the TableExtract object) behave as the first link in -the chain. Additional links are specified using the I -parameter. Each link in the chain has its own set of constraints. For -example: - - $te = new HTML::TableExtract - ( - headers => [qw(Summary Region)], - chain => [ - { depth => 0, count => 2 }, - { headers => [qw(Part Qty Cost)] } - ], - ); - -The matching process in this case will start with B tables in the -document that have "Summary" and "Region" in their headers. For now, -assume that there was only one table that matched these headers. Each -table contained within that table will be compared to the first link -in the chain. Depth 0 means that a matching table must be immediately -contained within the current table; count 2 means that the matching -table must also be the third at that depth (counts and depths start at -0). In other words, the next link of the chain will match on the -third table immediately contained within our first matched table. Once -this link matches, then B further tables beneath that table that -have "Part", "Qty", and "Cost" in their headers will match. By -default, it is only tables at the end of the chains that are returned -to the application, so these tables are returned. - -Each time a link in a chain matches a table, an additional context for -I and I is established. It is perhaps easiest to -visualize a I as a brand-new HTML document, with new depths -and counts to compare to the remaining links in the chain. The top -level HTML document is the first context. Each table in the document -establishes a new context. I in a chain link is relative to the -context that the matching table creates (i.e., a link depth of 0 would -be a table immediately contained within the table that matched the -prior link in the chain). Likewise, that same context keeps track of -I within the new depth scheme for comparison to the remaining -links in the chain. Headers still apply if they are present in a link, -but they are always independent of context. - -As it turns out, specifying a depth and count provides a unique -address for a table within a context. For non-unique constraints, such -as just a depth, or headers, there can be multiple matches for a given -link. In these cases the chain "forks" and attempts to make further -matches within each of these tables. - -By default, chains are I. This means that when a particular -link does not match on a table, it is passed down to subtables -unchanged. For example: - - $te = new HTML::TableExtract - ( - headers => [qw(Summary Region)], - chain => [ - { headers => [qw(Part Qty Cost)] } - ], - ); - -If there are intervening tables between the two header queries, they -will be ignored; this query will extract all tables with "Part", -"Qty", and "Cost" in the headers that are contained in any table with -"Summary" and "Region" in its headers, regardless of how embedded the -inner tables are. If you want a chain to be inelastic, you can set the -I parameter to 0 for the whole TableExtract object. Using the -same example: - - $te = new HTML::TableExtract - ( - headers => [qw(Summary Region)], - chain => [ - { headers => [qw(Part Qty Cost)] } - ], - elastic => 0, - ); - -In this case, the inner table (Part, Qty, Cost) must be B -contained within the outer table (Summary, Region) in order for the -match to take place. This is equivalent to specifying a depth of 0 for -each link in the chain; if you only want particular links to be -inelastic, then simply set their depths to 0. - -By default, only tables that match at the end of the chains are -retained. The intermediate matches along the chain are referred to as -I, and are not extracted by default. A waypoint may be -retained, however, by specifiying the I parameter in that link -of the chain. This parameter may be specified at the top level as well -if you want to keep tables that match the first set of constraints in -the object. If you want to keep all tables that match along the chain, -the specify the I parameter at the top level. - -Are chains overkill? Probably. In reality, nested HTML tables tend not -to be very deep, so there will usually not be much need for lots of -links in a chain. Theoretically, however, chains offer precise -targeting of tables relative to one another, no matter how deeply -nested they are. - -=head2 Pop Quiz - -What happens with the following table extraction? - - $te = new HTML::TableExtract( - chain => [ { depth => 0 } ], - ); - -Answer: All tables that are contained in another table are extracted -from the document. In this case, there were no top-level constraints -specified, which if you recall means that B tables match the -first set of constraints (or non-constraints, in this case!). A depth -of 0 in the next link of the chain means that the matching table must -be immediately contained within the table from a prior match. - -The following is equivalent: - - $te = new HTML::TableExtract( - depth => 1, - subtables => 1, - ) - -The I parameter tells TableExtract to scoop up all tables -contained within the matching tables. In conjunction with a depth of -1, this has the affect of discarding all top-level tables in the -document, which is exactly what occurred in the prior example. + use HTML::TableExtract; + +Alternativevly, tables can be extracted as HTML::ElementTable +structures, which are in turn embedded in an HTML::Element tree +representing the entire HTML document. Embedded tables are not decoupled +from one another since this tree structure must be manitained. In this +case, HTML::TableExtract is a subclass of HTML::TreeBuilder (itself a +subclass of HTML:::Parser): + + use HTML::TableExtract qw(tree); + +In either case, the basic interface for HTML::TableExtract and the +resulting table objects remains the same -- all that changes is what you +can do with the resulting data. + +HTML::TableExtract is a subclass of HTML::Parser, and as such inherits +all of its basic methods such as C and C. During +scans, C, C, and C are utilized. Feel free to +override them, but if you do not eventually invoke them in the SUPER +class with some content, results are not guaranteed. =head2 Advice The main point of this module was to provide a flexible method of extracting tabular information from HTML documents without relying to -heavily on the document layout. For that reason, I suggest using +heavily on the document layout. For that reason, I suggest using I whenever possible -- that way, you are anchoring your extraction on what the document is trying to communicate rather than some feature of the HTML comprising the document (other than the fact that the data is contained in a table). -HTML::TableExtract is a subclass of HTML::Parser, and as such inherits -all of its basic methods. In particular, C, C, and -C are utilized. Feel free to override them, but if you do not -eventually invoke them in the SUPER class with some content, results -are not guaranteed. - =head1 METHODS The following are the top-level methods of the HTML::TableExtract object. Tables that have matched a query are actually returned as -separate objects of type HTML::TableExtract::TableState. These table -state objects have their own methods, documented further below. There -are some top-level methods that are present for convenience and -backwards compatibility that are nothing more than front-ends for -equivalent table state methods. +separate objects of type HTML::TableExtract::Table. These table objects +have their own methods, documented further below. -=over +=head2 CONSTRUCTOR -=head2 Constructor +=over =item new() -Return a new HTML::TableExtract object. Valid attributes are: +Return a new HTML::TableExtract object. Valid attributes are: =over =item headers -Passed as an array reference, headers specify strings of interest at -the top of columns within targeted tables. These header strings will -eventually be passed through a non-anchored, case-insensitive regular -expression, so regexp special characters are allowed. The table row -containing the headers is B returned. Columns that are not -beneath one of the provided headers will be ignored. Columns will, by -default, be rearranged into the same order as the headers you provide -(see the I parameter for more information). Additionally, by -default columns are considered what you would see visually beneath -that header when the table is rendered in a browser. See the -I parameter for more information. +Passed as an array reference, headers specify strings of interest at the +top of columns within targeted tables. They can be either strings or +regular expressions (qr//). If they are strings, they will eventually be +passed through a non-anchored, case-insensitive regular expression, so +regexp special characters are allowed. + +The table row containing the headers is B returned, unless +C was specified or you are extracting into an element +tree. In either case the header row can be accessed via the hrow() +method from within the table object. + +Columns that are not beneath one of the provided headers will be +ignored unless C was set to 0. Columns will, by default, +be rearranged into the same order as the headers you provide (see the +I parameter for more information) I C is +0. + +Additionally, by default columns are considered what you would see +visually beneath that header when the table is rendered in a browser. +See the C parameter for more information. + +HTML within a header is stripped before the match is attempted, +unless the C parameter was specified and +C is false. =item depth -Specify how embedded in other tables your tables of interest should -be. Top-level tables in the HTML document have a depth of 0, tables -within top-level tables have a depth of 1, and so on. +Specify how embedded in other tables your tables of interest should be. +Top-level tables in the HTML document have a depth of 0, tables within +top-level tables have a depth of 1, and so on. =item count -Specify which table within each depth you are interested in, beginning -with 0. +Specify which table within each depth you are interested in, +beginning with 0. -=item chain +=item attribs -List of additional constraints to be matched sequentially from the top -level constraints. This is a reference to an array of hash -references. Each hash is a link in the chain, and can be specified in -terms of I, I, and I. Further modifiers include -I, which means to retain the table if it would normally be -dropped as a waypoint. +Passed as a hash reference, attribs specify attributes of interest +within the HTML EtableE tag itself. =item automap -Automatically applies the ordering reported by column_map() to the -rows returned by rows(). This only makes a difference if you have -specified I and they turn out to be in a different order in -the table than what you specified. Automap will rearrange the columns -in the same order as the headers appear. To get the original ordering, -you will need to take another slice of each row using -column_map(). I is enabled by default. +Automatically applies the ordering reported by column_map() to the rows +returned by rows(). This only makes a difference if you have specified +I and they turn out to be in a different order in the table +than what you specified. Automap will rearrange the columns in the same +order as the headers appear. To get the original ordering, you will need +to take another slice of each row using column_map(). I is +enabled by default. -=item gridmap +=item slice_columns -Controls whether the table contents are returned as a grid or a -tree. ROWSPAN and COLSPAN issues are compensated for, and columns -really are columns. Empty phantom cells are created where they would -have been obscured by ROWSPAN or COLSPAN settings. This really becomes -an issue when extracting columns beneath headers. Enabled by default. +Enabled by default, this option controls whether vertical slices are +returned from under headers that match. When disabled, all columns of +the matching table are retained, regardles of whether they had a +matching header above them. Disabling this also disables C. -=item keepall +=item keep_headers -Keep all tables that matched along a chain, including tables matched -by top level contraints. By default, waypoints are dropped and only -the matches at the end of the chain are retained. To retain a -particular waypoint along a chain, use the I parameter in that -link. +Disabled by default, and only applicable when header constraints have +been specified, C will retain the matching header row as +the first row of table data when enabled. This option has no effect if +extracting into an element tree tructure. In any case, the header row is +accessible from the table method C. -=item elastic +=item gridmap -When set to 0, all links in chains will be treated as though they had -a depth of 0 specified, which means there can be no intervening -unmatched tables between matches on links. +Controls whether the table contents are returned as a grid or a tree. +ROWSPAN and COLSPAN issues are compensated for, and columns really are +columns. Empty phantom cells are created where they would have been +obscured by ROWSPAN or COLSPAN settings. This really becomes an issue +when extracting columns beneath headers. Enabled by default. =item subtables -Extract all tables within matched tables. +Extract all tables embedded within matched tables. =item decode Automatically decode retrieved text with -HTML::Entities::decode_entities(). Enabled by default. +HTML::Entities::decode_entities(). Enabled by default. Has no effect if +C was specified or if extracting into an element tree +structure. + +=item br_translate + +Translate
    tags into newlines. Sometimes the remaining text can be +hard to parse if the
    tag is simply dropped. Enabled by default. Has +no effect if I is enabled or if extracting into an element +tree structure. + +=item keep_html + +Return the raw HTML contained in the cell, rather than just the visible +text. Embedded tables are B retained in the HTML extracted from a +cell. Patterns for header matches must take into account HTML in the +string if this option is enabled. This option has no effect if +extracting into an elment tree structure. + +=item strip_html_on_match + +When C is enabled, HTML is stripped by default during +attempts at matching header strings (so if C is not +enabled and C is, you would have to include potential HTML +tags in the regexp for header matches). Stripped header tags are +replaced with an empty string, e.g. 'hot dEemEogE/emE' +would become 'hot dog' before attempting a match. + +=item error_handle + +Filehandle where error messages are printed. STDERR by default. =item debug -Prints some debugging information to STDOUT, more for higher values. +Prints some debugging information to STDERR, more for higher values. +If C was provided, messages are printed there rather +than STDERR. =back -=head2 Regular Methods +=back + +=head2 REGULAR METHODS + +The following methods are invoked directly from an +HTML::TableExtract object. + +=over =item depths() @@ -1686,123 +1575,266 @@ Returns all depths that contained matched tables in the document. For a particular depth, returns all counts that contained matched tables. -=item table_state($depth, $count) +=item table($depth, $count) -For a particular depth and count, return the table state object for -the table found, if any. +For a particular depth and count, return the table object for the table +found, if any. -=item table_states() +=item tables() -Return table state objects for all tables that matched. +Return table objects for all tables that matched. Returns an empty list +if no tables matched. -=item first_table_state_found() +=item first_table_found() Return the table state object for the first table matched in the -document. +document. Returns undef if no tables were matched. -=head2 TABLE STATE METHODS +=item current_table() -The following methods are invoked from an -HTML::TableExtract::TableState object, such as those returned from the -C method. +Returns the current table object while parsing the HTML. Only useful if +you're messing around with overriding HTML::Parser methods. -=item rows() +=item tree() -Return all rows within a matched table. Each row returned is a -reference to an array containing the text of each cell. +If the module was invoked in tree extraction mode, returns a reference +to the top node of the HTML::Element tree structure for the entire +document (which includes, ultimately, all tables within the document). -=item depth() +=item tables_report([$show_content, $col_sep]) -Return the (absolute) depth at which this table was found. +Return a string summarizing extracted tables, along with their depth and +count. Optionally takes a C<$show_content> flag which will dump the +extracted contents of each table as well with columns separated by +C<$col_sep>. Default C<$col_sep> is ':'. -=item count() +=item tables_dump([$show_content, $col_sep]) -Return the count for this table within the depth it was found. +Same as C except dump the information to STDOUT. -=item coords() +=item start -Return depth and count in a list. +=item end -=item column_map() +=item text -Return the order (via indices) in which the provided headers were -found. These indices can be used as slices on rows to either order the -rows in the same order as headers or restore the rows to their natural -order, depending on whether the rows have been pre-adjusted using the -I parameter. +These are the hooks into HTML::Parser. If you want to subclass +this module and have things work, you must at some point call +these with content. -=item lineage() +=back -Returns the path of matched tables that led to matching this -table. Lineage only makes sense if chains were used. Tables that were -not matched by a link in the chain are not included in lineage. The -lineage path is a list of array refs containing depth and count values -for each table involved. +=head2 DEPRECATED METHODS -=head2 Procedural Methods +Tables used to be called 'table states'. Accordingly, the following +methods still work but have been deprecated: -The following top level methods are alternatives to invoking methods -in a table state object. If you do not want to deal with table state -objects, then these methods are for you. The "tables" they deal in are -actually just arrays of arrays, which happen to be the current -internal data structure of the table state objects. They are here for -backwards compatibility. +=over -=item table($depth, $count) +=item table_state() -Same as C, but returns the internal data structure -rather than the table state object. +Is now table() -=item tables() +=item table_states() -Same as C, but returns the data structures rather than -the table state objects. +Is now tables() -=item first_table_found() +=item first_table_state_found() + +Is now first_table_found() + +=back -Same as C, except returns the data -structure for first table that matched. +=head2 TABLE METHODS -=item table_coords($table) +The following methods are invoked from an HTML::TableExtract::Table +object, such as those returned from the C method. -Returns the depth and count for a particular table data structure. See -the C method provided by table state objects. +=over =item rows() -=item rows($table) +Return all rows within a matched table. Each row returned is a reference +to an array containing the text, HTML, or reference to the HTML::Element +object of each cell depending the mode of extraction. Tables with +rowspan or colspan attributes will have some cells containing undef. +Returns a list or a reference to an array depending on context. + +=item columns() + +Return all columns within a matched table. Each column returned is a +reference to an array containing the text, HTML, or reference to +HTML::Element object of each cell depending on the mode of extraction. +Tables with rowspan or colspan attributes will have some cells +containing undef. + +=item row($row) + +Return a particular row from within a matched table either as a list or +an array reference, depending on context. + +=item column($col) + +Return a particular column from within a matched table as a list or an +array reference, depending on context. + +=item cell($row,$col) + +Return a particular item from within a matched table, whether it be the +text, HTML, or reference to the HTML::Element object of that cell, +depending on the mode of extraction. If the cell was covered due to +rowspan or colspan effects, will return undef. + +=item space($row,$col) -Return a lsit of the rows for a particular table data structure (first -table found by default). See the C method provided by table -state objects. +The same as cell(), except in cases where the given coordinates were +covered due to rowspan or colspan issues, in which case the content of +the covering cell is returned rather than undef. + +=item depth() + +Return the depth at which this table was found. + +=item count() + +Return the count for this table within the depth it was found. + +=item coords() + +Return depth and count in a list. + +=item tree() + +If the module was invoked in tree extraction mode, this accessor +provides a reference to the HTML::ElementTable structure encompassing +the table. + +=item hrow() + +Returns the header row as a list when headers were specified as a +constraint. If C was specified initially, this is +equivalent to the first row returned by the C method. =item column_map() -=item column_map($table) +Return the order (via indices) in which the provided headers were found. +These indices can be used as slices on rows to either order the rows in +the same order as headers or restore the rows to their natural order, +depending on whether the rows have been pre-adjusted using the +I parameter. -Return the column map for a particular table data structure (first -found by default). See the C method provided by table -state objects. +=item lineage() + +Returns the path of matched tables that led to matching this table. The +path is a list of array refs containing depth, count, row, and column +values for each ancestor table involved. Note that corresponding table +objects will not exist for ancestral tables that did not match specified +constraints. =back +=head1 NOTES ON TREE EXTRACTION MODE + +As mentioned above, HTML::TableExtract can be invoked in 'tree' mode +where the resulting HTML and extracted tables are encoded in +HTML::Element tree structures: + + use HTML::TableExtract 'tree'; + +There are a number of things to take note of while using this mode. The +entire HTML document is encoded into an HTML::Element tree. Each table +is part of this structure, but nevertheless is tracked separately via an +HTML::ElementTable structure, which is a specialized form of +HTML::Element tree. + +The HTML::ElementTable objects are accessible by invoking the tree() +method from within each table object returned by HTML::TableExtract. The +HTML::ElementTable objects have their own row(), col(), and cell() +methods (among others). These are not to be confused with the row() and +column() methods provided by the HTML::TableExtract::Table objects. + +For example, the row() method from HTML::ElementTable will provide a +reference to a 'glob' of all the elements in that row. Actions (such as +setting attributes) performed on that row reference will affect all +elements within that row. On the other hand, the row() method from the +HTML::TableExtract::Table object will return an array (either by +reference or list, depending on context) of the contents of each cell +within the row. In tree mode, the content is represented by individual +references to each cell -- these are references to the same +HTML::Element objects that reside in the HTML::Element tree. + +The cell() methods provided in both cases will therefore return +references to the same object. The exception to this is when a 'cell' in +the table grid was originally 'covered' due to rowspan or colspan issues +-- in this case the cell content will be undef. Likewise, the row() or +column() methods from HTML::TableExtract::Table objects will return +arrays potentially containing a mixture of object references and undefs. +If you're going to be doing lots of manipulation of the table elements, +it might be more efficient to access them via the methods provided by +the HTML::ElementTable object instead. See L for +more information on how to manipulate those objects. + +An alternative to the cell() method in HTML::TableExtract::Table is the +space() method. It is largely similar to cell(), except when given +coordinates of a cell that was covered due to rowspan or colspan +effects, it will return the contents of the cell that was covering that +space rather than undef. So if, for example, cell (0,0) had a rowspan of +2 and colspan of 2, cell(1,1) would return undef and space(1,1) would +return the same content as cell(0,0) or space(0,0). + =head1 REQUIRES HTML::Parser(3), HTML::Entities(3) +=head1 OPTIONALLY REQUIRES + +HTML::TreeBuilder(3), HTML::ElementTable(3) + =head1 AUTHOR Matthew P. Sisk, EFE =head1 COPYRIGHT -Copyright (c) 2000 Matthew P. Sisk. +Copyright (c) 2000-2006 Matthew P. Sisk. All rights reserved. All wrongs revenged. This program is free -software; you can redistribute it and/or modify it under the -same terms as Perl itself. +software; you can redistribute it and/or modify it under the same terms +as Perl itself. =head1 SEE ALSO -HTML::Parser(3), perl(1). +HTML::Parser(3), HTML::TreeBuilder(3), HTML::ElementTable(3), perl(1). =cut + +In honor of fragmented markup languages and sugar mining: + +The Good and The Bad +Ted Hawkins (1936-1994) + +Living is good + when you have someone to share it with +Laughter is bad + when there is no one there to share it with +Talking is sad + if you've got no one to talk to +Dying is good + when the one you love grows tired of you + +Sugar is no good + once it's cast among the white sand +What the point + in pulling the gray hairs from among the black strands +When you're old + you shouldn't walk in the fast lane +Oh ain't it useless + to keep trying to draw true love from that man + +He'll hurt you, + Yes just for the sake of hurting you +and he'll hate you + if you try to love him just the same +He'll use you + and everything you have to offer him +On your way girl + Get out and find you someone new diff --git a/lib/site/MIME/Lite.pm b/lib/site/MIME/Lite.pm index 74deaf452..c7617c481 100644 --- a/lib/site/MIME/Lite.pm +++ b/lib/site/MIME/Lite.pm @@ -1,74 +1,87 @@ package MIME::Lite; - +use strict; +require 5.004; ### for /c modifier in m/\G.../gc modifier =head1 NAME MIME::Lite - low-calorie MIME generator - =head1 SYNOPSIS - use MIME::Lite; - -Create a single-part message: - - # Create a new single-part message, to send a GIF file: - $msg = new MIME::Lite - From =>'me@myhost.com', - To =>'you@yourhost.com', - Cc =>'some@other.com, some@more.com', - Subject =>'Helloooooo, nurse!', - Type =>'image/gif', - Encoding =>'base64', - Path =>'hellonurse.gif'; - - -Create a multipart message (i.e., one with attachments): - - # Create a new multipart message: - $msg = new MIME::Lite - From =>'me@myhost.com', - To =>'you@yourhost.com', - Cc =>'some@other.com, some@more.com', - Subject =>'A message with 2 parts...', - Type =>'multipart/mixed'; - - # Add parts (each "attach" has same arguments as "new"): - attach $msg - Type =>'TEXT', - Data =>"Here's the GIF file you wanted"; - attach $msg - Type =>'image/gif', - Path =>'aaa000123.gif', - Filename =>'logo.gif'; +Create and send using the default send method for your OS a single-part message: + use MIME::Lite; + ### Create a new single-part message, to send a GIF file: + $msg = MIME::Lite->new( + From => 'me@myhost.com', + To => 'you@yourhost.com', + Cc => 'some@other.com, some@more.com', + Subject => 'Helloooooo, nurse!', + Type => 'image/gif', + Encoding => 'base64', + Path => 'hellonurse.gif' + ); + $msg->send; # send via default + +Create a multipart message (i.e., one with attachments) and send it SMTP + + ### Create a new multipart message: + $msg = MIME::Lite->new( + From => 'me@myhost.com', + To => 'you@yourhost.com', + Cc => 'some@other.com, some@more.com', + Subject => 'A message with 2 parts...', + Type => 'multipart/mixed' + ); + + ### Add parts (each "attach" has same arguments as "new"): + $msg->attach( + Type => 'TEXT', + Data => "Here's the GIF file you wanted" + ); + $msg->attach( + Type => 'image/gif', + Path => 'aaa000123.gif', + Filename => 'logo.gif', + Disposition => 'attachment' + ); + ### use Net:SMTP to do the sending + $msg->send('smtp','some.host', Debug=>1 ); Output a message: - # Format as a string: + ### Format as a string: $str = $msg->as_string; - - # Print to a filehandle (say, a "sendmail" stream): - $msg->print(\*SENDMAIL); + ### Print to a filehandle (say, a "sendmail" stream): + $msg->print(\*SENDMAIL); Send a message: - # Send in the "best" way (the default is to use "sendmail"): + ### Send in the "best" way (the default is to use "sendmail"): $msg->send; - + ### Send a specific way: + $msg->send('type',@args); + +Specify default send method: + MIME::Lite->send('smtp','some.host',Debug=>0); + +with authentication + + MIME::Lite->send('smtp','some.host', + AuthUser=>$user, AuthPass=>$pass); =head1 DESCRIPTION In the never-ending quest for great taste with fewer calories, -we proudly present: I. +we proudly present: I. MIME::Lite is intended as a simple, standalone module for generating (not parsing!) MIME messages... specifically, it allows you to output a simple, decent single- or multi-part message with text or binary attachments. It does not require that you have the Mail:: or MIME:: -modules installed. +modules installed, but will work with them if they are. You can specify each message part as either the literal data itself (in a scalar or array), or as a string which can be given to open() to get @@ -77,135 +90,363 @@ a readable filehandle (e.g., "new( + From =>'me@myhost.com', + To =>'you@yourhost.com', + Cc =>'some@other.com, some@more.com', + Subject =>'Helloooooo, nurse!', + Data =>"How's it goin', eh?" + ); + +=head2 Create a simple message containing just an image + + $msg = MIME::Lite->new( + From =>'me@myhost.com', + To =>'you@yourhost.com', + Cc =>'some@other.com, some@more.com', + Subject =>'Helloooooo, nurse!', + Type =>'image/gif', + Encoding =>'base64', + Path =>'hellonurse.gif' + ); + + +=head2 Create a multipart message + + ### Create the multipart "container": + $msg = MIME::Lite->new( + From =>'me@myhost.com', + To =>'you@yourhost.com', + Cc =>'some@other.com, some@more.com', + Subject =>'A message with 2 parts...', + Type =>'multipart/mixed' + ); + + ### Add the text message part: + ### (Note that "attach" has same arguments as "new"): + $msg->attach( + Type =>'TEXT', + Data =>"Here's the GIF file you wanted" + ); + + ### Add the image part: + $msg->attach( + Type =>'image/gif', + Path =>'aaa000123.gif', + Filename =>'logo.gif', + Disposition => 'attachment' + ); + + +=head2 Attach a GIF to a text message + +This will create a multipart message exactly as above, but using the +"attach to singlepart" hack: + ### Start with a simple text message: + $msg = MIME::Lite->new( + From =>'me@myhost.com', + To =>'you@yourhost.com', + Cc =>'some@other.com, some@more.com', + Subject =>'A message with 2 parts...', + Type =>'TEXT', + Data =>"Here's the GIF file you wanted" + ); -=head1 MORE EXAMPLES + ### Attach a part... the make the message a multipart automatically: + $msg->attach( + Type =>'image/gif', + Path =>'aaa000123.gif', + Filename =>'logo.gif' + ); + + +=head2 Attach a pre-prepared part to a message + + ### Create a standalone part: + $part = MIME::Lite->new( + Type =>'text/html', + Data =>'

    Hello

    ', + ); + $part->attr('content-type.charset' => 'UTF-8'); + $part->add('X-Comment' => 'A message for you'); + + ### Attach it to any message: + $msg->attach($part); -Create a multipart message exactly as above, but using the -"attach to singlepart" hack: - # Create a new multipart message: - $msg = new MIME::Lite - From =>'me@myhost.com', - To =>'you@yourhost.com', - Cc =>'some@other.com, some@more.com', - Subject =>'A message with 2 parts...', - Type =>'TEXT', - Data =>"Here's the GIF file you wanted"; - - # Attach a part: - attach $msg Type =>'image/gif', - Path =>'aaa000123.gif', - Filename =>'logo.gif'; +=head2 Print a message to a filehandle + ### Write it to a filehandle: + $msg->print(\*STDOUT); -Output a message to a filehandle: + ### Write just the header: + $msg->print_header(\*STDOUT); - # Write it to a filehandle: - $msg->print(\*STDOUT); - - # Write just the header: - $msg->print_header(\*STDOUT); - - # Write just the encoded body: - $msg->print_body(\*STDOUT); + ### Write just the encoded body: + $msg->print_body(\*STDOUT); -Get a message as a string: +=head2 Print a message into a string - # Get entire message as a string: + ### Get entire message as a string: $str = $msg->as_string; - - # Get just the header: + + ### Get just the header: $str = $msg->header_as_string; - - # Get just the encoded body: + + ### Get just the encoded body: $str = $msg->body_as_string; -Change how messages are sent: +=head2 Send a message + + ### Send in the "best" way (the default is to use "sendmail"): + $msg->send; + - # Do something like this in your 'main': +=head2 Send an HTML document... with images included! + + $msg = MIME::Lite->new( + To =>'you@yourhost.com', + Subject =>'HTML with in-line images!', + Type =>'multipart/related' + ); + $msg->attach( + Type => 'text/html', + Data => qq{ + + Here's my image: + + + }, + ); + $msg->attach( + Type => 'image/gif', + Id => 'myimage.gif', + Path => '/path/to/somefile.gif', + ); + $msg->send(); + + +=head2 Change how messages are sent + + ### Do something like this in your 'main': if ($I_DONT_HAVE_SENDMAIL) { - MIME::Lite->send('smtp', "smtp.myisp.net", Timeout=>60); + MIME::Lite->send('smtp', $host, Timeout=>60 + AuthUser=>$user, AuthPass=>$pass); } - - # Now this will do the right thing: - $msg->send; # will now use Net::SMTP as shown above - + ### Now this will do the right thing: + $msg->send; ### will now use Net::SMTP as shown above =head1 PUBLIC INTERFACE -=cut +=head2 Global configuration +To alter the way the entire module behaves, you have the following +methods/options: -use Carp; -use FileHandle; +=over 4 -use strict; -use vars qw($VERSION $QUIET $PARANOID $VANILLA); +=item MIME::Lite->field_order() + +When used as a L, this changes the default +order in which headers are output for I messages. +However, please consider using the instance method variant instead, +so you won't stomp on other message senders in the same application. + + +=item MIME::Lite->quiet() + +This L can be used to suppress/unsuppress +all warnings coming from this module. + + +=item MIME::Lite->send() + +When used as a L, this can be used to specify +a different default mechanism for sending message. +The initial default is: + + MIME::Lite->send("sendmail", "/usr/lib/sendmail -t -oi -oem"); + +However, you should consider the similar but smarter and taint-safe variant: + + MIME::Lite->send("sendmail"); + +Or, for non-Unix users: + + MIME::Lite->send("smtp"); + + +=item $MIME::Lite::AUTO_CC + +If true, automatically send to the Cc/Bcc addresses for send_by_smtp(). +Default is B. + + +=item $MIME::Lite::AUTO_CONTENT_TYPE + +If true, try to automatically choose the content type from the file name +in C/C. In other words, setting this true changes the +default C from C<"TEXT"> to C<"AUTO">. + +Default is B, since we must maintain backwards-compatibility +with prior behavior. B consider keeping it false, +and just using Type 'AUTO' when you build() or attach(). + + +=item $MIME::Lite::AUTO_ENCODE + +If true, automatically choose the encoding from the content type. +Default is B. + + +=item $MIME::Lite::AUTO_VERIFY + +If true, check paths to attachments right before printing, raising an exception +if any path is unreadable. +Default is B. + + +=item $MIME::Lite::PARANOID + +If true, we won't attempt to use MIME::Base64, MIME::QuotedPrint, +or MIME::Types, even if they're available. +Default is B. Please consider keeping it false, +and trusting these other packages to do the right thing. + + +=back + +=cut + +use Carp (); +use FileHandle; + +use vars qw( + $AUTO_CC + $AUTO_CONTENT_TYPE + $AUTO_ENCODE + $AUTO_VERIFY + $PARANOID + $QUIET + $VANILLA + $VERSION + $DEBUG +); -#============================== -#============================== -# # GLOBALS, EXTERNAL/CONFIGURATION... +$VERSION = '3.027'; -# The package version, both in 1.23 style *and* usable by MakeMaker: -($VERSION) = q$Revision$ =~ /: (\d+)/; +### Automatically interpret CC/BCC for SMTP: +$AUTO_CC = 1; +### Automatically choose content type from file name: +$AUTO_CONTENT_TYPE = 0; -# Don't warn me about dangerous activities: -$QUIET = undef; +### Automatically choose encoding from content type: +$AUTO_ENCODE = 1; + +### Check paths right before printing: +$AUTO_VERIFY = 1; -# Set this true if you don't want to use MIME::Base64/MIME::QuotedPrint: +### Set this true if you don't want to use MIME::Base64/QuotedPrint/Types: $PARANOID = 0; -# Unsupported (for tester use): don't qualify boundary with time/pid: +### Don't warn me about dangerous activities: +$QUIET = undef; + +### Unsupported (for tester use): don't qualify boundary with time/pid: $VANILLA = 0; +$MIME::Lite::DEBUG = 0; #============================== #============================== # # GLOBALS, INTERNAL... -# Our sending facilities: -my $Sender = "sendmail"; +my $Sender = ""; +my $SENDMAIL = ""; + +if ( $^O =~ /win32|cygwin/i ) { + $Sender = "smtp"; +} else { + ### Find sendmail: + $Sender = "sendmail"; + $SENDMAIL = "/usr/lib/sendmail"; + ( -x $SENDMAIL ) or ( $SENDMAIL = "/usr/sbin/sendmail" ); + ( -x $SENDMAIL ) or ( $SENDMAIL = "sendmail" ); + unless (-x $SENDMAIL) { + require File::Spec; + for my $dir (File::Spec->path) { + if ( -x "$dir/sendmail" ) { + $SENDMAIL = "$dir/sendmail"; + last; + } + } + } + unless (-x $SENDMAIL) { + undef $SENDMAIL; + } +} + +### Our sending facilities: my %SenderArgs = ( - "sendmail" => ["/usr/lib/sendmail -t -oi -oem"], - "smtp" => [], - "sub" => [], + sendmail => [$SENDMAIL ? "$SENDMAIL -t -oi -oem" : undef], + smtp => [], + sub => [], ); -# Boundary counter: +### Boundary counter: my $BCount = 0; -# Known Mail/MIME fields... these, plus some general forms like -# "x-*", are recognized by build(): -my %KnownField = map {$_=>1} -qw( - bcc cc comments date encrypted - from keywords message-id mime-version organization - received references reply-to return-path sender - subject to - ); - -# What external packages do we use for encoding? +### Known Mail/MIME fields... these, plus some general forms like +### "x-*", are recognized by build(): +my %KnownField = map { $_ => 1 } + qw( + bcc cc comments date encrypted + from keywords message-id mime-version organization + received references reply-to return-path sender + subject to + + approved +); + +### What external packages do we use for encoding? my @Uses; +### Header order: +my @FieldOrder; + +### See if we have File::Basename +my $HaveFileBasename = 0; +if ( eval "require File::Basename" ) { # not affected by $PARANOID, core Perl + $HaveFileBasename = 1; + push @Uses, "F$File::Basename::VERSION"; +} + +### See if we have/want MIME::Types +my $HaveMimeTypes = 0; +if ( !$PARANOID and eval "require MIME::Types; MIME::Types->VERSION(1.28);" ) { + $HaveMimeTypes = 1; + push @Uses, "T$MIME::Types::VERSION"; +} #============================== #============================== # # PRIVATE UTILITY FUNCTIONS... -#------------------------------ +#------------------------------ # # fold STRING # @@ -214,8 +455,8 @@ my @Uses; sub fold { my $str = shift; - $str =~ s/^\s*|\s*$//g; # trim - $str =~ s/\n/\n /g; + $str =~ s/^\s*|\s*$//g; ### trim + $str =~ s/\n/\n /g; $str; } @@ -227,30 +468,84 @@ sub fold { # The unsupported $VANILLA is for test purposes only. sub gen_boundary { - return ("_----------=_".($VANILLA ? '' : int(time).$$).$BCount++); + return ( "_----------=_" . ( $VANILLA ? '' : int(time) . $$ ) . $BCount++ ); } #------------------------------ # -# known_field FIELDNAME +# is_mime_field FIELDNAME # -# Is this a recognized Mail/MIME field? +# Is this a field I manage? -sub known_field { - my $field = lc(shift); - $KnownField{$field} or ($field =~ m{^(content|resent|x)-.}); +sub is_mime_field { + $_[0] =~ /^(mime\-|content\-)/i; } #------------------------------ # -# is_mime_field FIELDNAME +# extract_full_addrs STRING +# extract_only_addrs STRING # -# Is this a field I manage? +# Split STRING into an array of email addresses: somewhat of a KLUDGE. +# +# Unless paranoid, we try to load the real code before supplying our own. +BEGIN { + my $ATOM = '[^ \000-\037()<>@,;:\134"\056\133\135]+'; + my $QSTR = '".*?"'; + my $WORD = '(?:' . $QSTR . '|' . $ATOM . ')'; + my $DOMAIN = '(?:' . $ATOM . '(?:' . '\\.' . $ATOM . ')*' . ')'; + my $LOCALPART = '(?:' . $WORD . '(?:' . '\\.' . $WORD . ')*' . ')'; + my $ADDR = '(?:' . $LOCALPART . '@' . $DOMAIN . ')'; + my $PHRASE = '(?:' . $WORD . ')+'; + my $SEP = "(?:^\\s*|\\s*,\\s*)"; ### before elems in a list + + sub my_extract_full_addrs { + my $str = shift; + return unless $str; + my @addrs; + $str =~ s/\s/ /g; ### collapse whitespace + + pos($str) = 0; + while ( $str !~ m{\G\s*\Z}gco ) { + ### print STDERR "TACKLING: ".substr($str, pos($str))."\n"; + if ( $str =~ m{\G$SEP($PHRASE)\s*<\s*($ADDR)\s*>}gco ) { + push @addrs, "$1 <$2>"; + } elsif ( $str =~ m{\G$SEP($ADDR)}gco or $str =~ m{\G$SEP($ATOM)}gco ) { + push @addrs, $1; + } else { + my $problem = substr( $str, pos($str) ); + die "can't extract address at <$problem> in <$str>\n"; + } + } + return wantarray ? @addrs : $addrs[0]; + } -sub is_mime_field { - $_[0] =~ /^(mime\-|content\-)/i; + sub my_extract_only_addrs { + my @ret = map { /<([^>]+)>/ ? $1 : $_ } my_extract_full_addrs(@_); + return wantarray ? @ret : $ret[0]; + } } +#------------------------------ + +if ( !$PARANOID and eval "require Mail::Address" ) { + push @Uses, "A$Mail::Address::VERSION"; + eval q{ + sub extract_full_addrs { + my @ret=map { $_->format } Mail::Address->parse($_[0]); + return wantarray ? @ret : $ret[0] + } + sub extract_only_addrs { + my @ret=map { $_->address } Mail::Address->parse($_[0]); + return wantarray ? @ret : $ret[0] + } + }; ### q +} else { + eval q{ + *extract_full_addrs=*my_extract_full_addrs; + *extract_only_addrs=*my_extract_only_addrs; + }; ### q +} ### if #============================== #============================== @@ -264,33 +559,32 @@ sub is_mime_field { # Encode the given string using BASE64. # Unless paranoid, we try to load the real code before supplying our own. -if (!$PARANOID and eval "require MIME::Base64") { +if ( !$PARANOID and eval "require MIME::Base64" ) { import MIME::Base64 qw(encode_base64); push @Uses, "B$MIME::Base64::VERSION"; -} -else { +} else { eval q{ -sub encode_base64 { - my $res = ""; - my $eol = "\n"; - - pos($_[0]) = 0; # thanks, Andreas! - while ($_[0] =~ /(.{1,45})/gs) { - $res .= substr(pack('u', $1), 1); - chop($res); - } - $res =~ tr|` -_|AA-Za-z0-9+/|; - - # Fix padding at the end: - my $padding = (3 - length($_[0]) % 3) % 3; - $res =~ s/.{$padding}$/'=' x $padding/e if $padding; - - # Break encoded string into lines of no more than 76 characters each: - $res =~ s/(.{1,76})/$1$eol/g if (length $eol); - return $res; -} # sub - } # q -} #if + sub encode_base64 { + my $res = ""; + my $eol = "\n"; + + pos($_[0]) = 0; ### thanks, Andreas! + while ($_[0] =~ /(.{1,45})/gs) { + $res .= substr(pack('u', $1), 1); + chop($res); + } + $res =~ tr|` -_|AA-Za-z0-9+/|; + + ### Fix padding at the end: + my $padding = (3 - length($_[0]) % 3) % 3; + $res =~ s/.{$padding}$/'=' x $padding/e if $padding; + + ### Break encoded string into lines of no more than 76 characters each: + $res =~ s/(.{1,76})/$1$eol/g if (length $eol); + return $res; + } ### sub + } ### q +} ### if #------------------------------ # @@ -303,28 +597,29 @@ sub encode_base64 { # # Unless paranoid, we try to load the real code before supplying our own. -if (!$PARANOID and eval "require MIME::QuotedPrint") { +if ( !$PARANOID and eval "require MIME::QuotedPrint" ) { import MIME::QuotedPrint qw(encode_qp); push @Uses, "Q$MIME::QuotedPrint::VERSION"; -} -else { +} else { eval q{ -sub encode_qp { - my $res = shift; - $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3 - $res =~ s/([ \t]+)$/ - join('', map { sprintf("=%02X", ord($_)) } - split('', $1) - )/egm; # rule #3 (encode whitespace at eol) - - # rule #5 (lines shorter than 76 chars, but can't break =XX escapes: - my $brokenlines = ""; - $brokenlines .= "$1=\n" while $res =~ s/^(.{70}([^=]{2})?)//; # 70 was 74 - $brokenlines =~ s/=\n$// unless length $res; - "$brokenlines$res"; -} # sub - } # q -} #if + sub encode_qp { + my $res = shift; + local($_); + $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; ### rule #2,#3 + $res =~ s/([ \t]+)$/ + join('', map { sprintf("=%02X", ord($_)) } + split('', $1) + )/egm; ### rule #3 (encode whitespace at eol) + + ### rule #5 (lines shorter than 76 chars, but can't break =XX escapes: + my $brokenlines = ""; + $brokenlines .= "$1=\n" while $res =~ s/^(.{70}([^=]{2})?)//; ### 70 was 74 + $brokenlines =~ s/=\n$// unless length $res; + "$brokenlines$res"; + } ### sub + } ### q +} ### if + #------------------------------ # @@ -335,7 +630,7 @@ sub encode_qp { sub encode_8bit { my $str = shift; - $str =~ s/^.{990}/$&\n/mg; + $str =~ s/^(.{990})/$1\n/mg; $str; } @@ -348,8 +643,8 @@ sub encode_8bit { sub encode_7bit { my $str = shift; - $str =~ s/[\x80-\xFF]//eg; - $str =~ s/^.{990}/$&\n/mg; + $str =~ s/[\x80-\xFF]//g; + $str =~ s/^(.{990})/$1\n/mg; $str; } @@ -368,43 +663,48 @@ sub encode_7bit { =item new [PARAMHASH] I -Create a new message object. +Create a new message object. If any arguments are given, they are passed into C; otherwise, just the empty object is created. =cut + sub new { my $class = shift; - # Create basic object: - my $self = { - Attrs => {}, - Header => [], # message header - Parts => [], # array of parts - }; + ### Create basic object: + my $self = { Attrs => {}, ### MIME attributes + SubAttrs => {}, ### MIME sub-attributes + Header => [], ### explicit message headers + Parts => [], ### array of parts + }; bless $self, $class; - # Build, if needed: - return (@_ ? $self->build(@_) : $self); + ### Build, if needed: + return ( @_ ? $self->build(@_) : $self ); } #------------------------------ -=item attach [OBJECT|PARAMHASH] +=item attach PART + +=item attach PARAMHASH... I Add a new part to this message, and return the new part. -You can attach a MIME::Lite OBJECT, or have it create one by specifying -a PARAMHASH that will be automatically given to C. +If you supply a single PART argument, it will be regarded +as a MIME::Lite object to be attached. Otherwise, this +method assumes that you are giving in the pairs of a PARAMHASH +which will be sent into C to create the new part. -One of the possibly-quite-useful hacks thrown into this is the +One of the possibly-quite-useful hacks thrown into this is the "attach-to-singlepart" hack: if you attempt to attach a part (let's -call it "part 1") to a message that I a multipart message -(the "self" object in this case), the following happens: +call it "part 1") to a message that doesn't have a content-type +of "multipart" or "message", the following happens: =over 4 @@ -433,37 +733,42 @@ that a user agent like Netscape allows you to do. =cut + sub attach { my $self = shift; + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; - # Create new part, if necessary: - my $part1 = ((@_ == 1) ? shift : ref($self)->new(Top=>0, @_)); - - # Do the "attach-to-singlepart" hack: - if ($self->attr('content-type') !~ m{^multipart/}i) { + ### Create new part, if necessary: + my $part1 = ( ( @_ == 1 ) ? shift: ref($self)->new( Top => 0, @_ ) ); - # Create part zero: - my $part0 = ref($self)->new; + ### Do the "attach-to-singlepart" hack: + if ( $attrs->{'content-type'} !~ m{^(multipart|message)/}i ) { - # Cut MIME stuff from self, and paste into part zero: - foreach (qw(Attrs Data Path FH)) { - $part0->{$_} = $self->{$_}; delete($self->{$_}); - } - $part0->top_level(0); # clear top-level attributes + ### Create part zero: + my $part0 = ref($self)->new; - # Make self a top-level multipart: - $self->{Attrs} ||= {}; # reset - $self->attr('content-type' => 'multipart/mixed'); - $self->attr('content-type.boundary' => gen_boundary()); - $self->attr('content-transfer-encoding' => '7bit'); - $self->top_level(1); # activate top-level attributes - - # Add part 0: - push @{$self->{Parts}}, $part0; + ### Cut MIME stuff from self, and paste into part zero: + foreach (qw(SubAttrs Attrs Data Path FH)) { + $part0->{$_} = $self->{$_}; + delete( $self->{$_} ); + } + $part0->top_level(0); ### clear top-level attributes + + ### Make self a top-level multipart: + $attrs = $self->{Attrs} ||= {}; ### reset (sam: bug? this doesn't reset anything since Attrs is already a hash-ref) + $sub_attrs = $self->{SubAttrs} ||= {}; ### reset + $attrs->{'content-type'} = 'multipart/mixed'; + $sub_attrs->{'content-type'}{'boundary'} = gen_boundary(); + $attrs->{'content-transfer-encoding'} = '7bit'; + $self->top_level(1); ### activate top-level attributes + + ### Add part 0: + push @{ $self->{Parts} }, $part0; } - # Add the new part: - push @{$self->{Parts}}, $part1; + ### Add the new part: + push @{ $self->{Parts} }, $part1; $part1; } @@ -471,8 +776,8 @@ sub attach { =item build [PARAMHASH] -I -Create (or initiallize) a MIME message object. +I +Create (or initialize) a MIME message object. Normally, you'll use the following keys in PARAMHASH: * Data, FH, or Path (either one of these, or none if multipart) @@ -488,29 +793,38 @@ The PARAMHASH can contain the following keys: Any field you want placed in the message header, taken from the standard list of header fields (you don't need to worry about case): - Bcc Encrypted Received Sender - Cc From References Subject - Comments Keywords Reply-To To - Content-* Message-ID Resent-* X-* - Date MIME-Version Return-Path - Organization + Approved Encrypted Received Sender + Bcc From References Subject + Cc Keywords Reply-To To + Comments Message-ID Resent-* X-* + Content-* MIME-Version Return-Path + Date Organization -To give experienced users some veto power, these fields will be set +To give experienced users some veto power, these fields will be set I the ones I set... so be careful: I (like C) unless you know what you're doing! To specify a fieldname that's I in the above list, even one that's identical to an option below, just give it with a trailing C<":">, -like C<"My-field:">. When in doubt, that I signals a mail +like C<"My-field:">. When in doubt, that I signals a mail field (and it sort of looks like one too). =item Data I The actual message data. This may be a scalar or a ref to an array of -strings; if the latter, the message consists of a simple concatenation +strings; if the latter, the message consists of a simple concatenation of all the strings in the array. +=item Datestamp + +I +If given true (or omitted), we force the creation of a C field +stamped with the current date/time if this is a top-level message. +You may want this if using L. +If you don't want this to be done, either provide your own Date +or explicitly set this to false. + =item Disposition I @@ -520,23 +834,25 @@ The default is C<"inline">. =item Encoding I -The content transfer encoding that should be used to encode your data. -The default is C<"binary">, which means "no encoding": this is generally -I suitable for sending anything but ASCII text files with short -lines, so consider using one of the following values instead: +The content transfer encoding that should be used to encode your data: - Use encoding: If your message contains: + Use encoding: | If your message contains: ------------------------------------------------------------ - 7bit Only 7-bit text, all lines <1000 characters - 8bit 8-bit text, all lines <1000 characters - quoted-printable 8-bit text or long lines (MUCH more reliable than "8bit") - base64 Largely binary data: a GIF, a tar file, etc. - -Be sure to pick an appropriate encoding. In the case of "7bit"/"8bit", -long lines are automatically chopped to legal length; in the case of "7bit", -all 8-bit characters are automatically I. This may not be -what you want, so pick your encoding well! -There's a L<"A MIME PRIMER"> in this document with more info. + 7bit | Only 7-bit text, all lines <1000 characters + 8bit | 8-bit text, all lines <1000 characters + quoted-printable | 8-bit text or long lines (more reliable than "8bit") + base64 | Largely non-textual data: a GIF, a tar file, etc. + +The default is taken from the Type; generally it is "binary" (no +encoding) for text/*, message/*, and multipart/*, and "base64" for +everything else. A value of C<"binary"> is generally I suitable +for sending anything but ASCII text files with lines under 1000 +characters, so consider using one of the other values instead. + +In the case of "7bit"/"8bit", long lines are automatically chopped to +legal length; in the case of "7bit", all 8-bit characters are +automatically I. This may not be what you want, so pick your +encoding well! For more info, see L<"A MIME PRIMER">. =item FH @@ -547,8 +863,17 @@ See "ReadNow" also. =item Filename I -The name of the attachment. You can use this to supply a filename -if the one in the Path is inadequate, or if you're using the Data argument. +The name of the attachment. You can use this to supply a +recommended filename for the end-user who is saving the attachment +to disk. You only need this if the filename at the end of the +"Path" is inadequate, or if you're using "Data" instead of "Path". +You should I put path information in here (e.g., no "/" +or "\" or ":" characters should be used). + +=item Id + +I +Same as setting "content-id". =item Length @@ -560,15 +885,15 @@ computed, but only under certain circumstances (see L<"Limitations">). I Path to a file containing the data... actually, it can be any open()able -expression. If it looks like a path, the last element will automatically -be treated as the filename. +expression. If it looks like a path, the last element will automatically +be treated as the filename. See "ReadNow" also. =item ReadNow I If true, will open the path and slurp the contents into core now. -This is useful if the Path points to a command and you don't want +This is useful if the Path points to a command and you don't want to run the command over and over if outputting the message several times. B raised if the open fails. @@ -586,8 +911,15 @@ The MIME content type, or one of these special values (case-sensitive): "TEXT" means "text/plain" "BINARY" means "application/octet-stream" + "AUTO" means attempt to guess from the filename, falling back + to 'application/octet-stream'. This is good if you have + MIME::Types on your system and you have no idea what + file might be used for the attachment. -The default is C<"TEXT">. +The default is C<"TEXT">, but it will be C<"AUTO"> if you set +$AUTO_CONTENT_TYPE to true (sorry, but you have to enable +it explicitly, since we don't want to break code which depends +on the old behavior). =back @@ -595,168 +927,196 @@ A picture being worth 1000 words (which is of course 2000 bytes, so it's probably more of an "icon" than a "picture", but I digress...), here are some examples: - $msg = build MIME::Lite - From => 'yelling@inter.com', - To => 'stocking@fish.net', - Subject => "Hi there!", - Type => 'TEXT', - Encoding => '7bit', - Data => "Just a quick note to say hi!"; - - $msg = build MIME::Lite - From => 'dorothy@emerald-city.oz', - To => 'gesundheit@edu.edu.edu', - Subject => "A gif for U" - Type => 'image/gif', - Path => "/home/httpd/logo.gif"; - - $msg = build MIME::Lite - From => 'laughing@all.of.us', - To => 'scarlett@fiddle.dee.de', - Subject => "A gzipp'ed tar file", - Type => 'x-gzip', - Path => "gzip < /usr/inc/somefile.tar |", - ReadNow => 1, - Filename => "somefile.tgz"; - -To show you what's really going on, that last example could also + $msg = MIME::Lite->build( + From => 'yelling@inter.com', + To => 'stocking@fish.net', + Subject => "Hi there!", + Type => 'TEXT', + Encoding => '7bit', + Data => "Just a quick note to say hi!" + ); + + $msg = MIME::Lite->build( + From => 'dorothy@emerald-city.oz', + To => 'gesundheit@edu.edu.edu', + Subject => "A gif for U" + Type => 'image/gif', + Path => "/home/httpd/logo.gif" + ); + + $msg = MIME::Lite->build( + From => 'laughing@all.of.us', + To => 'scarlett@fiddle.dee.de', + Subject => "A gzipp'ed tar file", + Type => 'x-gzip', + Path => "gzip < /usr/inc/somefile.tar |", + ReadNow => 1, + Filename => "somefile.tgz" + ); + +To show you what's really going on, that last example could also have been written: $msg = new MIME::Lite; - - $msg->build(Type => 'x-gzip', - Path => "gzip < /usr/inc/somefile.tar |", - ReadNow => 1, - Filename => "somefile.tgz"); - + $msg->build( + Type => 'x-gzip', + Path => "gzip < /usr/inc/somefile.tar |", + ReadNow => 1, + Filename => "somefile.tgz" + ); $msg->add(From => "laughing@all.of.us"); $msg->add(To => "scarlett@fiddle.dee.de"); - $msg->add(Subject => "A gzipp'ed tar file"); + $msg->add(Subject => "A gzipp'ed tar file"); =cut + sub build { - my $self = shift; + my $self = shift; my %params = @_; my @params = @_; my $key; - # Miko's note: reorganized to check for exactly one of Data, Path, or FH - (defined($params{Data})+defined($params{Path})+defined($params{FH}) <= 1) - or croak "supply exactly zero or one of (Data|Path|FH).\n"; + ### Miko's note: reorganized to check for exactly one of Data, Path, or FH + ( defined( $params{Data} ) + defined( $params{Path} ) + defined( $params{FH} ) <= 1 ) + or Carp::croak "supply exactly zero or one of (Data|Path|FH).\n"; - # Create new instance, if necessary: + ### Create new instance, if necessary: ref($self) or $self = $self->new; ### CONTENT-TYPE.... ### - # Get content-type: - my $type = ($params{Type} || 'TEXT'); - ($type eq 'TEXT') and $type = 'text/plain'; - ($type eq 'BINARY') and $type = 'application/octet-stream'; + ### Get content-type or content-type-macro: + my $type = ( $params{Type} || ( $AUTO_CONTENT_TYPE ? 'AUTO' : 'TEXT' ) ); + + ### Interpret content-type-macros: + if ( $type eq 'TEXT' ) { $type = 'text/plain'; } + elsif ( $type eq 'HTML' ) { $type = 'text/html'; } + elsif ( $type eq 'BINARY' ) { $type = 'application/octet-stream' } + elsif ( $type eq 'AUTO' ) { $type = $self->suggest_type( $params{Path} ); } + + ### We now have a content-type; set it: $type = lc($type); - $self->attr('content-type' => $type); - - # Get some basic attributes from the content type: - my $is_multipart = ($type =~ m{^(multipart)/}i); + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; + $attrs->{'content-type'} = $type; + + ### Get some basic attributes from the content type: + my $is_multipart = ( $type =~ m{^(multipart)/}i ); - # Add in the multipart boundary: + ### Add in the multipart boundary: if ($is_multipart) { - my $boundary = gen_boundary(); - $self->attr('content-type.boundary' => $boundary); + my $boundary = gen_boundary(); + $sub_attrs->{'content-type'}{'boundary'} = $boundary; + } + + + ### CONTENT-ID... + ### + if ( defined $params{Id} ) { + my $id = $params{Id}; + $id = "<$id>" unless $id =~ /\A\s*<.*>\s*\z/; + $attrs->{'content-id'} = $id; } ### DATA OR PATH... - ### Note that we must do this *after* we get the content type, + ### Note that we must do this *after* we get the content type, ### in case read_now() is invoked, since it needs the binmode(). - # Get data, as... - # ...either literal data: - if (defined($params{Data})) { - $self->data($params{Data}); + ### Get data, as... + ### ...either literal data: + if ( defined( $params{Data} ) ) { + $self->data( $params{Data} ); } - # ...or a path to data: - elsif (defined($params{Path})) { - $self->path($params{Path}); # also sets filename - $self->read_now if $params{ReadNow}; + ### ...or a path to data: + elsif ( defined( $params{Path} ) ) { + $self->path( $params{Path} ); ### also sets filename + $self->read_now if $params{ReadNow}; } - # ...or a filehandle to data: - # Miko's note: this part works much like the path routine just above, - elsif (defined($params{FH})) { - $self->fh($params{FH}); - $self->read_now if $params{ReadNow}; # implement later + ### ...or a filehandle to data: + ### Miko's note: this part works much like the path routine just above, + elsif ( defined( $params{FH} ) ) { + $self->fh( $params{FH} ); + $self->read_now if $params{ReadNow}; ### implement later } - + ### FILENAME... (added by Ian Smith on 8/4/97) ### Need this to make sure the filename is added. The Filename ### attribute is ignored, otherwise. - if (defined($params{Filename})) { - $self->filename($params{Filename}); + if ( defined( $params{Filename} ) ) { + $self->filename( $params{Filename} ); } - + ### CONTENT-TRANSFER-ENCODING... ### - # Get it: - my $enc = $params{Encoding} || 'binary'; # explicit value wins - $self->attr('content-transfer-encoding' => lc($enc)); - - # Sanity check: - if ($type =~ m{^(multipart|message)/}) { - ($enc =~ m{^(7bit|8bit|binary)\Z}) or - croak "illegal MIME: can't have encoding $enc with type $type!"; + ### Get it: + my $enc = + ( $params{Encoding} || ( $AUTO_ENCODE and $self->suggest_encoding($type) ) || 'binary' ); + $attrs->{'content-transfer-encoding'} = lc($enc); + + ### Sanity check: + if ( $type =~ m{^(multipart|message)/} ) { + ( $enc =~ m{^(7bit|8bit|binary)\Z} ) + or Carp::croak( "illegal MIME: " . "can't have encoding $enc with type $type\n" ); } ### CONTENT-DISPOSITION... ### Default is inline for single, none for multis: ### - my $disp = ($params{Disposition} or ($is_multipart ? undef : 'inline')); - $self->attr('content-disposition' => $disp); + my $disp = ( $params{Disposition} or ( $is_multipart ? undef: 'inline' ) ); + $attrs->{'content-disposition'} = $disp; ### CONTENT-LENGTH... ### my $length; - if (exists($params{Length})) { # given by caller: - $self->attr('content-length' => $params{Length}); - } - else { # compute it ourselves - $self->get_length; + if ( exists( $params{Length} ) ) { ### given by caller: + $attrs->{'content-length'} = $params{Length}; + } else { ### compute it ourselves + $self->get_length; } - - # Init the top-level fields: - $self->top_level(defined($params{Top}) ? $params{Top} : 1); + ### Init the top-level fields: + my $is_top = defined( $params{Top} ) ? $params{Top} : 1; + $self->top_level($is_top); - # Set message headers: + ### Datestamp if desired: + my $ds_wanted = $params{Datestamp}; + my $ds_defaulted = ( $is_top and !exists( $params{Datestamp} ) ); + if ( ( $ds_wanted or $ds_defaulted ) and !exists( $params{Date} ) ) { + require Email::Date::Format; + $self->add( "date", Email::Date::Format::email_date() ); + } + + ### Set message headers: my @paramz = @params; my $field; while (@paramz) { - my ($tag, $value) = (shift(@paramz), shift(@paramz)); - - # Get tag, if a tag: - if ($tag =~ /^\-/) { # old style, backwards-compatibility - $field = lc($'); - } - elsif ($tag =~ /:$/) { # new style - $field = lc($`); - } - elsif (known_field($field = lc($tag))) { # known field - # no-op - } - else { # not a field: - next; - } - - # Add it: - $self->add($field, $value); + my ( $tag, $value ) = ( shift(@paramz), shift(@paramz) ); + my $lc_tag = lc($tag); + + ### Get tag, if a tag: + if ( $lc_tag =~ /^-(.*)/ ) { ### old style, backwards-compatibility + $field = $1; + } elsif ( $lc_tag =~ /^(.*):$/ ) { ### new style + $field = $1; + } elsif ( $KnownField{$lc_tag} or + $lc_tag =~ m{^(content|resent|x)-.} ){ + $field = $lc_tag; + } else { ### not a field: + next; + } + + ### Add it: + $self->add( $field, $value ); } - # Done! + ### Done! $self; } @@ -774,6 +1134,7 @@ sub build { =cut + #------------------------------ # # top_level ONOFF @@ -782,16 +1143,16 @@ sub build { # This affects "MIME-Version" and "X-Mailer". sub top_level { - my ($self, $onoff) = @_; + my ( $self, $onoff ) = @_; + my $attrs = $self->{Attrs}; if ($onoff) { - $self->attr('MIME-Version' => '1.0'); - my $uses = (@Uses ? ("(" . join("; ", @Uses) . ")") : ''); - $self->replace('X-Mailer' => "MIME::Lite $VERSION $uses") - unless $VANILLA; - } - else { - $self->attr('MIME-Version' => undef); - $self->delete('X-Mailer'); + $attrs->{'MIME-Version'} = '1.0'; + my $uses = ( @Uses ? ( "(" . join( "; ", @Uses ) . ")" ) : '' ); + $self->replace( 'X-Mailer' => "MIME::Lite $VERSION $uses" ) + unless $VANILLA; + } else { + delete $attrs->{'MIME-Version'}; + $self->delete('X-Mailer'); } } @@ -799,8 +1160,9 @@ sub top_level { =item add TAG,VALUE -Add field TAG with the given VALUE to the end of the header. -The TAG will be converted to all-lowercase, and the VALUE +I +Add field TAG with the given VALUE to the end of the header. +The TAG will be converted to all-lowercase, and the VALUE will be made "safe" (returns will be given a trailing space). B any MIME fields you "add" will override any MIME @@ -809,34 +1171,47 @@ Normally, you will use this method to add I fields: $msg->add("Subject" => "Hi there!"); -Giving VALUE an arrayref will cause all those values to be added: +Giving VALUE as an arrayref will cause all those values to be added. +This is only useful for special multiple-valued fields like "Received": $msg->add("Received" => ["here", "there", "everywhere"] +Giving VALUE as the empty string adds an invisible placeholder +to the header, which can be used to suppress the output of +the "Content-*" fields or the special "MIME-Version" field. +When suppressing fields, you should use replace() instead of add(): + + $msg->replace("Content-disposition" => ""); + I add() is probably going to be more efficient than C, -so you're better off using it for most applications. +so you're better off using it for most applications if you are +certain that you don't need to delete() the field first. I the name comes from Mail::Header. =cut + sub add { - my $self = shift; - my $tag = lc(shift); + my $self = shift; + my $tag = lc(shift); my $value = shift; - # If a dangerous option, warn them: - carp "Explicitly setting a MIME header field ($tag) is dangerous:\n". - "use the attr() method instead.\n" - if (is_mime_field($tag) && !$QUIET); + ### If a dangerous option, warn them: + Carp::carp "Explicitly setting a MIME header field ($tag) is dangerous:\n" + . "use the attr() method instead.\n" + if ( is_mime_field($tag) && !$QUIET ); - # Get array of clean values: - my @vals = ref($value) ? @{$value} : ($value); + ### Get array of clean values: + my @vals = ( ( ref($value) and ( ref($value) eq 'ARRAY' ) ) + ? @{$value} + : ( $value . '' ) + ); map { s/\n/\n /g } @vals; - # Add them: + ### Add them: foreach (@vals) { - push @{$self->{Header}}, [$tag, $_]; + push @{ $self->{Header} }, [ $tag, $_ ]; } } @@ -844,7 +1219,8 @@ sub add { =item attr ATTR,[VALUE] -Set MIME attribute ATTR to the string VALUE. +I +Set MIME attribute ATTR to the string VALUE. ATTR is converted to all-lowercase. This method is normally used to set/get MIME attributes: @@ -856,7 +1232,7 @@ This would cause the final output to look something like this: Content-type: text/html; charset=US-ASCII; name="homepage.html" -Note that the special empty sub-field tag indicates the anonymous +Note that the special empty sub-field tag indicates the anonymous first sub-field. Giving VALUE as undefined will cause the contents of the named @@ -864,38 +1240,49 @@ subfield to be deleted. Supplying no VALUE argument just returns the attribute's value: - $type = $msg->attr("content-type"); # returns "text/html" - $name = $msg->attr("content-type.name"); # returns "homepage.html" + $type = $msg->attr("content-type"); ### returns "text/html" + $name = $msg->attr("content-type.name"); ### returns "homepage.html" =cut + sub attr { - my ($self, $attr, $value) = @_; + my ( $self, $attr, $value ) = @_; + my $attrs = $self->{Attrs}; + $attr = lc($attr); - # Break attribute name up: - my ($tag, $subtag) = split /\./, $attr; - defined($subtag) or $subtag = ''; - - # Set or get? - if (@_ > 2) { # set: - $self->{Attrs}{$tag} ||= {}; # force hash - delete $self->{Attrs}{$tag}{$subtag}; # delete first - if (defined($value)) { # set... - $value =~ s/[\r\n]//g; # make clean - $self->{Attrs}{$tag}{$subtag} = $value; - } + ### Break attribute name up: + my ( $tag, $subtag ) = split /\./, $attr; + if (defined($subtag)) { + $attrs = $self->{SubAttrs}{$tag} ||= {}; + $tag = $subtag; + } + + ### Set or get? + if ( @_ > 2 ) { ### set: + if ( defined($value) ) { + $attrs->{$tag} = $value; + } else { + delete $attrs->{$tag}; + } } - - # Return current value: - $self->{Attrs}{$tag}{$subtag}; + + ### Return current value: + $attrs->{$tag}; +} + +sub _safe_attr { + my ( $self, $attr ) = @_; + return defined $self->{Attrs}{$attr} ? $self->{Attrs}{$attr} : ''; } #------------------------------ =item delete TAG -Delete field TAG with the given VALUE to the end of the header. +I +Delete field TAG with the given VALUE to the end of the header. The TAG will be converted to all-lowercase. $msg->delete("Subject"); @@ -904,143 +1291,221 @@ I the name comes from Mail::Header. =cut + sub delete { my $self = shift; - my $tag = lc(shift); + my $tag = lc(shift); - # Delete from the header: + ### Delete from the header: my $hdr = []; my $field; - foreach $field (@{$self->{Header}}) { - push @$hdr, $field if ($field->[0] ne $tag); + foreach $field ( @{ $self->{Header} } ) { + push @$hdr, $field if ( $field->[0] ne $tag ); } $self->{Header} = $hdr; $self; } + +#------------------------------ + +=item field_order FIELD,...FIELD + +I +Change the order in which header fields are output for this object: + + $msg->field_order('from', 'to', 'content-type', 'subject'); + +When used as a class method, changes the default settings for +all objects: + + MIME::Lite->field_order('from', 'to', 'content-type', 'subject'); + +Case does not matter: all field names will be coerced to lowercase. +In either case, supply the empty array to restore the default ordering. + +=cut + + +sub field_order { + my $self = shift; + if ( ref($self) ) { + $self->{FieldOrder} = [ map { lc($_) } @_ ]; + } else { + @FieldOrder = map { lc($_) } @_; + } +} + #------------------------------ =item fields +I Return the full header for the object, as a ref to an array -of C<[TAG, VALUE]> pairs. - -Any fields that the user has explicitly set will override the -corresponding MIME fields that we would generate. So: I say: +of C<[TAG, VALUE]> pairs, where each TAG is all-lowercase. +Note that any fields the user has explicitly set will override the +corresponding MIME fields that we would otherwise generate. +So, don't say... $msg->set("Content-type" => "text/html; charset=US-ASCII"); -unless you I! +unless you want the above value to override the "Content-type" +MIME field that we would normally generate. I I called this "fields" because the header() method of -Mail::Header returns something different, but similar enough to +Mail::Header returns something different, but similar enough to be confusing. +You can change the order of the fields: see L. +You really shouldn't need to do this, but some people have to +deal with broken mailers. + =cut + sub fields { my $self = shift; my @fields; - - # Get a lookup-hash of all *explicitly-given* fields: - my %explicit = map { $_->[0] => 1 } @{$self->{Header}}; - - # Start with any MIME attributes not given explicitly: + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; + + ### Get a lookup-hash of all *explicitly-given* fields: + my %explicit = map { $_->[0] => 1 } @{ $self->{Header} }; + + ### Start with any MIME attributes not given explicitly: my $tag; - foreach $tag (sort keys %{$self->{Attrs}}) { - - # Skip if explicit: - next if ($explicit{$tag}); - - # Skip if no subtags: - my @subtags = keys %{$self->{Attrs}{$tag}}; - @subtags or next; - - # Create string: - my $value; - defined($value = $self->{Attrs}{$tag}{''}) or next; # need default tag! - foreach (sort @subtags) { - next if ($_ eq ''); - $value .= qq{; $_="$self->{Attrs}{$tag}{$_}"}; - } - - # Add to running fields; - push @fields, [$tag, $value]; + foreach $tag ( sort keys %{ $self->{Attrs} } ) { + + ### Skip if explicit: + next if ( $explicit{$tag} ); + + # get base attr value or skip if not available + my $value = $attrs->{$tag}; + defined $value or next; + + ### handle sub-attrs if available + if (my $subs = $sub_attrs->{$tag}) { + $value .= '; ' . + join('; ', map { qq{$_="$subs->{$_}"} } sort keys %$subs); + } + + # handle stripping \r\n now since we're not doing it in attr() + # anymore + $value =~ tr/\r\n//; + + ### Add to running fields; + push @fields, [ $tag, $value ]; + } + + ### Add remaining fields (note that we duplicate the array for safety): + foreach ( @{ $self->{Header} } ) { + push @fields, [ @{$_} ]; } - - # Add remaining fields (note that we duplicate the array for safety): - foreach (@{$self->{Header}}) { - push @fields, [@{$_}]; + + ### Final step: + ### If a suggested ordering was given, we "sort" by that ordering. + ### The idea is that we give each field a numeric rank, which is + ### (1000 * order(field)) + origposition. + my @order = @{ $self->{FieldOrder} || [] }; ### object-specific + @order or @order = @FieldOrder; ### no? maybe generic + if (@order) { ### either? + + ### Create hash mapping field names to 1-based rank: + my %rank = map { $order[$_] => ( 1 + $_ ) } ( 0 .. $#order ); + + ### Create parallel array to @fields, called @ranked. + ### It contains fields tagged with numbers like 2003, where the + ### 3 is the original 0-based position, and 2000 indicates that + ### we wanted ths type of field to go second. + my @ranked = map { + [ ( $_ + 1000 * ( $rank{ lc( $fields[$_][0] ) } || ( 2 + $#order ) ) ), $fields[$_] ] + } ( 0 .. $#fields ); + + # foreach (@ranked) { + # print STDERR "RANKED: $_->[0] $_->[1][0] $_->[1][1]\n"; + # } + + ### That was half the Schwartzian transform. Here's the rest: + @fields = map { $_->[1] } + sort { $a->[0] <=> $b->[0] } @ranked; } - # Done! + ### Done! return \@fields; } + #------------------------------ =item filename [FILENAME] +I Set the filename which this data will be reported as. This actually sets both "standard" attributes. -With no argument, returns the filename as dictated by the +With no argument, returns the filename as dictated by the content-disposition. =cut + sub filename { - my ($self, $filename) = @_; - if (@_ > 1) { - $self->attr('content-type.name' => $filename); - $self->attr('content-disposition.filename' => $filename); + my ( $self, $filename ) = @_; + my $sub_attrs = $self->{SubAttrs}; + + if ( @_ > 1 ) { + $sub_attrs->{'content-type'}{'name'} = $filename; + $sub_attrs->{'content-disposition'}{'filename'} = $filename; } - $self->attr('content-disposition.filename'); + return $sub_attrs->{'content-disposition'}{'filename'}; } #------------------------------ =item get TAG,[INDEX] -Get the contents of field TAG, which might have been set +I +Get the contents of field TAG, which might have been set with set() or replace(). Returns the text of the field. $ml->get('Subject', 0); If the optional 0-based INDEX is given, then we return the INDEX'th occurence of field TAG. Otherwise, we look at the context: -In a scalar context, only the first (0th) occurence of the -field is returned; in an array context, I occurences are returned. +In a scalar context, only the first (0th) occurence of the +field is returned; in an array context, I occurences are returned. I this should only be used with non-MIME fields. Behavior with MIME fields is TBD, and will raise an exception for now. =cut + sub get { - my ($self, $tag, $index) = @_; - $tag = lc($tag); - croak "get: can't be used with MIME fields\n" if is_mime_field($tag); - - my @all = map { ($_->[0] eq $tag) ? $_->[1] : ()} @{$self->{Header}}; - (defined($index) ? $all[$index] : (wantarray ? @all : $all[0])); + my ( $self, $tag, $index ) = @_; + $tag = lc($tag); + Carp::croak "get: can't be used with MIME fields\n" if is_mime_field($tag); + + my @all = map { ( $_->[0] eq $tag ) ? $_->[1] : () } @{ $self->{Header} }; + ( defined($index) ? $all[$index] : ( wantarray ? @all : $all[0] ) ); } #------------------------------ =item get_length -Recompute the content length for the message I, +I +Recompute the content length for the message I, setting the "content-length" attribute as a side-effect: $msg->get_length; Returns the length, or undefined if not set. -I the content length can be difficult to compute, since it +I the content length can be difficult to compute, since it involves assembling the entire encoded body and taking the length of it (which, in the case of multipart messages, means freezing -all the sub-parts, etc.). +all the sub-parts, etc.). This method only sets the content length to a defined value if the message is a singlepart with C<"binary"> encoding, I the body is @@ -1052,171 +1517,270 @@ it's not in the MIME RFCs, it's an HTTP thing), this seems pretty fair. =cut + #---- -# Miko's note: I wasn't quite sure how to handle this, so I waited to hear -# what you think. Given that the content-length isn't always required, +# Miko's note: I wasn't quite sure how to handle this, so I waited to hear +# what you think. Given that the content-length isn't always required, # and given the performance cost of calculating it from a file handle, -# I thought it might make more sense to add some some sort of computelength -# property. If computelength is false, then the length simply isn't +# I thought it might make more sense to add some some sort of computelength +# property. If computelength is false, then the length simply isn't # computed. What do you think? # # Eryq's reply: I agree; for now, we can silently leave out the content-type. sub get_length { my $self = shift; + my $attrs = $self->{Attrs}; - my $is_multipart = ($self->attr('content-type') =~ m{^multipart/}i); - my $enc = lc($self->attr('content-transfer-encoding') || 'binary'); + my $is_multipart = ( $attrs->{'content-type'} =~ m{^multipart/}i ); + my $enc = lc( $attrs->{'content-transfer-encoding'} || 'binary' ); my $length; - if (!$is_multipart && ($enc eq "binary")){ # might figure it out cheap: - if (defined($self->{Data})) { # it's in core - $length = length($self->{Data}); - } - elsif (defined($self->{FH})) { # it's in a filehandle - # no-op: it's expensive, so don't bother - } - elsif (-e $self->{Path}) { # it's a simple file! - $length = (-s $self->{Path}); - } + if ( !$is_multipart && ( $enc eq "binary" ) ) { ### might figure it out cheap: + if ( defined( $self->{Data} ) ) { ### it's in core + $length = length( $self->{Data} ); + } elsif ( defined( $self->{FH} ) ) { ### it's in a filehandle + ### no-op: it's expensive, so don't bother + } elsif ( defined( $self->{Path} ) ) { ### it's a simple file! + $length = ( -s $self->{Path} ) if ( -e $self->{Path} ); + } } - $self->attr('content-length' => $length); + $attrs->{'content-length'} = $length; return $length; } #------------------------------ -=item replace TAG,VALUE +=item parts -Delete all occurences of fields named TAG, and add a new -field with the given VALUE. TAG is converted to all-lowercase. +I +Return the parts of this entity, and this entity only. +Returns empty array if this entity has no parts. -B any MIME fields you "replace" will override any MIME -attributes I have when it comes time to output those fields. -Normally, you will use this method to set I fields: +This is B recursive! Parts can have sub-parts; use +parts_DFS() to get everything. - $msg->replace("Subject" => "Hi there!"); +=cut -Giving VALUE as undefined will simply cause the contents of the named -field to be deleted. Giving VALUE as an arrayref will cause all the values -in the array to be added. -I the name comes from Mail::Header. +sub parts { + my $self = shift; + @{ $self->{Parts} || [] }; +} -=cut +#------------------------------ -sub replace { - my ($self, $tag, $value) = @_; - $self->delete($tag); - $self->add($tag, $value) if defined($value); -} +=item parts_DFS -=back +I +Return the list of all MIME::Lite objects included in the entity, +starting with the entity itself, in depth-first-search order. +If this object has no parts, it alone will be returned. =cut -#============================== -#============================== +sub parts_DFS { + my $self = shift; + return ( $self, map { $_->parts_DFS } $self->parts ); +} -=head2 Setting/getting message data +#------------------------------ -=over 4 +=item preamble [TEXT] + +I +Get/set the preamble string, assuming that this object has subparts. +Set it to undef for the default string. =cut -#------------------------------ -=item binmode [OVERRIDE] +sub preamble { + my $self = shift; + $self->{Preamble} = shift if @_; + $self->{Preamble}; +} -With no argument, returns whether or not it thinks that the data -(as given by the "Path" argument of C) should be read using -binmode() (for example, when C is invoked). +#------------------------------ -The default behavior is that any content type other than -C or C is binmode'd; this should in general work fine. +=item replace TAG,VALUE -With a defined argument, this method sets an explicit "override" -value. An undefined argument unsets the override. -The new current value is returned. +I +Delete all occurences of fields named TAG, and add a new +field with the given VALUE. TAG is converted to all-lowercase. -=cut +B the special MIME fields (MIME-version, Content-*): +if you "replace" a MIME field, the replacement text will override +the I MIME attributes when it comes time to output that field. +So normally you use attr() to change MIME fields and add()/replace() to +change I fields: -sub binmode { - my $self = shift; - $self->{Binmode} = shift if (@_); # argument? set override - return (defined($self->{Binmode}) - ? $self->{Binmode} - : ($self->attr("content-type") !~ m{^(text|message)/}i)); -} + $msg->replace("Subject" => "Hi there!"); -#------------------------------ +Giving VALUE as the I will effectively I that +field from being output. This is the correct way to suppress +the special MIME fields: -=item data [DATA] + $msg->replace("Content-disposition" => ""); -Get/set the literal DATA of the message. The DATA may be -either a scalar, or a reference to an array of scalars (which -will simply be joined). +Giving VALUE as I will just cause all explicit values +for TAG to be deleted, without having any new values added. -I setting the data causes the "content-length" attribute -to be recomputed (possibly to nothing). +I the name of this method comes from Mail::Header. =cut -sub data { - my $self = shift; - if (@_) { - $self->{Data} = ((ref($_[0]) eq 'ARRAY') ? join('', @{$_[0]}) : $_[0]); - $self->get_length; - } - $self->{Data}; + +sub replace { + my ( $self, $tag, $value ) = @_; + $self->delete($tag); + $self->add( $tag, $value ) if defined($value); } #------------------------------ -=item path [PATH] +=item scrub -Get/set the PATH to the message data. +I +B +Recursively goes through the "parts" tree of this message and tries +to find MIME attributes that can be removed. +With an array argument, removes exactly those attributes; e.g.: -I setting the path recomputes any existing "content-length" field, -and re-sets the "filename" (to the last element of the path if it -looks like a simple path, and to nothing if not). + $msg->scrub(['content-disposition', 'content-length']); + +Is the same as recursively doing: + + $msg->replace('Content-disposition' => ''); + $msg->replace('Content-length' => ''); =cut -sub path { + +sub scrub { + my ( $self, @a ) = @_; + my ($expl) = @a; + local $QUIET = 1; + + ### Scrub me: + if ( !@a ) { ### guess + + ### Scrub length always: + $self->replace( 'content-length', '' ); + + ### Scrub disposition if no filename, or if content-type has same info: + if ( !$self->_safe_attr('content-disposition.filename') + || $self->_safe_attr('content-type.name') ) + { + $self->replace( 'content-disposition', '' ); + } + + ### Scrub encoding if effectively unencoded: + if ( $self->_safe_attr('content-transfer-encoding') =~ /^(7bit|8bit|binary)$/i ) { + $self->replace( 'content-transfer-encoding', '' ); + } + + ### Scrub charset if US-ASCII: + if ( $self->_safe_attr('content-type.charset') =~ /^(us-ascii)/i ) { + $self->attr( 'content-type.charset' => undef ); + } + + ### TBD: this is not really right for message/digest: + if ( ( keys %{ $self->{Attrs}{'content-type'} } == 1 ) + and ( $self->_safe_attr('content-type') eq 'text/plain' ) ) + { + $self->replace( 'content-type', '' ); + } + } elsif ( $expl and ( ref($expl) eq 'ARRAY' ) ) { + foreach ( @{$expl} ) { $self->replace( $_, '' ); } + } + + ### Scrub my kids: + foreach ( @{ $self->{Parts} } ) { $_->scrub(@a); } +} + +=back + +=cut + + +#============================== +#============================== + +=head2 Setting/getting message data + +=over 4 + +=cut + + +#------------------------------ + +=item binmode [OVERRIDE] + +I +With no argument, returns whether or not it thinks that the data +(as given by the "Path" argument of C) should be read using +binmode() (for example, when C is invoked). + +The default behavior is that any content type other than +C or C is binmode'd; this should in general work fine. + +With a defined argument, this method sets an explicit "override" +value. An undefined argument unsets the override. +The new current value is returned. + +=cut + + +sub binmode { my $self = shift; - if (@_) { + $self->{Binmode} = shift if (@_); ### argument? set override + return ( defined( $self->{Binmode} ) + ? $self->{Binmode} + : ( $self->{Attrs}{"content-type"} !~ m{^(text|message)/}i ) + ); +} - # Set the path, and invalidate the content length: - $self->{Path} = shift; +#------------------------------ + +=item data [DATA] + +I +Get/set the literal DATA of the message. The DATA may be +either a scalar, or a reference to an array of scalars (which +will simply be joined). - # Re-set filename, extracting it from path if possible: - my $filename; - if ($self->{Path} and ($self->{Path} !~ /\|$/)) { # non-shell path: - ($filename = $self->{Path}) =~ s/^filename($filename); +I setting the data causes the "content-length" attribute +to be recomputed (possibly to nothing). + +=cut - # Reset the length: - $self->get_length; + +sub data { + my $self = shift; + if (@_) { + $self->{Data} = ( ( ref( $_[0] ) eq 'ARRAY' ) ? join( '', @{ $_[0] } ) : $_[0] ); + $self->get_length; } - $self->{Path}; + $self->{Data}; } #------------------------------ =item fh [FILEHANDLE] +I Get/set the FILEHANDLE which contains the message data. Takes a filehandle as an input and stores it in the object. -This routine is similar to path(); one important difference is that -no attempt is made to set the content length. +This routine is similar to path(); one important difference is that +no attempt is made to set the content length. =cut + sub fh { my $self = shift; $self->{FH} = shift if @_; @@ -1225,9 +1789,51 @@ sub fh { #------------------------------ +=item path [PATH] + +I +Get/set the PATH to the message data. + +I setting the path recomputes any existing "content-length" field, +and re-sets the "filename" (to the last element of the path if it +looks like a simple path, and to nothing if not). + +=cut + + +sub path { + my $self = shift; + if (@_) { + + ### Set the path, and invalidate the content length: + $self->{Path} = shift; + + ### Re-set filename, extracting it from path if possible: + my $filename; + if ( $self->{Path} and ( $self->{Path} !~ /\|$/ ) ) { ### non-shell path: + ( $filename = $self->{Path} ) =~ s/^filename($filename); + + ### Reset the length: + $self->get_length; + } + $self->{Path}; +} + +#------------------------------ + =item resetfh [FILEHANDLE] -Set the current position of the filehandle back to the beginning. +I +Set the current position of the filehandle back to the beginning. Only applies if you used "FH" in build() or attach() for this message. Returns false if unable to reset the filehandle (since not all filehandles @@ -1235,50 +1841,55 @@ are seekable). =cut + #---- -# Miko's note: With the Data and Path, the same data could theoretically -# be reused. However, file handles need to be reset to be reused, +# Miko's note: With the Data and Path, the same data could theoretically +# be reused. However, file handles need to be reset to be reused, # so I added this routine. # # Eryq reply: beware... not all filehandles are seekable (think about STDIN)! sub resetfh { my $self = shift; - seek($self->{FH},0,0); + seek( $self->{FH}, 0, 0 ); } #------------------------------ -=item read_now +=item read_now +I Forces data from the path/filehandle (as specified by C) to be read into core immediately, just as though you had given it -literally with the C keyword. +literally with the C keyword. Note that the in-core data will always be used if available. -Be aware that everything is slurped into a giant scalar: you may not want -to use this if sending tar files! The benefit of I reading in the data +Be aware that everything is slurped into a giant scalar: you may not want +to use this if sending tar files! The benefit of I reading in the data is that very large files can be handled by this module if left on disk until the message is output via C or C. =cut + sub read_now { my $self = shift; local $/ = undef; - - if ($self->{FH}) { # data from a filehandle: - my $chunk; - $self->{Data} = ''; - CORE::binmode($self->{FH}) if $self->binmode; - while (read($self->{FH}, $chunk, 1024)) {$self->{Data} .= $chunk} - } - elsif ($self->{Path}) { # data from a path: - open SLURP, $self->{Path} or croak "open $self->{Path}: $!"; - CORE::binmode(SLURP) if $self->binmode; - $self->{Data} = ; # sssssssssssssslurp... - close SLURP; # ...aaaaaaaaahhh! + + if ( $self->{FH} ) { ### data from a filehandle: + my $chunk; + my @chunks; + CORE::binmode( $self->{FH} ) if $self->binmode; + while ( read( $self->{FH}, $chunk, 1024 ) ) { + push @chunks, $chunk; + } + $self->{Data} = join '', @chunks; + } elsif ( $self->{Path} ) { ### data from a path: + open SLURP, $self->{Path} or Carp::croak "open $self->{Path}: $!\n"; + CORE::binmode(SLURP) if $self->binmode; + $self->{Data} = ; ### sssssssssssssslurp... + close SLURP; ### ...aaaaaaaaahhh! } } @@ -1286,6 +1897,7 @@ sub read_now { =item sign PARAMHASH +I Sign the message. This forces the message to be read into core, after which the signature is appended to it. @@ -1310,34 +1922,146 @@ The content-length is recomputed. =cut + sub sign { - my $self = shift; + my $self = shift; my %params = @_; - # Default: + ### Default: @_ or $params{Path} = "$ENV{HOME}/.signature"; - # Force message in-core: - defined($self->{Data}) or $self->read_now; + ### Force message in-core: + defined( $self->{Data} ) or $self->read_now; - # Load signature: + ### Load signature: my $sig; - if (!defined($sig = $params{Data})) { # not given explicitly: - local $/ = undef; - open SIG, $params{Path} or croak "open sig $params{Path}: $!"; - $sig = ; # sssssssssssssslurp... - close SIG; # ...aaaaaaaaahhh! - } - $sig = join('',@$sig) if (ref($sig) and (ref($sig) eq 'ARRAY')); - - # Append, following Internet conventions: + if ( !defined( $sig = $params{Data} ) ) { ### not given explicitly: + local $/ = undef; + open SIG, $params{Path} or Carp::croak "open sig $params{Path}: $!\n"; + $sig = ; ### sssssssssssssslurp... + close SIG; ### ...aaaaaaaaahhh! + } + $sig = join( '', @$sig ) if ( ref($sig) and ( ref($sig) eq 'ARRAY' ) ); + + ### Append, following Internet conventions: $self->{Data} .= "\n-- \n$sig"; - # Re-compute length: + ### Re-compute length: $self->get_length; 1; } +#------------------------------ +# +# =item suggest_encoding CONTENTTYPE +# +# I +# Based on the CONTENTTYPE, return a good suggested encoding. +# C and C types have their bodies scanned line-by-line +# for 8-bit characters and long lines; lack of either means that the +# message is 7bit-ok. Other types are chosen independent of their body: +# +# Major type: 7bit ok? Suggested encoding: +# ------------------------------------------------------------ +# text yes 7bit +# no quoted-printable +# unknown binary +# +# message yes 7bit +# no binary +# unknown binary +# +# multipart n/a binary (in case some parts are not ok) +# +# (other) n/a base64 +# +#=cut + +sub suggest_encoding { + my ( $self, $ctype ) = @_; + $ctype = lc($ctype); + + ### Consult MIME::Types, maybe: + if ($HaveMimeTypes) { + + ### Mappings contain [suffix,mimetype,encoding] + my @mappings = MIME::Types::by_mediatype($ctype); + if ( scalar(@mappings) ) { + ### Just pick the first one: + my ( $suffix, $mimetype, $encoding ) = @{ $mappings[0] }; + if ( $encoding + && $encoding =~ /^(base64|binary|[78]bit|quoted-printable)$/i ) + { + return lc($encoding); ### sanity check + } + } + } + + ### If we got here, then MIME::Types was no help. + ### Extract major type: + my ($type) = split '/', $ctype; + if ( ( $type eq 'text' ) || ( $type eq 'message' ) ) { ### scan message body? + return 'binary'; + } else { + return ( $type eq 'multipart' ) ? 'binary' : 'base64'; + } +} + +#------------------------------ +# +# =item suggest_type PATH +# +# I +# Suggest the content-type for this attached path. +# We always fall back to "application/octet-stream" if no good guess +# can be made, so don't use this if you don't mean it! +# +sub suggest_type { + my ( $self, $path ) = @_; + + ### If there's no path, bail: + $path or return 'application/octet-stream'; + + ### Consult MIME::Types, maybe: + if ($HaveMimeTypes) { + + # Mappings contain [mimetype,encoding]: + my ( $mimetype, $encoding ) = MIME::Types::by_suffix($path); + return $mimetype if ( $mimetype && $mimetype =~ /^\S+\/\S+$/ ); ### sanity check + } + ### If we got here, then MIME::Types was no help. + ### The correct thing to fall back to is the most-generic content type: + return 'application/octet-stream'; +} + +#------------------------------ + +=item verify_data + +I +Verify that all "paths" to attached data exist, recursively. +It might be a good idea for you to do this before a print(), to +prevent accidental partial output if a file might be missing. +Raises exception if any path is not readable. + +=cut + + +sub verify_data { + my $self = shift; + + ### Verify self: + my $path = $self->{Path}; + if ( $path and ( $path !~ /\|$/ ) ) { ### non-shell path: + $path =~ s/^{Parts} } ) { $part->verify_data } + 1; +} + =back =cut @@ -1352,164 +2076,258 @@ sub sign { =cut + #------------------------------ =item print [OUTHANDLE] -I +I Print the message to the given output handle, or to the currently-selected filehandle if none was given. -All OUTHANDLE has to be is a filehandle (possibly a glob ref), or +All OUTHANDLE has to be is a filehandle (possibly a glob ref), or any object that responds to a print() message. =cut + sub print { - my ($self, $out) = @_; + my ( $self, $out ) = @_; - # Coerce into a printable output handle: - $out = wrap MIME::Lite::IO_Handle $out; + ### Coerce into a printable output handle: + $out = MIME::Lite::IO_Handle->wrap($out); - # Output the head and its terminating blank line: - $self->print_header($out); - $out->print("\n"); + ### Output head, separator, and body: + $self->verify_data if $AUTO_VERIFY; ### prevents missing parts! + $out->print( $self->header_as_string, "\n" ); + $self->print_body($out); +} - # Output either the body or the parts. - # Notice that we key off of the content-type! We expect fewer - # accidents that way, since the syntax will always match the MIME type. - if ($self->attr('content-type') !~ m{^multipart/}i) { - $self->print_body($out); # Single part - } - else { # Multipart... - my $boundary = $self->attr('content-type.boundary'); - - # Preamble: - $out->print("This is a multi-part message in MIME format.\n"); - - # Parts: - my $part; - foreach $part (@{$self->{Parts}}) { - $out->print("\n--$boundary\n"); - $part->print($out); - } - $out->print("\n--$boundary--\n\n"); - } - 1; +#------------------------------ +# +# print_for_smtp +# +# Instance method, private. +# Print, but filter out the topmost "Bcc" field. +# This is because qmail apparently doesn't do this for us! +# +sub print_for_smtp { + my ( $self, $out ) = @_; + + ### Coerce into a printable output handle: + $out = MIME::Lite::IO_Handle->wrap($out); + + ### Create a safe head: + my @fields = grep { $_->[0] ne 'bcc' } @{ $self->fields }; + my $header = $self->fields_as_string( \@fields ); + + ### Output head, separator, and body: + $out->print( $header, "\n" ); + $self->print_body( $out, '1' ); } #------------------------------ -=item print_body [OUTHANDLE] +=item print_body [OUTHANDLE] [IS_SMTP] -I -Print the body of the message to the given output handle, -or to the currently-selected filehandle if none was given. +I +Print the body of a message to the given output handle, or to +the currently-selected filehandle if none was given. -All OUTHANDLE has to be is a filehandle (possibly a glob ref), or +All OUTHANDLE has to be is a filehandle (possibly a glob ref), or any object that responds to a print() message. B raised if unable to open any of the input files, -or if a part contains no data, or if an unsupported encoding is +or if a part contains no data, or if an unsupported encoding is encountered. +IS_SMPT is a special option to handle SMTP mails a little more +intelligently than other send mechanisms may require. Specifically this +ensures that the last byte sent is NOT '\n' (octal \012) if the last two +bytes are not '\r\n' (\015\012) as this will cause some SMTP servers to +hang. + =cut + sub print_body { - my ($self, $out) = @_; - - # Coerce into a printable output handle: - $out = wrap MIME::Lite::IO_Handle $out; - - # Get content-transfer-encoding: - my $encoding = uc($self->attr('content-transfer-encoding')); - - # Notice that we don't just attempt to slurp the data in from a file: - # by processing files piecemeal, we still enable ourselves to prepare - # very large MIME messages... - - # Is the data in-core? If so, blit it out... - if (defined($self->{Data})) { - DATA: - { $_ = $encoding; - - /^BINARY$/ and do { - $out->print($self->{Data}); - last DATA; - }; - /^8BIT$/ and do { - $out->print(encode_8bit($self->{Data})); - last DATA; - }; - /^7BIT$/ and do { - $out->print(encode_7bit($self->{Data})); - last DATA; - }; - /^QUOTED-PRINTABLE$/ and do { - while ($self->{Data}=~ m{^.*[\r\n]*}mg) { - $out->print(encode_qp($&)); # have to do it line by line... - } - last DATA; - }; - /^BASE64/ and do { - $out->print(encode_base64($self->{Data})); - last DATA; - }; - croak "unsupported encoding: `$_'"; + my ( $self, $out, $is_smtp ) = @_; + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; + + ### Coerce into a printable output handle: + $out = MIME::Lite::IO_Handle->wrap($out); + + ### Output either the body or the parts. + ### Notice that we key off of the content-type! We expect fewer + ### accidents that way, since the syntax will always match the MIME type. + my $type = $attrs->{'content-type'}; + if ( $type =~ m{^multipart/}i ) { + my $boundary = $sub_attrs->{'content-type'}{'boundary'}; + + ### Preamble: + $out->print( defined( $self->{Preamble} ) + ? $self->{Preamble} + : "This is a multi-part message in MIME format.\n" + ); + + ### Parts: + my $part; + foreach $part ( @{ $self->{Parts} } ) { + $out->print("\n--$boundary\n"); + $part->print($out); + } + + ### Epilogue: + $out->print("\n--$boundary--\n\n"); + } elsif ( $type =~ m{^message/} ) { + my @parts = @{ $self->{Parts} }; + + ### It's a toss-up; try both data and parts: + if ( @parts == 0 ) { $self->print_simple_body( $out, $is_smtp ) } + elsif ( @parts == 1 ) { $parts[0]->print($out) } + else { Carp::croak "can't handle message with >1 part\n"; } + } else { + $self->print_simple_body( $out, $is_smtp ); + } + 1; +} + +#------------------------------ +# +# print_simple_body [OUTHANDLE] +# +# I +# Print the body of a simple singlepart message to the given +# output handle, or to the currently-selected filehandle if none +# was given. +# +# Note that if you want to print "the portion after +# the header", you don't want this method: you want +# L. +# +# All OUTHANDLE has to be is a filehandle (possibly a glob ref), or +# any object that responds to a print() message. +# +# B raised if unable to open any of the input files, +# or if a part contains no data, or if an unsupported encoding is +# encountered. +# +sub print_simple_body { + my ( $self, $out, $is_smtp ) = @_; + my $attrs = $self->{Attrs}; + + ### Coerce into a printable output handle: + $out = MIME::Lite::IO_Handle->wrap($out); + + ### Get content-transfer-encoding: + my $encoding = uc( $attrs->{'content-transfer-encoding'} ); + warn "M::L >>> Encoding using $encoding, is_smtp=" . ( $is_smtp || 0 ) . "\n" + if $MIME::Lite::DEBUG; + + ### Notice that we don't just attempt to slurp the data in from a file: + ### by processing files piecemeal, we still enable ourselves to prepare + ### very large MIME messages... + + ### Is the data in-core? If so, blit it out... + if ( defined( $self->{Data} ) ) { + DATA: + { + local $_ = $encoding; + + /^BINARY$/ and do { + $is_smtp and $self->{Data} =~ s/(?!\r)\n\z/\r/; + $out->print( $self->{Data} ); + last DATA; + }; + /^8BIT$/ and do { + $out->print( encode_8bit( $self->{Data} ) ); + last DATA; + }; + /^7BIT$/ and do { + $out->print( encode_7bit( $self->{Data} ) ); + last DATA; + }; + /^QUOTED-PRINTABLE$/ and do { + ### UNTAINT since m//mg on tainted data loops forever: + my ($untainted) = ( $self->{Data} =~ m/\A(.*)\Z/s ); + + ### Encode it line by line: + while ( $untainted =~ m{^(.*[\r\n]*)}smg ) { + ### have to do it line by line... + my $line = $1; # copy to avoid weird bug; rt 39334 + $out->print( encode_qp($line) ); + } + last DATA; + }; + /^BASE64/ and do { + $out->print( encode_base64( $self->{Data} ) ); + last DATA; + }; + Carp::croak "unsupported encoding: `$_'\n"; } } - # Else, is the data in a file? If so, output piecemeal... - # Miko's note: this routine pretty much works the same with a path - # or a filehandle. the only difference in behaviour is that it does - # not attempt to open anything if it already has a filehandle - elsif (defined($self->{Path}) || defined($self->{FH})) { - no strict 'refs'; # in case FH is not an object - my $DATA; - - # Open file if necessary: - if (defined($self->{Path})) { - $DATA = new FileHandle || croak "can't get new filehandle!"; - $DATA->open("$self->{Path}") or croak "open $self->{Path}: $!"; - } - else { - $DATA=$self->{FH}; - } - CORE::binmode($DATA) if $self->binmode; - - # Encode piece by piece: - PATH: - { $_ = $encoding; - - /^BINARY$/ and do { - $out->print($_) while read($DATA, $_, 2048); - last PATH; - }; - /^8BIT$/ and do { - $out->print(encode_8bit($_)) while (<$DATA>); - last PATH; - }; - /^7BIT$/ and do { - $out->print(encode_7bit($_)) while (<$DATA>); - last PATH; - }; - /^QUOTED-PRINTABLE$/ and do { - $out->print(encode_qp($_)) while (<$DATA>); - last PATH; - }; - /^BASE64$/ and do { - $out->print(encode_base64($_)) while (read($DATA, $_, 45)); - last PATH; - }; - croak "unsupported encoding: `$_'"; - } - - # Close file: - close $DATA if defined($self->{Path}); + ### Else, is the data in a file? If so, output piecemeal... + ### Miko's note: this routine pretty much works the same with a path + ### or a filehandle. the only difference in behaviour is that it does + ### not attempt to open anything if it already has a filehandle + elsif ( defined( $self->{Path} ) || defined( $self->{FH} ) ) { + no strict 'refs'; ### in case FH is not an object + my $DATA; + + ### Open file if necessary: + if ( defined( $self->{Path} ) ) { + $DATA = new FileHandle || Carp::croak "can't get new filehandle\n"; + $DATA->open("$self->{Path}") + or Carp::croak "open $self->{Path}: $!\n"; + } else { + $DATA = $self->{FH}; + } + CORE::binmode($DATA) if $self->binmode; + + ### Encode piece by piece: + PATH: + { + local $_ = $encoding; + + /^BINARY$/ and do { + my $last = ""; + while ( read( $DATA, $_, 2048 ) ) { + $out->print($last) if length $last; + $last = $_; + } + if ( length $last ) { + $is_smtp and $last =~ s/(?!\r)\n\z/\r/; + $out->print($last); + } + last PATH; + }; + /^8BIT$/ and do { + $out->print( encode_8bit($_) ) while (<$DATA>); + last PATH; + }; + /^7BIT$/ and do { + $out->print( encode_7bit($_) ) while (<$DATA>); + last PATH; + }; + /^QUOTED-PRINTABLE$/ and do { + $out->print( encode_qp($_) ) while (<$DATA>); + last PATH; + }; + /^BASE64$/ and do { + $out->print( encode_base64($_) ) while ( read( $DATA, $_, 45 ) ); + last PATH; + }; + Carp::croak "unsupported encoding: `$_'\n"; + } + + ### Close file: + close $DATA if defined( $self->{Path} ); } - + else { - croak "no data in this part!"; + Carp::croak "no data in this part\n"; } 1; } @@ -1518,23 +2336,24 @@ sub print_body { =item print_header [OUTHANDLE] -I -Print the header of the message to the given output handle, +I +Print the header of the message to the given output handle, or to the currently-selected filehandle if none was given. -All OUTHANDLE has to be is a filehandle (possibly a glob ref), or +All OUTHANDLE has to be is a filehandle (possibly a glob ref), or any object that responds to a print() message. =cut + sub print_header { - my ($self, $out) = @_; + my ( $self, $out ) = @_; - # Coerce into a printable output handle: - $out = wrap MIME::Lite::IO_Handle $out; + ### Coerce into a printable output handle: + $out = MIME::Lite::IO_Handle->wrap($out); - # Output the header: - $out->print($self->header_as_string); + ### Output the header: + $out->print( $self->header_as_string ); 1; } @@ -1542,70 +2361,89 @@ sub print_header { =item as_string -I +I Return the entire message as a string, with a header and an encoded body. =cut + sub as_string { my $self = shift; - my $str = ""; - my $io = (wrap MIME::Lite::IO_Scalar \$str); + my $buf = ""; + my $io = ( wrap MIME::Lite::IO_Scalar \$buf); $self->print($io); - $str; + return $buf; } -*stringify = \&as_string; # backwards compatibility +*stringify = \&as_string; ### backwards compatibility +*stringify = \&as_string; ### ...twice to avoid warnings :) #------------------------------ =item body_as_string -I +I Return the encoded body as a string. +This is the portion after the header and the blank line. I actually prepares the body by "printing" to a scalar. -Proof that you can hand the C methods any blessed object +Proof that you can hand the C methods any blessed object that responds to a C message. =cut + sub body_as_string { my $self = shift; - my $str = ""; - my $io = (wrap MIME::Lite::IO_Scalar \$str); + my $buf = ""; + my $io = ( wrap MIME::Lite::IO_Scalar \$buf); $self->print_body($io); - $str; + return $buf; +} +*stringify_body = \&body_as_string; ### backwards compatibility +*stringify_body = \&body_as_string; ### ...twice to avoid warnings :) + +#------------------------------ +# +# fields_as_string FIELDS +# +# PRIVATE! Return a stringified version of the given header +# fields, where FIELDS is an arrayref like that returned by fields(). +# +sub fields_as_string { + my ( $self, $fields ) = @_; + my $out = ""; + foreach (@$fields) { + my ( $tag, $value ) = @$_; + next if ( $value eq '' ); ### skip empties + $tag =~ s/\b([a-z])/uc($1)/ge; ### make pretty + $tag =~ s/^mime-/MIME-/i; ### even prettier + $out .= "$tag: $value\n"; + } + return $out; } -*stringify_body = \&body_as_string; # backwards compatibility #------------------------------ =item header_as_string -I +I Return the header as a string. =cut + sub header_as_string { my $self = shift; - my $str = ''; - foreach (@{$self->fields}) { - my ($tag, $value) = @$_; - $tag =~ s/\b([a-z])/uc($1)/ge; # make pretty - $tag =~ s/^mime-/MIME-/ig; # even prettier - $str .= "$tag: $value\n"; - } - $str; + $self->fields_as_string( $self->fields ); } -*stringify_header = \&header_as_string; # backwards compatibility +*stringify_header = \&header_as_string; ### backwards compatibility +*stringify_header = \&header_as_string; ### ...twice to avoid warnings :) =back =cut - #============================== #============================== @@ -1615,41 +2453,80 @@ sub header_as_string { =cut + #------------------------------ =item send =item send HOW, HOWARGS... -I -This is the principle method for sending mail, and for configuring +I +This is the principal method for sending mail, and for configuring how mail will be sent. -I (with no arguments), sends the message by whatever -means has been set up (the default is to use the Unix "sendmail" program). -Returns whatever the mail-handling routine returns: this should be true -on success, false/exception on error: +I with a HOW argument and optional HOWARGS, it sets +the default sending mechanism that the no-argument instance method +will use. The HOW is a facility name (B), +and the HOWARGS is interpreted by the facilty. +The class method returns the previous HOW and HOWARGS as an array. + + MIME::Lite->send('sendmail', "d:\\programs\\sendmail.exe"); + ... + $msg = MIME::Lite->new(...); + $msg->send; + +I +(a HOW argument and optional HOWARGS), sends the message in the +requested manner; e.g.: + + $msg->send('sendmail', "d:\\programs\\sendmail.exe"); + +I sends the +message by the default mechanism set up by the class method. +Returns whatever the mail-handling routine returns: this +should be true on success, false/exception on error: $msg = MIME::Lite->new(From=>...); $msg->send || die "you DON'T have mail!"; -I (with a HOW argument and optional HOWARGS), sets up -how the instance method will work for all objects until further notice. -It treats HOW as a facility name, with optional HOWARGS handled by -the facility. There are three facilities: +On Unix systems (or rather non-Win32 systems), the default +setting is equivalent to: + + MIME::Lite->send("sendmail", "/usr/lib/sendmail -t -oi -oem"); + +On Win32 systems the default setting is equivalent to: + + MIME::Lite->send("smtp"); + +The assumption is that on Win32 your site/lib/Net/libnet.cfg +file will be preconfigured to use the appropriate SMTP +server. See below for configuring for authentication. + +There are three facilities: =over 4 -=item "sendmail", SENDMAILCMD +=item "sendmail", ARGS... Send a message by piping it into the "sendmail" command. -Uses the C method, giving it the SENDMAILCMD. +Uses the L method, giving it the ARGS. This usage implements (and deprecates) the C method. - -=item "smtp", [HOSTNAME] + +=item "smtp", [HOSTNAME, [NAMEDPARMS] ] Send a message by SMTP, using optional HOSTNAME as SMTP-sending host. -Uses the C method. +Uses the L method. Any additional +arguments passed in will also be passed through to send_by_smtp. +This is useful for things like mail servers requiring authentication +where you can say something like the following + + MIME::List->send('smtp', $host, AuthUser=>$user, AuthPass=>$pass); + +which will configure things so future uses of + + $msg->send(); + +do the right thing. =item "sub", \&SUBREF, ARGS... @@ -1673,88 +2550,465 @@ That's it. Now, if you ever move your script to a Unix box, all you need to do is change that line in the setup and you're done. All of your $msg-Esend invocations will work as expected. +After sending, the method last_send_successful() can be used to determine +if the send was succesful or not. + =cut + sub send { my $self = shift; - if (ref($self)) { # instance method: - my $method = "send_by_$Sender"; - my @args = @{$SenderArgs{$Sender} || []}; - return $self->$method(@args); - } - else { # class method: - $Sender = shift; - $SenderArgs{$Sender} = [@_]; # remaining args - return 1; + my $meth = shift; + + if ( ref($self) ) { ### instance method: + my ( $method, @args ); + if (@_) { ### args; use them just this once + $method = 'send_by_' . $meth; + @args = @_; + } else { ### no args; use defaults + $method = "send_by_$Sender"; + @args = @{ $SenderArgs{$Sender} || [] }; + } + $self->verify_data if $AUTO_VERIFY; ### prevents missing parts! + Carp::croak "Unknown send method '$meth'" unless $self->can($method); + return $self->$method(@args); + } else { ### class method: + if (@_) { + my @old = ( $Sender, @{ $SenderArgs{$Sender} } ); + $Sender = $meth; + $SenderArgs{$Sender} = [@_]; ### remaining args + return @old; + } else { + Carp::croak "class method send must have HOW... arguments\n"; + } } } + #------------------------------ =item send_by_sendmail SENDMAILCMD +=item send_by_sendmail PARAM=>VALUE, ARRAY, HASH... + I -Send message via the external "sendmail" program, SENDMAILCMD. +Send message via an external "sendmail" program +(this will probably only work out-of-the-box on Unix systems). + Returns true on success, false or exception on error. -I this facility will probably only work on Unix systems. -The SENDMAILCMD for this facility must get all its message-specific -information from the standard input. +You can specify the program and all its arguments by giving a single +string, SENDMAILCMD. Nothing fancy is done; the message is simply +piped in. + +However, if your needs are a little more advanced, you can specify +zero or more of the following PARAM/VALUE pairs (or a reference to hash +or array of such arguments as well as any combination thereof); a +Unix-style, taint-safe "sendmail" command will be constructed for you: + +=over 4 + +=item Sendmail + +Full path to the program to use. +Default is "/usr/lib/sendmail". + +=item BaseArgs + +Ref to the basic array of arguments we start with. +Default is C<["-t", "-oi", "-oem"]>. + +=item SetSender + +Unless this is I given as false, we attempt to automatically +set the C<-f> argument to the first address that can be extracted from +the "From:" field of the message (if there is one). + +I +Suppose we did I use C<-f>, and you gave an explicit "From:" +field in your message: in this case, the sendmail "envelope" would +indicate the I user your process was running under, as a way +of preventing mail forgery. Using the C<-f> switch causes the sender +to be set in the envelope as well. + +I +If sendmail doesn't regard you as a "trusted" user, it will permit +the C<-f> but also add an "X-Authentication-Warning" header to the message +to indicate a forged envelope. To avoid this, you can either +(1) have SetSender be false, or +(2) make yourself a trusted user by adding a C configuration + command to your I file + (e.g.: C if the script is running as user "eryq"). + +=item FromSender + +If defined, this is identical to setting SetSender to true, +except that instead of looking at the "From:" field we use +the address given by this option. +Thus: + + FromSender => 'me@myhost.com' + +=back + +After sending, the method last_send_successful() can be used to determine +if the send was succesful or not. =cut +sub _unfold_stupid_params { + my $self = shift; + + my %p; + STUPID_PARAM: for (my $i = 0; $i < @_; $i++) { ## no critic Loop + my $item = $_[$i]; + if (not ref $item) { + $p{ $item } = $_[ ++$i ]; + } elsif (UNIVERSAL::isa($item, 'HASH')) { + $p{ $_ } = $item->{ $_ } for keys %$item; + } elsif (UNIVERSAL::isa($item, 'ARRAY')) { + for (my $j = 0; $j < @$item; $j += 2) { + $p{ $item->[ $j ] } = $item->[ $j + 1 ]; + } + } + } + + return %p; +} + sub send_by_sendmail { - my ($self, $sendmailcmd) = @_; + my $self = shift; + my $return; + if ( @_ == 1 and !ref $_[0] ) { + ### Use the given command... + my $sendmailcmd = shift @_; + Carp::croak "No sendmail command available" unless $sendmailcmd; + + ### Do it: + local *SENDMAIL; + open SENDMAIL, "|$sendmailcmd" or Carp::croak "open |$sendmailcmd: $!\n"; + $self->print( \*SENDMAIL ); + close SENDMAIL; + $return = ( ( $? >> 8 ) ? undef: 1 ); + } else { ### Build the command... + my %p = $self->_unfold_stupid_params(@_); + + $p{Sendmail} = $SENDMAIL unless defined $p{Sendmail}; + + ### Start with the command and basic args: + my @cmd = ( $p{Sendmail}, @{ $p{BaseArgs} || [ '-t', '-oi', '-oem' ] } ); + + ### See if we are forcibly setting the sender: + $p{SetSender} ||= defined( $p{FromSender} ); + + ### Add the -f argument, unless we're explicitly told NOT to: + if ( $p{SetSender} ) { + my $from = $p{FromSender} || ( $self->get('From') )[0]; + if ($from) { + my ($from_addr) = extract_full_addrs($from); + push @cmd, "-f$from_addr" if $from_addr; + } + } - # Do it: - my $pid; - open SENDMAIL, "|$sendmailcmd" or croak "open |$sendmailcmd: $!"; - $self->print(\*SENDMAIL); - close SENDMAIL; - return (($? >> 8) ? undef : 1); + ### Open the command in a taint-safe fashion: + my $pid = open SENDMAIL, "|-"; + defined($pid) or die "open of pipe failed: $!\n"; + if ( !$pid ) { ### child + exec(@cmd) or die "can't exec $p{Sendmail}: $!\n"; + ### NOTREACHED + } else { ### parent + $self->print( \*SENDMAIL ); + close SENDMAIL || die "error closing $p{Sendmail}: $! (exit $?)\n"; + $return = 1; + } + } + return $self->{last_send_successful} = $return; } #------------------------------ -=item send_by_smtp [ARGS...] +=item send_by_smtp HOST, ARGS... + +=item send_by_smtp REF, HOST, ARGS I -Send message via SMTP, using Net::SMTP. -The ARGS are sent into Net::SMTP::new(): usually, these are +Send message via SMTP, using Net::SMTP. - MAILHOST, OPTION=>VALUE, ... +HOST is the name of SMTP server to connect to, or undef to have +L use the defaults in Libnet.cfg. -Returns true on success, false or exception on error. +ARGS are a list of key value pairs which may be selected from the list +below. Many of these are just passed through to specific +L commands and you should review that module for +details. + +Please see L + +=over 4 + +=item Hello + +=item LocalAddr + +=item LocalPort + +=item Timeout + +=item Port + +=item ExactAddresses + +=item Debug + +See L for details. + +=item Size + +=item Return + +=item Bits + +=item Transaction + +=item Envelope + +See L for details. + +=item SkipBad + +If true doesnt throw an error when multiple email addresses are provided +and some are not valid. See L +for details. + +=item AuthUser + +Authenticate with L using this username. + +=item AuthPass + +Authenticate with L using this password. + +=item NoAuth + +Normally if AuthUser and AuthPass are defined MIME::Lite will attempt to +use them with the L command to +authenticate the connection, however if this value is true then no +authentication occurs. + +=item To + +Sets the addresses to send to. Can be a string or a reference to an +array of strings. Normally this is extracted from the To: (and Cc: and +Bcc: fields if $AUTO_CC is true). + +This value overrides that. + +=item From + +Sets the email address to send from. Normally this value is extracted +from the Return-Path: or From: field of the mail itself (in that order). + +This value overides that. + +=back + +I +True on success, croaks with an error message on failure. + +After sending, the method last_send_successful() can be used to determine +if the send was succesful or not. =cut -# Provided by Andrew McRae. Version 0.2 anm 09Sep97 + +# Derived from work by Andrew McRae. Version 0.2 anm 09Sep97 # Copyright 1997 Optimation New Zealand Ltd. # May be modified/redistributed under the same terms as Perl. -# + +# external opts +my @_mail_opts = qw( Size Return Bits Transaction Envelope ); +my @_recip_opts = qw( SkipBad ); +my @_net_smtp_opts = qw( Hello LocalAddr LocalPort Timeout + Port ExactAddresses Debug ); +# internal: qw( NoAuth AuthUser AuthPass To From Host); + +sub __opts { + my $args=shift; + return map { exists $args->{$_} ? ( $_ => $args->{$_} ) : () } @_; +} + sub send_by_smtp { - my ($self, @args) = @_; + require Net::SMTP; + my ($self,$hostname,%args) = @_; + # We may need the "From:" and "To:" headers to pass to the + # SMTP mailer also. + $self->{last_send_successful}=0; + + my @hdr_to = extract_only_addrs( scalar $self->get('To') ); + if ($AUTO_CC) { + foreach my $field (qw(Cc Bcc)) { + push @hdr_to, extract_only_addrs($_) for $self->get($field); + } + } + Carp::croak "send_by_smtp: nobody to send to for host '$hostname'?!\n" + unless @hdr_to; + + $args{To} ||= \@hdr_to; + $args{From} ||= extract_only_addrs( scalar $self->get('Return-Path') ); + $args{From} ||= extract_only_addrs( scalar $self->get('From') ) ; + + # Create SMTP client. + # MIME::Lite::SMTP is just a wrapper giving a print method + # to the SMTP object. + + my %opts = __opts(\%args, @_net_smtp_opts); + my $smtp = MIME::Lite::SMTP->new( $hostname, %opts ) + or Carp::croak "SMTP Failed to connect to mail server: $!\n"; + + # Possibly authenticate + if ( defined $args{AuthUser} and defined $args{AuthPass} + and !$args{NoAuth} ) + { + if ($smtp->supports('AUTH',500,["Command unknown: 'AUTH'"])) { + $smtp->auth( $args{AuthUser}, $args{AuthPass} ) + or die "SMTP auth() command failed: $!\n" + . $smtp->message . "\n"; + } else { + die "SMTP auth() command not supported on $hostname\n"; + } + } + + # Send the mail command + %opts = __opts( \%args, @_mail_opts); + $smtp->mail( $args{From}, %opts ? \%opts : () ) + or die "SMTP mail() command failed: $!\n" + . $smtp->message . "\n"; + + # Send the recipients command + %opts = __opts( \%args, @_recip_opts); + $smtp->recipient( @{ $args{To} }, %opts ? \%opts : () ) + or die "SMTP recipient() command failed: $!\n" + . $smtp->message . "\n"; + + # Send the data + $smtp->data() + or die "SMTP data() command failed: $!\n" + . $smtp->message . "\n"; + $self->print_for_smtp($smtp); + + # Finish the mail + $smtp->dataend() + or Carp::croak "Net::CMD (Net::SMTP) DATAEND command failed.\n" + . "Last server message was:" + . $smtp->message + . "This probably represents a problem with newline encoding "; + + # terminate the session + $smtp->quit; + + return $self->{last_send_successful} = 1; +} + +=item send_by_testfile FILENAME + +I +Print message to a file (namely FILENAME), which will default to +mailer.testfile +If file exists, message will be appended. + +=cut + +sub send_by_testfile { + my $self = shift; + + ### Use the default filename... + my $filename = 'mailer.testfile'; + + if ( @_ == 1 and !ref $_[0] ) { + ### Use the given filename if given... + $filename = shift @_; + Carp::croak "no filename given to send_by_testfile" unless $filename; + } + + ### Do it: + local *FILE; + open FILE, ">> $filename" or Carp::croak "open $filename: $!\n"; + $self->print( \*FILE ); + close FILE; + my $return = ( ( $? >> 8 ) ? undef: 1 ); + + return $self->{last_send_successful} = $return; +} + +=item last_send_successful + +This method will return TRUE if the last send() or send_by_XXX() method call was +successful. It will return defined but false if it was not successful, and undefined +if the object had not been used to send yet. + +=cut + + +sub last_send_successful { + my $self = shift; + return $self->{last_send_successful}; +} + + +### Provided by Andrew McRae. Version 0.2 anm 09Sep97 +### Copyright 1997 Optimation New Zealand Ltd. +### May be modified/redistributed under the same terms as Perl. +### Aditional changes by Yves. +### Until 3.01_03 this was send_by_smtp() +sub send_by_smtp_simple { + my ( $self, @args ) = @_; + $self->{last_send_successful} = 0; + ### We need the "From:" and "To:" headers to pass to the SMTP mailer: + my $hdr = $self->fields(); + + my $from_header = $self->get('From'); + my ($from) = extract_only_addrs($from_header); + + warn "M::L>>> $from_header => $from" if $MIME::Lite::DEBUG; + + + my $to = $self->get('To'); - # We need the "From:" and "To:" headers to pass to the SMTP mailer: - my $hdr = $self->fields(); - my $from = $self->get('From'); - my @to = $self->get('To'); + ### Sanity check: + defined($to) + or Carp::croak "send_by_smtp: missing 'To:' address\n"; - # Create SMTP client: + ### Get the destinations as a simple array of addresses: + my @to_all = extract_only_addrs($to); + if ($AUTO_CC) { + foreach my $field (qw(Cc Bcc)) { + my $value = $self->get($field); + push @to_all, extract_only_addrs($value) + if defined($value); + } + } + + ### Create SMTP client: require Net::SMTP; my $smtp = MIME::Lite::SMTP->new(@args) - or croak "Failed to connect to mail server: $!"; + or Carp::croak("Failed to connect to mail server: $!\n"); $smtp->mail($from) - or croak "SMTP MAIL command failed: $!"; - $smtp->to(@to) - or croak "SMTP RCPT command failed: $!"; + or Carp::croak( "SMTP MAIL command failed: $!\n" . $smtp->message . "\n" ); + $smtp->to(@to_all) + or Carp::croak( "SMTP RCPT command failed: $!\n" . $smtp->message . "\n" ); $smtp->data() - or croak "SMTP DATA command failed: $!"; + or Carp::croak( "SMTP DATA command failed: $!\n" . $smtp->message . "\n" ); + + ### MIME::Lite can print() to anything with a print() method: + $self->print_for_smtp($smtp); - # MIME::Lite can print() to anything with a print() method: - $self->print($smtp); - $smtp->dataend(); + $smtp->dataend() + or Carp::croak( "Net::CMD (Net::SMTP) DATAEND command failed.\n" + . "Last server message was:" + . $smtp->message + . "This probably represents a problem with newline encoding " ); $smtp->quit; + $self->{last_send_successful} = 1; 1; } @@ -1766,23 +3020,25 @@ sub send_by_smtp { # Send the message via an anonymous subroutine. # sub send_by_sub { - my ($self, $subref, @args) = @_; - &$subref($self, @args); + my ( $self, $subref, @args ) = @_; + $self->{last_send_successful} = &$subref( $self, @args ); + } #------------------------------ =item sendmail COMMAND... -I +I Declare the sender to be "sendmail", and set up the "sendmail" command. I =cut + sub sendmail { my $self = shift; - $self->send('sendmail', join(' ', @_)); + $self->send( 'sendmail', join( ' ', @_ ) ); } =back @@ -1790,7 +3046,6 @@ sub sendmail { =cut - #============================== #============================== @@ -1800,14 +3055,15 @@ sub sendmail { =cut + #------------------------------ =item quiet ONOFF -I +I Suppress/unsuppress all warnings coming from this module. - quiet MIME::Lite 1; # I know what I'm doing + MIME::Lite->quiet(1); ### I know what I'm doing I recommend that you include that comment as well. And while you type it, say it out loud: if it doesn't feel right, then maybe @@ -1815,6 +3071,7 @@ you should reconsider the whole line. C<;-)> =cut + sub quiet { my $class = shift; $QUIET = shift if @_; @@ -1826,7 +3083,6 @@ sub quiet { =cut - #============================================================ package MIME::Lite::SMTP; @@ -1839,8 +3095,35 @@ use strict; use vars qw( @ISA ); @ISA = qw(Net::SMTP); -sub print { shift->datasend(@_) } +# some of the below is borrowed from Data::Dumper +my %esc = ( "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + +sub _hexify { + local $_ = shift; + my @split = m/(.{1,16})/gs; + foreach my $split (@split) { + ( my $txt = $split ) =~ s/([\a\b\t\n\f\r\e])/$esc{$1}/sg; + $split =~ s/(.)/sprintf("%02X ",ord($1))/sge; + print STDERR "M::L >>> $split : $txt\n"; + } +} +sub print { + my $smtp = shift; + $MIME::Lite::DEBUG and _hexify( join( "", @_ ) ); + $smtp->datasend(@_) + or Carp::croak( "Net::CMD (Net::SMTP) DATASEND command failed.\n" + . "Last server message was:" + . $smtp->message + . "This probably represents a problem with newline encoding " ); +} #============================================================ @@ -1849,24 +3132,24 @@ package MIME::Lite::IO_Handle; #============================================================ -# Wrap a non-object filehandle inside a blessed, printable interface: -# Does nothing if the given $fh is already a blessed object. +### Wrap a non-object filehandle inside a blessed, printable interface: +### Does nothing if the given $fh is already a blessed object. sub wrap { - my ($class, $fh) = @_; + my ( $class, $fh ) = @_; no strict 'refs'; - # Get default, if necessary: - $fh or $fh = select; # no filehandle means selected one - ref($fh) or $fh = \*$fh; # scalar becomes a globref - - # Stop right away if already a printable object: - return $fh if (ref($fh) and (ref($fh) ne 'GLOB')); + ### Get default, if necessary: + $fh or $fh = select; ### no filehandle means selected one + ref($fh) or $fh = \*$fh; ### scalar becomes a globref - # Get and return a printable interface: - bless \$fh, $class; # wrap it in a printable interface + ### Stop right away if already a printable object: + return $fh if ( ref($fh) and ( ref($fh) ne 'GLOB' ) ); + + ### Get and return a printable interface: + bless \$fh, $class; ### wrap it in a printable interface } -# Print: +### Print: sub print { my $self = shift; print {$$self} @_; @@ -1879,17 +3162,37 @@ package MIME::Lite::IO_Scalar; #============================================================ -# Wrap a scalar inside a blessed, printable interface: +### Wrap a scalar inside a blessed, printable interface: sub wrap { - my ($class, $scalarref) = @_; + my ( $class, $scalarref ) = @_; defined($scalarref) or $scalarref = \""; bless $scalarref, $class; } -# Print: +### Print: +sub print { + ${$_[0]} .= join( '', @_[1..$#_] ); + 1; +} + + +#============================================================ + +package MIME::Lite::IO_ScalarArray; + +#============================================================ + +### Wrap an array inside a blessed, printable interface: +sub wrap { + my ( $class, $arrayref ) = @_; + defined($arrayref) or $arrayref = []; + bless $arrayref, $class; +} + +### Print: sub print { my $self = shift; - $$self .= join('', @_); + push @$self, @_; 1; } @@ -1899,9 +3202,75 @@ __END__ #============================================================ + =head1 NOTES -=head2 Limitations + +=head2 How do I prevent "Content" headers from showing up in my mail reader? + +Apparently, some people are using mail readers which display the MIME +headers like "Content-disposition", and they want MIME::Lite not +to generate them "because they look ugly". + +Sigh. + +Y'know, kids, those headers aren't just there for cosmetic purposes. +They help ensure that the message is I correctly by mail +readers. But okay, you asked for it, you got it... +here's how you can suppress the standard MIME headers. +Before you send the message, do this: + + $msg->scrub; + +You can scrub() any part of a multipart message independently; +just be aware that it works recursively. Before you scrub, +note the rules that I follow: + +=over 4 + +=item Content-type + +You can safely scrub the "content-type" attribute if, and only if, +the part is of type "text/plain" with charset "us-ascii". + +=item Content-transfer-encoding + +You can safely scrub the "content-transfer-encoding" attribute +if, and only if, the part uses "7bit", "8bit", or "binary" encoding. +You are far better off doing this if your lines are under 1000 +characters. Generally, that means you I scrub it for plain +text, and you can I scrub this for images, etc. + +=item Content-disposition + +You can safely scrub the "content-disposition" attribute +if you trust the mail reader to do the right thing when it decides +whether to show an attachment inline or as a link. Be aware +that scrubbing both the content-disposition and the content-type +means that there is no way to "recommend" a filename for the attachment! + +B there are reports of brain-dead MUAs out there that +do the wrong thing if you I the content-disposition. +If your attachments keep showing up inline or vice-versa, +try scrubbing this attribute. + +=item Content-length + +You can always scrub "content-length" safely. + +=back + +=head2 How do I give my attachment a [different] recommended filename? + +By using the Filename option (which is different from Path!): + + $msg->attach(Type => "image/gif", + Path => "/here/is/the/real/file.GIF", + Filename => "logo.gif"); + +You should I put path information in the Filename. + +=head2 Benign limitations This is "lite", after all... @@ -1913,8 +3282,8 @@ There's no parsing. Get MIME-tools if you need to parse MIME messages. =item * -MIME::Lite messages are currently I interchangeable with -either Mail::Internet or MIME::Entity objects. This is a completely +MIME::Lite messages are currently I interchangeable with +either Mail::Internet or MIME::Entity objects. This is a completely separate module. =item * @@ -1928,32 +3297,85 @@ it's not in the MIME RFCs, it's an HTTP thing), this seems pretty fair. =item * MIME::Lite alone cannot help you lose weight. You must supplement -your use of MIME::Lite with a healthy diet and exercise. +your use of MIME::Lite with a healthy diet and exercise. =back =head2 Cheap and easy mailing -I thought putting in a default "sendmail" invocation wasn't too bad an -idea, since a lot of Perlers are on UNIX systems. The default arguments -to sendmail (which you can change) are: +I thought putting in a default "sendmail" invocation wasn't too bad an +idea, since a lot of Perlers are on UNIX systems. (As of version 3.02 this is +default only on Non-Win32 boxen. On Win32 boxen the default is to use SMTP and the +defaults specified in the site/lib/Net/libnet.cfg) + +The out-of-the-box configuration is: + + MIME::Lite->send('sendmail', "/usr/lib/sendmail -t -oi -oem"); + +By the way, these arguments to sendmail are: -t Scan message for To:, Cc:, Bcc:, etc. - + -oi Do NOT treat a single "." on a line as a message terminator. As in, "-oi vey, it truncated my message... why?!" - + -oem On error, mail back the message (I assume to the appropriate address, given in the header). - When mail returns, circle is complete. Jai guru deva -oem. + When mail returns, circle is complete. Jai Guru Deva -oem. + +Note that these are the same arguments you get if you configure to use +the smarter, taint-safe mailing: + + MIME::Lite->send('sendmail'); + +If you get "X-Authentication-Warning" headers from this, you can forgo +diddling with the envelope by instead specifying: + + MIME::Lite->send('sendmail', SetSender=>0); + +And, if you're not on a Unix system, or if you'd just rather send mail +some other way, there's always SMTP, which these days probably requires +authentication so you probably need to say + + MIME::Lite->send('smtp', "smtp.myisp.net", + AuthUser=>"YourName",AuthPass=>"YourPass" ); + +Or you can set up your own subroutine to call. +In any case, check out the L method. + + +=head1 WARNINGS -If you're not on a Unix system, or if you'd just rather send mail -some other way, check out the C method. There's built in -support for SMTP delivery, or you can slip in your own hooks. +=head2 Good-vs-bad email addresses with send_by_smtp() +If using L, be aware that unless you +explicitly provide the email addresses to send to and from you will be +forcing MIME::Lite to extract email addresses out of a possible list +provided in the C, C, and C fields. This is tricky +stuff, and as such only the following sorts of addresses will work +reliably: -=head2 Under the hood + username + full.name@some.host.com + "Name, Full" + +B +MIME::Lite was never intended to be a Mail User Agent, so please +don't expect a full implementation of RFC-822. Restrict yourself to +the common forms of Internet addresses described herein, and you should +be fine. If this is not feasible, then consider using MIME::Lite +to I your message only, and using Net::SMTP explicitly to +I your message. + +B +As of MIME::Lite v3.02 the mail name extraction routines have been +beefed up considerably. Furthermore if Mail::Address if provided then +name extraction is done using that. Accordingly the above advice is now +less true than it once was. Funky email names I work properly +now. However the disclaimer remains. Patches welcome. :-) + +=head2 Formatting of headers delayed until print() This class treats a MIME header in the most abstract sense, as being a collection of high-level attributes. The actual @@ -1961,34 +3383,91 @@ RFC-822-style header fields are not constructed until it's time to actually print the darn thing. +=head2 Encoding of data delayed until print() -=head1 WARNINGS +When you specify message bodies +(in L or L) -- +whether by B, B, or B -- be warned that we don't +attempt to open files, read filehandles, or encode the data until +L is invoked. + +In the past, this created some confusion for users of sendmail +who gave the wrong path to an attachment body, since enough of +the print() would succeed to get the initial part of the message out. +Nowadays, $AUTO_VERIFY is used to spot-check the Paths given before +the mail facility is employed. A whisker slower, but tons safer. + +Note that if you give a message body via FH, and try to print() +a message twice, the second print() will not do the right thing +unless you explicitly rewind the filehandle. + +You can get past these difficulties by using the B option, +provided that you have enough memory to handle your messages. -B the MIME attributes are stored and manipulated separately -from the message header fields; when it comes time to print the + +=head2 MIME attributes are separate from header fields! + +B the MIME attributes are stored and manipulated separately +from the message header fields; when it comes time to print the header out, I That means that this: ### DANGER ### DANGER ### DANGER ### DANGER ### DANGER ### $msg->add("Content-type", "text/html; charset=US-ASCII"); -will set the exact C<"Content-type"> field in the header I write, +will set the exact C<"Content-type"> field in the header I write, I I as an escape hatch in case -the code that normally formats MIME header fields isn't doing what +the code that normally formats MIME header fields isn't doing what you need. And, like any escape hatch, it's got an alarm on it: MIME::Lite will warn you if you attempt to C or C any MIME header field. Use C instead. +=head2 Beware of lines consisting of a single dot + +Julian Haight noted that MIME::Lite allows you to compose messages +with lines in the body consisting of a single ".". +This is true: it should be completely harmless so long as "sendmail" +is used with the -oi option (see L<"Cheap and easy mailing">). + +However, I don't know if using Net::SMTP to transfer such a message +is equally safe. Feedback is welcomed. + +My perspective: I don't want to magically diddle with a user's +message unless absolutely positively necessary. +Some users may want to send files with "." alone on a line; +my well-meaning tinkering could seriously harm them. + + +=head2 Infinite loops may mean tainted data! + +Stefan Sautter noticed a bug in 2.106 where a m//gc match was +failing due to tainted data, leading to an infinite loop inside +MIME::Lite. + +I am attempting to correct for this, but be advised that my fix will +silently untaint the data (given the context in which the problem +occurs, this should be benign: I've labelled the source code with +UNTAINT comments for the curious). + +So: don't depend on taint-checking to save you from outputting +tainted data in a message. + + +=head2 Don't tweak the global configuration + +Global configuration variables are bad, and should go away. +Until they do, please follow the hints with each setting +on how I to change it. =head1 A MIME PRIMER =head2 Content types -The "Type" parameter of C is a I. -This is the actual type of data you are sending. +The "Type" parameter of C is a I. +This is the actual type of data you are sending. Generally this is a string of the form C<"majortype/minortype">. Here are the major MIME types. @@ -1998,8 +3477,8 @@ A more-comprehensive listing may be found in RFC-2046. =item application -Data which does not fit in any of the other categories, particularly -data to be processed by some type of application program. +Data which does not fit in any of the other categories, particularly +data to be processed by some type of application program. C, C, C... =item audio @@ -2048,13 +3527,13 @@ A more-comprehensive listing may be found in RFC-2045. =item 7bit Basically, no I encoding is done. However, this label guarantees that no -8-bit characters are present, and that lines do not exceed 1000 characters +8-bit characters are present, and that lines do not exceed 1000 characters in length. =item 8bit -Basically, no I encoding is done. The message might contain 8-bit -characters, but this encoding guarantees that lines do not exceed 1000 +Basically, no I encoding is done. The message might contain 8-bit +characters, but this encoding guarantees that lines do not exceed 1000 characters in length. =item binary @@ -2062,142 +3541,158 @@ characters in length. No encoding is done at all. Message might contain 8-bit characters, and lines might be longer than 1000 characters long. -The most liberal, and the least likely to get through mail gateways. +The most liberal, and the least likely to get through mail gateways. Use sparingly, or (better yet) not at all. =item base64 Like "uuencode", but very well-defined. This is how you should send -essentially binary information (tar files, GIFs, JPEGs, etc.). +essentially binary information (tar files, GIFs, JPEGs, etc.). =item quoted-printable -Useful for encoding messages which are textual in nature, yet which contain +Useful for encoding messages which are textual in nature, yet which contain non-ASCII characters (e.g., Latin-1, Latin-2, or any other 8-bit alphabet). =back +=cut -=head1 CHANGE LOG - -B -$Id$ - -=over 4 - - -=item Version 1.133 - -Fixed bug in "Data" handling: arrayrefs were not being handled -properly. - - -=item Version 1.130 - -Added much larger and more-flexible send() facility. -I - -Added get() method for extracting basic attributes. - -New... "t" tests! - +=begin FOR_README_ONLY -=item Version 1.124 +=head1 INSTALLATION -Folded in filehandle (FH) support in build/attach. -I +Install using + perl makefile.pl + make test + make install -=item Version 1.122 +Adjust the make command as is appropriate for your OS. +'nmake' is the usual name under Win32 -MIME::Base64 and MIME::QuotedPrint are used if available. +In order to read the docmentation please use -The 7bit encoding no longer does "escapes"; it merely strips 8-bit characters. + perldoc MIME::Lite +from the command line or visit -=item Version 1.121 + http://search.cpan.org/search?query=MIME%3A%3ALite&mode=all -Filename attribute is now no longer ignored by build(). -I +for a list of all MIME::Lite related materials including the +documentation in HTML of all of the released versions of +MIME::Lite. +=cut -=item Version 1.120 -Efficiency hack to speed up MIME::Lite::IO_Scalar. -I +=end FOR_README_ONLY +=cut -=item Version 1.116 -Small bug in our private copy of encode_base64() was patched. -I +=head1 HELPER MODULES -New, prettier way of specifying mail message headers in C. +MIME::Lite works nicely with other certain other modules if they are present. +Good to have installed is the latest L, +L, L, +L. -New quiet method to turn off warnings. +If they aren't present then some functionality won't work, and other features +wont be as efficient or up to date as they could be. Nevertheless they are optional +extras. -Changed "stringify" methods to more-standard "as_string" methods. +=head1 BUNDLED GOODIES +MIME::Lite comes with a number of extra files in the distribution bundle. +This includes examples, and utility modules that you can use to get yourself +started with the module. -=item Version 1.112 +The ./examples directory contains a number of snippets in prepared +form, generally they are documented, but they should be easy to understand. -Added C, and C method for our non-Unix-using brethren: -file data is now read using binmode() if appropriate. -I +The ./contrib directory contains a companion/tool modules that come bundled +with MIME::Lite, they dont get installed by default. Please review the POD they +come with. +=head1 BUGS -=item Version 1.110 +The whole reason that version 3.0 was released was to ensure that MIME::Lite +is up to date and patched. If you find an issue please report it. -Fixed bug in opening the data filehandle. +As far as I know MIME::Lite doesnt currently have any serious bugs, but my usage +is hardly comprehensive. +Having said that there are a number of open issues for me, mostly caused by the progress +in the community as whole since Eryq last released. The tests are based around an +interesting but non standard test framework. I'd like to change it over to using +Test::More. -=item Version 1.102 +Should tests fail please review the ./testout directory, and in any bug reports +please include the output of the relevent file. This is the only redeeming feature +of not using Test::More that I can see. -Initial release. +Bug fixes / Patches / Contribution are welcome, however I probably won't apply them +unless they also have an associated test. This means that if I dont have the time to +write the test the patch wont get applied, so please, include tests for any patches +you provide. +=head1 VERSION -=item Version 1.101 +Version: 3.027 -Baseline code. +=head1 CHANGE LOG -=back +Moved to ./changes.pod +NOTE: Users of the "advanced features" of 3.01_0x smtp sending +should take care: These features have been REMOVED as they never +really fit the purpose of the module. Redundant SMTP delivery is +a task that should be handled by another module. =head1 TERMS AND CONDITIONS -Copyright (c) 1997 by Eryq. -Copyright (c) 1998 by ZeeGee Software Inc. -All rights reserved. This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. + Copyright (c) 1997 by Eryq. + Copyright (c) 1998 by ZeeGee Software Inc. + Copyright (c) 2003,2005 Yves Orton. (demerphq) + +All rights reserved. This program is free software; you can +redistribute it and/or modify it under the same terms as Perl +itself. This software comes with B of any kind. See the COPYING file in the distribution for details. - =head1 NUTRITIONAL INFORMATION For some reason, the US FDA says that this is now required by law on any products that bear the name "Lite"... - Serving size: 1 module - Servings per container: 1 - Calories: 0 - Fat: 0g - Saturated Fat: 0g +Version 3.0 is now new and improved! The distribution is now 30% smaller! - Warning: for consumption by hardware only! May produce - indigestion in humans if taken internally. + MIME::Lite | + ------------------------------------------------------------ + Serving size: | 1 module + Servings per container: | 1 + Calories: | 0 + Fat: | 0g + Saturated Fat: | 0g +Warning: for consumption by hardware only! May produce +indigestion in humans if taken internally. =head1 AUTHOR Eryq (F). President, ZeeGee Software Inc. (F). -Created: 11 December 1996. Ho ho ho. +Go to F for the latest downloads +and on-line documentation for this module. Enjoy. + +Patches And Maintenance by Yves Orton and many others. +Consult ./changes.pod =cut + diff --git a/lib/site/OW.pm b/lib/site/OW.pm index 892f7b646..9af3c068d 100755 --- a/lib/site/OW.pm +++ b/lib/site/OW.pm @@ -1,16 +1,16 @@ # This file was automatically generated by SWIG (http://www.swig.org). -# Version 1.3.33 +# Version 1.3.40 # -# Don't modify this file, modify the SWIG interface instead. +# Do not make changes to this file unless you know what you are doing--modify +# the SWIG interface file instead. package OW; -require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use base qw(Exporter); +use base qw(DynaLoader); package OWc; bootstrap OW; package OW; -@EXPORT = qw( ); +@EXPORT = qw(); # ---------- BASE METHODS ------------- @@ -58,6 +58,7 @@ package OW; *get_error_print = *OWc::get_error_print; *set_error_level = *OWc::set_error_level; *get_error_level = *OWc::get_error_level; +*opt = *OWc::opt; # ------- VARIABLE STUBS -------- diff --git a/lib/trigger_code.pl b/lib/trigger_code.pl index 08b8745be..72953747a 100644 --- a/lib/trigger_code.pl +++ b/lib/trigger_code.pl @@ -1,12 +1,29 @@ -use strict; -# Monitors trigger code, used by code like tv_grid and the web alarm page, -# that specifies events that trigger actions. View, add, modify, or -# delete triggers with http://localhost:8080/bin/triggers.pl +=pod + +=head1 NAME + +trigger_code.pl - Misterhouse's trigger code + +=head1 DESCRIPTION + +This file contains code that implements Misterhouse's trigger functionality. +Monitors trigger code, used by code like tv_grid and the web alarm page, +that specifies events that trigger actions. View, add, modify, or +delete triggers with http://localhost:8080/bin/triggers.pl +(also under the ia5 MrHouse Home button). + +You can create triggers to easily run mh code on specified events. +When you create a trigger with trigger_set, mh will create or modify +the code_dir/triggers.mhp file. + +=cut # $Date$ # $Revision$ +use strict; + use vars '%triggers'; # use vars so we can use in the web server my ($trigger_write_code_flag, $prev_triggers, $prev_script); @@ -14,20 +31,20 @@ my $expired_file = "$::config_parms{data_dir}/triggers.expired"; my $script_file = "$::Code_Dirs[0]/triggers.mhp"; -&::MainLoop_pre_add_hook (\&triggers_loop, 1); -&::Exit_add_hook (\&triggers_save, 1); +&::MainLoop_pre_add_hook (\&_triggers_loop, 1); +&::Exit_add_hook (\&_triggers_save, 1); +$prev_triggers = &file_read($trigger_file) if -e $trigger_file; +$prev_script = &file_read($script_file) if -e $script_file; +&_triggers_read if -e $trigger_file; +&_trigger_write_code; -sub triggers_loop { - &triggers_read if $Reload and -e $trigger_file; - $prev_triggers = &file_read($trigger_file) if $Reload and -e $trigger_file; - $prev_script = &file_read($script_file) if $Reload and -e $script_file; - &triggers_save if new_minute 5; - &trigger_write_code if $trigger_write_code_flag; -} +sub _triggers_loop { + &_triggers_save if $trigger_write_code_flag or ($New_Hour and %triggers); + &_trigger_write_code if $trigger_write_code_flag; +} # Read current triggers file at startup -sub triggers_read { - # Read trigger data +sub _triggers_read { return unless -e $trigger_file; my $i = 0; @@ -44,11 +61,12 @@ sub triggers_read { $trigger = $record;; } else { - next if $record =~ /^\d+ \d+$/; # Old trigger format ... ignore + # Old trigger format ... ignore + next if $record =~ /^\d+ \d+$/; $code .= $record . "\n"; } } - # Assume there is always a blank line at end of file + # Assume there is always a blank line at end of file elsif ($trigger) { trigger_set($trigger, $code, $type, $name, 1, $triggered); $trigger = $code = $name = $type = $triggered = ''; @@ -58,38 +76,8 @@ sub triggers_read { print " - read $i trigger entries\n"; } - # Write trigger code -sub trigger_write_code { - $trigger_write_code_flag = 0; - my $script; - foreach my $name (trigger_list()) { - my ($trigger, $code, $type, $triggered, $trigger_error, $code_error) = trigger_get($name); - next unless $trigger; - next if $trigger_error; - $script .= "\n# name=$name type=$type\n"; - $script .= "if (($trigger) and &trigger_active('$name')) {\n"; - $script .= " # FYI trigger code: $code;\n"; - $script .= " &trigger_run('$name',1);\n}\n"; - } - $script = "#\n#@ You shouldn't edit this file. This file is auto-generated by mh/lib/trigger_code.pl. If there are \n" . - "#@ syntax errors here, you should delete this file and edit $::config_parms{data_dir}/triggers.current. \n" . - "#@ This file will be recreated when Misterhouse is next started.\n#\n" . $script; - return if $script eq $prev_script; - $prev_script = $script; - &file_write($script_file, $script); - # Replace (faster) or reload (if there was no file previously) - if ($::Run_Members{'triggers_table'}) { - &do_user_file("$::Code_Dirs[0]/triggers.mhp"); - } - else { - # Must be done before the user code eval - push @Nextpass_Actions, \&read_code; - } - -} - - # Save and prune out expired triggers -sub triggers_save { + # Save and prune out week old expired triggers +sub _triggers_save { my ($data, $data1, $data2, $i1, $i2); $i1 = $i2 = 0; $data1 = $data2 = ''; @@ -103,20 +91,21 @@ sub triggers_save { if (trigger_expired($name) and ($triggers{$name}{triggered} + 60*60*24*7) < $Time) { $data2 .= $data . "\n"; $i2++; - delete $triggers{$name}; + trigger_delete($name); } else { $data1 .= $data . "\n"; $i1++; } } - print_log "Saving triggers: $i2 expired, $i1 saved" if $i2; - $data1 = '# + if ($data) { + print_log "triggers_save: $i2 expired, $i1 saved" if $i2 or $Debug{'trigger'}; + $data1 = '# # Note: Do NOT edit this file while mh is running (edits will be lost). # It is used by mh/lib/trigger_code.pl to auto-generate code_dir/triggers.mhp. # It is updated by various trigger_ functions like trigger_set. -# If Misterhouse will not start because of a code error in this file, fix the -# error here, remove triggers.mhp, and restart Misterhouse. +# If Misterhouse will not start because of a code error in this file, fix the +# error here, remove triggers.mhp, and restart Misterhouse. # # Syntax is: # name=trigger name type=trigger_type triggered=triggered_time @@ -126,36 +115,146 @@ sub triggers_save { # # Expired triggers will be pruned to triggers.expired a week after they expire. # - ' . $data1; - $data2 = "# Expired on $Time_Date\n" . $data2 if $data2; - unless ($data1 eq $prev_triggers) { - &file_write($trigger_file, $data1); - &logit($expired_file, $data2, 0) if $data2; - $trigger_write_code_flag++; + $data2 = "# Expired on $Time_Date\n" . $data2 if $data2; + if ($data1 eq $prev_triggers) { + print_log "triggers_save: no triggers changed" if $Debug{'trigger'}; + } + else { + &file_write($trigger_file, $data1); + &logit($expired_file, $data2, 0) if $data2; + $trigger_write_code_flag++; + } + $prev_triggers = $data1; + } + else { + print_log "triggers_save: no triggers to write" if $Debug{'trigger'}; + if (-e $trigger_file) { + $trigger_write_code_flag = 1; + unlink $trigger_file; + $trigger_write_code_flag++; + } + $prev_triggers = ""; + return; + } +} + +# Write trigger code if changed +sub _trigger_write_code { + $trigger_write_code_flag = 0; + my $script; + foreach my $name (trigger_list()) { + my ($trigger, $code, $type, $triggered, $trigger_error, $code_error) + = trigger_get($name); + next unless $trigger; + next if $trigger_error; + # don't include expired or disabled triggers in script + next unless $type eq 'NoExpire' or $type eq 'OneShot'; + $script .= "\n# name=$name type=$type\n"; + $script .= "if (($trigger) and &trigger_active('$name')) {\n"; + $script .= " # FYI trigger code: $code;\n"; + $script .= " &trigger_run('$name',1);\n}\n"; + } + if ($script) { + $script = "# +# You shouldn't edit this file. This file is auto-generated by +# mh/lib/trigger_code.pl. +# If there are syntax errors here, you should delete this file and edit +# $::config_parms{data_dir}/triggers.current. This file will be recreated +# when Misterhouse is next started. +# +" . $script; + print_log "trigger_write_code: this sub was called, but triggers" + . " not changed", return if $script eq $prev_script; + $prev_script = $script; + &file_write($script_file, $script); + # Replace (faster) or reload (if there was no file previously) + if ($main::Run_Members{'triggers_table'}) { + print_log "trigger_write_code: trigger script $script_file" + . " written, running do_user_file" if $Debug{'trigger'}; + &do_user_file("$::Code_Dirs[0]/triggers.mhp"); + } + else { + # Must be done before the user code eval + print_log "trigger_write_code: trigger script $script_file" + . " written, running read_code" if $Debug{'trigger'}; + push @Nextpass_Actions, \&read_code; + } + } + else { + print_log "trigger_write_code: no script to write" if $Debug{'trigger'}; + if (-e $script_file) { + # reload on next pass if we remove trigger script + push @Nextpass_Actions, \&read_code; + unlink $script_file if -e $script_file; # don't write empty script + } + $prev_script = ""; + return; } - $prev_triggers = $data1; - return; } - # this routine does all the heavy lifting re modifying, renaming, copying triggers +=head1 SUBROUTINES + +=over 4 + +=item C + +Creates or modified an existing trigger. Only event and code are +required. The code will run when event returns true. +The type defaults to OneShot (see below) and $name +will default to a unique auto-generated name. If name is specified +and already exists, name will be incremented, unless replace=1. +triggered is the last time the trigger ran in epoch second. + +If new_name is specified, trigger name is renamed to new_name and the other +arguments are applied. + +The event string is evaluated to check for errors and the trigger doesn't +run any are found. The code is always run in an eval, so Misterhouse +won't crash if you type an error. + +Examples: + + &trigger_set("time_now '$date $time - 00:02'", + "speak 'Something cool happens in 2 minutes'"); + + &trigger_set("time_now '$Save{wakeup_time}'", + "speak 'Time to wake up'", "NoExpire", "Wakeup Trigger", 1); + +Another example of using triggers is in mh/code/common/tv_grid.pl. + +Here are the valid trigger types: + + OneShot => The trigger will run once, then changed type to Expired + + Expired => Will be pruned from the triggers.mhp file after one week + and archived in data_dir/triggers.expired. + + NoExpire => Runs on every event and never expires. + + Disabled => Will stay in your triggers.mph file, but will not run. + +=cut + +# this routine does the heavy lifting re modifying, renaming, copying triggers sub trigger_set { my ($trigger, $code, $type, $name, $replace, $triggered, $new_name) = @_; - print_log "trigger_set: trigger=$trigger code=$code type=$type name=$name replace=$replace triggered=$triggered new_name=$new_name" if $Debug{'trigger'}; return unless $trigger and $code; - $trigger =~ s/[;\s\r\n]*$//g; # in case trigger file was edited on windows + $trigger =~ s/[;\s\r\n]*$//g; # in case trigger file was edited on windows $code =~ s/[;\s\r\n]*$//g; # So we can consistenly add ;\n when used $triggered = 0 unless $triggered; $type = 'OneShot' unless $type; - # Give it a name if missing + # Give it a name if missing $name = time_date_stamp(12) unless $name; - # Find a uniq name if copying, should also handle renaming if new name is taken + if (exists $triggers{$name} and $replace) { - print_log "trigger $name already exists, modifying"; + print_log "trigger $name already exists, modifying" + if $Debug{'trigger'}; } + # Find a uniq name if copying elsif (exists $triggers{$name}) { $name =~ s/ \d+$//; my $i = 2; @@ -163,9 +262,11 @@ sub trigger_set { print_log "trigger $name already exists, adding '$i' to name"; $name = "$name $i"; } - print_log "trigger_set: trigger=$trigger code=$code type=$type name=$name replace=$replace triggered=$triggered new_name=$new_name" if $Debug{'trigger'}; - - # Flag an error if trigger is bad, can't test code here without running it + print_log "trigger_set: trigger=$trigger code=$code type=$type name=$name + replace=$replace triggered=$triggered new_name=$new_name" + if $Debug{'trigger'}; + + # Flag an error if trigger is bad, can't test code here without running it eval $trigger; if ($@) { $triggers{$name}{'trigger_error'} = $@; @@ -186,18 +287,31 @@ sub trigger_set { delete $triggers{$name}; } - $trigger_write_code_flag++; + $trigger_write_code_flag++ unless $Reload; return; } +=item C + +Returns the event, code, type, last triggered time, event error (if any), +and code error (if any) of the specified trigger. + +=cut + sub trigger_get { my $name = shift; return 0 unless exists $triggers{$name}; return 1 unless wantarray; - return $triggers{$name}{trigger}, $triggers{$name}{code}, $triggers{$name}{type}, $triggers{$name}{triggered}, + return $triggers{$name}{trigger}, $triggers{$name}{code}, + $triggers{$name}{type}, $triggers{$name}{triggered}, $triggers{$name}{trigger_error}, $triggers{$name}{code_error}; } +=item C + +Deletes the specified trigger. + +=cut sub trigger_delete { my $name = shift; @@ -207,6 +321,13 @@ sub trigger_delete { return; } +=item C + +Copies the specified trigger, the new name has a sequential number appended +to the old name. + +=cut + sub trigger_copy { my $name = shift; my $trigger = $triggers{$name}{trigger}; @@ -261,7 +382,20 @@ sub trigger_set_type { my $code = $triggers{$name}{code}; my $type = shift; my $replace = 1; - my $triggered = $triggers{$name}{triggerd}; + my $triggered = $triggers{$name}{triggered}; + trigger_set($trigger, $code, $type, $name, $replace, $triggered); + return; +} + +sub trigger_expire { + my $name = shift; + return unless exists $triggers{$name} and $triggers{$name}{type} + eq 'OneShot'; + my $trigger = $triggers{$name}{trigger}; + my $code = $triggers{$name}{code}; + my $type = 'Expired'; + my $replace = 1; + my $triggered = $Time; trigger_set($trigger, $code, $type, $name, $replace, $triggered); return; } @@ -269,14 +403,16 @@ sub trigger_set_type { sub trigger_run { my ($name,$expire) = @_; if (!exists $triggers{$name}) { - &print_log("Trigger '$name' does not exist"); + &print_log("trigger_run: trigger '$name' does not exist"); return; } - &trigger_expire($name) if $expire; my ($trigger, $code, $type, $triggered) = trigger_get($name); - &print_log ("Running trigger code for: $name") if $Debug{trigger}; + &print_log ("trigger_run: running trigger code for: $name") + if $Debug{trigger}; eval $code; - &print_log ("Finished running trigger code for: $name") if $Debug{trigger}; + trigger_set($trigger, $code, $type, $name, 1, $Time); + &print_log ("trigger_run: finished running trigger code for: $name") + if $Debug{trigger}; if ($@) { &print_log("Error: trigger '$name' failed to run cleanly"); &print_log(" Code = $code"); @@ -284,40 +420,49 @@ sub trigger_run { # At this point we could opt to disable the trigger # but it is likely more useful to have a repeating error message # to let the user know that something is wrong - # The following hash entry allows us to show the error in the web interface + # The following hash entry allows us to show the error in the + # web interface $triggers{$name}{code_error} = $@; } else { delete $triggers{$name}{code_error}; } + &trigger_expire($name) if $expire; return; } +=item C + +Returns a list of trigger names. + +=cut sub trigger_list { return sort keys %triggers; } +=item C + +Returns true if the trigger is active. + +=cut + sub trigger_active { my $name = shift; -# print "db n=$name t=$triggers{$name}{type} e=!$triggers{$name}{triggered}\n"; return (exists $triggers{$name} and - ($triggers{$name}{type} eq 'NoExpire' or $triggers{$name}{type} eq 'OneShot') and - (not exists $triggers{$name}{'trigger_error'}) + ($triggers{$name}{type} eq 'NoExpire' or $triggers{$name}{type} + eq 'OneShot') and (not exists $triggers{$name}{'trigger_error'}) ); } +=item C + +Returns true if the trigger is expired. + +=cut + sub trigger_expired { my $name = shift; return (exists $triggers{$name} and $triggers{$name}{type} eq 'Expired'); } -sub trigger_expire { - my $name = shift; - $triggers{$name}{triggered} = $Time; - return unless exists $triggers{$name} and $triggers{$name}{type} eq 'OneShot'; -# print "db setting name=$name expire_time=$Time\n"; - $triggers{$name}{type} = 'Expired'; - return; -} - 1; diff --git a/lib/xml_server.pl b/lib/xml_server.pl index e95b2d329..5ad29cd7e 100644 --- a/lib/xml_server.pl +++ b/lib/xml_server.pl @@ -215,25 +215,61 @@ sub xml { return &xml_page($xml); } +sub item_watcher { + my $item_list = shift; + my $field = shift; + + my @items = split ',', $item_list; + my ($xml, $tmp_xml); + foreach (@items) { + next unless my ($item, $state) = m/(.+)=(.*)/; + my $object = &get_object_by_name($item); + if ($state ne $object->state) { + $tmp_xml .= &object_detail($object, 0, state => 1, $field => 1); + } + + } + if ($tmp_xml) { + $xml .= "\t\n$tmp_xml\t\n"; + # Translate special characters + $xml = encode_entities($xml, "\200-\377&"); + $xml = &xml_page($xml); + } + return $xml; +} + sub object_detail { my ($object, $updates_only, %fields) = @_; - return if $fields{none}; + return if defined $fields{none} and $fields{none}; + $fields{all} = 1 unless %fields; return if ($updates_only and ! $object->{state_now}); my $object_name = $object->{object_name}; my $xml_objects = "\t\t\t\n"; $xml_objects .= "\t\t\t\t$object_name\n"; - $xml_objects .= "\t\t\t\t$object->{filename}\n" if $fields{all} or $fields{filename}; - $xml_objects .= "\t\t\t\t$object->{category}\n" if $fields{all} or $fields{category}; + $xml_objects .= "\t\t\t\t$object->{filename}\n" if $fields{all} or $fields{filename}; + $xml_objects .= "\t\t\t\t$object->{category}\n" + if ($fields{all} or $fields{category}) and exists $object->{category}; + $xml_objects .= "\t\t\t\t$object->{rf_id}\n" + if ($fields{all} or $fields{rf_id}) and exists $object->{rf_id}; my $state = encode_entities($object->{state}, "\200-\377&<>"); $xml_objects .= "\t\t\t\t$state\n" if $fields{all} or $fields{state}; -# $xml_objects .= "\t\t\t\t" . $object->get_set_by . "\n" if defined &$object->get_set_by; + $xml_objects .= "\t\t\t\t" . $object->get_set_by . "\n" + if ($fields{all} or $fields{set_by}) and exists $object->{get_set_by}; $xml_objects .= "\t\t\t\t$object->{get_type}\n" if $fields{all} or $fields{type}; - $xml_objects .= "\t\t\t\t@{$object->{states}}\n" if $fields{all} or $fields{states}; + $xml_objects .= "\t\t\t\t$object->{get_states}}\n" if $fields{all} or $fields{states}; + $xml_objects .= "\t\t\t\t" . $object->get_idle_time . "\n" + if ($fields{all} or $fields{idle_time}) and exists $object->{get_idle_time}; $xml_objects .= "\t\t\t\t$object->{text}\n" if $fields{all} or $fields{text}; $xml_objects .= "\t\t\t\t{get_type}) . "\]\]>\n\t\t\t\t\n" if $fields{all} or $fields{html}; - if ($object->{get_type} eq 'Timer') { - $xml_objects .= "\t\t\t\t" . $object->seconds_remaining . "\n"; + + my @alt_fields = qw(seconds_remaining level); + foreach my $field (@alt_fields) { + next unless $fields{all} or $fields{$field}; + my $method = $field; + $method = 'get_' . $method unless exists $object->{$method}; + next unless exists $object->{$method}; + $xml_objects .= "\t\t\t\t<$field>$object->{$method}\n"; } $xml_objects .= "\t\t\t\n"; return $xml_objects; @@ -243,16 +279,13 @@ sub xml_page { my ($xml) = @_; return if ($updates_only and ! $xml); -# -# - return < - + $xml diff --git a/web/bin/button_action.pl b/web/bin/button_action.pl index 2717f8e6e..4c6fddf78 100644 --- a/web/bin/button_action.pl +++ b/web/bin/button_action.pl @@ -11,7 +11,7 @@ #print "db ln=$list_name, i=$item, s=$state_xy xy=$x,$y\n"; # Do not dim the dishwasher :) -unless (eval qq|$item->isa('X10_Appliance') or $item->isa('Fan_Motor')|) { +unless (eval qq|$item->isa('X10_Appliance') or $item->isa('Fan_Motor') or $item->isa('Insteon_Device')|) { $state = 'dim' if $x < 40; # Left side of image $state = 'brighten' if $x > 110; # Right side of image } @@ -22,6 +22,9 @@ $state = 'up' if $x > 110; # Right side of image } +#if (eval qq|$item->isa('Insteon_Device'|) { +# $state = "toggle"; +#} eval qq|$item->set("$state", 'web')|; print "button_action.pl eval error: $@\n" if $@; diff --git a/web/bin/floorplan.pl b/web/bin/floorplan.pl index c134da933..7ff75a14f 100644 --- a/web/bin/floorplan.pl +++ b/web/bin/floorplan.pl @@ -13,7 +13,7 @@ jason@sharpee.com Contributors: - + Neil Cherry License: This free software is licensed under the terms of the GNU public license. @@ -159,22 +159,32 @@ sub web_fp_item #render all items based on type # print "--$p_obj:". $p_obj->state; $l_text=$$p_obj{object_name} . ":" . $p_obj->state; - if ($p_obj->isa('Light_Item') or - $p_obj->isa('Fan_Light') or - $p_obj->isa('Weeder_Light') or - $p_obj->isa('UPB_Device') or - $p_obj->isa('Insteon_Device') or - $p_obj->isa('UPB_Link') or - $p_obj->isa('X10_Item')) { - if ($p_obj->state eq 'off') { + if ($p_obj->isa('Group')) { + # Leave Group First as it is a Generic_Item too and we don't + # want an Icon for the Group (how would you deal with On/Off + # state of a group with mixed on and off device states?) + $l_text=web_fp_filter_name($p_obj->{object_name}); + } elsif ($p_obj->isa('Light_Item') or + $p_obj->isa('Fan_Light') or + $p_obj->isa('Weeder_Light') or + $p_obj->isa('UPB_Device') or + $p_obj->isa('Insteon_Device') or + $p_obj->isa('UPB_Link') or + $p_obj->isa('EIB_Item') or + $p_obj->isa('EIB1GItem') or + $p_obj->isa('EIB2_Item') or + $p_obj->isa('EIO_Item') or + $p_obj->isa('UIO_Item') or + $p_obj->isa('Generic_Item') or + $p_obj->isa('X10_Item') + ) { + if ($p_obj->state eq 'off') { $l_image='fp-light-off.gif'; $l_state='on'; } else { $l_image='fp-light-on.gif'; $l_state='off'; } - } elsif ($p_obj->isa('Group')) { - $l_text=web_fp_filter_name($p_obj->{object_name}); } elsif ($p_obj->isa('Motion_Item') || $p_obj->isa('X10_Sensor') ) { $l_state='motion'; if (lc($p_obj->state) eq 'motion') { @@ -254,7 +264,8 @@ sub web_fp_item #render all items based on type } if ($l_state ne '') { - $l_html.= ""; + my ($l_str) = $l_text =~ /\$(.*)/; + $l_html.= ""; } if ($l_image ne '') { $l_html.="$l_text"; diff --git a/web/bin/floorplan_svg.pl b/web/bin/floorplan_svg.pl index b4cad6fe1..2acf3c437 100644 --- a/web/bin/floorplan_svg.pl +++ b/web/bin/floorplan_svg.pl @@ -11,6 +11,9 @@ Pierrick DINTRAT pierrick.dintrat@laposte.net +Contributor: + Neil Cherry + License: This free software is licensed under the terms of the GNU public license. @@ -33,12 +36,45 @@ my $object_name = shift || '$Property'; my $object = &get_object_by_name($object_name); -my $svg= SVG->new(viewBox=>"0 0 1200 800",preserveAspectRatio=>"none"); -my $top=$svg->group( id => 'group_top',style=> { stroke=>'green', fill=>'black' }); +# This was giving Firefox fits until I change it to this setup +# create an SVG object +my $svg = SVG->new('xmlns:xlink' => 'http://www.w3.org/1999/xlink', + xmlns => 'http://www.w3.org/2000/svg', + viewBox => "0 0 1200 800", # + preserveAspectRatio => "none", + -indent => ' ', + onload => 'init();', +); + +my $top = $svg->group( id => 'group_top',style=> { stroke=>'green', fill=>'black' }); + +my $tag = $svg->script(type=>"text/ecmascript"); -#return &svg_error('FloorPlan', "No $object_name Group found to generate a floorplan from") unless $object; +# I need to catch the a URL problem (such as when MH reboots) so I need to +# use a catch try which mean I need to move the javascript from the above +# onload to here where it can be more complex than a quick one liner +$tag->CDATA(' +function init() { + var i; -&draw_top($top); + i = 10; + + while(i) { + //window.status = "Reload ... "; + + try { + window.setTimeout(\'window.location.reload()\', 10000 ) + i = 0; + //window.status = "Done!"; + } catch (e) { + window.status = "URL error, retrying"; + i--; // if after 10 tries we can not get back in then give up! + } + } +} +'); + +#&draw_top($top); &web_fp($object); &svg_page($svg->xmlify); @@ -47,6 +83,7 @@ sub web_fp #render table representation of objects and their co-ordinates my ($p_obj) = @_; my @l_objs; + my @n_objs; my $l_html; my @l_fp; my ($l_x,$l_y,$l_w,$l_h); @@ -55,9 +92,17 @@ sub web_fp #render table representation of objects and their co-ordinates my $l_obj; my $l_xscale=12; my $l_yscale=5; - use vars qw($i $j); + our ($i, $j, $k); + + # I know I need this but I'm not sure as to the what or the why - njc + my $xOffset = 20; # Mine 105, his 110 + my $yOffset = 20; # Mine 120, his 110 + + my $units = 10; # 15px = 1 ft + $i=1; - $j=125; + $j=0; + $k=0; my $l_bcolor='#CCCCCC'; my $l_acolor='#00FF00'; @@ -69,32 +114,63 @@ sub web_fp #render table representation of objects and their co-ordinates if ($p_obj->isa('Group')) { @l_objs=@{$$p_obj{members}}; - for my $obj (list $p_obj) - { + for my $obj (@l_objs) { # Rooms ($l_x,$l_y,$l_w,$l_h) = $obj->get_fp_location(); - # Just for keep floorplan.pl coordonates - $l_x*=10; - $l_y*=10; - $l_w*=10; - $l_h*=10; + + # Just for keeping floorplan.pl coordonates + # It was 10, I'm not sure that 12 is correct + # times 10, the rooms are given in feet (I guess) + $l_x *= 12; $l_x += $xOffset; # Corrective offset to move it of the right edge of the display area + $l_y *= 12; $l_y += $yOffset; # Corrective offset to move it of the top edge of the display area + $l_w *= 12; + $l_h *= 12; if ($l_x ne "") { - $y->rectangle(x=>$l_x+100, y=>$l_y+100,width =>$l_w, height => $l_h,ry=> 0,fill=>'lightgray',id=> "rect_y-$i" ); - my $group_name=$svg->text(id=>"room_name_$i",x=>$l_x+110,y=>$l_y+110)->cdata(web_fp_filter_name($obj->{object_name})); + $y->rectangle(x=>$l_x, y=>$l_y,width =>$l_w, height => $l_h,ry=> 0,fill=>'lightgray',id=> "rect_y-$i" ); + my $group_name=$svg->text(id=>"room_name_$i",x=>$l_x+4,y=>$l_y+16)->cdata(web_fp_filter_name($obj->{object_name})); $i++; - $j=125; } - for my $item (list $obj) - { + @n_objs = @{$$obj{members}}; # This is the Devices within the Room + for my $item (@n_objs) { + my ($width, $height); + my $ob = Ob($item); + my ($l_x_item,$l_y_item) = $item->get_fp_location(); - $l_x_item*=10; - $l_x_item+=$l_x; - $l_y_item*=10; - $l_y_item+=$l_y; + + # If group is defined as just Group_X instead of Group_X(x;y) + # the device ends up at 0,0. If more than one device has the + # same definition they overlap. This code *mostly* takes care + # of that (we really need to figure out collisions and this + # doesn't do that) + if(($l_x_item eq '' && $l_y_item eq '') || ($l_x_item == 0 && $l_y_item == 0)) { + $l_x_item += $j; + $j++; + } + + $l_x_item *= $units; + $l_x_item += $l_x; + $l_y_item *= $units; + $l_y_item += $l_y; + + if(defined($ob->{fp_icon_w})) { + $width = $ob->{fp_icon_w}; # In pixels + $height = $ob->{fp_icon_h}; + } else { + $width = 16; + $height = 16; + } + my ($l_text,$l_state,$l_image) = web_fp_item($item); - #$svg->text(x=>$l_x_item+110,y=>$l_y_item+110)->cdata("$l_text"); - $svg->anchor(-href=>"/bin/SET;referer?$l_text")->image(x=>$l_x_item+80,y=>$l_y_item+120,width=>15,height=>15,'-href'=>"$l_image"); + + $svg->anchor(-href=>"/bin/SET;referer?$l_text")->image( x => $l_x_item, + y => $l_y_item, + width => $width, + height => $height, + '-href' => "$l_image", + id => "i${k}" . "$ob->{object_name}", + title => "$ob->{object_name}: $ob->{state}"); + $k++; } } } @@ -118,8 +194,18 @@ sub web_fp_item #render all items based on type my $l_image; $l_text=$$p_obj{object_name} . "=" . $p_obj->state; - if ($p_obj->isa('Light_Item') or - $p_obj->isa('Fan_Light') or + if ($p_obj->isa('Light_Item') or + $p_obj->isa('Fan_Light') or + $p_obj->isa('Weeder_Light') or + $p_obj->isa('UPB_Device') or + $p_obj->isa('Insteon_Device') or + $p_obj->isa('UPB_Link') or + $p_obj->isa('EIB_Item') or + $p_obj->isa('EIB1GItem') or + $p_obj->isa('EIB2_Item') or + $p_obj->isa('EIO_Item') or + $p_obj->isa('UIO_Item') or + $p_obj->isa('Generic_Item') or $p_obj->isa('X10_Item')) { if ($p_obj->state eq 'off') { $l_image='/graphics/fp-light-off.gif'; @@ -183,6 +269,14 @@ sub web_fp_item #render all items based on type $l_text.=':' . $p_obj->state(); } + # Check for custom icons + my %icons = $p_obj->get_fp_icons(); + + if ((keys %icons) and $icons{$p_obj->state}) { + $l_image = '/graphics/' . $icons{$p_obj->state}; + $l_text = $$p_obj{object_name} . "=" . $l_state; + } + return ($l_text,$l_state,$l_image); } @@ -218,4 +312,11 @@ sub draw_top } +# Return the obj +# Yes I know this is stupid but I can't figure out how else to tell Perl +# that a $obj really is a $$obj (I get errors). This fakes Perl out. +sub Ob { + my ($obj) = @_; + return $obj; +} diff --git a/web/bin/iniedit.pl b/web/bin/iniedit.pl index 24109373b..eb4921458 100644 --- a/web/bin/iniedit.pl +++ b/web/bin/iniedit.pl @@ -27,7 +27,7 @@
    - + + diff --git a/web/misc/alarms.shtml b/web/misc/alarms.shtml index 548e6ccce..fdd78f482 100644 --- a/web/misc/alarms.shtml +++ b/web/misc/alarms.shtml @@ -9,7 +9,7 @@ - +
    Edit alarms diff --git a/web/misc/empty.html b/web/misc/empty.html index 90531a4b3..62c4e2415 100644 --- a/web/misc/empty.html +++ b/web/misc/empty.html @@ -1,2 +1,4 @@ - + + + \ No newline at end of file diff --git a/web/misc/mp3.html b/web/misc/mp3.html index 315f15d82..0dc18fe9c 100644 --- a/web/misc/mp3.html +++ b/web/misc/mp3.html @@ -1,9 +1,9 @@ MrHouse - + - - + + diff --git a/web/misc/mplist.html b/web/misc/mplist.html index e0612ae9d..5e1f04bea 100644 --- a/web/misc/mplist.html +++ b/web/misc/mplist.html @@ -4,6 +4,7 @@ - + - \ No newline at end of file + + diff --git a/web/misc/mpnowplay.html b/web/misc/mpnowplay.html index 6334b2507..239a55884 100644 --- a/web/misc/mpnowplay.html +++ b/web/misc/mpnowplay.html @@ -1,8 +1,8 @@ MisterHouse Jukebox Remote - - + + diff --git a/web/misc/timers.shtml b/web/misc/timers.shtml index 5da0dabbe..a3fde401d 100644 --- a/web/misc/timers.shtml +++ b/web/misc/timers.shtml @@ -21,7 +21,7 @@
    - + From 2ffbcde91d2d20599e90b121dee0775f587acffa Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 17 Jan 2011 22:02:47 +0000 Subject: [PATCH 020/150] Fix typo and proper inclusion of BaseInterface object in conditional within has_link method. Thanks to Eloy P. for bug fix. --- lib/Insteon/AllLinkDatabase.pm | 2778 ++++++++++++++++---------------- 1 file changed, 1389 insertions(+), 1389 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 46ce13fdf..41088cd8d 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -1,1389 +1,1389 @@ -=begin comment -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - -File: - AllLinkDatabase.pm - -Description: - Generic class implementation of an insteon device's all link database. - -Author(s): - Gregg Liming / gregg@limings.net - -License: - This free software is licensed under the terms of the GNU public license. - - -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -=cut - - -package Insteon::AllLinkDatabase; - -use strict; -use Insteon; -use Insteon::Lighting; - -# @Insteon::AllLinkDatabase::ISA = ('Generic_Item'); - - -sub new -{ - my ($class, $device) = @_; - my $self={}; - bless $self,$class; - $$self{device} = $device; - return $self; -} - -sub _send_cmd -{ - my ($self, $msg) = @_; - $$self{device}->_send_cmd($msg); -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = ''; - if ($$self{aldb}) { - my $aldb = ''; - foreach my $aldb_key (keys %{$$self{aldb}}) { - next unless $aldb_key eq 'empty' || $aldb_key eq 'duplicates' || $$self{aldb}{$aldb_key}{inuse}; - $aldb .= '|' if $aldb; # separate sections - my $record = ''; - if ($aldb_key eq 'empty') { - foreach my $address (@{$$self{aldb}{empty}}) { - $record .= ';' if $record; - $record .= $address; - } - $record = 'empty=' . $record; - } elsif ($aldb_key eq 'duplicates') { - my $duplicate_record = ''; - foreach my $address (@{$$self{aldb}{duplicates}}) { - $duplicate_record .= ';' if $duplicate_record; - $duplicate_record .= $address; - } - $record = 'duplicates=' . $duplicate_record; - } else { - my %aldb_record = %{$$self{aldb}{$aldb_key}}; - foreach my $record_key (keys %aldb_record) { - next unless $aldb_record{$record_key}; - $record .= ',' if $record; - $record .= $record_key . '=' . $aldb_record{$record_key}; - } - } - $aldb .= $record; - } -# &::print_log("[AllLinkDataBase] aldb restore string: $aldb") if $main::Debug{insteon}; - $restore_string .= $$self{device}->get_object_name . "->_adlb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_adlb;\n"; - } - return $restore_string; -} - -sub restore_aldb -{ - my ($self,$aldb) = @_; - if ($aldb) { - foreach my $aldb_section (split(/\|/,$aldb)) { - my %aldb_record = (); - my @aldb_empty = (); - my @aldb_duplicates = (); - my $deviceid = ''; - my $groupid = '01'; - my $is_controller = 0; - my $subaddress = '00'; - foreach my $aldb_entry (split(/,/,$aldb_section)) { - my ($key,$value) = split(/=/,$aldb_entry); - next unless $key and defined($value) and $value ne ''; - if ($key eq 'empty') { - @aldb_empty = split(/;/,$value); - } elsif ($key eq 'duplicates') { - @aldb_duplicates = split(/;/,$value); - } else { - $deviceid = lc $value if ($key eq 'deviceid'); - $groupid = lc $value if ($key eq 'group'); - $is_controller = $value if ($key eq 'is_controller'); - $subaddress = $value if ($key eq 'data3'); - $aldb_record{$key} = $value if $key and defined($value); - } - } - if (@aldb_empty) { - @{$$self{aldb}{empty}} = @aldb_empty; - } elsif (@aldb_duplicates) { - @{$$self{aldb}{duplicates}} = @aldb_duplicates; - } elsif (scalar %aldb_record) { - next unless $deviceid; - my $aldbkey = $deviceid . $groupid . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $aldbkey .= $subaddress; - } - %{$$self{aldb}{$aldbkey}} = %aldb_record; - } - } -# $self->log_alllink_table(); - } -} - - - - -package Insteon::ALDB_i1; - -use strict; -use Insteon; -use Insteon::Lighting; -use Insteon::Message; - -@Insteon::ALDB_i1::ISA = ('Insteon::AllLinkDatabase'); - -sub new -{ - my ($class,$device) = @_; - - my $self = new Insteon::AllLinkDatabase($device); - bless $self,$class; - return $self; -} - -sub _on_poke -{ - my ($self,%msg) = @_; - my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); - if (($$self{_mem_activity} eq 'update') or ($$self{_mem_activity} eq 'add')) { - if ($$self{_mem_action} eq 'aldb_flag') { - $$self{_mem_action} = 'aldb_group'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_group') { - $$self{_mem_action} = 'aldb_devhi'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_devhi') { - $$self{_mem_action} = 'aldb_devmid'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_devmid') { - $$self{_mem_action} = 'aldb_devlo'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_devlo') { - $$self{_mem_action} = 'aldb_data1'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_data1') { - $$self{_mem_action} = 'aldb_data2'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_data2') { - $$self{_mem_action} = 'aldb_data3'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_data3') { - ## update the aldb records w/ the changes that were made - my $aldbkey = $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - my $subaddress = $$self{pending_aldb}{data3}; - if (($subaddress ne '00') and ($subaddress ne '01')) { - $aldbkey .= $subaddress; - } - $$self{aldb}{$aldbkey}{data1} = $$self{pending_aldb}{data1}; - $$self{aldb}{$aldbkey}{data2} = $$self{pending_aldb}{data2}; - $$self{aldb}{$aldbkey}{data3} = $$self{pending_aldb}{data3}; - $$self{aldb}{$aldbkey}{inuse} = 1; # needed so that restore string will preserve record - if ($$self{_mem_activity} eq 'add') { - $$self{aldb}{$aldbkey}{is_controller} = $$self{pending_aldb}{is_controller}; - $$self{aldb}{$aldbkey}{deviceid} = lc $$self{pending_aldb}{deviceid}; - $$self{aldb}{$aldbkey}{group} = lc $$self{pending_aldb}{group}; - $$self{aldb}{$aldbkey}{address} = $$self{pending_aldb}{address}; - # on completion, check to see if the empty links list is now empty; if so, - # then decrement the current address and add it to the list - my $num_empty = @{$$self{aldb}{empty}}; - if (!($num_empty)) { - my $low_address = 0; - for my $key (keys %{$$self{aldb}}) { - next if $key eq 'empty' or $key eq 'duplicates'; - my $new_address = hex($$self{aldb}{$key}{address}); - if (!($low_address)) { - $low_address = $new_address; - next; - } else { - $low_address = $new_address if $new_address < $low_address; - } - } - $low_address = sprintf('%04X', $low_address - 8); - unshift @{$$self{aldb}{empty}}, $low_address; - } - } - # clear out mem_activity flag - $$self{_mem_activity} = undef; - if (defined $$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; - # clear it out *before* the eval - $$self{_mem_callback} = undef; - package main; - eval ($callback); - package Insteon::ALDB_i1; - &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) - if $@ and $main::Debug{insteon}; - } - } - } elsif ($$self{_mem_activity} eq 'update_local') { - if ($$self{_mem_action} eq 'local_onlevel') { - $$self{_mem_lsb} = '21'; - $$self{_mem_action} = 'local_ramprate'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'local_ramprate') { - if ($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) { - # update from eeprom--only a kpl issue - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); - } - } - } elsif ($$self{_mem_activity} eq 'update_flags') { - # update from eeprom--only a kpl issue - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'delete') { - # clear out mem_activity flag - $$self{_mem_activity} = undef; - # add the address of the deleted link to the empty list - push @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; - if (exists $$self{pending_aldb}{deviceid}) { - my $key = lc $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - my $subaddress = $$self{pending_aldb}{data3}; - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - delete $$self{aldb}{$key}; - } - - if (defined $$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; - # clear it out *before* the eval - $$self{_mem_callback} = undef; - package main; - eval ($callback); - &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon::ALDB_i1; - $$self{_mem_callback} = undef; - } - } -# -} - -sub _on_peek -{ - my ($self,%msg) = @_; - my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); - if ($msg{is_extended}) { - &::print_log("[Insteon::ALDB_i1]: extended peek for " . $$self{device}->{object_name} - . " is " . $msg{extra}) if $main::Debug{insteon}; - } else { - if ($$self{_mem_action} eq 'aldb_peek') { - if ($$self{_mem_activity} eq 'scan') { - $$self{_mem_action} = 'aldb_flag'; - # if the device is responding to the peek, then init the link table - # if at the very start of a scan - if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { - # reinit the aldb hash as there will be a new one - $$self{aldb} = undef; - # reinit the empty address list - @{$$self{aldb}{empty}} = (); - # and, also the duplicates list - @{$$self{aldb}{duplicates}} = (); - } - } elsif ($$self{_mem_activity} eq 'update') { - $$self{_mem_action} = 'aldb_data1'; - } elsif ($$self{_mem_activity} eq 'update_local') { - $$self{_mem_action} = 'local_onlevel'; - } elsif ($$self{_mem_activity} eq 'update_flags') { - $$self{_mem_action} = 'update_flags'; - } elsif ($$self{_mem_activity} eq 'delete') { - $$self{_mem_action} = 'aldb_flag'; - } elsif ($$self{_mem_activity} eq 'add') { - $$self{_mem_action} = 'aldb_flag'; - } - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_flag') { - if ($$self{_mem_activity} eq 'scan') { - my $flag = hex($msg{extra}); - $$self{pending_aldb}{inuse} = ($flag & 0x80) ? 1 : 0; - $$self{pending_aldb}{is_controller} = ($flag & 0x40) ? 1 : 0; - $$self{pending_aldb}{highwater} = ($flag & 0x02) ? 1 : 0; - if (!($$self{pending_aldb}{highwater})) { - # since this is the last unused memory location, then add it to the empty list - unshift @{$$self{aldb}{empty}}, $$self{_mem_msb} . $$self{_mem_lsb}; - $$self{_mem_action} = undef; - # clear out mem_activity flag - $$self{_mem_activity} = undef; - &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " completed link memory scan") - if $main::Debug{insteon}; - if (defined $$self{_mem_callback}) { - package main; - eval ($$self{_mem_callback}); - &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . ": error during scan callback $@") - if $@ and $main::Debug{insteon}; - package Insteon::ALDB_i1; - $$self{_mem_callback} = undef; - } - # ping the device as part of the scan if we don't already have a devcat - # if (!($self->{devcat})) { - # $self->ping(); - # } - } else { - $$self{pending_aldb}{flag} = $msg{extra}; - ## confirm that we have a high-water mark; otherwise stop - $$self{pending_aldb}{address} = $$self{_mem_msb} . $$self{_mem_lsb}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'aldb_group'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_activity} eq 'add') { - my $flag = ($$self{pending_aldb}{is_controller}) ? 'E2' : 'A2'; - $$self{pending_aldb}{flag} = $flag; - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($flag); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $flag, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'delete') { - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra('02'); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => '02', 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_group') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_aldb}{group} = lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'aldb_devhi'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, -# 'is_synchronous' => 1); - } else { - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($$self{pending_aldb}{group}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{group}, -# 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_devhi') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_aldb}{deviceid} = lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'aldb_devmid'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { - my $devid = substr($$self{pending_aldb}{deviceid},0,2); - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($devid); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_devmid') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_aldb}{deviceid} .= lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'aldb_devlo'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { - my $devid = substr($$self{pending_aldb}{deviceid},2,2); - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($devid); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_devlo') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_aldb}{deviceid} .= lc $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'aldb_data1'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { - my $devid = substr($$self{pending_aldb}{deviceid},4,2); - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($devid); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_data1') { - if ($$self{_mem_activity} eq 'scan') { - $$self{_mem_action} = 'aldb_data2'; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{pending_aldb}{data1} = $msg{extra}; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { - # poke the new value - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($$self{pending_aldb}{data1}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data1}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_data2') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_aldb}{data2} = $msg{extra}; - $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); - $$self{_mem_action} = 'aldb_data3'; - $message->extra($$self{_mem_lsb}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { - # poke the new value - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($$self{pending_aldb}{data2}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data2}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'aldb_data3') { - if ($$self{_mem_activity} eq 'scan') { - $$self{pending_aldb}{data3} = $msg{extra}; - # check the previous record if highwater is set - if ($$self{pending_aldb}{highwater}) { - if ($$self{pending_aldb}{inuse}) { - # save pending_aldb and then clear it out - my $aldbkey = lc $$self{pending_aldb}{deviceid} - . $$self{pending_aldb}{group} - . $$self{pending_aldb}{is_controller}; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - my $subaddress = $$self{pending_aldb}{data3}; - if ($subaddress ne '00' and $subaddress ne '01') { - $aldbkey .= $subaddress; - } - # check for duplicates - if (exists $$self{aldb}{$aldbkey} && $$self{aldb}{$aldbkey}{inuse}) { - unshift @{$$self{aldb}{duplicates}}, $$self{pending_aldb}{address}; - } else { - %{$$self{aldb}{$aldbkey}} = %{$$self{pending_aldb}}; - } - } else { - # TO-DO: record the locations of deleted aldb records for subsequent reuse - unshift @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; - } - my $newaddress = sprintf("%04X", hex($$self{pending_aldb}{address}) - 8); - $$self{pending_aldb} = undef; - $self->_peek($newaddress); - } - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { - # poke the new value - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($$self{pending_aldb}{data3}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data3}, 'is_synchronous' => 1); - } - } elsif ($$self{_mem_action} eq 'local_onlevel') { - my $on_level = $self->local_onlevel; - $on_level = &Insteon::DimmableLight::convert_level($on_level); - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($on_level); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $on_level, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'local_ramprate') { - my $ramp_rate = $$self{_ramprate}; - $ramp_rate = '1f' unless $ramp_rate; - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($ramp_rate); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $ramp_rate, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'update_flags') { - my $flags = $$self{_operating_flags}; - $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); - $message->extra($flags); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $flags, 'is_synchronous' => 1); - } -# -# &::print_log("AllLinkDataBase: peek for " . $self->{object_name} -# . " is " . $msg{extra}) if $main::Debug{insteon}; - } -} - - -sub scan_link_table -{ - my ($self,$callback) = @_; - $$self{_mem_activity} = 'scan'; - $$self{_mem_callback} = ($callback) ? $callback : undef; - $self->_peek('0FF8',0); -} - -sub delete_link -{ - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - if ($link_parms{address}) { - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $$self{_mem_activity} = 'delete'; - $$self{pending_aldb}{address} = $link_parms{address}; - $self->_peek($link_parms{address},0); - - } else { - my $insteon_object = $link_parms{object}; - my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; - my $groupid = $link_parms{group}; - $groupid = '01' unless $groupid; - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; - # get the address via lookup into the hash - my $key = lc $deviceid . $groupid . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - my $address = $$self{aldb}{$key}{address}; - if ($address) { - &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$address] with the following data" - . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); - # now, alter the flags byte such that the in_use flag is set to 0 - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $$self{_mem_activity} = 'delete'; - $$self{pending_aldb}{deviceid} = lc $deviceid; - $$self{pending_aldb}{group} = $groupid; - $$self{pending_aldb}{is_controller} = $is_controller; - $$self{pending_aldb}{address} = $address; - $self->_peek($address,0); - } else { - &main::print_log('[Insteon::ALDB_i1] WARN: (' . $$self{device}->get_object_name . ') attempt to delete link that does not exist!' - . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); - if ($link_parms{callback}) { - package main; - eval($link_parms{callback}); - &::print_log("[Insteon::ALDB_i1] error encountered during delete_link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon::AllLinkDataBase; - } - } - } -} - -sub delete_orphan_links -{ - my ($self) = @_; - @{$$self{delete_queue}} = (); # reset the work queue - my $selfname = $$self{device}->get_object_name; - my $num_deleted = 0; - for my $linkkey (keys %{$$self{aldb}}) { - if ($linkkey ne 'empty' and $linkkey ne 'duplicates') { - my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; - next unless $deviceid; - my $group = $$self{aldb}{$linkkey}{group}; - my $is_controller = $$self{aldb}{$linkkey}{is_controller}; - my $data3 = $$self{aldb}{$linkkey}{data3}; - my $device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface - : &Insteon::get_object($deviceid,'01'); - if (!($device)) { -# &::print_log("[AllLinkDataBase] " . $self->get_object_name . " now deleting orphaned link w/ details: " -# . (($is_controller) ? "controller" : "responder") -# . ", deviceid=$deviceid, group=$group"); - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", cause => "no device could be found"); - push @{$$self{delete_queue}}, \%delete_req; - } elsif ($device->isa("Insteon::BaseInterface") and $is_controller) { - # ignore since this is just a link back to the PLM - } elsif ($device->isa("Insteon::BaseInterface")) { - # does the PLM have a link point back? If not, the delete this one - if (!($device->has_link($self,$group,1))) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - # is there an entry in the items.mht that corresponds to this link? - if ($is_controller) { - # TO-DO: handle this case - } else { - my $plm_link = $device->get_device('000000',$group); - if ($plm_link) { - my $is_invalid = 1; - foreach my $member_ref (keys %{$$plm_link{members}}) { - my $member = $$plm_link{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon::BaseLight'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->device_id eq $self->device_id) { - if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { - $is_invalid = 0; - last; - } - } - } - if ($is_invalid) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no link is defined for the plm controlled scene", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } else { - # delete the link since it doesn't exist - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no plm link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } - } else { - if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no link to the device could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } else { - my $is_invalid = 1; - my $link = ($is_controller) ? &Insteon::get_object($self->device_id,$group) - : &Insteon::get_object($device->device_id,$group); - if ($link) { - foreach my $member_ref (keys %{$$link{members}}) { - my $member = $$link{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon::BaseLight'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->isa('Insteon::BaseDevice') and !($member->is_root)) { - $member = $member->get_root; - } - if ($member->isa('Insteon::BaseDevice') and !($is_controller) and ($member->device_id eq $self->device_id)) { - $is_invalid = 0; - last; - } elsif ($member->isa('Insteon::BaseDevice') and $is_controller and ($member->device_id eq $device->device_id)) { - $is_invalid = 0; - last; - } - - } - } - if ($is_invalid) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no reverse link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } - } - } elsif ($linkkey eq 'duplicates') { - my $address = pop @{$$self{aldb}{duplicates}}; - while ($address) { - my %delete_req = (address => $address, - callback => "$selfname->_process_delete_queue()", - cause => "duplicate record found"); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - $address = pop @{$$self{aldb}{duplicates}}; - } - } - } - $$self{delete_queue_processed} = 0; - $self->_process_delete_queue(); - return $num_deleted; -} - -sub _process_delete_queue { - my ($self) = @_; - my $num_in_queue = @{$$self{delete_queue}}; - if ($num_in_queue) { - my $delete_req_ptr = shift(@{$$self{delete_queue}}); - my %delete_req = %$delete_req_ptr; - if ($delete_req{address}) { - &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting duplicate record at address " - . $delete_req{address}); - } else { - &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " - . (($delete_req{is_controller}) ? "controller" : "responder") - . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name - : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); - } - $self->delete_link(%delete_req); - $$self{delete_queue_processed}++; - } else { - $self->interface->_process_delete_queue($$self{delete_queue_processed}); - } -} - -sub add_link -{ - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - my $device_id; - my $insteon_object = $link_parms{object}; - my $group = $link_parms{group}; - if (!(defined($insteon_object))) { - $device_id = lc $link_parms{deviceid}; - $insteon_object = &Insteon::get_object($device_id, $group); - } else { - $device_id = lc $insteon_object->device_id; - } - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - # check whether the link already exists - my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; - # get the address via lookup into the hash - my $key = lc $device_id . $group . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - if (defined $$self{aldb}{$key}{inuse}) { - &::print_log("[Insteon::ALDB_i1] WARN: attempt to add link to " . $$self{device}->get_object_name . " that already exists! " - . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); - if ($link_parms{callback}) { - package main; - eval($link_parms{callback}); - &::print_log("[Insteon::ALDB_i1] failure occurred in callback eval for " . $$self{device}->get_object_name . ":" . $@) - if $@ and $main::Debug{insteon}; - package Insteon::ALDB_i1; - } - } else { - # strip optional % sign to append on_level - my $on_level = $link_parms{on_level}; - $on_level =~ s/(\d)%?/$1/; - $on_level = '100' unless defined($on_level); # 100% == on is the default - # strip optional s (seconds) to append ramp_rate - my $ramp_rate = $link_parms{ramp_rate}; - $ramp_rate =~ s/(\d)s?/$1/; - $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default - &::print_log("[Insteon::ALDB_i1] adding link record " . $$self{device}->get_object_name - . " light level controlled by " . $insteon_object->get_object_name - . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; - my $data1 = &Insteon::DimmableLight::convert_level($on_level); - my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; - my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; - # get the first available memory location - my $address = pop @{$$self{aldb}{empty}}; - # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails - $$self{_mem_activity} = 'add'; - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); - } -} - -sub update_link -{ - my ($self, %link_parms) = @_; - my $insteon_object = $link_parms{object}; - my $group = $link_parms{group}; - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - # strip optional % sign to append on_level - my $on_level = $link_parms{on_level}; - $on_level =~ s/(\d+)%?/$1/; - # strip optional s (seconds) to append ramp_rate - my $ramp_rate = $link_parms{ramp_rate}; - $ramp_rate =~ s/(\d)s?/$1/; - &::print_log("[Insteon::ALDB_i1] updating " . $$self{device}->get_object_name . " light level controlled by " . $insteon_object->get_object_name - . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; - my $data1 = sprintf('%02X',$on_level * 2.55); - $data1 = 'ff' if $on_level eq '100'; - $data1 = '00' if $on_level eq '0'; - my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; - my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; - my $deviceid = $insteon_object->device_id; - my $subaddress = $data3; - # get the address via lookup into the hash - my $key = lc $deviceid . $group . $is_controller; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - my $address = $$self{aldb}{$key}{address}; - $$self{_mem_activity} = 'update'; - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $self->_write_link($address, $deviceid, $group, $is_controller, $data1, $data2, $data3); -} - - -sub log_alllink_table -{ - my ($self) = @_; - &::print_log("[Insteon::ALDB_i1] link table for " . $$self{device}->get_object_name . " (devcat: $$self{devcat}):"); - foreach my $aldbkey (sort(keys(%{$$self{aldb}}))) { - next if $aldbkey eq 'empty' or $aldbkey eq 'duplicates'; - my ($device); - my $is_controller = $$self{aldb}{$aldbkey}{is_controller}; - if ($$self{device}->interface()->device_id() and ($$self{device}->interface()->device_id() eq $$self{aldb}{$aldbkey}{deviceid})) { - $device = $$self{device}->interface; - } else { - $device = &Insteon::get_object($$self{aldb}{$aldbkey}{deviceid},'01'); - } - my $object_name = ($device) ? $device->get_object_name : $$self{aldb}{$aldbkey}{deviceid}; - - my $on_level = 'unknown'; - if (defined $$self{aldb}{$aldbkey}{data1}) { - if ($$self{aldb}{$aldbkey}{data1}) { - $on_level = int((hex($$self{aldb}{$aldbkey}{data1})*100/255) + .5) . "%"; - } else { - $on_level = '0%'; - } - } - - my $rspndr_group = $$self{aldb}{$aldbkey}{data3}; - $rspndr_group = '01' if $rspndr_group eq '00'; - - my $ramp_rate = 'unknown'; - if ($$self{aldb}{$aldbkey}{data2}) { - if (!($$self{device}->isa('Insteon::DimmableLight')) or (!($is_controller) and ($rspndr_group != '01'))) { - $ramp_rate = 'none'; - if ($on_level eq '0%') { - $on_level = 'off'; - } else { - $on_level = 'on'; - } - } else { - $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($$self{aldb}{$aldbkey}{data2}) . "s"; - } - } - - &::print_log("[Insteon::ALDB_i1] [0x" . $$self{aldb}{$aldbkey}{address} . "] " . - (($$self{aldb}{$aldbkey}{is_controller}) ? "contlr($$self{aldb}{$aldbkey}{group}) record to " - . $object_name . "($rspndr_group), (d1:$$self{aldb}{$aldbkey}{data1}, d2:$$self{aldb}{$aldbkey}{data2}, d3:$$self{aldb}{$aldbkey}{data3})" - : "rspndr($rspndr_group) record to " . $object_name . "($$self{aldb}{$aldbkey}{group})" - . ": onlevel=$on_level and ramp=$ramp_rate (d3:$$self{aldb}{$aldbkey}{data3})")) if $main::Debug{insteon}; - } - foreach my $address (@{$$self{aldb}{empty}}) { - &::print_log("[Insteon::ALDB_i1] [0x$address] is empty"); - } - - foreach my $address (@{$$self{aldb}{duplicates}}) { - &::print_log("[Insteon::ALDB_i1] [0x$address] holds a duplicate entry"); - } - -} - -sub update_local_properties -{ - my ($self) = @_; - $$self{_mem_activity} = 'update_local'; - $self->_peek('0032'); # 0032 is the address for the onlevel -} - -sub update_flags -{ - my ($self, $flags) = @_; - return unless defined $flags; - - $$self{_mem_activity} = 'update_flags'; - $$self{_operating_flags} = $flags; - $self->_peek('0023'); -} - -sub get_link_record -{ - my ($self,$link_key) = @_; - my %link_record = (); - %link_record = %{$$self{aldb}{$link_key}} if $$self{aldb}{$link_key}; - return %link_record; -} - - - -sub has_link -{ - my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = ""; - if ($insteon_object->isa('Insteon::BaseObject')) { - lc $insteon_object->device_id . $group . $is_controller; - } else { - lc $$insteon_object{device}->device_id . $group . $is_controller; - } - $subaddress = '00' unless $subaddress; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - return (defined $$self{aldb}{$key}) ? 1 : 0; -} - -sub _write_link -{ - my ($self, $address, $deviceid, $group, $is_controller, $data1, $data2, $data3) = @_; - if ($address) { - &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " address: $address found for device: $deviceid and group: $group"); - # change address for start of change to be address + offset - if ($$self{_mem_activity} eq 'update') { - $address = sprintf('%04X',hex($address) + 5); - } - $$self{pending_aldb}{address} = $address; - $$self{pending_aldb}{deviceid} = lc $deviceid; - $$self{pending_aldb}{group} = lc $group; - $$self{pending_aldb}{is_controller} = $is_controller; - $$self{pending_aldb}{data1} = (defined $data1) ? lc $data1 : '00'; - $$self{pending_aldb}{data2} = (defined $data2) ? lc $data2 : '00'; - # Note: if device is a KeypadLinc, then $data3 must be assigned the value of the applicable button (01) - if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) { - &::print_log("[Insteon::ALDB_i1] setting data3 to " . $self->group . " for this keypadlinc") - if $main::Debug{insteon}; - $data3 = $self->group; - } - $$self{pending_aldb}{data3} = (defined $data3) ? lc $data3 : '00'; - $self->_peek($address); - } else { - &::print_log("[Insteon::ALDB_i1] WARN: " . $$self{device}->get_object_name - . " write_link failure: no address available for record to device: $deviceid and group: $group" . - " and is_controller: $is_controller");; - } -} - -sub _peek -{ - my ($self, $address, $extended) = @_; - my $msb = substr($address,0,2); - my $lsb = substr($address,2,2); - if ($extended) { - my $message = $self->device->derive_message('peek','insteon_ext_send', - $lsb . "0000000000000000000000000000"); - $self->interface->queue_message($message); - - } else { - $$self{_mem_lsb} = $lsb; - $$self{_mem_msb} = $msb; - $$self{_mem_action} = 'aldb_peek'; - &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " accessing memory at location: 0x" . $address); - my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'set_address_msb'); - $message->extra($msb); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'set_address_msb', 'extra' => $msb, 'is_synchronous' => 1); - } -} - - - -package Insteon::ALDB_i2; - -use strict; -use Insteon; -use Insteon::Lighting; - -@Insteon::ALDB_i2::ISA = ('Insteon::AllLinkDatabase'); - -sub new -{ - my ($class,$device) = @_; - - my $self = new Insteon::AllLinkDatabase($device); - bless $self,$class; - return $self; -} - - - - - -package Insteon::ALDB_PLM; - -use strict; -use Insteon; -use Insteon::Lighting; - -@Insteon::ALDB_PLM::ISA = ('Insteon::AllLinkDatabase'); - -sub new -{ - my ($class,$device) = @_; - - my $self = new Insteon::AllLinkDatabase($device); - bless $self,$class; - return $self; -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = ''; - if ($$self{aldb}) { - my $link = ''; - foreach my $link_key (keys %{$$self{aldb}}) { - $link .= '|' if $link; # separate sections - my %link_record = %{$$self{aldb}{$link_key}}; - my $record = ''; - foreach my $record_key (keys %link_record) { - next unless $link_record{$record_key}; - $record .= ',' if $record; - $record .= $record_key . '=' . $link_record{$record_key}; - } - $link .= $record; - } - $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_linktable(q~$link~) if " . $$self{device}->get_object_name . "->_aldb;\n"; - } - return $restore_string; -} - -sub restore_linktable -{ - my ($self, $links) = @_; - if ($links) { - foreach my $link_section (split(/\|/,$links)) { - my %link_record = (); - my $deviceid = ''; - my $groupid = '01'; - my $is_controller = 0; - foreach my $link_record (split(/,/,$link_section)) { - my ($key,$value) = split(/=/,$link_record); - $deviceid = $value if ($key eq 'deviceid'); - $groupid = $value if ($key eq 'group'); - $is_controller = $value if ($key eq 'is_controller'); - $link_record{$key} = $value if $key and defined($value); - } - my $linkkey = $deviceid . $groupid . $is_controller; - %{$$self{aldb}{lc $linkkey}} = %link_record; - } -# $self->log_alllink_table(); - } -} - -sub log_alllink_table -{ - my ($self) = @_; - foreach my $linkkey (sort(keys(%{$$self{aldb}}))) { - my $data3 = $$self{aldb}{$linkkey}{data3}; - my $is_controller = $$self{aldb}{$linkkey}{is_controller}; - my $group = ($is_controller) ? $data3 : $$self{aldb}{$linkkey}{group}; - $group = '01' if $group eq '00'; - my $deviceid = $$self{aldb}{$linkkey}{deviceid}; - my $device = &Insteon::get_object($deviceid,$group); - my $object_name = ''; - if ($device) - { - $object_name = $device->get_object_name; - } - else - { - $object_name = uc substr($deviceid,0,2) . '.' . - uc substr($deviceid,2,2) . '.' . - uc substr($deviceid,4,2); - } - &::print_log("[Insteon::ALDB_PLM] " . - (($is_controller) ? "cntlr($$self{aldb}{$linkkey}{group}) record to " - . $object_name - : "responder record to " . $object_name . "($$self{aldb}{$linkkey}{group})") - . " (d1=$$self{aldb}{$linkkey}{data1}, d2=$$self{aldb}{$linkkey}{data2}, " - . "d3=$data3)") - if $main::Debug{insteon}; - } -} - -sub parse_alllink -{ - my ($self, $data) = @_; -# &::print_log("[DEBUG] $data"); - if (substr($data,0,6)) { - my %link = (); - my $flag = substr($data,0,1); - $link{is_controller} = (hex($flag) & 0x04) ? 1 : 0; - $link{flags} = substr($data,0,2); - $link{group} = lc substr($data,2,2); - $link{deviceid} = lc substr($data,4,6); - $link{data1} = substr($data,10,2); - $link{data2} = substr($data,12,2); - $link{data3} = substr($data,14,2); - my $key = $link{deviceid} . $link{group} . $link{is_controller}; - %{$$self{aldb}{lc $key}} = %link; - } -} - -sub get_first_alllink -{ - my ($self) = @_; - $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_first_rec', $$self{device})); -} - -sub get_next_alllink -{ - my ($self) = @_; - $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_next_rec', $$self{device})); -} - -sub delete_orphan_links -{ - my ($self) = @_; - @{$$self{delete_queue}} = (); # reset the work queue - my $selfname = $$self{device}->get_object_name; - my $num_deleted = 0; - foreach my $linkkey (keys %{$$self{aldb}}) { - my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; - my $group = $$self{aldb}{$linkkey}{group}; - my $is_controller = $$self{aldb}{$linkkey}{is_controller}; - my $data3 = $$self{aldb}{$linkkey}{data3}; - my $device = &Insteon::get_object($deviceid,'01'); - # if a PLM link (regardless of responder or controller) exists to a device that is not known, then delete - if (!($device)) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $self, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - } else { - my $is_invalid = 1; - my $link = undef; - if ($is_controller) { - # then, this is a PLM defined link; and, we won't care about responder links as we assume - # they're ok given that they reference known devices - $link = &Insteon::get_object('000000',$group); - if (!($link)) { - # a reference in the PLM's linktable does not match a scene member target - $is_invalid = 1; - } else { - # iterate over all of the members of the Insteon_Link item - foreach my $member_ref (keys %{$$link{members}}) { - my $member = $$link{members}{$member_ref}{object}; - # member will correspond to a scene member item - # and, if it is a light item, then get the real device - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon::BaseLight'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->isa('Insteon::BaseDevice')) { - my $linkmember = $member; - # make sure that this is a root device - if (!($member->is_root)) { - $member = $member->get_root; - } - if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) { - # at this point, the forward link is ok; but, only if the reverse - # link also exists. So, check: - if ($member->has_link($self, $group, 0, $data3)) { - $is_invalid = 0; - } - last; - } - } else { - $is_invalid = 0; - } - } - if ($is_invalid) { - # then, there is a good chance that a reciprocal link exists; if so, delet it too - if ($device->has_link($self,$group,0, $data3)) { - my %delete_req = (object => $self, group => $group, is_controller => 0, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $device, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - } - } - } - if ($is_invalid) { - my %delete_req = (object => $device, group => $group, is_controller => 1, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $self, data3 => $data3); -# push @{$$self{delete_queue}}, \%delete_req; - } - } - } - } - - $$self{delete_queue_processed} = 0; # reset the counter - - # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links - for my $obj (&Insteon::find_members('Insteon::BaseObject')) - { - #Match on real objects only - if (($obj->is_root)) - { -# $num_deleted += $obj->delete_orphan_links(); -# my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); -# push @{$$self{delete_queue}}, \%delete_req; - } - } - $self->_process_delete_queue(); -} - -sub _process_delete_queue { - my ($self, $p_num_deleted) = @_; - $$self{delete_queue_processed} += $p_num_deleted if $p_num_deleted; - my $num_in_queue = @{$$self{delete_queue}}; - if ($num_in_queue) { - my $delete_req_ptr = shift(@{$$self{delete_queue}}); - my %delete_req = %$delete_req_ptr; - # distinguish between deleting PLM links and processing delete orphans for a root item - if ($delete_req{'root_object'}) { - $delete_req{'root_object'}->delete_orphan_links(); - } else { - if ($delete_req{linkdevice} eq $self) { - &::print_log("[Insteon::ALDB_PLM] now deleting orphaned link w/ details: " - . (($delete_req{is_controller}) ? "controller" : "responder") - . ", " . (($delete_req{object}) ? "object=" . $delete_req{object}->get_object_name - : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}") - if $main::Debug{insteon}; - $self->delete_link(%delete_req); - } elsif ($delete_req{linkdevice}) { - $delete_req{linkdevice}->delete_link(%delete_req); - } - } - } else { - &::print_log("[Insteon::ALDB_PLM] A total of $$self{delete_queue_processed} orphaned link records were deleted."); - } - -} - -sub delete_link -{ - # linkkey is concat of: deviceid, group, is_controller - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - my $num_deleted = 0; - my $insteon_object = $link_parms{object}; - my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; - my $group = $link_parms{group}; - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - my $linkkey = lc $deviceid . $group . (($is_controller) ? '1' : '0'); - if (defined $$self{aldb}{$linkkey}) { - my $cmd = '80' - . $$self{aldb}{$linkkey}{flags} - . $$self{aldb}{$linkkey}{group} - . $$self{aldb}{$linkkey}{deviceid} - . $$self{aldb}{$linkkey}{data1} - . $$self{aldb}{$linkkey}{data2} - . $$self{aldb}{$linkkey}{data3}; - $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; - delete $$self{aldb}{$linkkey}; - $num_deleted = 1; - my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); - $message->interface_data($cmd); - $$self{device}->queue_message($message); - } else { - &::print_log("[Insteon::ALDB_PLM] no entry in linktable could be found for linkkey: $linkkey"); - if ($link_parms{callback}) { - package main; - eval ($link_parms{callback}); - &::print_log("[Insteon_PLM] error in add link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; - } - } - return $num_deleted; -} - -sub add_link -{ - my ($self, $parms_text) = @_; - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - my $device_id; - my $group = ($link_parms{group}) ? $link_parms{group} : '01'; - my $insteon_object = $link_parms{object}; - if (!(defined($insteon_object))) { - $device_id = lc $link_parms{deviceid}; - $insteon_object = &Insteon::get_object($device_id, $group); - } else { - $device_id = lc $insteon_object->device_id; - } - my $is_controller = ($link_parms{is_controller}) ? 1 : 0; - # first, confirm that the link does not already exist - my $linkkey = lc $device_id . $group . $is_controller; - if (defined $$self{aldb}{$linkkey}) { - &::print_log("[Insteon::ALDB_PLM] WARN: attempt to add link to PLM that already exists! " - . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); - if ($link_parms{callback}) { - package main; - eval ($link_parms{callback}); - &::print_log("[Insteon_PLM] error in add link callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; - } - } else { - my $control_code = ($is_controller) ? '40' : '41'; - # flags should be 'a2' for responder and 'e2' for controller - my $flags = ($is_controller) ? 'E2' : 'A2'; - my $data1 = (defined $link_parms{data1}) ? $link_parms{data1} : (($is_controller) ? '01' : '00'); - my $data2 = (defined $link_parms{data2}) ? $link_parms{data2} : '00'; - my $data3 = (defined $link_parms{data3}) ? $link_parms{data3} : '00'; - # from looking at manually linked records, data1 and data2 are both 00 for responder records - # and, data1 is 01 and usually data2 is 00 for controller records - - my $cmd = $control_code - . $flags - . $group - . $device_id - . $data1 - . $data2 - . $data3; - $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; - $$self{aldb}{$linkkey}{flags} = lc $flags; - $$self{aldb}{$linkkey}{group} = lc $group; - $$self{aldb}{$linkkey}{is_controller} = $is_controller; - $$self{aldb}{$linkkey}{deviceid} = lc $device_id; - $$self{aldb}{$linkkey}{data1} = lc $data1; - $$self{aldb}{$linkkey}{data2} = lc $data2; - $$self{aldb}{$linkkey}{data3} = lc $data3; - my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); - $message->interface_data($cmd); - $$self{device}->queue_message($message); - } -} - -sub has_link -{ - my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = lc $insteon_object->device_id . $group . $is_controller; - $subaddress = '00' unless $subaddress; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } - return (defined $$self{aldb}{$key}) ? 1 : 0; -} - - - - -1; +=begin comment +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +File: + AllLinkDatabase.pm + +Description: + Generic class implementation of an insteon device's all link database. + +Author(s): + Gregg Liming / gregg@limings.net + +License: + This free software is licensed under the terms of the GNU public license. + + +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +=cut + + +package Insteon::AllLinkDatabase; + +use strict; +use Insteon; +use Insteon::Lighting; + +# @Insteon::AllLinkDatabase::ISA = ('Generic_Item'); + + +sub new +{ + my ($class, $device) = @_; + my $self={}; + bless $self,$class; + $$self{device} = $device; + return $self; +} + +sub _send_cmd +{ + my ($self, $msg) = @_; + $$self{device}->_send_cmd($msg); +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = ''; + if ($$self{aldb}) { + my $aldb = ''; + foreach my $aldb_key (keys %{$$self{aldb}}) { + next unless $aldb_key eq 'empty' || $aldb_key eq 'duplicates' || $$self{aldb}{$aldb_key}{inuse}; + $aldb .= '|' if $aldb; # separate sections + my $record = ''; + if ($aldb_key eq 'empty') { + foreach my $address (@{$$self{aldb}{empty}}) { + $record .= ';' if $record; + $record .= $address; + } + $record = 'empty=' . $record; + } elsif ($aldb_key eq 'duplicates') { + my $duplicate_record = ''; + foreach my $address (@{$$self{aldb}{duplicates}}) { + $duplicate_record .= ';' if $duplicate_record; + $duplicate_record .= $address; + } + $record = 'duplicates=' . $duplicate_record; + } else { + my %aldb_record = %{$$self{aldb}{$aldb_key}}; + foreach my $record_key (keys %aldb_record) { + next unless $aldb_record{$record_key}; + $record .= ',' if $record; + $record .= $record_key . '=' . $aldb_record{$record_key}; + } + } + $aldb .= $record; + } +# &::print_log("[AllLinkDataBase] aldb restore string: $aldb") if $main::Debug{insteon}; + $restore_string .= $$self{device}->get_object_name . "->_adlb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_adlb;\n"; + } + return $restore_string; +} + +sub restore_aldb +{ + my ($self,$aldb) = @_; + if ($aldb) { + foreach my $aldb_section (split(/\|/,$aldb)) { + my %aldb_record = (); + my @aldb_empty = (); + my @aldb_duplicates = (); + my $deviceid = ''; + my $groupid = '01'; + my $is_controller = 0; + my $subaddress = '00'; + foreach my $aldb_entry (split(/,/,$aldb_section)) { + my ($key,$value) = split(/=/,$aldb_entry); + next unless $key and defined($value) and $value ne ''; + if ($key eq 'empty') { + @aldb_empty = split(/;/,$value); + } elsif ($key eq 'duplicates') { + @aldb_duplicates = split(/;/,$value); + } else { + $deviceid = lc $value if ($key eq 'deviceid'); + $groupid = lc $value if ($key eq 'group'); + $is_controller = $value if ($key eq 'is_controller'); + $subaddress = $value if ($key eq 'data3'); + $aldb_record{$key} = $value if $key and defined($value); + } + } + if (@aldb_empty) { + @{$$self{aldb}{empty}} = @aldb_empty; + } elsif (@aldb_duplicates) { + @{$$self{aldb}{duplicates}} = @aldb_duplicates; + } elsif (scalar %aldb_record) { + next unless $deviceid; + my $aldbkey = $deviceid . $groupid . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $aldbkey .= $subaddress; + } + %{$$self{aldb}{$aldbkey}} = %aldb_record; + } + } +# $self->log_alllink_table(); + } +} + + + + +package Insteon::ALDB_i1; + +use strict; +use Insteon; +use Insteon::Lighting; +use Insteon::Message; + +@Insteon::ALDB_i1::ISA = ('Insteon::AllLinkDatabase'); + +sub new +{ + my ($class,$device) = @_; + + my $self = new Insteon::AllLinkDatabase($device); + bless $self,$class; + return $self; +} + +sub _on_poke +{ + my ($self,%msg) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); + if (($$self{_mem_activity} eq 'update') or ($$self{_mem_activity} eq 'add')) { + if ($$self{_mem_action} eq 'aldb_flag') { + $$self{_mem_action} = 'aldb_group'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_group') { + $$self{_mem_action} = 'aldb_devhi'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_devhi') { + $$self{_mem_action} = 'aldb_devmid'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_devmid') { + $$self{_mem_action} = 'aldb_devlo'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_devlo') { + $$self{_mem_action} = 'aldb_data1'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_data1') { + $$self{_mem_action} = 'aldb_data2'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_data2') { + $$self{_mem_action} = 'aldb_data3'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_data3') { + ## update the aldb records w/ the changes that were made + my $aldbkey = $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + my $subaddress = $$self{pending_aldb}{data3}; + if (($subaddress ne '00') and ($subaddress ne '01')) { + $aldbkey .= $subaddress; + } + $$self{aldb}{$aldbkey}{data1} = $$self{pending_aldb}{data1}; + $$self{aldb}{$aldbkey}{data2} = $$self{pending_aldb}{data2}; + $$self{aldb}{$aldbkey}{data3} = $$self{pending_aldb}{data3}; + $$self{aldb}{$aldbkey}{inuse} = 1; # needed so that restore string will preserve record + if ($$self{_mem_activity} eq 'add') { + $$self{aldb}{$aldbkey}{is_controller} = $$self{pending_aldb}{is_controller}; + $$self{aldb}{$aldbkey}{deviceid} = lc $$self{pending_aldb}{deviceid}; + $$self{aldb}{$aldbkey}{group} = lc $$self{pending_aldb}{group}; + $$self{aldb}{$aldbkey}{address} = $$self{pending_aldb}{address}; + # on completion, check to see if the empty links list is now empty; if so, + # then decrement the current address and add it to the list + my $num_empty = @{$$self{aldb}{empty}}; + if (!($num_empty)) { + my $low_address = 0; + for my $key (keys %{$$self{aldb}}) { + next if $key eq 'empty' or $key eq 'duplicates'; + my $new_address = hex($$self{aldb}{$key}{address}); + if (!($low_address)) { + $low_address = $new_address; + next; + } else { + $low_address = $new_address if $new_address < $low_address; + } + } + $low_address = sprintf('%04X', $low_address - 8); + unshift @{$$self{aldb}{empty}}, $low_address; + } + } + # clear out mem_activity flag + $$self{_mem_activity} = undef; + if (defined $$self{_mem_callback}) { + my $callback = $$self{_mem_callback}; + # clear it out *before* the eval + $$self{_mem_callback} = undef; + package main; + eval ($callback); + package Insteon::ALDB_i1; + &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) + if $@ and $main::Debug{insteon}; + } + } + } elsif ($$self{_mem_activity} eq 'update_local') { + if ($$self{_mem_action} eq 'local_onlevel') { + $$self{_mem_lsb} = '21'; + $$self{_mem_action} = 'local_ramprate'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'local_ramprate') { + if ($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) { + # update from eeprom--only a kpl issue + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); + } + } + } elsif ($$self{_mem_activity} eq 'update_flags') { + # update from eeprom--only a kpl issue + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'delete') { + # clear out mem_activity flag + $$self{_mem_activity} = undef; + # add the address of the deleted link to the empty list + push @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; + if (exists $$self{pending_aldb}{deviceid}) { + my $key = lc $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + my $subaddress = $$self{pending_aldb}{data3}; + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + delete $$self{aldb}{$key}; + } + + if (defined $$self{_mem_callback}) { + my $callback = $$self{_mem_callback}; + # clear it out *before* the eval + $$self{_mem_callback} = undef; + package main; + eval ($callback); + &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon::ALDB_i1; + $$self{_mem_callback} = undef; + } + } +# +} + +sub _on_peek +{ + my ($self,%msg) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); + if ($msg{is_extended}) { + &::print_log("[Insteon::ALDB_i1]: extended peek for " . $$self{device}->{object_name} + . " is " . $msg{extra}) if $main::Debug{insteon}; + } else { + if ($$self{_mem_action} eq 'aldb_peek') { + if ($$self{_mem_activity} eq 'scan') { + $$self{_mem_action} = 'aldb_flag'; + # if the device is responding to the peek, then init the link table + # if at the very start of a scan + if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { + # reinit the aldb hash as there will be a new one + $$self{aldb} = undef; + # reinit the empty address list + @{$$self{aldb}{empty}} = (); + # and, also the duplicates list + @{$$self{aldb}{duplicates}} = (); + } + } elsif ($$self{_mem_activity} eq 'update') { + $$self{_mem_action} = 'aldb_data1'; + } elsif ($$self{_mem_activity} eq 'update_local') { + $$self{_mem_action} = 'local_onlevel'; + } elsif ($$self{_mem_activity} eq 'update_flags') { + $$self{_mem_action} = 'update_flags'; + } elsif ($$self{_mem_activity} eq 'delete') { + $$self{_mem_action} = 'aldb_flag'; + } elsif ($$self{_mem_activity} eq 'add') { + $$self{_mem_action} = 'aldb_flag'; + } + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'aldb_flag') { + if ($$self{_mem_activity} eq 'scan') { + my $flag = hex($msg{extra}); + $$self{pending_aldb}{inuse} = ($flag & 0x80) ? 1 : 0; + $$self{pending_aldb}{is_controller} = ($flag & 0x40) ? 1 : 0; + $$self{pending_aldb}{highwater} = ($flag & 0x02) ? 1 : 0; + if (!($$self{pending_aldb}{highwater})) { + # since this is the last unused memory location, then add it to the empty list + unshift @{$$self{aldb}{empty}}, $$self{_mem_msb} . $$self{_mem_lsb}; + $$self{_mem_action} = undef; + # clear out mem_activity flag + $$self{_mem_activity} = undef; + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " completed link memory scan") + if $main::Debug{insteon}; + if (defined $$self{_mem_callback}) { + package main; + eval ($$self{_mem_callback}); + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . ": error during scan callback $@") + if $@ and $main::Debug{insteon}; + package Insteon::ALDB_i1; + $$self{_mem_callback} = undef; + } + # ping the device as part of the scan if we don't already have a devcat + # if (!($self->{devcat})) { + # $self->ping(); + # } + } else { + $$self{pending_aldb}{flag} = $msg{extra}; + ## confirm that we have a high-water mark; otherwise stop + $$self{pending_aldb}{address} = $$self{_mem_msb} . $$self{_mem_lsb}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_group'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_activity} eq 'add') { + my $flag = ($$self{pending_aldb}{is_controller}) ? 'E2' : 'A2'; + $$self{pending_aldb}{flag} = $flag; + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($flag); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $flag, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'delete') { + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra('02'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => '02', 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_group') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{group} = lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_devhi'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, +# 'is_synchronous' => 1); + } else { + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{group}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{group}, +# 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_devhi') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{deviceid} = lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_devmid'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'add') { + my $devid = substr($$self{pending_aldb}{deviceid},0,2); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($devid); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_devmid') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{deviceid} .= lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_devlo'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'add') { + my $devid = substr($$self{pending_aldb}{deviceid},2,2); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($devid); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_devlo') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{deviceid} .= lc $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_data1'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'add') { + my $devid = substr($$self{pending_aldb}{deviceid},4,2); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($devid); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_data1') { + if ($$self{_mem_activity} eq 'scan') { + $$self{_mem_action} = 'aldb_data2'; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{pending_aldb}{data1} = $msg{extra}; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + # poke the new value + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{data1}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data1}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_data2') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{data2} = $msg{extra}; + $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); + $$self{_mem_action} = 'aldb_data3'; + $message->extra($$self{_mem_lsb}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); + } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + # poke the new value + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{data2}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data2}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'aldb_data3') { + if ($$self{_mem_activity} eq 'scan') { + $$self{pending_aldb}{data3} = $msg{extra}; + # check the previous record if highwater is set + if ($$self{pending_aldb}{highwater}) { + if ($$self{pending_aldb}{inuse}) { + # save pending_aldb and then clear it out + my $aldbkey = lc $$self{pending_aldb}{deviceid} + . $$self{pending_aldb}{group} + . $$self{pending_aldb}{is_controller}; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + my $subaddress = $$self{pending_aldb}{data3}; + if ($subaddress ne '00' and $subaddress ne '01') { + $aldbkey .= $subaddress; + } + # check for duplicates + if (exists $$self{aldb}{$aldbkey} && $$self{aldb}{$aldbkey}{inuse}) { + unshift @{$$self{aldb}{duplicates}}, $$self{pending_aldb}{address}; + } else { + %{$$self{aldb}{$aldbkey}} = %{$$self{pending_aldb}}; + } + } else { + # TO-DO: record the locations of deleted aldb records for subsequent reuse + unshift @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; + } + my $newaddress = sprintf("%04X", hex($$self{pending_aldb}{address}) - 8); + $$self{pending_aldb} = undef; + $self->_peek($newaddress); + } + } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + # poke the new value + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($$self{pending_aldb}{data3}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data3}, 'is_synchronous' => 1); + } + } elsif ($$self{_mem_action} eq 'local_onlevel') { + my $on_level = $self->local_onlevel; + $on_level = &Insteon::DimmableLight::convert_level($on_level); + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($on_level); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $on_level, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'local_ramprate') { + my $ramp_rate = $$self{_ramprate}; + $ramp_rate = '1f' unless $ramp_rate; + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($ramp_rate); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $ramp_rate, 'is_synchronous' => 1); + } elsif ($$self{_mem_action} eq 'update_flags') { + my $flags = $$self{_operating_flags}; + $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); + $message->extra($flags); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'poke', 'extra' => $flags, 'is_synchronous' => 1); + } +# +# &::print_log("AllLinkDataBase: peek for " . $self->{object_name} +# . " is " . $msg{extra}) if $main::Debug{insteon}; + } +} + + +sub scan_link_table +{ + my ($self,$callback) = @_; + $$self{_mem_activity} = 'scan'; + $$self{_mem_callback} = ($callback) ? $callback : undef; + $self->_peek('0FF8',0); +} + +sub delete_link +{ + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + if ($link_parms{address}) { + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_mem_activity} = 'delete'; + $$self{pending_aldb}{address} = $link_parms{address}; + $self->_peek($link_parms{address},0); + + } else { + my $insteon_object = $link_parms{object}; + my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; + my $groupid = $link_parms{group}; + $groupid = '01' unless $groupid; + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; + # get the address via lookup into the hash + my $key = lc $deviceid . $groupid . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + my $address = $$self{aldb}{$key}{address}; + if ($address) { + &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$address] with the following data" + . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); + # now, alter the flags byte such that the in_use flag is set to 0 + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_mem_activity} = 'delete'; + $$self{pending_aldb}{deviceid} = lc $deviceid; + $$self{pending_aldb}{group} = $groupid; + $$self{pending_aldb}{is_controller} = $is_controller; + $$self{pending_aldb}{address} = $address; + $self->_peek($address,0); + } else { + &main::print_log('[Insteon::ALDB_i1] WARN: (' . $$self{device}->get_object_name . ') attempt to delete link that does not exist!' + . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); + if ($link_parms{callback}) { + package main; + eval($link_parms{callback}); + &::print_log("[Insteon::ALDB_i1] error encountered during delete_link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon::AllLinkDataBase; + } + } + } +} + +sub delete_orphan_links +{ + my ($self) = @_; + @{$$self{delete_queue}} = (); # reset the work queue + my $selfname = $$self{device}->get_object_name; + my $num_deleted = 0; + for my $linkkey (keys %{$$self{aldb}}) { + if ($linkkey ne 'empty' and $linkkey ne 'duplicates') { + my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; + next unless $deviceid; + my $group = $$self{aldb}{$linkkey}{group}; + my $is_controller = $$self{aldb}{$linkkey}{is_controller}; + my $data3 = $$self{aldb}{$linkkey}{data3}; + my $device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface + : &Insteon::get_object($deviceid,'01'); + if (!($device)) { +# &::print_log("[AllLinkDataBase] " . $self->get_object_name . " now deleting orphaned link w/ details: " +# . (($is_controller) ? "controller" : "responder") +# . ", deviceid=$deviceid, group=$group"); + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", cause => "no device could be found"); + push @{$$self{delete_queue}}, \%delete_req; + } elsif ($device->isa("Insteon::BaseInterface") and $is_controller) { + # ignore since this is just a link back to the PLM + } elsif ($device->isa("Insteon::BaseInterface")) { + # does the PLM have a link point back? If not, the delete this one + if (!($device->has_link($self,$group,1))) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + # is there an entry in the items.mht that corresponds to this link? + if ($is_controller) { + # TO-DO: handle this case + } else { + my $plm_link = $device->get_device('000000',$group); + if ($plm_link) { + my $is_invalid = 1; + foreach my $member_ref (keys %{$$plm_link{members}}) { + my $member = $$plm_link{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) { + $member = @lights[0]; # pick the first + } + } + if ($member->device_id eq $self->device_id) { + if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { + $is_invalid = 0; + last; + } + } + } + if ($is_invalid) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link is defined for the plm controlled scene", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } else { + # delete the link since it doesn't exist + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no plm link could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + } else { + if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link to the device could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } else { + my $is_invalid = 1; + my $link = ($is_controller) ? &Insteon::get_object($self->device_id,$group) + : &Insteon::get_object($device->device_id,$group); + if ($link) { + foreach my $member_ref (keys %{$$link{members}}) { + my $member = $$link{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) { + $member = @lights[0]; # pick the first + } + } + if ($member->isa('Insteon::BaseDevice') and !($member->is_root)) { + $member = $member->get_root; + } + if ($member->isa('Insteon::BaseDevice') and !($is_controller) and ($member->device_id eq $self->device_id)) { + $is_invalid = 0; + last; + } elsif ($member->isa('Insteon::BaseDevice') and $is_controller and ($member->device_id eq $device->device_id)) { + $is_invalid = 0; + last; + } + + } + } + if ($is_invalid) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no reverse link could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + } + } elsif ($linkkey eq 'duplicates') { + my $address = pop @{$$self{aldb}{duplicates}}; + while ($address) { + my %delete_req = (address => $address, + callback => "$selfname->_process_delete_queue()", + cause => "duplicate record found"); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + $address = pop @{$$self{aldb}{duplicates}}; + } + } + } + $$self{delete_queue_processed} = 0; + $self->_process_delete_queue(); + return $num_deleted; +} + +sub _process_delete_queue { + my ($self) = @_; + my $num_in_queue = @{$$self{delete_queue}}; + if ($num_in_queue) { + my $delete_req_ptr = shift(@{$$self{delete_queue}}); + my %delete_req = %$delete_req_ptr; + if ($delete_req{address}) { + &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting duplicate record at address " + . $delete_req{address}); + } else { + &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " + . (($delete_req{is_controller}) ? "controller" : "responder") + . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name + : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); + } + $self->delete_link(%delete_req); + $$self{delete_queue_processed}++; + } else { + $self->interface->_process_delete_queue($$self{delete_queue_processed}); + } +} + +sub add_link +{ + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + my $device_id; + my $insteon_object = $link_parms{object}; + my $group = $link_parms{group}; + if (!(defined($insteon_object))) { + $device_id = lc $link_parms{deviceid}; + $insteon_object = &Insteon::get_object($device_id, $group); + } else { + $device_id = lc $insteon_object->device_id; + } + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + # check whether the link already exists + my $subaddress = ($link_parms{data3}) ? $link_parms{data3} : '00'; + # get the address via lookup into the hash + my $key = lc $device_id . $group . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if !($subaddress eq '00' or $subaddress eq '01') { + $key .= $subaddress; + } + if (defined $$self{aldb}{$key}{inuse}) { + &::print_log("[Insteon::ALDB_i1] WARN: attempt to add link to " . $$self{device}->get_object_name . " that already exists! " + . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); + if ($link_parms{callback}) { + package main; + eval($link_parms{callback}); + &::print_log("[Insteon::ALDB_i1] failure occurred in callback eval for " . $$self{device}->get_object_name . ":" . $@) + if $@ and $main::Debug{insteon}; + package Insteon::ALDB_i1; + } + } else { + # strip optional % sign to append on_level + my $on_level = $link_parms{on_level}; + $on_level =~ s/(\d)%?/$1/; + $on_level = '100' unless defined($on_level); # 100% == on is the default + # strip optional s (seconds) to append ramp_rate + my $ramp_rate = $link_parms{ramp_rate}; + $ramp_rate =~ s/(\d)s?/$1/; + $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default + &::print_log("[Insteon::ALDB_i1] adding link record " . $$self{device}->get_object_name + . " light level controlled by " . $insteon_object->get_object_name + . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; + my $data1 = &Insteon::DimmableLight::convert_level($on_level); + my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; + # get the first available memory location + my $address = pop @{$$self{aldb}{empty}}; + # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails + $$self{_mem_activity} = 'add'; + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); + } +} + +sub update_link +{ + my ($self, %link_parms) = @_; + my $insteon_object = $link_parms{object}; + my $group = $link_parms{group}; + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + # strip optional % sign to append on_level + my $on_level = $link_parms{on_level}; + $on_level =~ s/(\d+)%?/$1/; + # strip optional s (seconds) to append ramp_rate + my $ramp_rate = $link_parms{ramp_rate}; + $ramp_rate =~ s/(\d)s?/$1/; + &::print_log("[Insteon::ALDB_i1] updating " . $$self{device}->get_object_name . " light level controlled by " . $insteon_object->get_object_name + . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; + my $data1 = sprintf('%02X',$on_level * 2.55); + $data1 = 'ff' if $on_level eq '100'; + $data1 = '00' if $on_level eq '0'; + my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; + my $deviceid = $insteon_object->device_id; + my $subaddress = $data3; + # get the address via lookup into the hash + my $key = lc $deviceid . $group . $is_controller; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if !($subaddress eq '00' or $subaddress eq '01') { + $key .= $subaddress; + } + my $address = $$self{aldb}{$key}{address}; + $$self{_mem_activity} = 'update'; + $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $self->_write_link($address, $deviceid, $group, $is_controller, $data1, $data2, $data3); +} + + +sub log_alllink_table +{ + my ($self) = @_; + &::print_log("[Insteon::ALDB_i1] link table for " . $$self{device}->get_object_name . " (devcat: $$self{devcat}):"); + foreach my $aldbkey (sort(keys(%{$$self{aldb}}))) { + next if $aldbkey eq 'empty' or $aldbkey eq 'duplicates'; + my ($device); + my $is_controller = $$self{aldb}{$aldbkey}{is_controller}; + if ($$self{device}->interface()->device_id() and ($$self{device}->interface()->device_id() eq $$self{aldb}{$aldbkey}{deviceid})) { + $device = $$self{device}->interface; + } else { + $device = &Insteon::get_object($$self{aldb}{$aldbkey}{deviceid},'01'); + } + my $object_name = ($device) ? $device->get_object_name : $$self{aldb}{$aldbkey}{deviceid}; + + my $on_level = 'unknown'; + if (defined $$self{aldb}{$aldbkey}{data1}) { + if ($$self{aldb}{$aldbkey}{data1}) { + $on_level = int((hex($$self{aldb}{$aldbkey}{data1})*100/255) + .5) . "%"; + } else { + $on_level = '0%'; + } + } + + my $rspndr_group = $$self{aldb}{$aldbkey}{data3}; + $rspndr_group = '01' if $rspndr_group eq '00'; + + my $ramp_rate = 'unknown'; + if ($$self{aldb}{$aldbkey}{data2}) { + if (!($$self{device}->isa('Insteon::DimmableLight')) or (!($is_controller) and ($rspndr_group != '01'))) { + $ramp_rate = 'none'; + if ($on_level eq '0%') { + $on_level = 'off'; + } else { + $on_level = 'on'; + } + } else { + $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($$self{aldb}{$aldbkey}{data2}) . "s"; + } + } + + &::print_log("[Insteon::ALDB_i1] [0x" . $$self{aldb}{$aldbkey}{address} . "] " . + (($$self{aldb}{$aldbkey}{is_controller}) ? "contlr($$self{aldb}{$aldbkey}{group}) record to " + . $object_name . "($rspndr_group), (d1:$$self{aldb}{$aldbkey}{data1}, d2:$$self{aldb}{$aldbkey}{data2}, d3:$$self{aldb}{$aldbkey}{data3})" + : "rspndr($rspndr_group) record to " . $object_name . "($$self{aldb}{$aldbkey}{group})" + . ": onlevel=$on_level and ramp=$ramp_rate (d3:$$self{aldb}{$aldbkey}{data3})")) if $main::Debug{insteon}; + } + foreach my $address (@{$$self{aldb}{empty}}) { + &::print_log("[Insteon::ALDB_i1] [0x$address] is empty"); + } + + foreach my $address (@{$$self{aldb}{duplicates}}) { + &::print_log("[Insteon::ALDB_i1] [0x$address] holds a duplicate entry"); + } + +} + +sub update_local_properties +{ + my ($self) = @_; + $$self{_mem_activity} = 'update_local'; + $self->_peek('0032'); # 0032 is the address for the onlevel +} + +sub update_flags +{ + my ($self, $flags) = @_; + return unless defined $flags; + + $$self{_mem_activity} = 'update_flags'; + $$self{_operating_flags} = $flags; + $self->_peek('0023'); +} + +sub get_link_record +{ + my ($self,$link_key) = @_; + my %link_record = (); + %link_record = %{$$self{aldb}{$link_key}} if $$self{aldb}{$link_key}; + return %link_record; +} + + + +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $key = ""; + if ($insteon_object->isa('Insteon::BaseObject') || $insteon_object->isa('Insteon::BaseInterface')) { + $key = lc $insteon_object->device_id . $group . $is_controller; + } else { + $key = lc $$insteon_object{device}->device_id . $group . $is_controller; + } + $subaddress = '00' unless $subaddress; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if !($subaddress eq '00' or $subaddress eq '01') { + $key .= $subaddress; + } + return (defined $$self{aldb}{$key}) ? 1 : 0; +} + +sub _write_link +{ + my ($self, $address, $deviceid, $group, $is_controller, $data1, $data2, $data3) = @_; + if ($address) { + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " address: $address found for device: $deviceid and group: $group"); + # change address for start of change to be address + offset + if ($$self{_mem_activity} eq 'update') { + $address = sprintf('%04X',hex($address) + 5); + } + $$self{pending_aldb}{address} = $address; + $$self{pending_aldb}{deviceid} = lc $deviceid; + $$self{pending_aldb}{group} = lc $group; + $$self{pending_aldb}{is_controller} = $is_controller; + $$self{pending_aldb}{data1} = (defined $data1) ? lc $data1 : '00'; + $$self{pending_aldb}{data2} = (defined $data2) ? lc $data2 : '00'; + # Note: if device is a KeypadLinc, then $data3 must be assigned the value of the applicable button (01) + if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) { + &::print_log("[Insteon::ALDB_i1] setting data3 to " . $self->group . " for this keypadlinc") + if $main::Debug{insteon}; + $data3 = $self->group; + } + $$self{pending_aldb}{data3} = (defined $data3) ? lc $data3 : '00'; + $self->_peek($address); + } else { + &::print_log("[Insteon::ALDB_i1] WARN: " . $$self{device}->get_object_name + . " write_link failure: no address available for record to device: $deviceid and group: $group" . + " and is_controller: $is_controller");; + } +} + +sub _peek +{ + my ($self, $address, $extended) = @_; + my $msb = substr($address,0,2); + my $lsb = substr($address,2,2); + if ($extended) { + my $message = $self->device->derive_message('peek','insteon_ext_send', + $lsb . "0000000000000000000000000000"); + $self->interface->queue_message($message); + + } else { + $$self{_mem_lsb} = $lsb; + $$self{_mem_msb} = $msb; + $$self{_mem_action} = 'aldb_peek'; + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " accessing memory at location: 0x" . $address); + my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'set_address_msb'); + $message->extra($msb); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'set_address_msb', 'extra' => $msb, 'is_synchronous' => 1); + } +} + + + +package Insteon::ALDB_i2; + +use strict; +use Insteon; +use Insteon::Lighting; + +@Insteon::ALDB_i2::ISA = ('Insteon::AllLinkDatabase'); + +sub new +{ + my ($class,$device) = @_; + + my $self = new Insteon::AllLinkDatabase($device); + bless $self,$class; + return $self; +} + + + + + +package Insteon::ALDB_PLM; + +use strict; +use Insteon; +use Insteon::Lighting; + +@Insteon::ALDB_PLM::ISA = ('Insteon::AllLinkDatabase'); + +sub new +{ + my ($class,$device) = @_; + + my $self = new Insteon::AllLinkDatabase($device); + bless $self,$class; + return $self; +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = ''; + if ($$self{aldb}) { + my $link = ''; + foreach my $link_key (keys %{$$self{aldb}}) { + $link .= '|' if $link; # separate sections + my %link_record = %{$$self{aldb}{$link_key}}; + my $record = ''; + foreach my $record_key (keys %link_record) { + next unless $link_record{$record_key}; + $record .= ',' if $record; + $record .= $record_key . '=' . $link_record{$record_key}; + } + $link .= $record; + } + $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_linktable(q~$link~) if " . $$self{device}->get_object_name . "->_aldb;\n"; + } + return $restore_string; +} + +sub restore_linktable +{ + my ($self, $links) = @_; + if ($links) { + foreach my $link_section (split(/\|/,$links)) { + my %link_record = (); + my $deviceid = ''; + my $groupid = '01'; + my $is_controller = 0; + foreach my $link_record (split(/,/,$link_section)) { + my ($key,$value) = split(/=/,$link_record); + $deviceid = $value if ($key eq 'deviceid'); + $groupid = $value if ($key eq 'group'); + $is_controller = $value if ($key eq 'is_controller'); + $link_record{$key} = $value if $key and defined($value); + } + my $linkkey = $deviceid . $groupid . $is_controller; + %{$$self{aldb}{lc $linkkey}} = %link_record; + } +# $self->log_alllink_table(); + } +} + +sub log_alllink_table +{ + my ($self) = @_; + foreach my $linkkey (sort(keys(%{$$self{aldb}}))) { + my $data3 = $$self{aldb}{$linkkey}{data3}; + my $is_controller = $$self{aldb}{$linkkey}{is_controller}; + my $group = ($is_controller) ? $data3 : $$self{aldb}{$linkkey}{group}; + $group = '01' if $group eq '00'; + my $deviceid = $$self{aldb}{$linkkey}{deviceid}; + my $device = &Insteon::get_object($deviceid,$group); + my $object_name = ''; + if ($device) + { + $object_name = $device->get_object_name; + } + else + { + $object_name = uc substr($deviceid,0,2) . '.' . + uc substr($deviceid,2,2) . '.' . + uc substr($deviceid,4,2); + } + &::print_log("[Insteon::ALDB_PLM] " . + (($is_controller) ? "cntlr($$self{aldb}{$linkkey}{group}) record to " + . $object_name + : "responder record to " . $object_name . "($$self{aldb}{$linkkey}{group})") + . " (d1=$$self{aldb}{$linkkey}{data1}, d2=$$self{aldb}{$linkkey}{data2}, " + . "d3=$data3)") + if $main::Debug{insteon}; + } +} + +sub parse_alllink +{ + my ($self, $data) = @_; +# &::print_log("[DEBUG] $data"); + if (substr($data,0,6)) { + my %link = (); + my $flag = substr($data,0,1); + $link{is_controller} = (hex($flag) & 0x04) ? 1 : 0; + $link{flags} = substr($data,0,2); + $link{group} = lc substr($data,2,2); + $link{deviceid} = lc substr($data,4,6); + $link{data1} = substr($data,10,2); + $link{data2} = substr($data,12,2); + $link{data3} = substr($data,14,2); + my $key = $link{deviceid} . $link{group} . $link{is_controller}; + %{$$self{aldb}{lc $key}} = %link; + } +} + +sub get_first_alllink +{ + my ($self) = @_; + $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_first_rec', $$self{device})); +} + +sub get_next_alllink +{ + my ($self) = @_; + $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_next_rec', $$self{device})); +} + +sub delete_orphan_links +{ + my ($self) = @_; + @{$$self{delete_queue}} = (); # reset the work queue + my $selfname = $$self{device}->get_object_name; + my $num_deleted = 0; + foreach my $linkkey (keys %{$$self{aldb}}) { + my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; + my $group = $$self{aldb}{$linkkey}{group}; + my $is_controller = $$self{aldb}{$linkkey}{is_controller}; + my $data3 = $$self{aldb}{$linkkey}{data3}; + my $device = &Insteon::get_object($deviceid,'01'); + # if a PLM link (regardless of responder or controller) exists to a device that is not known, then delete + if (!($device)) { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $self, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } else { + my $is_invalid = 1; + my $link = undef; + if ($is_controller) { + # then, this is a PLM defined link; and, we won't care about responder links as we assume + # they're ok given that they reference known devices + $link = &Insteon::get_object('000000',$group); + if (!($link)) { + # a reference in the PLM's linktable does not match a scene member target + $is_invalid = 1; + } else { + # iterate over all of the members of the Insteon_Link item + foreach my $member_ref (keys %{$$link{members}}) { + my $member = $$link{members}{$member_ref}{object}; + # member will correspond to a scene member item + # and, if it is a light item, then get the real device + if ($member->isa('Light_Item')) { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) { + $member = @lights[0]; # pick the first + } + } + if ($member->isa('Insteon::BaseDevice')) { + my $linkmember = $member; + # make sure that this is a root device + if (!($member->is_root)) { + $member = $member->get_root; + } + if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) { + # at this point, the forward link is ok; but, only if the reverse + # link also exists. So, check: + if ($member->has_link($self, $group, 0, $data3)) { + $is_invalid = 0; + } + last; + } + } else { + $is_invalid = 0; + } + } + if ($is_invalid) { + # then, there is a good chance that a reciprocal link exists; if so, delet it too + if ($device->has_link($self,$group,0, $data3)) { + my %delete_req = (object => $self, group => $group, is_controller => 0, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $device, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } + } + } + if ($is_invalid) { + my %delete_req = (object => $device, group => $group, is_controller => 1, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $self, data3 => $data3); +# push @{$$self{delete_queue}}, \%delete_req; + } + } + } + } + + $$self{delete_queue_processed} = 0; # reset the counter + + # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links + for my $obj (&Insteon::find_members('Insteon::BaseObject')) + { + #Match on real objects only + if (($obj->is_root)) + { +# $num_deleted += $obj->delete_orphan_links(); +# my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); +# push @{$$self{delete_queue}}, \%delete_req; + } + } + $self->_process_delete_queue(); +} + +sub _process_delete_queue { + my ($self, $p_num_deleted) = @_; + $$self{delete_queue_processed} += $p_num_deleted if $p_num_deleted; + my $num_in_queue = @{$$self{delete_queue}}; + if ($num_in_queue) { + my $delete_req_ptr = shift(@{$$self{delete_queue}}); + my %delete_req = %$delete_req_ptr; + # distinguish between deleting PLM links and processing delete orphans for a root item + if ($delete_req{'root_object'}) { + $delete_req{'root_object'}->delete_orphan_links(); + } else { + if ($delete_req{linkdevice} eq $self) { + &::print_log("[Insteon::ALDB_PLM] now deleting orphaned link w/ details: " + . (($delete_req{is_controller}) ? "controller" : "responder") + . ", " . (($delete_req{object}) ? "object=" . $delete_req{object}->get_object_name + : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}") + if $main::Debug{insteon}; + $self->delete_link(%delete_req); + } elsif ($delete_req{linkdevice}) { + $delete_req{linkdevice}->delete_link(%delete_req); + } + } + } else { + &::print_log("[Insteon::ALDB_PLM] A total of $$self{delete_queue_processed} orphaned link records were deleted."); + } + +} + +sub delete_link +{ + # linkkey is concat of: deviceid, group, is_controller + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + my $num_deleted = 0; + my $insteon_object = $link_parms{object}; + my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; + my $group = $link_parms{group}; + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + my $linkkey = lc $deviceid . $group . (($is_controller) ? '1' : '0'); + if (defined $$self{aldb}{$linkkey}) { + my $cmd = '80' + . $$self{aldb}{$linkkey}{flags} + . $$self{aldb}{$linkkey}{group} + . $$self{aldb}{$linkkey}{deviceid} + . $$self{aldb}{$linkkey}{data1} + . $$self{aldb}{$linkkey}{data2} + . $$self{aldb}{$linkkey}{data3}; + $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; + delete $$self{aldb}{$linkkey}; + $num_deleted = 1; + my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); + $message->interface_data($cmd); + $$self{device}->queue_message($message); + } else { + &::print_log("[Insteon::ALDB_PLM] no entry in linktable could be found for linkkey: $linkkey"); + if ($link_parms{callback}) { + package main; + eval ($link_parms{callback}); + &::print_log("[Insteon_PLM] error in add link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + } + return $num_deleted; +} + +sub add_link +{ + my ($self, $parms_text) = @_; + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + my $device_id; + my $group = ($link_parms{group}) ? $link_parms{group} : '01'; + my $insteon_object = $link_parms{object}; + if (!(defined($insteon_object))) { + $device_id = lc $link_parms{deviceid}; + $insteon_object = &Insteon::get_object($device_id, $group); + } else { + $device_id = lc $insteon_object->device_id; + } + my $is_controller = ($link_parms{is_controller}) ? 1 : 0; + # first, confirm that the link does not already exist + my $linkkey = lc $device_id . $group . $is_controller; + if (defined $$self{aldb}{$linkkey}) { + &::print_log("[Insteon::ALDB_PLM] WARN: attempt to add link to PLM that already exists! " + . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); + if ($link_parms{callback}) { + package main; + eval ($link_parms{callback}); + &::print_log("[Insteon_PLM] error in add link callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + } else { + my $control_code = ($is_controller) ? '40' : '41'; + # flags should be 'a2' for responder and 'e2' for controller + my $flags = ($is_controller) ? 'E2' : 'A2'; + my $data1 = (defined $link_parms{data1}) ? $link_parms{data1} : (($is_controller) ? '01' : '00'); + my $data2 = (defined $link_parms{data2}) ? $link_parms{data2} : '00'; + my $data3 = (defined $link_parms{data3}) ? $link_parms{data3} : '00'; + # from looking at manually linked records, data1 and data2 are both 00 for responder records + # and, data1 is 01 and usually data2 is 00 for controller records + + my $cmd = $control_code + . $flags + . $group + . $device_id + . $data1 + . $data2 + . $data3; + $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; + $$self{aldb}{$linkkey}{flags} = lc $flags; + $$self{aldb}{$linkkey}{group} = lc $group; + $$self{aldb}{$linkkey}{is_controller} = $is_controller; + $$self{aldb}{$linkkey}{deviceid} = lc $device_id; + $$self{aldb}{$linkkey}{data1} = lc $data1; + $$self{aldb}{$linkkey}{data2} = lc $data2; + $$self{aldb}{$linkkey}{data3} = lc $data3; + my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); + $message->interface_data($cmd); + $$self{device}->queue_message($message); + } +} + +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $key = lc $insteon_object->device_id . $group . $is_controller; + $subaddress = '00' unless $subaddress; + # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists + if ($subaddress ne '00' and $subaddress ne '01') { + $key .= $subaddress; + } + return (defined $$self{aldb}{$key}) ? 1 : 0; +} + + + + +1; \ No newline at end of file From ac1333a554bca1d38386e161affb9456a724bd41 Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Tue, 18 Jan 2011 14:56:07 +0000 Subject: [PATCH 021/150] updated code for Omnistat2 support. --- .../hai_web/omnistat_sched_web.pl | 427 +++++++++++++++-- .../hai_web/omnistat_setup_web.pl | 17 +- code/support/hai-omnistat/omnistat.pl | 96 ++-- lib/Omnistat.pm | 428 ++++++++++++++++-- 4 files changed, 866 insertions(+), 102 deletions(-) diff --git a/code/support/hai-omnistat/hai_web/omnistat_sched_web.pl b/code/support/hai-omnistat/hai_web/omnistat_sched_web.pl index 13f727509..cd151328e 100644 --- a/code/support/hai-omnistat/hai_web/omnistat_sched_web.pl +++ b/code/support/hai-omnistat/hai_web/omnistat_sched_web.pl @@ -4,12 +4,15 @@ # 3456789112345678921234567893123456789412345678951234567896123456789712345678981234567899123456789012345678911234567892123456789312 =begin comment -This page can be used to program Omnistats. +This page can be used to program Omnistats. You can also call it as http://server:8080/hai/omnistat_sched_web.pl?location=mbr_stat Originally by Joel Davidson, Daniel Arnold et al The HTML of this page is based on work by Kent Noonan. +2011/01/09 -- Mickey Argo/Karl Suchy/Marc MERLIN +- Added Omnistat2 code + 2009/08/03 -- merlin - cleanups, added debugging, logging and comments - fixed to support 24H time, like the rest of the world uses :) @@ -24,6 +27,7 @@ # Authority: admin my $html; my @days; +my @vaca; my $reg; my $i; my $location; @@ -72,6 +76,9 @@ Omnistat::omnistat_debug("$NAME: will work with stat $location"); } +my $IsOmnistat2 = 0; +$IsOmnistat2 = 1 if ($stat->is_omnistat2); + #Loop through the arguments passed for ( $i = 1 ; $i <= $#ARGV ; $i++ ) { Omnistat::omnistat_debug("$NAME: looking at arg# $i: $ARGV[$i]"); @@ -104,6 +111,7 @@ } } +# Weekday (RC-xx) or Monday (Omnistat2) my ( $wmt, $wmc, $wmh, $wdt, $wdc, $wdh, $wet, $wec, $weh, $wnt, $wnc, $wnh ) = split ' ', $stat->read_cached_reg( "0x15", 12 ); $days[0][0][0] = &Omnistat::translate_time($wmt); @@ -118,34 +126,107 @@ $days[0][3][0] = &Omnistat::translate_time($wnt); $days[0][3][1] = &Omnistat::translate_temp($wnc); $days[0][3][2] = &Omnistat::translate_temp($wnh); + +# Tuesday to Friday for Omnistat2 +my $weekday_or_monday = 'Weekday'; +if ($IsOmnistat2) +{ + # Used later down to display Monday or Weekday for the first day. + $weekday_or_monday = 'Monday'; + ( $wmt, $wmc, $wmh, $wdt, $wdc, $wdh, $wet, $wec, $weh, $wnt, $wnc, $wnh ) = + split ' ', $stat->read_cached_reg( "0x4B", 12 ); + $days[1][0][0] = &Omnistat::translate_time($wmt); + $days[1][0][1] = &Omnistat::translate_temp($wmc); + $days[1][0][2] = &Omnistat::translate_temp($wmh); + $days[1][1][0] = &Omnistat::translate_time($wdt); + $days[1][1][1] = &Omnistat::translate_temp($wdc); + $days[1][1][2] = &Omnistat::translate_temp($wdh); + $days[1][2][0] = &Omnistat::translate_time($wet); + $days[1][2][1] = &Omnistat::translate_temp($wec); + $days[1][2][2] = &Omnistat::translate_temp($weh); + $days[1][3][0] = &Omnistat::translate_time($wnt); + $days[1][3][1] = &Omnistat::translate_temp($wnc); + $days[1][3][2] = &Omnistat::translate_temp($wnh); + split ' ', $stat->read_cached_reg( "0x57", 12 ); + $days[2][0][0] = &Omnistat::translate_time($wmt); + $days[2][0][1] = &Omnistat::translate_temp($wmc); + $days[2][0][2] = &Omnistat::translate_temp($wmh); + $days[2][1][0] = &Omnistat::translate_time($wdt); + $days[2][1][1] = &Omnistat::translate_temp($wdc); + $days[2][1][2] = &Omnistat::translate_temp($wdh); + $days[2][2][0] = &Omnistat::translate_time($wet); + $days[2][2][1] = &Omnistat::translate_temp($wec); + $days[2][2][2] = &Omnistat::translate_temp($weh); + $days[2][3][0] = &Omnistat::translate_time($wnt); + $days[2][3][1] = &Omnistat::translate_temp($wnc); + $days[2][3][2] = &Omnistat::translate_temp($wnh); + split ' ', $stat->read_cached_reg( "0x63", 12 ); + $days[3][0][0] = &Omnistat::translate_time($wmt); + $days[3][0][1] = &Omnistat::translate_temp($wmc); + $days[3][0][2] = &Omnistat::translate_temp($wmh); + $days[3][1][0] = &Omnistat::translate_time($wdt); + $days[3][1][1] = &Omnistat::translate_temp($wdc); + $days[3][1][2] = &Omnistat::translate_temp($wdh); + $days[3][2][0] = &Omnistat::translate_time($wet); + $days[3][2][1] = &Omnistat::translate_temp($wec); + $days[3][2][2] = &Omnistat::translate_temp($weh); + $days[3][3][0] = &Omnistat::translate_time($wnt); + $days[3][3][1] = &Omnistat::translate_temp($wnc); + $days[3][3][2] = &Omnistat::translate_temp($wnh); + split ' ', $stat->read_cached_reg( "0x6F", 12 ); + $days[4][0][0] = &Omnistat::translate_time($wmt); + $days[4][0][1] = &Omnistat::translate_temp($wmc); + $days[4][0][2] = &Omnistat::translate_temp($wmh); + $days[4][1][0] = &Omnistat::translate_time($wdt); + $days[4][1][1] = &Omnistat::translate_temp($wdc); + $days[4][1][2] = &Omnistat::translate_temp($wdh); + $days[4][2][0] = &Omnistat::translate_time($wet); + $days[4][2][1] = &Omnistat::translate_temp($wec); + $days[4][2][2] = &Omnistat::translate_temp($weh); + $days[4][3][0] = &Omnistat::translate_time($wnt); + $days[4][3][1] = &Omnistat::translate_temp($wnc); + $days[4][3][2] = &Omnistat::translate_temp($wnh); +} + +# Saturday/Sunday (all stats) ( $wmt, $wmc, $wmh, $wdt, $wdc, $wdh, $wet, $wec, $weh, $wnt, $wnc, $wnh ) = split ' ', $stat->read_cached_reg( "0x21", 12 ); -$days[1][0][0] = &Omnistat::translate_time($wmt); -$days[1][0][1] = &Omnistat::translate_temp($wmc); -$days[1][0][2] = &Omnistat::translate_temp($wmh); -$days[1][1][0] = &Omnistat::translate_time($wdt); -$days[1][1][1] = &Omnistat::translate_temp($wdc); -$days[1][1][2] = &Omnistat::translate_temp($wdh); -$days[1][2][0] = &Omnistat::translate_time($wet); -$days[1][2][1] = &Omnistat::translate_temp($wec); -$days[1][2][2] = &Omnistat::translate_temp($weh); -$days[1][3][0] = &Omnistat::translate_time($wnt); -$days[1][3][1] = &Omnistat::translate_temp($wnc); -$days[1][3][2] = &Omnistat::translate_temp($wnh); +$days[5][0][0] = &Omnistat::translate_time($wmt); +$days[5][0][1] = &Omnistat::translate_temp($wmc); +$days[5][0][2] = &Omnistat::translate_temp($wmh); +$days[5][1][0] = &Omnistat::translate_time($wdt); +$days[5][1][1] = &Omnistat::translate_temp($wdc); +$days[5][1][2] = &Omnistat::translate_temp($wdh); +$days[5][2][0] = &Omnistat::translate_time($wet); +$days[5][2][1] = &Omnistat::translate_temp($wec); +$days[5][2][2] = &Omnistat::translate_temp($weh); +$days[5][3][0] = &Omnistat::translate_time($wnt); +$days[5][3][1] = &Omnistat::translate_temp($wnc); +$days[5][3][2] = &Omnistat::translate_temp($wnh); ( $wmt, $wmc, $wmh, $wdt, $wdc, $wdh, $wet, $wec, $weh, $wnt, $wnc, $wnh ) = split ' ', $stat->read_cached_reg( "0x2d", 12 ); -$days[2][0][0] = &Omnistat::translate_time($wmt); -$days[2][0][1] = &Omnistat::translate_temp($wmc); -$days[2][0][2] = &Omnistat::translate_temp($wmh); -$days[2][1][0] = &Omnistat::translate_time($wdt); -$days[2][1][1] = &Omnistat::translate_temp($wdc); -$days[2][1][2] = &Omnistat::translate_temp($wdh); -$days[2][2][0] = &Omnistat::translate_time($wet); -$days[2][2][1] = &Omnistat::translate_temp($wec); -$days[2][2][2] = &Omnistat::translate_temp($weh); -$days[2][3][0] = &Omnistat::translate_time($wnt); -$days[2][3][1] = &Omnistat::translate_temp($wnc); -$days[2][3][2] = &Omnistat::translate_temp($wnh); +$days[6][0][0] = &Omnistat::translate_time($wmt); +$days[6][0][1] = &Omnistat::translate_temp($wmc); +$days[6][0][2] = &Omnistat::translate_temp($wmh); +$days[6][1][0] = &Omnistat::translate_time($wdt); +$days[6][1][1] = &Omnistat::translate_temp($wdc); +$days[6][1][2] = &Omnistat::translate_temp($wdh); +$days[6][2][0] = &Omnistat::translate_time($wet); +$days[6][2][1] = &Omnistat::translate_temp($wec); +$days[6][2][2] = &Omnistat::translate_temp($weh); +$days[6][3][0] = &Omnistat::translate_time($wnt); +$days[6][3][1] = &Omnistat::translate_temp($wnc); +$days[6][3][2] = &Omnistat::translate_temp($wnh); + +#Vacation Mode Data (test) +#my ( $vsc, $vsh ) = +# split ' ', $stat->read_cached_reg( "0x81", 2 ); +#my ( $ved, $veh ) = +# split ' ', $stat->read_cached_reg( "0x95", 2 ); +#$vaca[0][0] = &Omnistat::translate_temp($vsc); +#$vaca[0][1] = &Omnistat::translate_temp($vsh); +#$vaca[1][0] = &Omnistat::translate_time($ved); +#$vaca[1][1] = &Omnistat::translate_time($veh); my $pretty_name = &pretty_object_name($location)." (".$stat->get_stat_type().")"; @@ -178,12 +259,12 @@ $html = $html . ""; } else { Omnistat::omnistat_debug("$NAME: Got single location $location, skipping drop down menu"); - $html = $html . $pretty_name; + $html = $html . $pretty_name; $html = $html . ""; } -$html = $html . " - +$html .= " +         

    -Weekday
    +$weekday_or_monday
     @@ -295,8 +376,11 @@ @@ -365,7 +449,7 @@ @@ -430,7 +514,285 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Morning
     
    -
    -Saturday
    +
    "; + +if ($IsOmnistat2) { +$html .= " +Tuesday
    		 Morning
    		 

    -Sunday
    +Wednesday
    		 Morning
     
    +
    +Thursday
    +     		Morning
    +     		$days[3][0][0]
    +     		$days[3][0][1]
    +     		$days[3][0][2]
    +
    Day
    +     		$days[3][1][0]
    +     		$days[3][1][1]
    +     		$days[3][1][2]
    +
    Evening
    +     		$days[3][2][0]
    +     		$days[3][2][1]
    +     		$days[3][2][2]
    +
    Night
    +     		$days[3][3][0]
    +     		$days[3][3][1]
    +     		$days[3][3][2]
    +
     
    +
    +Friday
    +     		Morning
    +     		$days[4][0][0]
    +     		$days[4][0][1]
    +     		$days[4][0][2]
    +
    Day
    +     		$days[4][1][0]
    +     		$days[4][1][1]
    +     		$days[4][1][2]
    +
    Evening
    +     		$days[4][2][0]
    +     		$days[4][2][1]
    +     		$days[4][2][2]
    +
    Night
    +     		$days[4][3][0]
    +     		$days[4][3][1]
    +     		$days[4][3][2]
    +
     
    +
    "; +} +$html .= " +Saturday
    +     		Morning
    +     		$days[5][0][0]
    +     		$days[5][0][1]
    +     		$days[5][0][2]
    +
    Day
    +     		$days[5][1][0]
    +     		$days[5][1][1]
    +     		$days[5][1][2]
    +
    Evening
    +     		$days[5][2][0]
    +     		$days[5][2][1]
    +     		$days[5][2][2]
    +
    Night
    +     		$days[5][3][0]
    +     		$days[5][3][1]
    +     		$days[5][3][2]
    +
     
    +
    +Sunday
    +     		Morning
    +     		$days[6][0][0]
    +     		$days[6][0][1]
    +     		$days[6][0][2]
    +
    Day
    +     		$days[6][1][0]
    +     		$days[6][1][1]
    +     		$days[6][1][2]
    +
    Evening
    +     		$days[6][2][0]
    +     		$days[6][2][1]
    +     		$days[6][2][2]
    +
    Night
    +     		$days[6][3][0]
    +     		$days[6][3][1]
    +     		$days[6][3][2]
    +
    @@ -441,4 +803,5 @@ "; + return &html_page( '', $html ); diff --git a/code/support/hai-omnistat/hai_web/omnistat_setup_web.pl b/code/support/hai-omnistat/hai_web/omnistat_setup_web.pl index 6ce6c18d1..910e0c0cb 100644 --- a/code/support/hai-omnistat/hai_web/omnistat_setup_web.pl +++ b/code/support/hai-omnistat/hai_web/omnistat_setup_web.pl @@ -7,6 +7,9 @@ Originally by Joel Davidson, Daniel Arnold et al The HTML of this page is based on work by Kent Noonan. +2011/01/09 -- Mickey Argo/Karl Suchy/Marc MERLIN +- Added Omnistat2 code + 2009/08/03 -- merlin - cleanups, added debugging, logging and comments - added code to report stat not found errors as opposed to outputting perl errors @@ -72,6 +75,14 @@ Omnistat::omnistat_debug("$NAME: will work with stat $location"); } +my $print_cycle = ""; +my $print_vacation = ""; + +if ($stat->is_omnistat2) { + $print_cycle = ""; + $print_vacation = ""; +} + if ($submit eq 'reset stat to scheduled values') { Omnistat::omnistat_debug("$NAME: Got 'reset to scheduled values' for $location"); $stat->restore_setpoints(); @@ -169,7 +180,7 @@

    - -
    Mode$stat_mode
    Hold$stat_hold

    diff --git a/code/support/hai-omnistat/omnistat.pl b/code/support/hai-omnistat/omnistat.pl index 468c76b21..6490a9b93 100644 --- a/code/support/hai-omnistat/omnistat.pl +++ b/code/support/hai-omnistat/omnistat.pl @@ -10,9 +10,10 @@ # Close to full rewrite/overhaul by Marc MERLIN 2009/07/22 -use vars qw(@omnilist @omnistat @omniname @omnioffset $stat_cool_temp $stat_heat_temp $stat_mode $stat_fan $stat_hold - $stat_indoor_temp $cmd $stat_model @v_omnistat_fan @v_omnistat_resume @v_omnistat_hold @v_omnistat_mode - @v_omnistat_cool_sp @v_omnistat_heat_sp @v_omnistat_setting @stat_reset_timer $house_stat $mbr_stat $test_stat); +use vars qw(@omnilist @omnistat @omniname @omnioffset $stat_cool_temp $stat_heat_temp $stat_mode $stat_fan $stat_hold + $stat_indoor_temp $cmd $stat_model @v_omnistat_fan @v_omnistat_resume @v_omnistat_hold @v_omnistat_mode + @v_omnistat_cool_sp @v_omnistat_heat_sp @v_omnistat_setting @stat_reset_timer $house_stat $mbr_stat $test_stat + @v_omnistat_background); # noloop=start # define the stats and which serial address they are using. @@ -26,7 +27,7 @@ # by binding them to a real variable, which only then we can assign to an array element. # This would work fine if/when everyone uses the @omnistat array, but misterhouse likes # having named variables like the ones below, so we skip this: -#foreach my $omnistat (@omnilist) +#foreach my $omnistat (@omnilist) #{ # $omnistat[$omnistat] = new Omnistat($omnistat); #} @@ -49,8 +50,8 @@ # what offset in seconds is each omnistat scanned at? # (you can't do them all at once, it can hang the main loop a bit) -$omnioffset[1] = 0; -$omnioffset[2] = 30; +$omnioffset[1] = 7; +$omnioffset[2] = 37; foreach my $omnistat (@omnilist) { @@ -60,19 +61,22 @@ my $statidx = " "; $statidx = " $omniname[$omnistat]" if ($#omnilist > 0); - $v_omnistat_fan[$omnistat]=new Voice_Cmd("Set$statidx Thermostat fan [on,auto]"); + $v_omnistat_fan[$omnistat]=new Voice_Cmd("Set$statidx Thermostat fan [on,auto,cycle]"); $v_omnistat_resume[$omnistat]=new Voice_Cmd("Resume $statidx Thermostat"); - $v_omnistat_hold[$omnistat]=new Voice_Cmd("Set$statidx Thermostat hold [on,off]"); + $v_omnistat_hold[$omnistat]=new Voice_Cmd("Set$statidx Thermostat hold [on,off,vacation]"); $v_omnistat_mode[$omnistat]=new Voice_Cmd("Set$statidx Thermostat mode [off,heat,cool,auto]"); $v_omnistat_cool_sp[$omnistat]=new Voice_Cmd("Set$statidx Thermostat cool setpoint to [$temprange]"); $v_omnistat_heat_sp[$omnistat]=new Voice_Cmd("Set$statidx Thermostat heat setpoint to [$temprange]"); $v_omnistat_setting[$omnistat]=new Voice_Cmd("What is the$statidx thermostat set to"); + $v_omnistat_background[$omnistat]=new Voice_Cmd("Set$statidx Thermostat background to [Blue,Green,Purple,Red,Orange,Yellow]"); - # With these, you can either send - # 'Set Thermostat cool setpoint to 68' - # if you have one thermostat, or + # With these, you can either send + # 'Set Thermostat cool setpoint to 68' + # if you have one thermostat, or # 'Set Bedroom Thermostat cool setpoint to 72' # if you have multiple + + Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: Mh restarted, will reconfigure stat", 2); } # noloop=stop @@ -80,7 +84,7 @@ foreach my $omnistat (@omnilist) { if ($Reload or $Reread or $New_Day) { - # Talking to Omnistats can be a bit expensive for mh, due to the main loop hangs this can create, so we'll wait + # Talking to Omnistats can be a bit expensive for mh, due to the main loop hangs this can create, so we'll wait # 60 seconds after the event to space things out from whatever else might be happening at those magic times # (plus an offset for each omnistat id) $stat_reset_timer[$omnistat]->set(60 + $omnistat*4); @@ -94,13 +98,13 @@ #$omnistat[$omnistat]->heating_cycle_time('8'); $omnistat[$omnistat]->set_time; } - + # update data once a minute, per omnistat offset seconds. - if ($New_Second and $Second eq $omnioffset[$omnistat]) { + if ($New_Second and $Second eq $omnioffset[$omnistat]) { # we make the extended group1 call that also retreives the stat's output status my ($cool_sp, $heat_sp, $mode, $fan, $hold, $temp, $output) = $omnistat[$omnistat]->read_group1("true"); - my $stat_type = $omnistat[$omnistat]->get_stat_type; + # This mashes $hold and $mode together from registers cached in the group1 call and outputs a combined string $mode = $omnistat[$omnistat]->get_mode; @@ -113,31 +117,31 @@ if ($state = $v_omnistat_fan[$omnistat]->said) { $omnistat[$omnistat]->fan($state); } - + if ($state = $v_omnistat_resume[$omnistat]->said) { $omnistat[$omnistat]->restore_setpoints; } - + if ($state = $v_omnistat_hold[$omnistat]->said) { $omnistat[$omnistat]->hold($state); } - + if ($state = $v_omnistat_mode[$omnistat]->said) { $omnistat[$omnistat]->mode($state); } - + if ($state = $v_omnistat_cool_sp[$omnistat]->said) { $omnistat[$omnistat]->cool_setpoint($state); speak "Air conditioning set to $state degrees for $omniname[$omnistat] Omnistat"; Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: Air conditioning set to $state degrees", 2); } - + if ($state = $v_omnistat_heat_sp[$omnistat]->said) { $omnistat[$omnistat]->heat_setpoint($state); speak "Heat set to $state degrees for $omniname[$omnistat] Omnistat"; Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: Heat set to $state degrees", 2); } - + if ($state = $v_omnistat_setting[$omnistat]->said) { my ($heat,$cool); $cool = $omnistat[$omnistat]->get_cool_sp; @@ -145,7 +149,11 @@ speak "cool setpoint $cool, heat setpoint $heat"; Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: cool setpoint $cool, heat setpoint $heat", 2); } - + + if ($state = $v_omnistat_background[$omnistat]->said) { + $omnistat[$omnistat]->set_background_color($state); + } + # Old code left over in case it's useful to some -- merlin # note that you have to turn hold mode off to change setpoints #if (defined ($state = state_changed $mode) && $state eq 'away') { @@ -155,7 +163,7 @@ # $omnistat[$omnistat]->heat_setpoint('50'); # $omnistat[$omnistat]->hold('on'); #} - + #if (defined ($state = state_changed $mode) && $state eq 'home') { # Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: Setting to home mode"); # $omnistat[$omnistat]->hold('off'); @@ -163,28 +171,54 @@ # $omnistat[$omnistat]->heat_setpoint('68'); # $omnistat[$omnistat]->hold('on'); #} - - if (time_now '7:15 PM') { - if ($omnistat[$omnistat]->get_filter_reminder == 0) + + if (time_now '7:45 PM') { + my $filter_days = $omnistat[$omnistat]->get_filter_reminder; + if ($filter_days == 0) { speak "Replace the furnace filter linked to $omniname[$omnistat] Omnistat"; + print_log "$omniname[$omnistat] Omnistat: replace the filter"; Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: replace the filter", 0); + # reset the timer to 6 months + $omnistat[$omnistat]->set_filter_reminder(180); + } + else + { + Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: $filter_days days before filter replacement", 1); } } - - - if (new_minute 5) + + # set stat temperature every 5 minutes at an offset to reduce hangs + if ($Minute % 5 == 0 and $New_Second and $Second eq ($omnioffset[$omnistat]+5)) { # Set the outside temp on the thermostat if available (refreshing this value should cause the # stat to display the outside temperature on the display). if ($Weather{TempOutdoor}) { Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: Setting outside temperature to $Weather{TempOutdoor}", 2); - $omnistat[$omnistat]->outdoor_temp($Weather{TempOutdoor}); + $omnistat[$omnistat]->outdoor_temp($Weather{TempOutdoor}); + } + + if ($omnistat[$omnistat]->is_omnistat2 and defined ($Weather{TempOutdoor})) + { + # Change the backlight based on outside temp + my $background_color; + + if ($Weather{TempOutdoor} >= 95) { $background_color = "Red"; } + elsif ($Weather{TempOutdoor} >= 85) { $background_color = "Yello"; } + elsif ($Weather{TempOutdoor} >= 65) { $background_color = "Green"; } + elsif ($Weather{TempOutdoor} >= 55) { $background_color = "Purple"; } + elsif ($Weather{TempOutdoor} < 55) { $background_color = "Blue"; } + else { $background_color = "Orange"; } + + Omnistat::omnistat_log("$omniname[$omnistat] Omnistat: Setting background color to $background_color", 2); + $omnistat[$omnistat]->set_background_color($state); } } - + if ($state = $omnistat[$omnistat]->state_now) { # this may or many not be useful to you, you can comment it out if you're not planning on using state changes for coding Omnistat::omnistat_log("".$omniname[$omnistat]." Omnistat State set to: $state", 3); } } + +#vim:sts=4:sw=4 diff --git a/lib/Omnistat.pm b/lib/Omnistat.pm index f388f4d09..d243258c7 100644 --- a/lib/Omnistat.pm +++ b/lib/Omnistat.pm @@ -10,10 +10,13 @@ Specifically written with/for RC-80 but should work with any of them. http://www.homeauto.com/Products/HAIAccessories/Omnistat/rc80.htm Newer Omnistat2 thermostats have a slightly different protocol and may need -some work. They look nicer, but they are pricier (vs $50 for an RC-80 on ebay) -and don't offer functionality that's useful to most people -- merlin +some work. They look nicer, but they are pricier (vs $50 for an RC-80 on ebay). +<<<<<<< .mine +Have a look at http://misterhouse.wikispaces.com/hai_stats +======= Have a look at http://misterhouse.wikispaces.com/hai_stats and +>>>>>>> .r1810 ################### @@ -33,7 +36,7 @@ Omnistat_non_program=[0,1] Omnistat_rtp_mode=[0,1] # hide clock on thermostat Omnistat_hide_clock=[0,1] -# You can set how much gets logged +# You can set how much gets logged Omnistat_no_stat_log=[0,1,2,3] # For debugging, add omnistat to debug in mh.private.ini, as in @@ -59,11 +62,8 @@ This module is used 2 ways TODOs ================================================================================ -TODO: Add hooks for caching instead of relying on pl file -TODO: ini parameter for range of registers to read (default to temp) TODO: Adjust clock speed? Not sure if possible (reg 14), may need to be done in pl TODO: Modify set_reg to accept muliple registers (hasn't been really needed so far) -TODO: Ini Parameter to turn on/off set outdoor temp (may be in pl) TODO: The sleep situation has been much improved, but if someone smart could replace the sleep with a proper callback so as not to stall mh, that would rule @@ -71,6 +71,61 @@ TODO: The sleep situation has been much improved, but if someone smart could rep Changelog ================================================================================ +2010/07/26 - Marc MERLIN +======================== +Minor fixes, but the biggest was modifying bin/mh to support code that occasionally dies +(mh would disable that code after it died 9 times, which is not so good since it killed +all temp and stat logging if you were using that). +It is just hard to never trigger die code, in my case I sometimes have: +Omnistat[1]->send_cmd did not get expected first byte (0x81) in ack reply to command 01 20 48 + 01 6a (got 0x82 in 0x82 0x22 0x48 0x00 0xec 0x81 0x22 0x48 0x00 0xeb ) at ../lib/Omnistat.pm line 544. +this shows that I got a reply from stat #2 when I was expecting a reply from stat #1. +It happens rarely, and it's likely mostly serial port issues that I can't easily fix nor really +care to since they're rare and the code just deals with them. + +As a result, you should put this in mh,private.ini: +omnistat_allowed_errors = 999999999999 +hvac_allowed_errors = 999999999999 +replacing the first word (hvac/omnistat) by your code/module.pl names that use this library. +This will stop mh from disabling your code if the libraries dies every so often. + + +2011/01/09 - Mickey Argo/Karl Suchy/Marc MERLIN +================================================ +Mickey did the original work to port the code to Omnistat2. +Karl ported the code for inclusion with the svn Omnistat code +I (Marc), reviewed the code and modified it for inclusion so that it didn't break existing users. + +- Added "Vacation" hold mode, and modified "on" hold mode to 0x01 from 0xff +- Added "Cycle" to fan mode +- Added "vacation" to occupancy mode +- Added a few other get registers that are not on the original Omnistat's but will not effect the operation of them +- Added "Vacation" to get_mode() +- Added "cycle" to get_fan_mode() +- Added "Vacation" to get_occupancy_mode() +- Added RC-1000 and RC-2000 to type of thermostat table +- Added "vacation" to read group 1 data sub + + +2010/07/26 - Marc MERLIN +======================== +Minor fixes, but the biggest was modifying bin/mh to support code that occasionally dies +(mh would disable that code after it died 9 times, which is not so good since it killed +all temp and stat logging if you were using that). +It is just hard to never trigger die code, in my case I sometimes have: +Omnistat[1]->send_cmd did not get expected first byte (0x81) in ack reply to command 01 20 48 + 01 6a (got 0x82 in 0x82 0x22 0x48 0x00 0xec 0x81 0x22 0x48 0x00 0xeb ) at ../lib/Omnistat.pm line 544. +this shows that I got a reply from stat #2 when I was expecting a reply from stat #1. +It happens rarely, and it's likely mostly serial port issues that I can't easily fix nor really +care to since they're rare and the code just deals with them. + +As a result, you should put this in mh,private.ini: +omnistat_allowed_errors = 999999999999 +hvac_allowed_errors = 999999999999 +replacing the first word (hvac/omnistat) by your code/module.pl names that use this library. +This will stop mh from disabling your code if the libraries dies every so often. + + 2009/08/03 - Marc MERLIN ======================== - send_cmd is now a method too so that we can compare the return value against $$self{addr} @@ -546,7 +601,7 @@ sub send_cmd { # FIXME? Those two dies aren't ideal, but it happens that you get corruption or bad data on a reply. # Expected for 01 20 3b 0e 6a is something like # 0x81 0xf2 0x3b 0x7c 0x71 0x03 0x00 0x00 0x7d 0x07 0x1e 0x0f 0x00 0x00 0x00 0x02 0x0c 0x5d - # but I have seen replies like + # but I have seen replies like # 0x03 0xf2 0x3b 0x7c 0x71 0x03 0x00 0x00 0x7d 0x00 0x1c 0x0f 0x00 0x00 0x00 0x02 0x0c 0x54 (0x81 ack byte is wrong) # or sync issues like # 0x64 0x82 0xf2 0x3b 0x8e 0x64 0x00 0x00 0x00 0x7d 0x20 0x29 0x0f 0x60 0x00 0x00 0x00 0x00 0xd6 (0x64 shouldn't be here) @@ -644,13 +699,18 @@ sub hold { if ( $state eq "off" ) { $new_hold = "0x00"; } elsif ( $state eq "on" ) { - $new_hold = "0xff"; + if ( $self->is_omnistat2() ) + { $new_hold = "0x01" ; } + else + { $new_hold = "0xff" ; } + } elsif ( $state eq "vacation" and $self->is_omnistat2() ) { + $new_hold = "0x02"; } else { - print "$::Time_Date: Omnistat[$$self{address}]: Invalid Hold state: $state\n"; + &::print_log("Omnistat[$$self{address}]: Invalid Hold state: $state\n"); return; } - # obviously there is a small race condition here, if hold was changed in the last minute from the panel, + # obviously there is a small race condition here, if hold was changed in the last minute from the panel, # we could fail to set it when it needs to be, but that should be quite rare, and avoiding all the repeated # hold set to off before changing other values is worth it -- merlin if ($cur_hold ne $new_hold) { @@ -835,7 +895,7 @@ sub mode { $self->set_reg( "0x3d", "0x03" ); $self->set_reg( "0x3f", "0x00" ); } else { - print "$::Time_Date: Omnistat: Invalid Mode state: $state\n"; + &::print_log("Omnistat: Invalid Mode state: $state\n"); } } @@ -877,52 +937,49 @@ sub restore_setpoints { } else { # Weekday $register = 0x1e; # Weekday night time } - + # Check for setpoints for that day, need to consider what time it is for ( $setpointnum = 0 ; $setpointnum < 4 ; $setpointnum++ ) { - # FIXME: make sure I didn't break this (test it) and remove my FIXME -- merlin if ( hex($self->read_cached_reg( sprintf( "0x%02x", $register - 3 * $setpointnum))) < $time ) { $point = $register - 3 * $setpointnum; last; } } - + #Check for setpoints on previous days, don't need to consider the time, any setpoint will do if ( $point == 0 ) { #Loop days for ( $daynum = 0 ; $daynum < 3 ; $daynum++ ) { - if ($day > 0 && $day < 5 && $daynum == 0) { - #Weekday, previous day is also a weekday for first loop + if ($day > 0 && $day < 5 && $daynum == 0) { + #Weekday, previous day is also a weekday for first loop } else { #Get the previous day - $register = $register - 12; + $register = $register - 12; } - + if ( $register < 30 ) { $register = 54; } #Previous to weekday is sunday - + #Loop setpoints for ( $setpointnum = 0 ; $setpointnum < 4 ; $setpointnum++ ) { - # FIXME: make sure I didn't break this (test it) and remove my FIXME -- merlin if ( hex($self->read_cached_reg( sprintf( "0x%02x", $register - 3 * $setpointnum))) != 96 ) { - #If the setpoint has a time set, use the setpoint + #If the setpoint has a time set, use the setpoint $point = $register - 3 * $setpointnum; last; } } } } - + if ( $point != 0 ) { my $heat_sp = $self->read_cached_reg( sprintf( "0x%02x", $point + 2)); my $cool_sp = $self->read_cached_reg( sprintf( "0x%02x", $point + 1)); - # FIXME: make sure I didn't break this (test it) and remove my FIXME -- merlin # Set the setpoints (setting the registers avoids converting the temp only to convert it back) - print "$::Time_Date: Omnistat: Heat Set to " . &Omnistat::translate_temp($heat_sp) . "\n"; - print "$::Time_Date: Omnistat: Cool Set to " . &Omnistat::translate_temp($cool_sp) . "\n"; + &::print_log("Omnistat: Heat Set to " . &Omnistat::translate_temp($heat_sp) . "\n"); + &::print_log("Omnistat: Cool Set to " . &Omnistat::translate_temp($cool_sp) . "\n"); $self->set_reg( "0x3c", $heat_sp ); $self->set_reg( "0x3b", $cool_sp ); } @@ -931,7 +988,7 @@ sub restore_setpoints { # ************************************ -# * Set the fan mode to on/off/auto. +# * Set the fan mode to on/off/auto/cycle. # ************************************ sub fan { my ( $self, $state ) = @_; @@ -944,8 +1001,96 @@ sub fan { $self->set_reg( "0x3e", "0x01" ); } elsif ( $state eq "auto" ) { $self->set_reg( "0x3e", "0x00" ); + } elsif ( $state eq "cycle" ) { + $self->set_reg( "0x3e", "0x02" ); + } else { + &::print_log("Omnistat: Invalid Fan state: $state\n"); + } +} + +# ************************ +# * Is this an Omnistat2 ? +# ************************ +sub is_omnistat2 { + my ( $self ) = @_; + my $stat = $self->get_stat_type(); + + if ($stat eq "RC-1000" or $stat eq "RC-2000") + { + omnistat_debug("Omnistat[$$self{address}] -> is_omnistat2: yes"); + return 1; + } + omnistat_debug("Omnistat[$$self{address}] -> is_omnistat2: no"); + return 0; +} + +# ******************************** +# * Set Omnistat2 background color +# ******************************** +sub set_background_color { + my ( $self, $state ) = @_; + $state = lc($state); + + my $background_hex = "0x00"; + if ($state = 'blue'){ + $background_hex = "0x44"; + } elsif ($state = 'green'){ + $background_hex = "0x25"; + } elsif ($state = 'purple'){ + $background_hex = "0x5a"; + } elsif ($state = 'red'){ + $background_hex = "0x01"; + } elsif ($state = 'orange'){ + $background_hex = "0x03"; + } elsif ($state = 'yellow'){ + $background_hex = "0x05"; + } else { + &::print_log("Omnistat: Invalid Background Color: $state\n"); + } + $self->set_reg("0x8c", $background_hex); +} + +# ************************************** +# * Set the occupancy mode +# ************************************** +sub set_occupancy_mode { + my ( $self, $state ) = @_; + $state = lc($state); + my $addr = $$self{address}; + my @cmd; + + omnistat_debug("Omnistat[$$self{address}] -> occupancy $state"); + if ( $state eq "day" ) { + $self->set_reg( "0xa1", "0x00" ); + } elsif ( $state eq "night" ) { + $self->set_reg( "0xa1", "0x01" ); + } elsif ( $state eq "away" ) { + $self->set_reg( "0xa1", "0x02" ); + } elsif ( $state eq "vacation" ) { + $self->set_reg( "0xa1", "0x03" ); + } else { + &::print_log("Omnistat: Invalid Occupancy state: $state\n"); + } +} + +# ************************************** +# * Set the program mode +# ************************************** +sub set_program_mode { + my ( $self, $state ) = @_; + $state = lc($state); + my $addr = $$self{address}; + my @cmd; + + omnistat_debug("Omnistat[$$self{address}] -> program $state"); + if ( $state eq "none" ) { + $self->set_reg( "0x83", "0x00" ); + } elsif ( $state eq "schedule" ) { + $self->set_reg( "0x83", "0x01" ); + } elsif ( $state eq "occupancy" ) { + $self->set_reg( "0x83", "0x02" ); } else { - print "$::Time_Date: Omnistat: Invalid Fan state: $state\n"; + &::print_log("Omnistat: Invalid Program state: $state\n"); } } @@ -971,6 +1116,94 @@ sub heat_setpoint { $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; } +# ************************** +# * Set the day cool setpoint. +# ************************** +sub day_cool_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x7b", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the day heat setpoint. +# ************************** +sub day_heat_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x7c", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the night cool setpoint. +# ************************** +sub night_cool_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x7d", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the night heat setpoint. +# ************************** +sub night_heat_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x7e", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the away cool setpoint. +# ************************** +sub away_cool_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x7f", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the away heat setpoint. +# ************************** +sub away_heat_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x80", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the vacation cool setpoint. +# ************************** +sub vaca_cool_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x81", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + +# ************************** +# * Set the vacation heat setpoint. +# ************************** +sub vaca_heat_setpoint { + my ( $self, $settemp ) = @_; + # hold has to be removed for this command to go through. + $self->hold('off'); + $self->set_reg( "0x82", &Omnistat::translate_temp($settemp) ); + $self->hold('on') unless $main::config_parms{Omnistat_set_does_not_hold}; +} + # ************************************** # * Set the outdoor temperature # ************************************** @@ -1025,6 +1258,16 @@ sub get_temp { return translate_temp($temp); } +# ************************************** +# * Get the indoor humidity +# ************************************** +sub get_humidity { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0xa2",1); + my $translated = translate_temp($temp); + return translate_temp($temp); +} + # ******************************************************** # * Get the current command output by the stat to the HVAC # ******************************************************** @@ -1053,6 +1296,78 @@ sub get_cool_sp { return translate_temp($temp); } +# ************************************** +# * Get the programming day cool setpoint +# ************************************** +sub get_program_day_cool_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x7b",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming day heat setpoint +# ************************************** +sub get_program_day_heat_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x7c",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming night cool setpoint +# ************************************** +sub get_program_night_cool_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x7d",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming night heat setpoint +# ************************************** +sub get_program_night_heat_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x7e",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming away cool setpoint +# ************************************** +sub get_program_away_cool_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x7f",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming away heat setpoint +# ************************************** +sub get_program_away_heat_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x80",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming vacation cool setpoint +# ************************************** +sub get_program_vaca_cool_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x81",1); + return translate_temp($temp); +} + +# ************************************** +# * Get the programming vacation heat setpoint +# ************************************** +sub get_program_vaca_heat_sp { + my ( $self) = @_; + my $temp = $self->read_cached_reg("0x82",1); + return translate_temp($temp); +} + # ************************************** # * Get the mode # ************************************** @@ -1061,18 +1376,21 @@ sub get_mode { # system mode to argument: 'off', 'heat', 'cool', 'auto','program_heat', 'program_cool', 'program_auto' my ( $self ) = @_; my $mode = $self->read_cached_reg("0x3d",1); - my $hold = $self->read_cached_reg("0x3f",1); + my $hold = $self->read_cached_reg("0x3f",1); + + if ($hold eq "0x00") { $hold = 'off'; } + if ($hold eq "0x01") { $hold = 'on'; } # Omnistat2 + if ($hold eq "0x02") { $hold = 'vacation'; } + if ($hold eq "0xff") { $hold = 'on'; } # RCxx - $hold = $hold eq "0x00" ? 'off' : 'on'; - # if hold is off, mode is program heat/cool/auto, if hold is on, mode is heat/cool/auto - if ($hold eq 'on') + if ($hold eq 'on') { $mode = ['off', 'heat', 'cool', 'auto']->[hex($mode)]; } else { $mode = ['off', 'program_heat', 'program_cool', 'program_auto']->[hex($mode)]; } - + return $mode; } @@ -1084,10 +1402,33 @@ sub get_fan_mode { my $fan = $self->read_cached_reg("0x3e",1); if ( $fan eq "0x00" ) { $fan = 'auto'; } if ( $fan eq "0x01" ) { $fan = 'on'; } - + if ( $fan eq "0x02" ) { $fan = 'cycle'; } + return $fan; } +# ************************************** +# * Get the occupancy mode +# ************************************** +sub get_occupancy_mode { + my ( $self ) = @_; + my $occupancy_mode = $self->read_reg("0xa1",1); + $occupancy_mode = ['day', 'night', 'away', 'vacation']->[hex($occupancy_mode)]; + + return $occupancy_mode; +} + +# ************************************** +# * Get the program mode +# ************************************** +sub get_program_mode { + my ( $self ) = @_; + my $program_mode = $self->read_cached_reg("0x83",1); + $program_mode = ['none', 'schedule', 'occupancy']->[hex($program_mode)]; + + return $program_mode; +} + # ************************************** # * Get the filter reminder # ************************************** @@ -1097,12 +1438,18 @@ sub get_filter_reminder { return hex($days); } +sub set_filter_reminder { + my ( $self, $days ) = @_; + $self->set_reg( "0x0f", sprintf( "0x%02x", $days) ); +} + + # ************************************** # * Get and translate type of thermostat # ************************************** sub get_stat_type { my ( $self ) = @_; - + my $stat = $self->read_cached_reg("0x49",1); my %stat_table = ( 0 => "RC-80", 1 => "RC-81", @@ -1113,7 +1460,9 @@ sub get_stat_type { 34 => "RC-112", 48 => "RC-120", 49 => "RC-121", - 50 => "RC-122", ); + 50 => "RC-122", + 110 => "RC-1000", + 120 => "RC-2000", ); return $stat_table{hex($stat)} ? $stat_table{hex($stat)} : "RC-unknown"; } @@ -1378,8 +1727,13 @@ sub read_group1 { $heat_set = &Omnistat::translate_temp($heat_set); $mode = ['off', 'heat', 'cool', 'auto']->[hex($mode)]; - $fan = $fan eq "0x00" ? 'auto' : 'on'; - $hold = $hold eq "0x00" ? 'off' : 'on'; + if ( $fan eq "0x00" ) { $fan = 'auto'; } + if ( $fan eq "0x01" ) { $fan = 'on'; } + if ( $fan eq "0x02" ) { $fan = 'cycle'; } + if ($hold eq "0x00") { $hold = 'off'; } + if ($hold eq "0x01") { $hold = 'on'; } # Omnistat2 + if ($hold eq "0x02") { $hold = 'vacation'; } + if ($hold eq "0xff") { $hold = 'on'; } # RC-xx $cur = &Omnistat::translate_temp($cur); From 275ada38b2a243961176d52a088c0d51a588b98b Mon Sep 17 00:00:00 2001 From: peloy Date: Tue, 18 Jan 2011 23:06:20 +0000 Subject: [PATCH 022/150] Fixed small typos in Gregg's previous commit --- lib/Insteon/AllLinkDatabase.pm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 41088cd8d..ac3af0c26 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -771,7 +771,7 @@ sub add_link # get the address via lookup into the hash my $key = lc $device_id . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if !($subaddress eq '00' or $subaddress eq '01') { + if (!($subaddress eq '00' or $subaddress eq '01')) { $key .= $subaddress; } if (defined $$self{aldb}{$key}{inuse}) { @@ -832,7 +832,7 @@ sub update_link # get the address via lookup into the hash my $key = lc $deviceid . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if !($subaddress eq '00' or $subaddress eq '01') { + if (!($subaddress eq '00' or $subaddress eq '01')) { $key .= $subaddress; } my $address = $$self{aldb}{$key}{address}; @@ -937,7 +937,7 @@ sub has_link } $subaddress = '00' unless $subaddress; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if !($subaddress eq '00' or $subaddress eq '01') { + if (!($subaddress eq '00' or $subaddress eq '01')) { $key .= $subaddress; } return (defined $$self{aldb}{$key}) ? 1 : 0; @@ -1386,4 +1386,4 @@ sub has_link -1; \ No newline at end of file +1; From 144afc27fc7135aa04c058fbeb55575f87857ed1 Mon Sep 17 00:00:00 2001 From: peloy Date: Tue, 18 Jan 2011 23:09:53 +0000 Subject: [PATCH 023/150] Remove a couple of lines of dead code. Note that according to Gregg, a good part of Insteon.pm is going to be re-written, so it may not be a good use of anyone's time to look to deeply into the current Insteon.pm code. --- lib/Insteon.pm | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 221dada50..d6bdc8bac 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -228,13 +228,8 @@ sub generate_voice_commands push @_scannable_link, $object_name; } $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - if ($object->isa('Insteon::BaseController')) { - $object_string .= "$object_name_v -> tie_event('$object_name->initiate_linking_as_controller(\"$group\")', 'initiate linking as controller');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->interface()->cancel_linking','cancel linking');\n\n"; - } else { - $object_string .= "$object_name_v -> tie_event('$object_name->link_to_interface','link to interface');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->unlink_to_interface','unlink with interface');\n\n"; - } + $object_string .= "$object_name_v -> tie_event('$object_name->initiate_linking_as_controller(\"$group\")', 'initiate linking as controller');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->interface()->cancel_linking','cancel linking');\n\n"; if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; From 04d4d1d90435a0a2ef6fb45af312d7c6ba0af6ee Mon Sep 17 00:00:00 2001 From: peloy Date: Tue, 18 Jan 2011 23:20:15 +0000 Subject: [PATCH 024/150] Port r1805:r1806 from trunk. --- web/bin/triggers.pl | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/web/bin/triggers.pl b/web/bin/triggers.pl index 4a97c6c11..07380caa7 100644 --- a/web/bin/triggers.pl +++ b/web/bin/triggers.pl @@ -1,7 +1,8 @@ =begin comment -This code is used to list and manipulate triggers. See mh/doc/mh.* set_trigger for more info. +This code is used to list and manipulate triggers. See +the trigger documentation for more info. http://localhost:8080/bin/triggers.pl @@ -23,7 +24,7 @@ sub web_trigger_list { - &triggers_save; # Check for changes to write out + &_triggers_save; # Check for changes to write out # Create header and 'add a trigger' form my $html = &html_header('Triggers Menu'); From 2444ea1597cc3c7882e53904bb7cdcbb1341ba82 Mon Sep 17 00:00:00 2001 From: peloy Date: Thu, 20 Jan 2011 03:08:17 +0000 Subject: [PATCH 025/150] Sync. with trunk (r1803 to 1814): * Improve stripping of end of line comments in .mht files. * Missing rename of triggers_save to _triggers_save in web page code. * Remove stray vim swap file. * lib/Omnistat.pm updates by Marc. --- bin/mh | 2 ++ lib/Omnistat.pm | 4 ---- web/bin/items.pl | 1 + web/iphone/.index.shtml.swp | Bin 12288 -> 0 bytes 4 files changed, 3 insertions(+), 4 deletions(-) delete mode 100644 web/iphone/.index.shtml.swp diff --git a/bin/mh b/bin/mh index eec9d1b34..25060db30 100755 --- a/bin/mh +++ b/bin/mh @@ -4706,6 +4706,8 @@ sub read_table_files { print TABLE_OUT $_; next; } + $_ =~ s/#.*//; # Strip off comments + next if (/^\s*$/); # Skip blank lines } if ($format) { # These code reading subroutines are in mh/lib/read_table.pl diff --git a/lib/Omnistat.pm b/lib/Omnistat.pm index d243258c7..b732cd44d 100644 --- a/lib/Omnistat.pm +++ b/lib/Omnistat.pm @@ -12,11 +12,7 @@ http://www.homeauto.com/Products/HAIAccessories/Omnistat/rc80.htm Newer Omnistat2 thermostats have a slightly different protocol and may need some work. They look nicer, but they are pricier (vs $50 for an RC-80 on ebay). -<<<<<<< .mine Have a look at http://misterhouse.wikispaces.com/hai_stats -======= -Have a look at http://misterhouse.wikispaces.com/hai_stats and ->>>>>>> .r1810 ################### diff --git a/web/bin/items.pl b/web/bin/items.pl index cccbf311e..b6d91422c 100644 --- a/web/bin/items.pl +++ b/web/bin/items.pl @@ -99,6 +99,7 @@ sub web_items_list { for my $record (@file_data) { # Do not list comments unless ($record =~ /^\s*\#/ or $record =~ /^\s*$/ or $record =~ /^Format *=/) { + $record =~ s/#.*//; # Ignore comments $record =~ s/,? *$//; my(@item_info) = split(',\s*', $record); my $type = shift @item_info; diff --git a/web/iphone/.index.shtml.swp b/web/iphone/.index.shtml.swp deleted file mode 100644 index b053a3cbbbc8f7a8563b786f20db77f438446914..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 12288 zcmeI2Pj4GV6u_s56Hq`PPJlGssEI9kcb%d_kasQ85O7teKyX^BavATwc&FK&S!QPK z7!-*w0fHOcdgH(+;J}rB1vntVg*y@wyzwU9M4(0$C(w-a^ZxP7ytluZ%^`l{?yc)P z^tGT%usuu2efsO*;G4(E@F_x+l*ZmZud!0*xfJJhBVnags57P@EVwqHGFfQ|Q@+0+ z@-mYGLM~D`40L9S{M_kW2WP+;cq9WC$tzdZyDQ!$`uuZyk2KPCb_SdQXTTY72AlzB zz!`7`oPqzo0aIQef8t|2hIEh%$Kb&=XTTY72AlzBz!`7`oB?OR8E^)i0cXG&_@5YH zDIp&`LC8x_;sfFD|Mq_Xzdu9BZ^#4W4)Ox>{nLaPBts_1hsa&zD)Q4sLViTPL%v47 zLOw@6Lki>#+alesZ4jX?@=N)kK!_ z-j!~5gYL2$9m?{YDn7}KrV2EuDWt(-(#2>TOp}~x9eeyOEV%{c^-1$J*2kWTg^679 z{S_{fyh?#4GKJV%t*d8m!+5hSTWdRvi?z-gAF?^9wYKN`O|CfJ#^Wgl8%mbiVD`wx zq(jRbmd}xjsMVCx0!pztJSUTb+2d_V1RcQ(ke?+0}a5^s> z!)T^pKlWC<7sOVgxqv|J_|;`U~+3m;XWO-t3s4i#0N z*Prd)vh#i=62qmSTNx7*c;7GsCqvrwlVKcGmxC&Wxw9 zw>um&)oP!bilyoH6oeVt%4-3t<>k2SUWc9})56G9gBkGxWMx{-JRRC?_vjIJWx0lB z%&4|O&Ah}tXyDL<_t=!xcTcuQRKGQgN5|I*7pk!r?QD-W>0mT^*WZ3`@A|FS+mZs4 zGrpbDqg(IX9Btnm9nWoF#U4$td>oUExt9LM#?{w-e!RYR0Un+a)hda-Ags4VxVcz@ za407{3GQjH|M%sMnmwb+FNZ-i)Uvi&L2L1pLKCk8;5cXSuHvmP5QAbbGX5hrFnY)3>m6UM;TK g7<+YlXQLYXzV&z1z?RrYVSPy!3Dt`b)qmRl0`7jH=Kufz From 239fc668dde706eca02e9029079a8de61d81f324 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 21 Jan 2011 21:48:06 +0000 Subject: [PATCH 026/150] Added "equals" method to be used to compare objects based on device_id and, if applicable, group. --- lib/Insteon/BaseInsteon.pm | 3130 +++++++++++++++++----------------- lib/Insteon/BaseInterface.pm | 698 ++++---- 2 files changed, 1931 insertions(+), 1897 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 9e51818da..643c3c3f9 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -1,1558 +1,1572 @@ -=begin comment -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - -File: - BaseInsteon.pm - -Description: - Generic class implementation of an Insteon Device. - -Author(s): - Gregg Liming / gregg@limings.net - -License: - This free software is licensed under the terms of the GNU public license. - -Usage: - - $ip_patio_light = new Insteon_Device($myPLM,"33.44.55"); - - $ip_patio_light->set("ON"); - -Special Thanks to: - Brian Warren for significant testing and patches - Bruce Winter - MH - -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -=cut - -package Insteon::BaseObject; - -use strict; -use Insteon; -use Insteon::AllLinkDatabase; -use Insteon::Message; - -@Insteon::BaseObject::ISA = ('Generic_Item'); - -our %message_types = ( - on => 0x11, - off => 0x13 -); - -sub derive_link_state -{ - my ($p_state) = @_; - - my $link_state = 'on'; - if ($p_state eq 'off') - { - $link_state = 'off'; - } - elsif ($p_state =~ /\d+%?/) - { - my ($dim_state) = $p_state =~ /(\d+)%?/; - $link_state = 'off' if $dim_state == 0; - } - - return $link_state; -} - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - my $self={}; - bless $self,$class; - - $$self{message_types} = \%message_types; - - if (defined $p_deviceid) { - my ($deviceid, $group) = $p_deviceid =~ /(\w\w\.\w\w\.\w\w):?(.+)?/; - # if a group is passed in, then assume it can be a controller - $$self{is_controller} = ($group) ? 1 : 0; - $self->device_id($deviceid); - $group = '01' unless $group; - $group = '0' . $group if length($group) == 1; - $self->group(uc $group); - } - - if ($p_interface) { - $self->interface($p_interface); - } else { - $self->interface(&Insteon::active_interface()); - } - - $self->restore_data('level'); - - $self->initialize(); - $$self{level} = undef; - $$self{flag} = "0F"; - $$self{ackMode} = "1"; - $$self{awaiting_ack} = 0; - $$self{is_acknowledged} = 0; - $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; - $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack - @{$$self{command_stack}} = (); - $$self{_onlevel} = undef; - $$self{is_responder} = 1; - - &Insteon::add($self); - return $self; -} - -sub initialize -{ - my ($self) = @_; - $$self{m_write} = 1; - $$self{m_is_locally_set} = 0; - # persist local, simple attribs - - # do we really need to ping the devices anymore for a devcat? - $$self{ping_timer} = new Timer(); - $$self{ping_timerTime} = 300; -# $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self) -# unless $self->group eq '01' and defined $self->devcat; -} - -sub interface -{ - my ($self,$p_interface) = @_; - if (defined $p_interface) { - $$self{interface} = $p_interface; - } - return $$self{interface}; -} - -sub device_id -{ - my ($self,$p_device_id) = @_; - - if (defined $p_device_id) - { - $p_device_id =~ /(\w\w)\W?(\w\w)\W?(\w\w)/; - $$self{device_id}=$1 . $2 . $3; - } - return $$self{device_id}; -} - -sub group -{ - my ($self, $p_group) = @_; - $$self{m_group} = $p_group if $p_group; - return $$self{m_group}; -} - -sub set -{ - my ($self,$p_state,$p_setby,$p_response) = @_; - return if &main::check_for_tied_filters($self, $p_state); - - # Override any set_with_timer requests - if ($$self{set_timer}) { - &Timer::unset($$self{set_timer}); - delete $$self{set_timer}; - } - - # did the queue timer go off? - if (ref $p_setby and $p_setby eq $$self{ping_timer}) { - if (! (defined($$self{devcat}))) { - $self->ping(); - # set the timer again in case nothing occurs - $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self); - } - } elsif ($self->_is_valid_state($p_state)) { - # always reset the is_locally_set property unless set_by is the device - $$self{m_is_locally_set} = 0 unless ref $p_setby and $p_setby eq $self; - - # handle invalid state for non-dimmable devices - if (($p_state eq 'dim' or $p_state eq 'bright') and !($self->isa('Insteon::DimmableLight'))) { - $p_state = 'on'; - } - my $setby_name = $p_setby; - $setby_name = $p_setby->get_object_name() if (ref $p_setby and $p_setby->can('get_object_name')); - if (ref $p_setby and (($p_setby eq $self->interface()) - or (($p_setby->isa('Insteon::BaseObject')) - and (($p_setby eq $self) - or (&main::set_by_to_target($p_setby) eq $self->interface))))) - { - # don't reset the object w/ the same state if set from the interface - return if (lc $p_state eq lc $self->state) and $self->is_acknowledged - and not(($p_setby->isa('Insteon::BaseObject') and ($p_setby eq $self))); - &::print_log("[Insteon::BaseObject] " . $self->get_object_name() - . "::set($p_state, $setby_name)") if $main::Debug{insteon}; - $self->set_receive($p_state,$p_setby,$p_response) if defined $p_state; - } else { - my $message = $self->derive_message($p_state); - $self->_send_cmd($message); - -# $self->_send_cmd(command => $p_state, -# type => (($self->isa('Insteon::Insteon_Link') and !($self->is_root)) ? 'alllink' : 'standard')); - &::print_log("[Insteon::BaseObject] " . $self->get_object_name() . "::set($p_state, $setby_name)") - if $main::Debug{insteon}; - $self->is_acknowledged(0); - $$self{pending_state} = $p_state; - $$self{pending_setby} = $p_setby; - $$self{pending_response} = $p_response; - } - $self->level($p_state) if $self->isa("Insteon::BaseDevice"); # update the level value -# $self->SUPER::set($p_state,$p_setby,$p_response) if defined $p_state; - } else { - &::print_log("[Insteon::BaseObject] failed state validation with state=$p_state"); - } -} - -sub is_acknowledged -{ - my ($self, $p_ack) = @_; - $$self{is_acknowledged} = $p_ack if defined $p_ack; - if ($p_ack) { - $self->set_receive($$self{pending_state},$$self{pending_setby}, $$self{pending_response}) if defined $$self{pending_state}; - $$self{pending_state} = undef; - $$self{pending_setby} = undef; - $$self{pending_response} = undef; - } - return $$self{is_acknowledged}; -} - -sub set_receive -{ - my ($self, $p_state, $p_setby, $p_response) = @_; - $self->SUPER::set($p_state, $p_setby, $p_response); -} - -sub set_with_timer { - my ($self, $state, $time, $return_state, $additional_return_states) = @_; - return if &main::check_for_tied_filters($self, $state); - - $self->set($state) unless $state eq ''; - - return unless $time; - - my $state_change = ($state eq 'off') ? 'on' : 'off'; - $state_change = $return_state if defined $return_state; - $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; - - $state_change .= ';' . $additional_return_states if $additional_return_states; - - $$self{set_timer} = &Timer::new() unless $$self{set_timer}; - my $object_name = $self->{object_name}; - my $action = "$object_name->set('$state_change')"; - $$self{set_timer}->set($time, $action); -} - -sub _send_cmd -{ - my ($self, $message) = @_; -# $msg{type} = 'standard' unless $msg{type}; - -# my $message = $self->derive_message($msg{command},$msg{type},$msg{extra}); - - if ($message->command eq 'peek' - or $message->command eq 'poke' - or $message->command eq 'status_request' - or $message->command eq 'do_read_ee' - or $message->command eq 'set_address_msb' - ) - { - push(@{$$self{command_stack}}, $message); - } - else - { - unshift(@{$$self{command_stack}},$message); - } - $self->_process_command_stack(); -} - -sub derive_message -{ - my ($self, $p_command, $p_extra) = @_; - my @args; - my $level; - - #msg id - my ($command, $subcommand) = split(/:/, $p_command, 2); - $command=lc($command); -# &::print_log("XLATE:$msg:$substate:$p_state:"); - - my $message; - - if ($self->isa("Insteon::BaseController")) - { - # only send out as all-link if the link originates from the plm - if ($self->isa("Insteon::InterfaceController")) - { # return the size of the command stack - $message = new Insteon::InsteonMessage('all_link_send', $self); - } - elsif ($self->is_root) - { # return the size of the command stack - $message = new Insteon::InsteonMessage('insteon_send', $self); - } else { - # silently ignore as this is now permitted if via "surrogate" - } - } elsif ($self->isa("Insteon::BaseObject")) { - $message = new Insteon::InsteonMessage('insteon_send', $self); - } - - if (!(defined $p_extra)) { - if ($command eq 'on') - { - if ($self->isa('Insteon::BaseDevice') && defined $self->local_onlevel) { - $level = 2.55 * $self->local_onlevel; - $command = 'on_fast'; - } else { - $level=255; - } - } elsif ($command eq 'off') - { - $level = 0; - } elsif ($command=~/^([1]?[0-9]?[0-9])/) - { - if ($1 < 1) { - $command='off'; - $level = 0; - } else { - $level = ($self->isa('Insteon::DimmableLight')) ? $1 * 2.55 : 255; - $command='on'; - } - } - } - - # confirm that the resulting $msg is legitimate - if (!(defined($self->message_type_code($command)))) { - &::print_log("[Insteon::BaseInsteon] invalid state=$command") if $main::Debug{insteon}; - return undef; - } - - if ($p_extra) - { $message->extra($p_extra); - - } elsif ($subcommand) { - $message->extra($subcommand); - } else { - if ($command eq 'on') - { - $message->extra(sprintf("%02X",$level)); - } else { - $message->extra('00'); - } - } - - $message->command($command); - return $message; -} - -sub message_type_code -{ - my ($self, $msg) = @_; - my $msg_type_ptr = $$self{message_types}; - my %msg_types = %$msg_type_ptr; - my $code = $msg_types{$msg}; - return $code; -} - -sub message_type -{ - my ($self, $cmd1) = @_; - my $msg_type; - my $msg_type_ptr = $$self{message_types}; - my %msg_types = %$msg_type_ptr; - for my $key (keys %msg_types){ - if (pack("C",$msg_types{$key}) eq pack("H*",$cmd1)) - { -# &::print_log("[Insteon::BaseObject] found: $key"); - $msg_type=$key; - last; - } - } - return $msg_type; -} - -sub _is_info_request -{ - my ($self, $cmd, $ack_setby, %msg) = @_; - my $is_info_request = ($cmd eq 'status_request') ? 1 : 0; -#print "cmd: $cmd; is_info_request: $is_info_request\n"; - if ($is_info_request) { - my $ack_on_level = (hex($msg{extra}) >= 254) ? 100 : sprintf("%d", hex($msg{extra}) * 100 / 255); - &::print_log("[Insteon::BaseObject] received status for " . - $self->{object_name} . " with on-level: $ack_on_level%, " - . "hops left: $msg{hopsleft}") if $main::Debug{insteon}; - $self->level($ack_on_level); # update the level value - if ($ack_on_level == 0) { - $self->SUPER::set('off', $ack_setby); - } elsif ($ack_on_level > 0 and !($self->isa('Insteon::DimmableLight'))) { - $self->SUPER::set('on', $ack_setby); - } else { - $self->SUPER::set($ack_on_level . '%', $ack_setby); - } - # if this were a scene controller, then also propogate the result to all members - } - return $is_info_request; - -} - -sub _process_message -{ - my ($self,$p_setby,%msg) = @_; - my $p_state = undef; - - # the current approach assumes that links from other controllers to some responder - # would be seen by the plm by also direct linking the controller as a responder - # and not putting the plm into monitor mode. This means that updating the state - # of the responder based upon the link controller's request is handled - # by Insteon_Link. - $$self{m_is_locally_set} = 1 if $msg{source} eq lc $self->device_id; - if ($msg{is_ack}) { - my $pending_cmd = ($$self{_prior_msg}) ? $$self{_prior_msg}->command : $msg{command}; - if ($$self{awaiting_ack}) { - my $ack_setby = (ref $$self{m_status_request_pending}) - ? $$self{m_status_request_pending} : $p_setby; - if ($self->_is_info_request($pending_cmd,$ack_setby,%msg)) { - $self->is_acknowledged(1); - $$self{m_status_request_pending} = 0; - $self->_process_command_stack(%msg); - } elsif (($pending_cmd eq 'peek') or ($pending_cmd eq 'set_address_msb')) { - $self->_aldb->_on_peek(%msg) if $self->_aldb; - $self->_process_command_stack(%msg); - } elsif (($pending_cmd eq 'poke') or ($pending_cmd eq 'set_address_msb')) { - $self->_aldb->_on_poke(%msg) if $self->_aldb; - $self->_process_command_stack(%msg); - } else { - $self->is_acknowledged(1); - # signal receipt of message to the command stack in case commands are queued - $self->_process_command_stack(%msg); - &::print_log("[Insteon::BaseObject] received command/state (awaiting) acknowledge from " . $self->{object_name} - . ": $pending_cmd and data: $msg{extra}") if $main::Debug{insteon}; - } - } else { - # allow non-synchronous messages to also use the _is_info_request hook - $self->_is_info_request($pending_cmd,$p_setby,%msg); - $self->is_acknowledged(1); - # signal receipt of message to the command stack in case commands are queued - $self->_process_command_stack(%msg); - &::print_log("[Insteon::BaseObject] received command/state acknowledge from " . $self->{object_name} - . ": " . (($msg{command}) ? $msg{command} : "(unknown)") - . " and data: $msg{extra}") if $main::Debug{insteon}; - } - } elsif ($msg{is_nack}) { - if ($$self{awaiting_ack}) { - # NOTE!!! NACKs are usually a sign of a burnt-out bulb!! - &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} - . " ... waiting for retry"); - } else { - if ($self->isa('Insteon::BaseLight')) - { - &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} - . ". It may be unplugged or have a burned out bulb") if $main::Debug{insteon}; - } - else - { - &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} - . " ... skipping"); - } - $self->is_acknowledged(0); - $self->_process_command_stack(%msg); - } - } elsif ($msg{command} eq 'start_manual_change') { - # do nothing; although, maybe anticipate change? we should always get a stop - } elsif ($msg{command} eq 'stop_manual_change') { - # request status so that the final state can be known - $self->request_status($self); - } elsif ($msg{type} eq 'broadcast') { - $self->devcat($msg{devcat}); - &::print_log("[Insteon::BaseObject] device category: $msg{devcat} received for " . $self->{object_name}); - # stop ping timer now that we have a devcat; possibly may want to change this behavior to allow recurring pings - $$self{ping_timer}->stop(); - } else { - ## TO-DO: make sure that the state passed by command is something that is reasonable to set - $p_state = $msg{command}; - if ($msg{type} eq 'alllink') - { - $$self{_pending_cleanup} = 1; - } - elsif ($msg{type} eq 'cleanup') - { - $self->set($p_state, $self); # unless (lc($self->state) eq lc($p_state)) and - # ($msg{type} eq 'cleanup' and $$self{_pending_cleanup}); - $$self{_pending_cleanup} = 0; - } - } -} - -sub _process_command_stack -{ - my ($self, %ackmsg) = @_; - if (%ackmsg) { # which may also be something that can be interpretted as a "nack" - # determine whether to unset awaiting_ack - # for now, be "dumb" and just unset it - $$self{awaiting_ack} = 0; - } - if (!($$self{awaiting_ack})) { - my $callback = undef; - my $message = pop(@{$$self{command_stack}}); - # convert ptr to cmd hash - if ($message) - { - my $plm_queue_size = $self->interface->queue_message($message); - - # send msg - if ($message->command eq 'peek' - or $message->command eq 'poke' - or $message->command eq 'status_request' - or $message->command eq 'do_read_ee' - or $message->command eq 'set_address_msb' - ) - { - $$self{awaiting_ack} = 1; - } - else - { - $$self{awaiting_ack} = 0; - } - - $$self{_prior_msg} = $message; - # TO-DO: adjust timer based upon (1) type of message and (2) retry_count - my $queue_time = $$self{max_queue_time} + $plm_queue_size; - # if is_synchronous, then no other command can be sent until an insteon ack or nack is received - # for this command - } else { - # and, always clear awaiting_ack and _prior_msg - $$self{awaiting_ack} = 0; - $$self{_prior_msg} = undef; - } - if ($callback) { - package main; - eval ($callback); - &::print_log("[Insteon::BaseObject] error in queue timer callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon::BaseObject; - } - } else { -# &::print_log("[Insteon_Device] " . $self->get_object_name . " command queued but not yet sent; awaiting ack from prior command") if $main::Debug{insteon}; - } -} - -sub _is_valid_state -{ - my ($self,$state) = @_; - if (!(defined($state)) or $state eq '') { - return 0; - } - - my ($msg, $substate) = split(/:/, $state, 2); - $msg=lc($msg); - - if ($msg=~/^([1]?[0-9]?[0-9])/) - { - if ($1 < 1) { - $msg='off'; - } else { - $msg='on'; - } - } - - # confirm that the resulting $msg is legitimate - if (!(defined($message_types{$msg}))) { - return 0; - } else { - return 1; - } -} - - -#################################### -### ##################### -### BaseObject ##################### -### ##################### -#################################### - -package Insteon::BaseDevice; - -use strict; -use Insteon; -use Insteon::AllLinkDatabase; - -@Insteon::BaseDevice::ISA = ('Insteon::BaseObject'); - -our %message_types = ( - %Insteon::BaseObject::message_types, - assign_to_group => 0x01, - delete_from_group => 0x02, - linking_mode => 0x09, - unlinking_mode => 0x0A, - ping => 0x10, - on_fast => 0x12, - off_fast => 0x14, - start_manual_change => 0x17, - stop_manual_change => 0x18, - status_request => 0x19, - get_operating_flags => 0x1f, - set_operating_flags => 0x20, - do_read_ee => 0x24, - remote_set_button_tap => 0x25, - set_led_status => 0x27, - set_address_msb => 0x28, - poke => 0x29, - poke_extended => 0x2a, - peek => 0x2b, - peek_internal => 0x2c, - poke_internal => 0x2d -); - - -my %operating_flags = ( - 'program_lock_on' => '00', - 'program_lock_off' => '01', - 'led_on_during_tx' => '02', - 'led_off_during_tx' => '03', - 'resume_dim_on' => '04', - 'beeper_enabled' => '04', - 'resume_dim_off' => '05', - 'beeper_off' => '05', - 'eight_key_kpl' => '06', - 'load_sense_on' => '06', - 'six_key_kpl' => '07', - 'load_sense_off' => '07', - 'led_backlight_off' => '08', - 'led_off' => '08', - 'led_backlight_on' => '09', - 'led_enabled' => '09', - 'key_beep_enabled' => '0a', - 'one_minute_warn_disabled' => '0a', - 'key_beep_off' => '0b', - 'one_minute_warn_enabled' => '0b' -); - - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - my $self= new Insteon::BaseObject($p_deviceid,$p_interface); - bless $self,$class; - - $$self{message_types} = \%message_types; - - if ($self->group eq '01') { - $$self{aldb} = new Insteon::ALDB_i1($self); - } - - $self->restore_data('level'); - - $self->initialize(); - $self->rate(undef); - $$self{level} = undef; - $$self{flag} = "0F"; - $$self{ackMode} = "1"; - $$self{awaiting_ack} = 0; - $$self{is_acknowledged} = 0; - $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; - $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack - @{$$self{command_stack}} = (); - $$self{_onlevel} = undef; - $$self{is_responder} = 1; - - return $self; -} - -sub initialize -{ - my ($self) = @_; - $$self{m_write} = 1; - $$self{m_is_locally_set} = 0; - # persist local, simple attribs - - # do we really need to ping the devices anymore for a devcat? - $$self{ping_timer} = new Timer(); - $$self{ping_timerTime} = 300; -} - -sub rate -{ - my ($self,$p_rate) = @_; - $$self{rate} = $p_rate if defined $p_rate; - return $$self{rate}; -} - -sub set_receive -{ - my ($self, $p_state, $p_setby, $p_response) = @_; - $self->level($p_state) if $self->can('level'); # update the level value - $self->SUPER::set_receive($p_state, $p_setby, $p_response); -} - -sub is_controller -{ - my ($self) = @_; - return $$self{is_controller}; -} - -sub is_responder -{ - my ($self,$is_responder) = @_; - $$self{is_responder} = $is_responder if defined $is_responder; - if ($self->is_root) { - return $$self{is_responder}; - } else { - my $root_obj = $self->get_root(); - if (ref $root_obj) { - return $$root_obj{is_responder}; - } else { - return 0; - } - } -} - -sub link_to_interface -{ - my ($self,$p_group, $p_data3) = @_; - my $group = $p_group; - $group = '01' unless $group; - # add a link first to this device back to interface - # and, add a reference to creating a link from interface back to device via hook - my $callback_instance = $self->interface->get_object_name; - my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; - my %link_info = ( object => $self->interface, group => $group, is_controller => 1, - on_level => '100%', ramp_rate => '0.1s', - callback => "$callback_instance->add_link('$callback_info')"); - $link_info{data3} = $p_data3 if $p_data3; - if ($self->_aldb) { - $self->_aldb->add_link(%link_info); - } else { - &main::print_log("[BaseInsteon] This item " . $self->get_object_name . - " does not have an ALDB object. Linking is not permitted."); - } -} - -sub unlink_to_interface -{ - my ($self,$p_group) = @_; - my $group = $p_group; - $group = '01' unless $group; - my $callback_instance = $self->interface->get_object_name; - my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; - if ($self->_aldb) { - $self->_aldb->delete_link(object => $self->interface, group => $group, is_controller => 1, - callback => "$callback_instance->delete_link('$callback_info')"); - } else { - &main::print_log("[BaseInsteon] This item " . $self->get_object_name . - " does not have an ALDB object. Unlinking is not permitted."); - } -} - - -sub _aldb -{ - my ($self) = @_; - return $$self{aldb}; -} - - -sub set_operating_flag { - my ($self, $flag) = @_; - - if (!(exists($operating_flags{$flag}))) { - &::print_log("[Insteon::BaseDevice] $flag is not a support operating flag"); - return; - } - - if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { - # TO-DO: check devcat to determine if the action is supported by the device - my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_operating_flags'); - $message->extra($operating_flags{$flag}); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'set_operating_flags', 'extra' => $operating_flags{$flag}); - } else { - &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); - return; - } -} - -sub get_operating_flag { - my ($self) = @_; - - if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { - # TO-DO: check devcat to determine if the action is supported by the device - my $message = new Insteon::InsteonMessage('insteon_send', $self, 'get_operating_flags'); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'get_operating_flags'); - } else { - &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); - return; - } -} - -sub writable { - my ($self, $p_write) = @_; - if (defined $p_write) { - if ($p_write =~ /r/i or $p_write =~/^0/) { - $$self{m_write} = 0; - } else { - $$self{m_write} = 1; - } - } - return $$self{m_write}; -} - -sub is_locally_set { - my ($self) = @_; - return $$self{m_is_locally_set}; -} - - -sub is_root { - my ($self) = @_; - return (($self->group eq '01') and !($self->isa('Insteon::InterfaceController'))) ? 1 : 0; -} - -sub get_root { - my ($self) = @_; - if ($self->is_root) { - return $self; - } else { - return &Insteon::get_object($self->device_id, '01'); - } -} - -sub has_link -{ - my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $aldb = $self->get_root()->_aldb; - if ($aldb) - { - return $aldb->has_link($insteon_object, $group, $is_controller, $subaddress); - } - else - { - return 0; - } - -} - -sub add_link -{ - my ($self, $parms_text) = @_; - my $aldb = $self->get_root()->_aldb; - if ($aldb) - { - my %link_parms; - if (@_ > 2) { - shift @_; - %link_parms = @_; - } else { - %link_parms = &main::parse_func_parms($parms_text); - } - $aldb->add_link(%link_parms); - } - -} - -sub scan_link_table -{ - my ($self, $callback) = @_; - my $aldb = $self->get_root()->_aldb; - if ($aldb) - { - return $aldb->scan_link_table($callback); - } - -} - -### WARN: Testing using the following does not produce results as expected. Use at your own risk. [GL] -sub remote_set_button_tap -{ - my ($self,$p_number_taps) = @_; - my $taps = ($p_number_taps =~ /2/) ? '02' : '01'; - my $message = new Insteon::InsteonMessage('insteon_send', $self, 'remote_set_button_tap'); - $message->extra($taps); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'remote_set_button_tap', 'extra' => $taps); -} - -sub request_status -{ - my ($self, $requestor) = @_; - $$self{m_status_request_pending} = ($requestor) ? $requestor : 1; - my $message = new Insteon::InsteonMessage('insteon_send', $self, 'status_request'); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'status_request', 'is_synchronous' => 1); -} - -sub ping -{ - my ($self) = @_; - my $message = new Insteon::InsteonMessage('insteon_send', $self, 'ping'); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'ping'); -} - -sub set_led_status -{ - my ($self, $status_mask) = @_; - my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_led_status'); - $message->extra($status_mask); - $self->_send_cmd($message); -# $self->_send_cmd('command' => 'set_led_status', 'extra' => $status_mask); -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = $self->SUPER::restore_string(); - if ($self->_aldb) { - $restore_string .= $self->_aldb->restore_string(); - } - if ($$self{states}) { - my $states = ''; - foreach my $state (@{$$self{states}}) { - $states .= '|' if $states; - $states .= $state; - } - $restore_string .= $self->{object_name} . "->restore_states(q~$states~);\n"; - } - return $restore_string; -} - -sub restore_states -{ - my ($self, $states) = @_; - if ($states) { - @{$$self{states}} = split(/\|/,$states); - } -} - -sub restore_aldb -{ - my ($self,$aldb) = @_; - if ($self->_aldb and $aldb) { - $self->_aldb->restore_aldb($aldb); - } -} - -sub devcat -{ - my ($self, $devcat) = @_; - if ($devcat) { - $$self{devcat} = $devcat; - if (($$self{devcat} =~ /^01\w\w/) or ($$self{devcat} =~ /^02\w\w/) && !($self->states)) { - $self->states( 'on,off' ); - } - } - return $$self{devcat}; -} - -sub states -{ - my ($self, $states) = @_; - if ($states) { - @{$$self{states}} = split(/,/,$states); - } - if ($$self{states}) { - return @{$$self{states}}; - } else { - return undef; - } - -} - - -sub local_onlevel -{ - my ($self, $p_onlevel) = @_; - if (defined $p_onlevel) { - my ($onlevel) = $p_onlevel =~ /(\d+)%?/; - $$self{_onlevel} = $onlevel; - } - return $$self{_onlevel}; -} - -sub local_ramprate -{ - my ($self, $p_ramprate) = @_; - if (defined $p_ramprate) { - $$self{_ramprate} = &Insteon::DimmableLight::convert_ramp($p_ramprate); - } - return $$self{_ramprate}; - -} - - -sub scan_link_table -{ - my ($self,$callback) = @_; - $self->_aldb->scan_link_table($callback) if $self->_aldb; -} - -sub delete_orphan_links -{ - my ($self) = @_; - return $self->_aldb->delete_orphan_links if $self->_aldb; -} - -sub _process_delete_queue { - my ($self) = @_; - $self->_aldb->_process_delete_queue() if $self->_aldb; -} - -sub log_alllink_table -{ - my ($self) = @_; - $self->_aldb->log_alllink_table if $self->_aldb; -} - -sub update_local_properties -{ - my ($self) = @_; - if ($self->isa('Insteon::DimmableLight')) { - $self->_aldb->update_local_properties() if $self->_aldb; - } else { - &::print_log("[Insteon::BaseDevice] update_local_properties may only be applied to dimmable devices!"); - } -} - -sub update_flags -{ - my ($self, $flags) = @_; - if (!($self->isa('Insteon::KeyPadLinc') or $self->isa('Insteon::KeyPadLincRelay'))) { - &::print_log("[Insteon::BaseDevice] Operating flags may only be revised on keypadlincs!"); - return; - } - return unless defined $flags; - - $self->_aldb->update_flags($flags) if $self->_aldb; -} - - -#################################### -### ################# -### BaseController ################# -### ################# -#################################### - -package Insteon::BaseController; - -use strict; -use Insteon; - -@Insteon::BaseController::ISA = ('Generic_Item'); - -sub new -{ - my ($class,$p_deviceid,$p_interface,$p_devcat) = @_; - - # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller - my $self = {}; - bless $self,$class; -# don't apply ping timer to this class -# $$self{ping_timer}->stop(); - return $self; -} - -sub add -{ - my ($self, $obj, $on_level, $ramp_rate) = @_; - if (ref $obj and ($obj->isa('Light_Item') or $obj->isa('Insteon::BaseDevice'))) { - if ($$self{members} && $$self{members}{$obj}) { - print "[Insteon::BaseController] An object (" . $obj->{object_name} . ") already exists " - . "in this scene. Aborting add request.\n"; - return; - } - if ($on_level =~ /^sur/i) { - $on_level = '100%'; - $$obj{surrogate} = $self; - } elsif (lc $on_level eq 'on') { - $on_level = '100%'; - } elsif (lc $on_level eq 'off') { - $on_level = '0%'; - } - $on_level = '100%' unless $on_level; - $$self{members}{$obj}{on_level} = $on_level; - $$self{members}{$obj}{object} = $obj; - $ramp_rate =~ s/s$//i; - $$self{members}{$obj}{ramp_rate} = $ramp_rate if defined $ramp_rate; - } else { - &::print_log("[Insteon::BaseController] WARN: unable to add $obj as items of this type are not supported!"); - } -} - -sub sync_links -{ - my ($self, $callback) = @_; - @{$$self{sync_queue}} = (); # reset the work queue - $$self{sync_queue_callback} = ($callback) ? $callback : undef; - my $insteon_object = $self->interface; - if (!($self->isa('Insteon::InterfaceController'))) { - $insteon_object = &Insteon::get_object($self->device_id,'01'); - if (!(defined($insteon_object))) { - &main::print_log("[Insteon::BaseController] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " - . "Please double check your items.mht file."); - } - } - my $self_link_name = $self->get_object_name; - # abort if $insteon_object doesn't exist - $self->_process_sync_queue() unless $insteon_object; - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my $member = $$self{members}{$member_ref}{object}; - # find real device if member is a Light_Item - if ($member->isa('Light_Item')) { - my @children = $member->find_members('Insteon::BaseDevice'); - $member = $children[0]; - } - my $linkmember = $member; - # find real device if member's group is not '01'; for example, cross-linked KeypadLincs - if ($member->group ne '01') { - $member = &Insteon::get_object($member->device_id,'01'); - } - my $tgt_on_level = $$self{members}{$member_ref}{on_level}; - $tgt_on_level = '100%' unless defined $tgt_on_level; - - my $tgt_ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $tgt_ramp_rate = '0' unless defined $tgt_ramp_rate; - # first, check existance for each link; if found, then perform an update (unless link is to PLM) - # if not, then add the link - if ($member->has_link($insteon_object, $self->group, 0, $linkmember->group)) { - # TO-DO: only update link if the on_level and ramp_rate are different - my $requires_update = 0; - $tgt_on_level =~ s/(\d+)%?/$1/; - $tgt_ramp_rate =~ s/(\d)s?/$1/; - my $adlbkey = lc $insteon_object->device_id . $self->group . '0'; - if (($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) - and $linkmember->group ne '01') { - $adlbkey .= $linkmember->group; - } - if (!($member->isa('Insteon::DimmableLight'))) { - if ($tgt_on_level >= 1 and $$member{adlb}{$adlbkey}{data1} ne 'ff') { - $requires_update = 1; - $tgt_on_level = 100; - } elsif ($tgt_on_level == 0 and $$member{adlb}{$adlbkey}{data1} ne '00') { - $requires_update = 1; - } - if ($$member{adlb}{$adlbkey}{data2} ne '00') { - $tgt_ramp_rate = 0; - } - } else { - $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; - my $link_on_level = hex($$member{adlb}{$adlbkey}{data1})/2.55; - my $raw_ramp_rate = $$member{adlb}{$adlbkey}{data2}; - my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); - if ($raw_ramp_rate != $raw_tgt_ramp_rate) { - $requires_update = 1; - } elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) { - $requires_update = 1; - } - } - if ($requires_update) { - my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, - group => $self->group, is_controller => 0, - on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; - } - } else { - my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, - group => $self->group, is_controller => 0, - on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; - } - if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) { - my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, - group => $self->group, is_controller => 1, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; - } - } - } - # if not a plm controlled link, then confirm that a link back to the plm exists - if (!($self->isa('Insteon::InterfaceController'))) { - my $subaddress = ($self->isa('Insteon::KeyPadLincRelay') or $self->isa('Insteon::KeyPadLinc')) ? $self->group : '00'; - if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) { - my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, - group => $self->group, is_controller => 1, - callback => "$self_link_name->_process_sync_queue()" ); - $link_req{data3} = $self->group if $insteon_object->isa('Insteon::KeyPadLincRelay') or $insteon_object->isa('Insteon::KeyPadLinc'); - push @{$$self{sync_queue}}, \%link_req; - } - if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) { - my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, - group => $self->group, is_controller => 0, - callback => "$self_link_name->_process_sync_queue()" ); - push @{$$self{sync_queue}}, \%link_req; - } - } - my $num_sync_queue = @{$$self{sync_queue}}; - if (!($num_sync_queue)) { - &::print_log("[Insteon::BaseController] Nothing to do when syncing links for " . $self->get_object_name) - if $main::Debug{insteon}; - } - $self->_process_sync_queue(); - - # TO-DO: consult links table to determine if any "orphaned links" refer to this device; if so, then delete - # WARN: can't immediately do this as the link tables aren't finalized on the above operations - # until the end of the actual insteon memory poke sequences; therefore, may need to handle separately -} - -sub _process_sync_queue { - my ($self) = @_; - # get next in queue if it exists - my $num_sync_queue = @{$$self{sync_queue}}; - if ($num_sync_queue) { - my $link_req_ptr = shift(@{$$self{sync_queue}}); - my %link_req = %$link_req_ptr; - if ($link_req{cmd} eq 'update') { - my $link_member = $link_req{member}; - $link_member->update_link(%link_req); - } elsif ($link_req{cmd} eq 'add') { - my $link_member = $link_req{member}; - $link_member->add_link(%link_req); - } - } elsif ($$self{sync_queue_callback}) { - package main; - eval ($$self{sync_queue_callback}); - &::print_log("[Insteon::BaseController] error in sync links callback: " . $@) - if $@ and $main::Debug{insteon}; - $$self{sync_queue_callback} = undef; - package Insteon::Insteon_link; - } -} - -sub set -{ - my ($self, $p_state, $p_setby, $p_respond) = @_; - # prevent reciprocal setby loops - return -1 if (ref $p_setby and ($p_setby ne $self) and $p_setby->can('get_set_by') and - $p_setby->{set_by} eq $self); - return -1 if &main::check_for_tied_filters($self, $p_state); - - # prevent setby internal Insteon_Device timers - return -1 if $p_setby eq $$self{ping_timer}; - - my $link_state = &Insteon::BaseObject::derive_link_state($p_state); - - $self->set_linked_devices($link_state); - - return 0; -} - -sub set_linked_devices -{ - my ($self, $link_state) = @_; - # iterate over the members - if ($$self{members}) - { - foreach my $member_ref (keys %{$$self{members}}) - { - my $member = $$self{members}{$member_ref}{object}; - my $on_state = $$self{members}{$member_ref}{on_level}; - $on_state = '100%' unless $on_state; - my $local_state = $on_state; - $local_state = 'on' if $local_state eq '100%' - && $member->isa('Insteon::BaseDevice') && !($member->is_root); - $local_state = 'off' if $local_state eq '0%' or $link_state eq 'off'; - if ($member->isa('Light_Item')) - { - # if they are Light_Items, then set their on_dim attrib to the member on level - # and then "blank" them via the manual method for a tad over the ramp rate - # In addition, locate the Light_Item's Insteon_Device member and do the - # same as if the member were an Insteon_Device - my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $ramp_rate = 0 unless defined $ramp_rate; - $ramp_rate = $ramp_rate + 2; - my @lights = $member->find_members('Insteon::BaseDevice'); - if (@lights) - { - my $light = @lights[0]; - # remember the current state to support resume - $$self{members}{$member_ref}{resume_state} = $light->state; - $member->manual($light, $ramp_rate); - $light->set_receive($local_state,$self); - } - else - { - $member->manual(1, $ramp_rate); - } - $member->set_on_state($local_state) unless $link_state eq 'off'; - } - elsif ($member->isa('Insteon::BaseDevice')) - { - # remember the current state to support resume - $$self{members}{$member_ref}{resume_state} = $member->state; - # if they are Insteon_Device objects, then simply set_receive their state to - # the member on level - $member->set_receive($local_state,$self); - } - } - } - - -} - -sub set_with_timer { - my ($self, $state, $time, $return_state, $additional_return_states) = @_; - return if &main::check_for_tied_filters($self, $state); - - $self->set($state) unless $state eq ''; - - return unless $time; - - my $state_change = ($state eq 'off') ? 'on' : 'off'; - $state_change = $return_state if defined $return_state; - $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; - - $state_change .= ';' . $additional_return_states if $additional_return_states; - - $$self{set_timer} = &Timer::new() unless $$self{set_timer}; - my $object_name = $self->{object_name}; - my $action = "$object_name->set('$state_change')"; - $$self{set_timer}->set($time, $action); -} - - -sub update_members -{ - my ($self) = @_; - # iterate over the members - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my ($device); - my $member = $$self{members}{$member_ref}{object}; - my $on_state = $$self{members}{$member_ref}{on_level}; - $on_state = '100%' unless $on_state; - my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; - $ramp_rate = 0 unless defined $ramp_rate; - if ($member->isa('Light_Item')) { - # if they are Light_Items, then locate the Light_Item's Insteon_Device member - my @lights = $member->find_members('Insteon::BaseDevice'); - if (@lights) { - $device = @lights[0]; - } - } elsif ($member->isa('Insteon::BaseDevice')) { - $device = $member; - } - if ($device) { - my %current_record = $device->get_link_record($self->device_id . $self->group); - if (%current_record) { - &::print_log("[Insteon::BaseController] remote record: $current_record{data1}") - if $::Debug{insteon}; - } - } - } - } -} - - -sub initiate_linking_as_controller -{ - my ($self, $p_group) = @_; - # iterate over the members - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { - my $member = $$self{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - # if they are Light_Items, then set them to manual to avoid automation - # while manually setting light parameters - $member->manual(1,120,120); # 120 seconds should be enough - } - } - } - $self->interface()->initiate_linking_as_controller($p_group); -} - -sub derive_message -{ - my ($self, $p_state, $p_extra) = @_; - if ($self->is_root) { - return $self->Insteon::BaseObject::derive_message($p_state, $p_extra); - } else { - return $self->Insteon::BaseObject::derive_message($p_state, $p_extra); - } -} - -sub find_members -{ - my ($self,$p_type) = @_; - - my @l_found; - if ($$self{members}) - { - foreach my $member_ref (keys %{$$self{members}}) - { - my $member = $$self{members}{$member_ref}{object}; - if ($member->isa($p_type)) - { - push @l_found, $member; - } - } - } - return @l_found; - -} - -#################################### -### ##################### -### DeviceController ############### -### ############### -#################################### - - -package Insteon::DeviceController; - -use strict; -use Insteon; - -@Insteon::DeviceController::ISA = ('Insteon::BaseController'); - -sub new -{ - my ($class,$p_deviceid,$p_interface,$p_devcat) = @_; - - # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller - my $self = new Insteon::BaseController($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -sub set -{ - my ($self, $p_state, $p_setby, $p_respond) = @_; - - my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); - return $rslt_code if $rslt_code; - - my $link_state = &Insteon::BaseObject::derive_link_state($p_state); - - $self->Insteon::BaseObject::set((($self->is_root) ? $p_state : $link_state), $p_setby, $p_respond); - - return 0; -} - - -sub request_status -{ - my ($self,$requestor) = @_; -# if ($self->group ne '01') { - if ($$self{members} and !($self->isa('Insteon::InterfaceController')) - and (!(ref $requestor) or ($requestor eq $self))) { - &::print_log("[Insteon::DeviceController] requesting status for members of " . $$self{object_name}); - foreach my $member (keys %{$$self{members}}) { - next unless $member->isa('Insteon::BaseObject'); - my $member_obj = $$self{members}{$member}{object}; - next if $requestor eq $member_obj; - if ($member_obj->isa('Insteon::BaseDevice')) { - &::print_log("[Insteon::DeviceController] checking status of " . $member_obj->get_object_name() - . " for requestor " . $requestor->get_object_name()); - $member_obj->request_status($self); - } - } - } - # the following has bad assumptions in that we don't always know if a device is a responder - # since it could be a slave - if ($self->is_root && $self->is_responder) { - $self->Insteon::BaseDevice::request_status($requestor); - } -} - -sub link_to_interface -{ - my ($self, $p_group, $p_data3) = @_; - my $group = $p_group; - $group = $self->group unless $group; - # get the surrogate device for this if group is not '01' - if ($self->group ne '01') { - my $surrogate_obj = &Insteon::get_object($self->device_id,'01'); - if ($p_data3) { - $surrogate_obj->link_to_interface($group,$p_data3); - } elsif ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { - $surrogate_obj->link_to_interface($group,$self->group); - } else { - $surrogate_obj->link_to_interface($group); - } - # next, if the link is a keypadlinc, then create the reverse link to permit - # control over the button's light - if ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { - - } - } else { - if ($p_data3) { - $self->SUPER::link_to_interface($group, $p_data3); - } else { - $self->SUPER::link_to_interface($group); - } - } -} - -sub unlink_to_interface -{ - my ($self,$p_group) = @_; - my $group = $p_group; - $group = $self->group unless $group; - # get the surrogate device for this if group is not '01' - if ($self->group ne '01') { - my $surrogate_obj = &Insteon::get_object($self->device_id,'01'); - $surrogate_obj->unlink_to_interface($group); - # next, if the link is a keypadlinc, then delete the reverse link to permit - # control over the button's light - if ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { - - } - } else { - $self->SUPER::unlink_to_interface($group); - } -} - - - -#################################### -### ############ -### InterfaceController ############ -### ############ -#################################### - - -package Insteon::InterfaceController; - -use strict; -use Insteon; - -@Insteon::InterfaceController::ISA = ('Insteon::BaseController','Insteon::BaseObject'); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller - my $self = new Insteon::BaseObject($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -sub set -{ - my ($self, $p_state, $p_setby, $p_respond) = @_; - - my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); - return $rslt_code if $rslt_code; - - $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); - - return 0; -} - -sub is_root -{ - return 0; -} - -1; +=begin comment +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +File: + BaseInsteon.pm + +Description: + Generic class implementation of an Insteon Device. + +Author(s): + Gregg Liming / gregg@limings.net + +License: + This free software is licensed under the terms of the GNU public license. + +Usage: + + $ip_patio_light = new Insteon_Device($myPLM,"33.44.55"); + + $ip_patio_light->set("ON"); + +Special Thanks to: + Brian Warren for significant testing and patches + Bruce Winter - MH + +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +=cut + +package Insteon::BaseObject; + +use strict; +use Insteon; +use Insteon::AllLinkDatabase; +use Insteon::Message; + +@Insteon::BaseObject::ISA = ('Generic_Item'); + +our %message_types = ( + on => 0x11, + off => 0x13 +); + +sub derive_link_state +{ + my ($p_state) = @_; + + my $link_state = 'on'; + if ($p_state eq 'off') + { + $link_state = 'off'; + } + elsif ($p_state =~ /\d+%?/) + { + my ($dim_state) = $p_state =~ /(\d+)%?/; + $link_state = 'off' if $dim_state == 0; + } + + return $link_state; +} + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + my $self={}; + bless $self,$class; + + $$self{message_types} = \%message_types; + + if (defined $p_deviceid) { + my ($deviceid, $group) = $p_deviceid =~ /(\w\w\.\w\w\.\w\w):?(.+)?/; + # if a group is passed in, then assume it can be a controller + $$self{is_controller} = ($group) ? 1 : 0; + $self->device_id($deviceid); + $group = '01' unless $group; + $group = '0' . $group if length($group) == 1; + $self->group(uc $group); + } + + if ($p_interface) { + $self->interface($p_interface); + } else { + $self->interface(&Insteon::active_interface()); + } + + $self->restore_data('level'); + + $self->initialize(); + $$self{level} = undef; + $$self{flag} = "0F"; + $$self{ackMode} = "1"; + $$self{awaiting_ack} = 0; + $$self{is_acknowledged} = 0; + $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; + $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack + @{$$self{command_stack}} = (); + $$self{_onlevel} = undef; + $$self{is_responder} = 1; + + &Insteon::add($self); + return $self; +} + +sub initialize +{ + my ($self) = @_; + $$self{m_write} = 1; + $$self{m_is_locally_set} = 0; + # persist local, simple attribs + + # do we really need to ping the devices anymore for a devcat? + $$self{ping_timer} = new Timer(); + $$self{ping_timerTime} = 300; +# $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self) +# unless $self->group eq '01' and defined $self->devcat; +} + +sub interface +{ + my ($self,$p_interface) = @_; + if (defined $p_interface) { + $$self{interface} = $p_interface; + } + return $$self{interface}; +} + +sub device_id +{ + my ($self,$p_device_id) = @_; + + if (defined $p_device_id) + { + $p_device_id =~ /(\w\w)\W?(\w\w)\W?(\w\w)/; + $$self{device_id}=$1 . $2 . $3; + } + return $$self{device_id}; +} + +sub group +{ + my ($self, $p_group) = @_; + $$self{m_group} = $p_group if $p_group; + return $$self{m_group}; +} + +sub equals +{ + my ($self, $compare_object) = @_; + # make sure that the compare_object is legitimate + return 0 unless $compare_object && ref $compare_object && $compare_object->isa('Insteon::BaseObject'); + return 1 if $compare_object eq $self; + # self and compare_object need to have device_ids and groups to be equal + return 0 unless $self->device_id && $self->group && $compare_object->device_id && $compare_object->group; + return 1 if (($compare_object->device_id eq $self->device_id) + && ($compare_object->group eq $self->group)); + # default to false; + return 0; +} + +sub set +{ + my ($self,$p_state,$p_setby,$p_response) = @_; + return if &main::check_for_tied_filters($self, $p_state); + + # Override any set_with_timer requests + if ($$self{set_timer}) { + &Timer::unset($$self{set_timer}); + delete $$self{set_timer}; + } + + # did the queue timer go off? + if (ref $p_setby and $p_setby eq $$self{ping_timer}) { + if (! (defined($$self{devcat}))) { + $self->ping(); + # set the timer again in case nothing occurs + $$self{ping_timer}->set($$self{ping_timerTime} + (rand() * $$self{ping_timerTime}), $self); + } + } elsif ($self->_is_valid_state($p_state)) { + # always reset the is_locally_set property unless set_by is the device + $$self{m_is_locally_set} = 0 unless ref $p_setby and $p_setby eq $self; + + # handle invalid state for non-dimmable devices + if (($p_state eq 'dim' or $p_state eq 'bright') and !($self->isa('Insteon::DimmableLight'))) { + $p_state = 'on'; + } + my $setby_name = $p_setby; + $setby_name = $p_setby->get_object_name() if (ref $p_setby and $p_setby->can('get_object_name')); + if (ref $p_setby and (($p_setby eq $self->interface()) + or (($p_setby->isa('Insteon::BaseObject')) + and (($p_setby eq $self) + or (&main::set_by_to_target($p_setby) eq $self->interface))))) + { + # don't reset the object w/ the same state if set from the interface + return if (lc $p_state eq lc $self->state) and $self->is_acknowledged + and not(($p_setby->isa('Insteon::BaseObject') and ($p_setby eq $self))); + &::print_log("[Insteon::BaseObject] " . $self->get_object_name() + . "::set($p_state, $setby_name)") if $main::Debug{insteon}; + $self->set_receive($p_state,$p_setby,$p_response) if defined $p_state; + } else { + my $message = $self->derive_message($p_state); + $self->_send_cmd($message); + +# $self->_send_cmd(command => $p_state, +# type => (($self->isa('Insteon::Insteon_Link') and !($self->is_root)) ? 'alllink' : 'standard')); + &::print_log("[Insteon::BaseObject] " . $self->get_object_name() . "::set($p_state, $setby_name)") + if $main::Debug{insteon}; + $self->is_acknowledged(0); + $$self{pending_state} = $p_state; + $$self{pending_setby} = $p_setby; + $$self{pending_response} = $p_response; + } + $self->level($p_state) if $self->isa("Insteon::BaseDevice"); # update the level value +# $self->SUPER::set($p_state,$p_setby,$p_response) if defined $p_state; + } else { + &::print_log("[Insteon::BaseObject] failed state validation with state=$p_state"); + } +} + +sub is_acknowledged +{ + my ($self, $p_ack) = @_; + $$self{is_acknowledged} = $p_ack if defined $p_ack; + if ($p_ack) { + $self->set_receive($$self{pending_state},$$self{pending_setby}, $$self{pending_response}) if defined $$self{pending_state}; + $$self{pending_state} = undef; + $$self{pending_setby} = undef; + $$self{pending_response} = undef; + } + return $$self{is_acknowledged}; +} + +sub set_receive +{ + my ($self, $p_state, $p_setby, $p_response) = @_; + $self->SUPER::set($p_state, $p_setby, $p_response); +} + +sub set_with_timer { + my ($self, $state, $time, $return_state, $additional_return_states) = @_; + return if &main::check_for_tied_filters($self, $state); + + $self->set($state) unless $state eq ''; + + return unless $time; + + my $state_change = ($state eq 'off') ? 'on' : 'off'; + $state_change = $return_state if defined $return_state; + $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; + + $state_change .= ';' . $additional_return_states if $additional_return_states; + + $$self{set_timer} = &Timer::new() unless $$self{set_timer}; + my $object_name = $self->{object_name}; + my $action = "$object_name->set('$state_change')"; + $$self{set_timer}->set($time, $action); +} + +sub _send_cmd +{ + my ($self, $message) = @_; +# $msg{type} = 'standard' unless $msg{type}; + +# my $message = $self->derive_message($msg{command},$msg{type},$msg{extra}); + + if ($message->command eq 'peek' + or $message->command eq 'poke' + or $message->command eq 'status_request' + or $message->command eq 'do_read_ee' + or $message->command eq 'set_address_msb' + ) + { + push(@{$$self{command_stack}}, $message); + } + else + { + unshift(@{$$self{command_stack}},$message); + } + $self->_process_command_stack(); +} + +sub derive_message +{ + my ($self, $p_command, $p_extra) = @_; + my @args; + my $level; + + #msg id + my ($command, $subcommand) = split(/:/, $p_command, 2); + $command=lc($command); +# &::print_log("XLATE:$msg:$substate:$p_state:"); + + my $message; + + if ($self->isa("Insteon::BaseController")) + { + # only send out as all-link if the link originates from the plm + if ($self->isa("Insteon::InterfaceController")) + { # return the size of the command stack + $message = new Insteon::InsteonMessage('all_link_send', $self); + } + elsif ($self->is_root) + { # return the size of the command stack + $message = new Insteon::InsteonMessage('insteon_send', $self); + } else { + # silently ignore as this is now permitted if via "surrogate" + } + } elsif ($self->isa("Insteon::BaseObject")) { + $message = new Insteon::InsteonMessage('insteon_send', $self); + } + + if (!(defined $p_extra)) { + if ($command eq 'on') + { + if ($self->isa('Insteon::BaseDevice') && defined $self->local_onlevel) { + $level = 2.55 * $self->local_onlevel; + $command = 'on_fast'; + } else { + $level=255; + } + } elsif ($command eq 'off') + { + $level = 0; + } elsif ($command=~/^([1]?[0-9]?[0-9])/) + { + if ($1 < 1) { + $command='off'; + $level = 0; + } else { + $level = ($self->isa('Insteon::DimmableLight')) ? $1 * 2.55 : 255; + $command='on'; + } + } + } + + # confirm that the resulting $msg is legitimate + if (!(defined($self->message_type_code($command)))) { + &::print_log("[Insteon::BaseInsteon] invalid state=$command") if $main::Debug{insteon}; + return undef; + } + + if ($p_extra) + { $message->extra($p_extra); + + } elsif ($subcommand) { + $message->extra($subcommand); + } else { + if ($command eq 'on') + { + $message->extra(sprintf("%02X",$level)); + } else { + $message->extra('00'); + } + } + + $message->command($command); + return $message; +} + +sub message_type_code +{ + my ($self, $msg) = @_; + my $msg_type_ptr = $$self{message_types}; + my %msg_types = %$msg_type_ptr; + my $code = $msg_types{$msg}; + return $code; +} + +sub message_type +{ + my ($self, $cmd1) = @_; + my $msg_type; + my $msg_type_ptr = $$self{message_types}; + my %msg_types = %$msg_type_ptr; + for my $key (keys %msg_types){ + if (pack("C",$msg_types{$key}) eq pack("H*",$cmd1)) + { +# &::print_log("[Insteon::BaseObject] found: $key"); + $msg_type=$key; + last; + } + } + return $msg_type; +} + +sub _is_info_request +{ + my ($self, $cmd, $ack_setby, %msg) = @_; + my $is_info_request = ($cmd eq 'status_request') ? 1 : 0; +#print "cmd: $cmd; is_info_request: $is_info_request\n"; + if ($is_info_request) { + my $ack_on_level = (hex($msg{extra}) >= 254) ? 100 : sprintf("%d", hex($msg{extra}) * 100 / 255); + &::print_log("[Insteon::BaseObject] received status for " . + $self->{object_name} . " with on-level: $ack_on_level%, " + . "hops left: $msg{hopsleft}") if $main::Debug{insteon}; + $self->level($ack_on_level); # update the level value + if ($ack_on_level == 0) { + $self->SUPER::set('off', $ack_setby); + } elsif ($ack_on_level > 0 and !($self->isa('Insteon::DimmableLight'))) { + $self->SUPER::set('on', $ack_setby); + } else { + $self->SUPER::set($ack_on_level . '%', $ack_setby); + } + # if this were a scene controller, then also propogate the result to all members + } + return $is_info_request; + +} + +sub _process_message +{ + my ($self,$p_setby,%msg) = @_; + my $p_state = undef; + + # the current approach assumes that links from other controllers to some responder + # would be seen by the plm by also direct linking the controller as a responder + # and not putting the plm into monitor mode. This means that updating the state + # of the responder based upon the link controller's request is handled + # by Insteon_Link. + $$self{m_is_locally_set} = 1 if $msg{source} eq lc $self->device_id; + if ($msg{is_ack}) { + my $pending_cmd = ($$self{_prior_msg}) ? $$self{_prior_msg}->command : $msg{command}; + if ($$self{awaiting_ack}) { + my $ack_setby = (ref $$self{m_status_request_pending}) + ? $$self{m_status_request_pending} : $p_setby; + if ($self->_is_info_request($pending_cmd,$ack_setby,%msg)) { + $self->is_acknowledged(1); + $$self{m_status_request_pending} = 0; + $self->_process_command_stack(%msg); + } elsif (($pending_cmd eq 'peek') or ($pending_cmd eq 'set_address_msb')) { + $self->_aldb->_on_peek(%msg) if $self->_aldb; + $self->_process_command_stack(%msg); + } elsif (($pending_cmd eq 'poke') or ($pending_cmd eq 'set_address_msb')) { + $self->_aldb->_on_poke(%msg) if $self->_aldb; + $self->_process_command_stack(%msg); + } else { + $self->is_acknowledged(1); + # signal receipt of message to the command stack in case commands are queued + $self->_process_command_stack(%msg); + &::print_log("[Insteon::BaseObject] received command/state (awaiting) acknowledge from " . $self->{object_name} + . ": $pending_cmd and data: $msg{extra}") if $main::Debug{insteon}; + } + } else { + # allow non-synchronous messages to also use the _is_info_request hook + $self->_is_info_request($pending_cmd,$p_setby,%msg); + $self->is_acknowledged(1); + # signal receipt of message to the command stack in case commands are queued + $self->_process_command_stack(%msg); + &::print_log("[Insteon::BaseObject] received command/state acknowledge from " . $self->{object_name} + . ": " . (($msg{command}) ? $msg{command} : "(unknown)") + . " and data: $msg{extra}") if $main::Debug{insteon}; + } + } elsif ($msg{is_nack}) { + if ($$self{awaiting_ack}) { + # NOTE!!! NACKs are usually a sign of a burnt-out bulb!! + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + . " ... waiting for retry"); + } else { + if ($self->isa('Insteon::BaseLight')) + { + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + . ". It may be unplugged or have a burned out bulb") if $main::Debug{insteon}; + } + else + { + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + . " ... skipping"); + } + $self->is_acknowledged(0); + $self->_process_command_stack(%msg); + } + } elsif ($msg{command} eq 'start_manual_change') { + # do nothing; although, maybe anticipate change? we should always get a stop + } elsif ($msg{command} eq 'stop_manual_change') { + # request status so that the final state can be known + $self->request_status($self); + } elsif ($msg{type} eq 'broadcast') { + $self->devcat($msg{devcat}); + &::print_log("[Insteon::BaseObject] device category: $msg{devcat} received for " . $self->{object_name}); + # stop ping timer now that we have a devcat; possibly may want to change this behavior to allow recurring pings + $$self{ping_timer}->stop(); + } else { + ## TO-DO: make sure that the state passed by command is something that is reasonable to set + $p_state = $msg{command}; + if ($msg{type} eq 'alllink') + { + $$self{_pending_cleanup} = 1; + } + elsif ($msg{type} eq 'cleanup') + { + $self->set($p_state, $self); # unless (lc($self->state) eq lc($p_state)) and + # ($msg{type} eq 'cleanup' and $$self{_pending_cleanup}); + $$self{_pending_cleanup} = 0; + } + } +} + +sub _process_command_stack +{ + my ($self, %ackmsg) = @_; + if (%ackmsg) { # which may also be something that can be interpretted as a "nack" + # determine whether to unset awaiting_ack + # for now, be "dumb" and just unset it + $$self{awaiting_ack} = 0; + } + if (!($$self{awaiting_ack})) { + my $callback = undef; + my $message = pop(@{$$self{command_stack}}); + # convert ptr to cmd hash + if ($message) + { + my $plm_queue_size = $self->interface->queue_message($message); + + # send msg + if ($message->command eq 'peek' + or $message->command eq 'poke' + or $message->command eq 'status_request' + or $message->command eq 'do_read_ee' + or $message->command eq 'set_address_msb' + ) + { + $$self{awaiting_ack} = 1; + } + else + { + $$self{awaiting_ack} = 0; + } + + $$self{_prior_msg} = $message; + # TO-DO: adjust timer based upon (1) type of message and (2) retry_count + my $queue_time = $$self{max_queue_time} + $plm_queue_size; + # if is_synchronous, then no other command can be sent until an insteon ack or nack is received + # for this command + } else { + # and, always clear awaiting_ack and _prior_msg + $$self{awaiting_ack} = 0; + $$self{_prior_msg} = undef; + } + if ($callback) { + package main; + eval ($callback); + &::print_log("[Insteon::BaseObject] error in queue timer callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon::BaseObject; + } + } else { +# &::print_log("[Insteon_Device] " . $self->get_object_name . " command queued but not yet sent; awaiting ack from prior command") if $main::Debug{insteon}; + } +} + +sub _is_valid_state +{ + my ($self,$state) = @_; + if (!(defined($state)) or $state eq '') { + return 0; + } + + my ($msg, $substate) = split(/:/, $state, 2); + $msg=lc($msg); + + if ($msg=~/^([1]?[0-9]?[0-9])/) + { + if ($1 < 1) { + $msg='off'; + } else { + $msg='on'; + } + } + + # confirm that the resulting $msg is legitimate + if (!(defined($message_types{$msg}))) { + return 0; + } else { + return 1; + } +} + + +#################################### +### ##################### +### BaseObject ##################### +### ##################### +#################################### + +package Insteon::BaseDevice; + +use strict; +use Insteon; +use Insteon::AllLinkDatabase; + +@Insteon::BaseDevice::ISA = ('Insteon::BaseObject'); + +our %message_types = ( + %Insteon::BaseObject::message_types, + assign_to_group => 0x01, + delete_from_group => 0x02, + linking_mode => 0x09, + unlinking_mode => 0x0A, + ping => 0x10, + on_fast => 0x12, + off_fast => 0x14, + start_manual_change => 0x17, + stop_manual_change => 0x18, + status_request => 0x19, + get_operating_flags => 0x1f, + set_operating_flags => 0x20, + do_read_ee => 0x24, + remote_set_button_tap => 0x25, + set_led_status => 0x27, + set_address_msb => 0x28, + poke => 0x29, + poke_extended => 0x2a, + peek => 0x2b, + peek_internal => 0x2c, + poke_internal => 0x2d +); + + +my %operating_flags = ( + 'program_lock_on' => '00', + 'program_lock_off' => '01', + 'led_on_during_tx' => '02', + 'led_off_during_tx' => '03', + 'resume_dim_on' => '04', + 'beeper_enabled' => '04', + 'resume_dim_off' => '05', + 'beeper_off' => '05', + 'eight_key_kpl' => '06', + 'load_sense_on' => '06', + 'six_key_kpl' => '07', + 'load_sense_off' => '07', + 'led_backlight_off' => '08', + 'led_off' => '08', + 'led_backlight_on' => '09', + 'led_enabled' => '09', + 'key_beep_enabled' => '0a', + 'one_minute_warn_disabled' => '0a', + 'key_beep_off' => '0b', + 'one_minute_warn_enabled' => '0b' +); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + my $self= new Insteon::BaseObject($p_deviceid,$p_interface); + bless $self,$class; + + $$self{message_types} = \%message_types; + + if ($self->group eq '01') { + $$self{aldb} = new Insteon::ALDB_i1($self); + } + + $self->restore_data('level'); + + $self->initialize(); + $self->rate(undef); + $$self{level} = undef; + $$self{flag} = "0F"; + $$self{ackMode} = "1"; + $$self{awaiting_ack} = 0; + $$self{is_acknowledged} = 0; + $$self{max_queue_time} = $::config_parms{'Insteon_PLM_max_queue_time'}; + $$self{max_queue_time} = 10 unless $$self{max_queue_time}; # 10 seconds is max time allowed in command stack + @{$$self{command_stack}} = (); + $$self{_onlevel} = undef; + $$self{is_responder} = 1; + + return $self; +} + +sub initialize +{ + my ($self) = @_; + $$self{m_write} = 1; + $$self{m_is_locally_set} = 0; + # persist local, simple attribs + + # do we really need to ping the devices anymore for a devcat? + $$self{ping_timer} = new Timer(); + $$self{ping_timerTime} = 300; +} + +sub rate +{ + my ($self,$p_rate) = @_; + $$self{rate} = $p_rate if defined $p_rate; + return $$self{rate}; +} + +sub set_receive +{ + my ($self, $p_state, $p_setby, $p_response) = @_; + $self->level($p_state) if $self->can('level'); # update the level value + $self->SUPER::set_receive($p_state, $p_setby, $p_response); +} + +sub is_controller +{ + my ($self) = @_; + return $$self{is_controller}; +} + +sub is_responder +{ + my ($self,$is_responder) = @_; + $$self{is_responder} = $is_responder if defined $is_responder; + if ($self->is_root) { + return $$self{is_responder}; + } else { + my $root_obj = $self->get_root(); + if (ref $root_obj) { + return $$root_obj{is_responder}; + } else { + return 0; + } + } +} + +sub link_to_interface +{ + my ($self,$p_group, $p_data3) = @_; + my $group = $p_group; + $group = '01' unless $group; + # add a link first to this device back to interface + # and, add a reference to creating a link from interface back to device via hook + my $callback_instance = $self->interface->get_object_name; + my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; + my %link_info = ( object => $self->interface, group => $group, is_controller => 1, + on_level => '100%', ramp_rate => '0.1s', + callback => "$callback_instance->add_link('$callback_info')"); + $link_info{data3} = $p_data3 if $p_data3; + if ($self->_aldb) { + $self->_aldb->add_link(%link_info); + } else { + &main::print_log("[BaseInsteon] This item " . $self->get_object_name . + " does not have an ALDB object. Linking is not permitted."); + } +} + +sub unlink_to_interface +{ + my ($self,$p_group) = @_; + my $group = $p_group; + $group = '01' unless $group; + my $callback_instance = $self->interface->get_object_name; + my $callback_info = "deviceid=" . lc $self->device_id . " group=$group is_controller=0"; + if ($self->_aldb) { + $self->_aldb->delete_link(object => $self->interface, group => $group, is_controller => 1, + callback => "$callback_instance->delete_link('$callback_info')"); + } else { + &main::print_log("[BaseInsteon] This item " . $self->get_object_name . + " does not have an ALDB object. Unlinking is not permitted."); + } +} + + +sub _aldb +{ + my ($self) = @_; + return $$self{aldb}; +} + + +sub set_operating_flag { + my ($self, $flag) = @_; + + if (!(exists($operating_flags{$flag}))) { + &::print_log("[Insteon::BaseDevice] $flag is not a support operating flag"); + return; + } + + if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { + # TO-DO: check devcat to determine if the action is supported by the device + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_operating_flags'); + $message->extra($operating_flags{$flag}); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'set_operating_flags', 'extra' => $operating_flags{$flag}); + } else { + &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); + return; + } +} + +sub get_operating_flag { + my ($self) = @_; + + if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { + # TO-DO: check devcat to determine if the action is supported by the device + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'get_operating_flags'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'get_operating_flags'); + } else { + &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); + return; + } +} + +sub writable { + my ($self, $p_write) = @_; + if (defined $p_write) { + if ($p_write =~ /r/i or $p_write =~/^0/) { + $$self{m_write} = 0; + } else { + $$self{m_write} = 1; + } + } + return $$self{m_write}; +} + +sub is_locally_set { + my ($self) = @_; + return $$self{m_is_locally_set}; +} + + +sub is_root { + my ($self) = @_; + return (($self->group eq '01') and !($self->isa('Insteon::InterfaceController'))) ? 1 : 0; +} + +sub get_root { + my ($self) = @_; + if ($self->is_root) { + return $self; + } else { + return &Insteon::get_object($self->device_id, '01'); + } +} + +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + return $aldb->has_link($insteon_object, $group, $is_controller, $subaddress); + } + else + { + return 0; + } + +} + +sub add_link +{ + my ($self, $parms_text) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + $aldb->add_link(%link_parms); + } + +} + +sub scan_link_table +{ + my ($self, $callback) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + return $aldb->scan_link_table($callback); + } + +} + +### WARN: Testing using the following does not produce results as expected. Use at your own risk. [GL] +sub remote_set_button_tap +{ + my ($self,$p_number_taps) = @_; + my $taps = ($p_number_taps =~ /2/) ? '02' : '01'; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'remote_set_button_tap'); + $message->extra($taps); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'remote_set_button_tap', 'extra' => $taps); +} + +sub request_status +{ + my ($self, $requestor) = @_; + $$self{m_status_request_pending} = ($requestor) ? $requestor : 1; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'status_request'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'status_request', 'is_synchronous' => 1); +} + +sub ping +{ + my ($self) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'ping'); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'ping'); +} + +sub set_led_status +{ + my ($self, $status_mask) = @_; + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_led_status'); + $message->extra($status_mask); + $self->_send_cmd($message); +# $self->_send_cmd('command' => 'set_led_status', 'extra' => $status_mask); +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = $self->SUPER::restore_string(); + if ($self->_aldb) { + $restore_string .= $self->_aldb->restore_string(); + } + if ($$self{states}) { + my $states = ''; + foreach my $state (@{$$self{states}}) { + $states .= '|' if $states; + $states .= $state; + } + $restore_string .= $self->{object_name} . "->restore_states(q~$states~);\n"; + } + return $restore_string; +} + +sub restore_states +{ + my ($self, $states) = @_; + if ($states) { + @{$$self{states}} = split(/\|/,$states); + } +} + +sub restore_aldb +{ + my ($self,$aldb) = @_; + if ($self->_aldb and $aldb) { + $self->_aldb->restore_aldb($aldb); + } +} + +sub devcat +{ + my ($self, $devcat) = @_; + if ($devcat) { + $$self{devcat} = $devcat; + if (($$self{devcat} =~ /^01\w\w/) or ($$self{devcat} =~ /^02\w\w/) && !($self->states)) { + $self->states( 'on,off' ); + } + } + return $$self{devcat}; +} + +sub states +{ + my ($self, $states) = @_; + if ($states) { + @{$$self{states}} = split(/,/,$states); + } + if ($$self{states}) { + return @{$$self{states}}; + } else { + return undef; + } + +} + + +sub local_onlevel +{ + my ($self, $p_onlevel) = @_; + if (defined $p_onlevel) { + my ($onlevel) = $p_onlevel =~ /(\d+)%?/; + $$self{_onlevel} = $onlevel; + } + return $$self{_onlevel}; +} + +sub local_ramprate +{ + my ($self, $p_ramprate) = @_; + if (defined $p_ramprate) { + $$self{_ramprate} = &Insteon::DimmableLight::convert_ramp($p_ramprate); + } + return $$self{_ramprate}; + +} + + +sub scan_link_table +{ + my ($self,$callback) = @_; + $self->_aldb->scan_link_table($callback) if $self->_aldb; +} + +sub delete_orphan_links +{ + my ($self) = @_; + return $self->_aldb->delete_orphan_links if $self->_aldb; +} + +sub _process_delete_queue { + my ($self) = @_; + $self->_aldb->_process_delete_queue() if $self->_aldb; +} + +sub log_alllink_table +{ + my ($self) = @_; + $self->_aldb->log_alllink_table if $self->_aldb; +} + +sub update_local_properties +{ + my ($self) = @_; + if ($self->isa('Insteon::DimmableLight')) { + $self->_aldb->update_local_properties() if $self->_aldb; + } else { + &::print_log("[Insteon::BaseDevice] update_local_properties may only be applied to dimmable devices!"); + } +} + +sub update_flags +{ + my ($self, $flags) = @_; + if (!($self->isa('Insteon::KeyPadLinc') or $self->isa('Insteon::KeyPadLincRelay'))) { + &::print_log("[Insteon::BaseDevice] Operating flags may only be revised on keypadlincs!"); + return; + } + return unless defined $flags; + + $self->_aldb->update_flags($flags) if $self->_aldb; +} + + +#################################### +### ################# +### BaseController ################# +### ################# +#################################### + +package Insteon::BaseController; + +use strict; +use Insteon; + +@Insteon::BaseController::ISA = ('Generic_Item'); + +sub new +{ + my ($class,$p_deviceid,$p_interface,$p_devcat) = @_; + + # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller + my $self = {}; + bless $self,$class; +# don't apply ping timer to this class +# $$self{ping_timer}->stop(); + return $self; +} + +sub add +{ + my ($self, $obj, $on_level, $ramp_rate) = @_; + if (ref $obj and ($obj->isa('Light_Item') or $obj->isa('Insteon::BaseDevice'))) { + if ($$self{members} && $$self{members}{$obj}) { + print "[Insteon::BaseController] An object (" . $obj->{object_name} . ") already exists " + . "in this scene. Aborting add request.\n"; + return; + } + if ($on_level =~ /^sur/i) { + $on_level = '100%'; + $$obj{surrogate} = $self; + } elsif (lc $on_level eq 'on') { + $on_level = '100%'; + } elsif (lc $on_level eq 'off') { + $on_level = '0%'; + } + $on_level = '100%' unless $on_level; + $$self{members}{$obj}{on_level} = $on_level; + $$self{members}{$obj}{object} = $obj; + $ramp_rate =~ s/s$//i; + $$self{members}{$obj}{ramp_rate} = $ramp_rate if defined $ramp_rate; + } else { + &::print_log("[Insteon::BaseController] WARN: unable to add $obj as items of this type are not supported!"); + } +} + +sub sync_links +{ + my ($self, $callback) = @_; + @{$$self{sync_queue}} = (); # reset the work queue + $$self{sync_queue_callback} = ($callback) ? $callback : undef; + my $insteon_object = $self->interface; + if (!($self->isa('Insteon::InterfaceController'))) { + $insteon_object = &Insteon::get_object($self->device_id,'01'); + if (!(defined($insteon_object))) { + &main::print_log("[Insteon::BaseController] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " + . "Please double check your items.mht file."); + } + } + my $self_link_name = $self->get_object_name; + # abort if $insteon_object doesn't exist + $self->_process_sync_queue() unless $insteon_object; + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my $member = $$self{members}{$member_ref}{object}; + # find real device if member is a Light_Item + if ($member->isa('Light_Item')) { + my @children = $member->find_members('Insteon::BaseDevice'); + $member = $children[0]; + } + my $linkmember = $member; + # find real device if member's group is not '01'; for example, cross-linked KeypadLincs + if ($member->group ne '01') { + $member = &Insteon::get_object($member->device_id,'01'); + } + my $tgt_on_level = $$self{members}{$member_ref}{on_level}; + $tgt_on_level = '100%' unless defined $tgt_on_level; + + my $tgt_ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $tgt_ramp_rate = '0' unless defined $tgt_ramp_rate; + # first, check existance for each link; if found, then perform an update (unless link is to PLM) + # if not, then add the link + if ($member->has_link($insteon_object, $self->group, 0, $linkmember->group)) { + # TO-DO: only update link if the on_level and ramp_rate are different + my $requires_update = 0; + $tgt_on_level =~ s/(\d+)%?/$1/; + $tgt_ramp_rate =~ s/(\d)s?/$1/; + my $adlbkey = lc $insteon_object->device_id . $self->group . '0'; + if (($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + and $linkmember->group ne '01') { + $adlbkey .= $linkmember->group; + } + if (!($member->isa('Insteon::DimmableLight'))) { + if ($tgt_on_level >= 1 and $$member{adlb}{$adlbkey}{data1} ne 'ff') { + $requires_update = 1; + $tgt_on_level = 100; + } elsif ($tgt_on_level == 0 and $$member{adlb}{$adlbkey}{data1} ne '00') { + $requires_update = 1; + } + if ($$member{adlb}{$adlbkey}{data2} ne '00') { + $tgt_ramp_rate = 0; + } + } else { + $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; + my $link_on_level = hex($$member{adlb}{$adlbkey}{data1})/2.55; + my $raw_ramp_rate = $$member{adlb}{$adlbkey}{data2}; + my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); + if ($raw_ramp_rate != $raw_tgt_ramp_rate) { + $requires_update = 1; + } elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) { + $requires_update = 1; + } + } + if ($requires_update) { + my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, + group => $self->group, is_controller => 0, + on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } + } else { + my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, + group => $self->group, is_controller => 0, + on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } + if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) { + my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, + group => $self->group, is_controller => 1, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } + } + } + # if not a plm controlled link, then confirm that a link back to the plm exists + if (!($self->isa('Insteon::InterfaceController'))) { + my $subaddress = ($self->isa('Insteon::KeyPadLincRelay') or $self->isa('Insteon::KeyPadLinc')) ? $self->group : '00'; + if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) { + my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, + group => $self->group, is_controller => 1, + callback => "$self_link_name->_process_sync_queue()" ); + $link_req{data3} = $self->group if $insteon_object->isa('Insteon::KeyPadLincRelay') or $insteon_object->isa('Insteon::KeyPadLinc'); + push @{$$self{sync_queue}}, \%link_req; + } + if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) { + my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, + group => $self->group, is_controller => 0, + callback => "$self_link_name->_process_sync_queue()" ); + push @{$$self{sync_queue}}, \%link_req; + } + } + my $num_sync_queue = @{$$self{sync_queue}}; + if (!($num_sync_queue)) { + &::print_log("[Insteon::BaseController] Nothing to do when syncing links for " . $self->get_object_name) + if $main::Debug{insteon}; + } + $self->_process_sync_queue(); + + # TO-DO: consult links table to determine if any "orphaned links" refer to this device; if so, then delete + # WARN: can't immediately do this as the link tables aren't finalized on the above operations + # until the end of the actual insteon memory poke sequences; therefore, may need to handle separately +} + +sub _process_sync_queue { + my ($self) = @_; + # get next in queue if it exists + my $num_sync_queue = @{$$self{sync_queue}}; + if ($num_sync_queue) { + my $link_req_ptr = shift(@{$$self{sync_queue}}); + my %link_req = %$link_req_ptr; + if ($link_req{cmd} eq 'update') { + my $link_member = $link_req{member}; + $link_member->update_link(%link_req); + } elsif ($link_req{cmd} eq 'add') { + my $link_member = $link_req{member}; + $link_member->add_link(%link_req); + } + } elsif ($$self{sync_queue_callback}) { + package main; + eval ($$self{sync_queue_callback}); + &::print_log("[Insteon::BaseController] error in sync links callback: " . $@) + if $@ and $main::Debug{insteon}; + $$self{sync_queue_callback} = undef; + package Insteon::Insteon_link; + } +} + +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + # prevent reciprocal setby loops + return -1 if (ref $p_setby and ($p_setby ne $self) and $p_setby->can('get_set_by') and + $p_setby->{set_by} eq $self); + return -1 if &main::check_for_tied_filters($self, $p_state); + + # prevent setby internal Insteon_Device timers + return -1 if $p_setby eq $$self{ping_timer}; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + $self->set_linked_devices($link_state); + + return 0; +} + +sub set_linked_devices +{ + my ($self, $link_state) = @_; + # iterate over the members + if ($$self{members}) + { + foreach my $member_ref (keys %{$$self{members}}) + { + my $member = $$self{members}{$member_ref}{object}; + my $on_state = $$self{members}{$member_ref}{on_level}; + $on_state = '100%' unless $on_state; + my $local_state = $on_state; + $local_state = 'on' if $local_state eq '100%' + && $member->isa('Insteon::BaseDevice') && !($member->is_root); + $local_state = 'off' if $local_state eq '0%' or $link_state eq 'off'; + if ($member->isa('Light_Item')) + { + # if they are Light_Items, then set their on_dim attrib to the member on level + # and then "blank" them via the manual method for a tad over the ramp rate + # In addition, locate the Light_Item's Insteon_Device member and do the + # same as if the member were an Insteon_Device + my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $ramp_rate = 0 unless defined $ramp_rate; + $ramp_rate = $ramp_rate + 2; + my @lights = $member->find_members('Insteon::BaseDevice'); + if (@lights) + { + my $light = @lights[0]; + # remember the current state to support resume + $$self{members}{$member_ref}{resume_state} = $light->state; + $member->manual($light, $ramp_rate); + $light->set_receive($local_state,$self); + } + else + { + $member->manual(1, $ramp_rate); + } + $member->set_on_state($local_state) unless $link_state eq 'off'; + } + elsif ($member->isa('Insteon::BaseDevice')) + { + # remember the current state to support resume + $$self{members}{$member_ref}{resume_state} = $member->state; + # if they are Insteon_Device objects, then simply set_receive their state to + # the member on level + $member->set_receive($local_state,$self); + } + } + } + + +} + +sub set_with_timer { + my ($self, $state, $time, $return_state, $additional_return_states) = @_; + return if &main::check_for_tied_filters($self, $state); + + $self->set($state) unless $state eq ''; + + return unless $time; + + my $state_change = ($state eq 'off') ? 'on' : 'off'; + $state_change = $return_state if defined $return_state; + $state_change = $self->{state} if $return_state and lc $return_state eq 'previous'; + + $state_change .= ';' . $additional_return_states if $additional_return_states; + + $$self{set_timer} = &Timer::new() unless $$self{set_timer}; + my $object_name = $self->{object_name}; + my $action = "$object_name->set('$state_change')"; + $$self{set_timer}->set($time, $action); +} + + +sub update_members +{ + my ($self) = @_; + # iterate over the members + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my ($device); + my $member = $$self{members}{$member_ref}{object}; + my $on_state = $$self{members}{$member_ref}{on_level}; + $on_state = '100%' unless $on_state; + my $ramp_rate = $$self{members}{$member_ref}{ramp_rate}; + $ramp_rate = 0 unless defined $ramp_rate; + if ($member->isa('Light_Item')) { + # if they are Light_Items, then locate the Light_Item's Insteon_Device member + my @lights = $member->find_members('Insteon::BaseDevice'); + if (@lights) { + $device = @lights[0]; + } + } elsif ($member->isa('Insteon::BaseDevice')) { + $device = $member; + } + if ($device) { + my %current_record = $device->get_link_record($self->device_id . $self->group); + if (%current_record) { + &::print_log("[Insteon::BaseController] remote record: $current_record{data1}") + if $::Debug{insteon}; + } + } + } + } +} + + +sub initiate_linking_as_controller +{ + my ($self, $p_group) = @_; + # iterate over the members + if ($$self{members}) { + foreach my $member_ref (keys %{$$self{members}}) { + my $member = $$self{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) { + # if they are Light_Items, then set them to manual to avoid automation + # while manually setting light parameters + $member->manual(1,120,120); # 120 seconds should be enough + } + } + } + $self->interface()->initiate_linking_as_controller($p_group); +} + +sub derive_message +{ + my ($self, $p_state, $p_extra) = @_; + if ($self->is_root) { + return $self->Insteon::BaseObject::derive_message($p_state, $p_extra); + } else { + return $self->Insteon::BaseObject::derive_message($p_state, $p_extra); + } +} + +sub find_members +{ + my ($self,$p_type) = @_; + + my @l_found; + if ($$self{members}) + { + foreach my $member_ref (keys %{$$self{members}}) + { + my $member = $$self{members}{$member_ref}{object}; + if ($member->isa($p_type)) + { + push @l_found, $member; + } + } + } + return @l_found; + +} + +#################################### +### ##################### +### DeviceController ############### +### ############### +#################################### + + +package Insteon::DeviceController; + +use strict; +use Insteon; + +@Insteon::DeviceController::ISA = ('Insteon::BaseController'); + +sub new +{ + my ($class,$p_deviceid,$p_interface,$p_devcat) = @_; + + # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller + my $self = new Insteon::BaseController($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + $self->Insteon::BaseObject::set((($self->is_root) ? $p_state : $link_state), $p_setby, $p_respond); + + return 0; +} + + +sub request_status +{ + my ($self,$requestor) = @_; +# if ($self->group ne '01') { + if ($$self{members} and !($self->isa('Insteon::InterfaceController')) + and (!(ref $requestor) or ($requestor eq $self))) { + &::print_log("[Insteon::DeviceController] requesting status for members of " . $$self{object_name}); + foreach my $member (keys %{$$self{members}}) { + next unless $member->isa('Insteon::BaseObject'); + my $member_obj = $$self{members}{$member}{object}; + next if $requestor eq $member_obj; + if ($member_obj->isa('Insteon::BaseDevice')) { + &::print_log("[Insteon::DeviceController] checking status of " . $member_obj->get_object_name() + . " for requestor " . $requestor->get_object_name()); + $member_obj->request_status($self); + } + } + } + # the following has bad assumptions in that we don't always know if a device is a responder + # since it could be a slave + if ($self->is_root && $self->is_responder) { + $self->Insteon::BaseDevice::request_status($requestor); + } +} + +sub link_to_interface +{ + my ($self, $p_group, $p_data3) = @_; + my $group = $p_group; + $group = $self->group unless $group; + # get the surrogate device for this if group is not '01' + if ($self->group ne '01') { + my $surrogate_obj = &Insteon::get_object($self->device_id,'01'); + if ($p_data3) { + $surrogate_obj->link_to_interface($group,$p_data3); + } elsif ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { + $surrogate_obj->link_to_interface($group,$self->group); + } else { + $surrogate_obj->link_to_interface($group); + } + # next, if the link is a keypadlinc, then create the reverse link to permit + # control over the button's light + if ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { + + } + } else { + if ($p_data3) { + $self->SUPER::link_to_interface($group, $p_data3); + } else { + $self->SUPER::link_to_interface($group); + } + } +} + +sub unlink_to_interface +{ + my ($self,$p_group) = @_; + my $group = $p_group; + $group = $self->group unless $group; + # get the surrogate device for this if group is not '01' + if ($self->group ne '01') { + my $surrogate_obj = &Insteon::get_object($self->device_id,'01'); + $surrogate_obj->unlink_to_interface($group); + # next, if the link is a keypadlinc, then delete the reverse link to permit + # control over the button's light + if ($surrogate_obj->isa('Insteon::KeyPadLincRelay') or $surrogate_obj->isa('Insteon::KeyPadLinc')) { + + } + } else { + $self->SUPER::unlink_to_interface($group); + } +} + + + +#################################### +### ############ +### InterfaceController ############ +### ############ +#################################### + + +package Insteon::InterfaceController; + +use strict; +use Insteon; + +@Insteon::InterfaceController::ISA = ('Insteon::BaseController','Insteon::BaseObject'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + # note that $p_deviceid will be 00.00.00: if the link uses the interface as the controller + my $self = new Insteon::BaseObject($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + + return 0; +} + +sub is_root +{ + return 0; +} + +1; \ No newline at end of file diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 78ea08ff0..4122e7deb 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -1,339 +1,359 @@ - -package Insteon::BaseInterface; - -use strict; -use Insteon::Message; -@Insteon::BaseInterface::ISA = ('Class::Singleton'); - -sub check_for_data -{ - my $interface = &Insteon::active_interface(); - $interface->check_for_data(); -} - -sub poll_all { - my $scan_at_startup = $main::config_parms{Insteon_PLM_scan_at_startup}; - $scan_at_startup = 1 unless defined $scan_at_startup; - $scan_at_startup = 0 unless $main::Save{mh_exit} eq 'normal'; - my $plm = &Insteon::active_interface(); - if (defined $plm) { - if (!($plm->device_id) and !($$plm{_id_check})) { - $$plm{_id_check} = 1; - $plm->queue_message(new Insteon::InsteonMessage('plm_info', $plm)); - } - if ($scan_at_startup) { - - for my $insteon_device (&Insteon::find_members('Insteon::BaseDevice')) { - if ($insteon_device and $insteon_device->is_root and $insteon_device->is_responder) - { - # don't request status for objects associated w/ other than the primary group - # as they are psuedo links - $insteon_device->request_status(); - } - if ($insteon_device->devcat) { - # reset devcat so as to trigger any device specific properties - $insteon_device->devcat($insteon_device->devcat); - } - } - } - } -} - -sub new -{ - my ($class) = @_; - - my $self = {}; - @{$$self{command_stack2}} = (); - @{$$self{command_history}} = (); - bless $self, $class; -# &Insteon::add($self); - return $self; -} - -sub _is_duplicate -{ - my ($self, $cmd) = @_; - return 1 if ($self->active_message && $self->active_message->interface_data eq $cmd); - my $duplicate_detected = 0; - # check for duplicates of $cmd already in command_stack and ignore if they exist - foreach my $message (@{$$self{command_stack2}}) { - if ($message->interface_data eq $cmd) { - $duplicate_detected = 1; - last; - } - } - return $duplicate_detected; -} - -sub has_link -{ - my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = lc $insteon_object->device_id . $group . $is_controller; - return (defined $$self{links}{$key}) ? 1 : 0; -} - -sub active_message -{ - my ($self, $message) = @_; - if (defined $message) - { - $$self{active_message} = $message; - } - return $$self{active_message}; -} - -sub clear_active_message -{ - my ($self) = @_; - $$self{active_message} = undef; -# $self->_clear_timeout('command'); - $$self{xmit_in_progress} = 0; -} - -sub retry_active_message -{ - my ($self) = @_; -# $self->_clear_timeout('command'); - $$self{xmit_in_progress} = 0; -} - -sub queue_message -{ - my ($self, $message) = @_; - - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size unless $message; - - #queue any new command - if (defined $message) - { - my $setby = $message->setby; - if ($self->_is_duplicate($message->interface_data) && !($message->isa('Insteon::X10Message'))) { - &main::print_log("[Insteon_PLM] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; - } else { - my $queue_size = @{$$self{command_stack2}}; -# &main::print_log("[Insteon_PLM] Command stack size: $queue_size") if $queue_size > 0 and $main::Debug{insteon}; - $message->queue_time($::Time); - if ($setby and ref($setby) and $setby->can('set_retry_timeout') - and $setby->get_object_name) { - $message->callback($setby->get_object_name . "->set_retry_timeout()"); - } - unshift(@{$$self{command_stack2}}, $message); - } - } - # and, begin processing either this entry or the oldest one in the queue - $self->process_queue(); -} - -sub process_queue -{ - my ($self) = @_; - - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size unless !($$self{xmit_in_progress}); - - # get pending command record - my $pending_message = $self->active_message; - - if (!($pending_message)) { - $pending_message = pop(@{$$self{command_stack2}}); - $self->active_message($pending_message) if $pending_message; - #put the command back into the stack.. Its not our job to tamper with this array - # push(@{$$self{command_stack2}},$pending_message) if $pending_message; - } - - #we dont transmit on top of another xmit - if (!($$self{xmit_in_progress})) { # && ($self->_check_timeout('command')!=0)) { - #always send the oldest command first - if ($pending_message) - { - if (!($self->_check_timeout('xmit')==0)) { - - if ($self->active_message->send($self) == 0) - { - &::print_log("[Insteon_PLM] WARN: number of retries (" - . $self->active_message->send_attempts - . ") for " . $self->active_message->to_string() - . " exceeds limit. Now moving on...") if $main::Debug{insteon}; - # clear active message and try again - $self->clear_active_message(); - $self->process_queue(); - } - } - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; - } - else - { - # clear the timer - $self->_clear_timeout('command'); - return 0; - } - } else { -# &::print_log("[Insteon_PLM] active transmission; moving on...") if $main::Debug{insteon}; - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; - } - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; -} - -sub device_id { - my ($self, $p_deviceid) = @_; - $$self{deviceid} = $p_deviceid if defined $p_deviceid; - return $$self{deviceid}; -} - -sub get_device -{ - my ($self, $p_deviceid, $p_group) = @_; - foreach my $device (&Insteon::find_members('Insteon::BaseDevice')) { - if (lc $device->device_id eq lc $p_deviceid and lc $device->group eq lc $p_group) { - return $device; - } - } -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = $self->SUPER::restore_string(); - $restore_string .= $self->_adlb->restore_string(); - return $restore_string; -} - -sub restore_linktable -{ - my ($self,$aldb) = @_; - if ($self->_aldb and $aldb) { - $self->_aldb->restore_linktable($aldb); - } -} - - -sub log_alllink_table -{ - my ($self) = @_; - $self->_aldb->log_alllink_table if $self->_aldb; -} - -sub delete_orphan_links -{ - my ($self) = @_; - return $self->_aldb->delete_orphan_links if $self->_aldb; -} - - ###################### - ### EVENT HANDLERS ### -###################### - -sub on_interface_info_received -{ - my ($self) = @_; - &::print_log("[Insteon_PLM] PLM id: " . $self->device_id . - " firmware: " . $self->firmware) - if $main::Debug{insteon}; - $self->clear_active_message(); -} - - -sub on_standard_insteon_received -{ - my ($self, $message_data) = @_; - my %msg = &Insteon::InsteonMessage::command_to_hash($message_data); - if (%msg) - { - # get the matching object - my $object = &Insteon::get_object($msg{source}, $msg{group}); - if (defined $object) - { - if ($msg{type} ne 'broadcast') - { - $msg{command} = $object->message_type($msg{cmd_code}); - &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") - if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; - } -# &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; - $object->_process_message($self, %msg); - if ($msg{is_ack} or $msg{is_nack}) - { - $self->clear_active_message(); - } - } - else - { - &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); - } - # treat the message as legitimate even if an object match did not occur - } -} - -sub on_extended_insteon_received -{ - my ($self, $message_data) = @_; - my %msg = &Insteon::InsteonMessage::command_to_hash($message_data); - if (%msg) - { - # get the matching object - my $object = &Insteon::get_object($msg{source}, $msg{group}); - if (defined $object) - { - if ($msg{type} ne 'broadcast') - { - $msg{command} = $object->message_type($msg{cmd_code}); - &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") - if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; - } - &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; - $object->_process_message($self, %msg); - if ($msg{is_ack} or $msg{is_nack}) - { - $self->clear_active_message(); - } - } - else - { - &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); - } - # treat the message as legitimate even if an object match did not occur - } - -} - - ################################# - ### INTERNAL METHODS/FUNCTION ### -################################# - -sub _set_timeout -{ - my ($self, $timeout_name, $timeout_in_millis) = @_; - my $tickcount = &main::get_tickcount + $timeout_in_millis; - $tickcount += 2**32 if $tickcount < 0; # force a wrap; to be handleded by check timeout - $$self{"_timeout_$timeout_name"} = $tickcount; -} - -sub _check_timeout -{ - my ($self, $timeout_name) = @_; - return 0 unless $timeout_name; - return -1 unless defined $$self{"_timeout_$timeout_name"}; - my $current_tickcount = &main::get_tickcount; - return 0 if (($current_tickcount >= 2**16) and ($$self{"_timeout_$timeout_name"} < 2**16)); - return ($current_tickcount > $$self{"_timeout_$timeout_name"}) ? 1 : 0; -} - -sub _clear_timeout -{ - my ($self, $timeout_name) = @_; - $$self{"_timeout_$timeout_name"} = undef; -} - -sub _aldb -{ - my ($self) = @_; - return $$self{aldb}; -} - - -1 + +package Insteon::BaseInterface; + +use strict; +use Insteon::Message; +@Insteon::BaseInterface::ISA = ('Class::Singleton'); + +sub check_for_data +{ + my $interface = &Insteon::active_interface(); + $interface->check_for_data(); +} + +sub poll_all { + my $scan_at_startup = $main::config_parms{Insteon_PLM_scan_at_startup}; + $scan_at_startup = 1 unless defined $scan_at_startup; + $scan_at_startup = 0 unless $main::Save{mh_exit} eq 'normal'; + my $plm = &Insteon::active_interface(); + if (defined $plm) { + if (!($plm->device_id) and !($$plm{_id_check})) { + $$plm{_id_check} = 1; + $plm->queue_message(new Insteon::InsteonMessage('plm_info', $plm)); + } + if ($scan_at_startup) { + + for my $insteon_device (&Insteon::find_members('Insteon::BaseDevice')) { + if ($insteon_device and $insteon_device->is_root and $insteon_device->is_responder) + { + # don't request status for objects associated w/ other than the primary group + # as they are psuedo links + $insteon_device->request_status(); + } + if ($insteon_device->devcat) { + # reset devcat so as to trigger any device specific properties + $insteon_device->devcat($insteon_device->devcat); + } + } + } + } +} + +sub new +{ + my ($class) = @_; + + my $self = {}; + @{$$self{command_stack2}} = (); + @{$$self{command_history}} = (); + bless $self, $class; +# &Insteon::add($self); + return $self; +} + +sub equals +{ + my ($self, $compare_object) = @_; + # make sure that the compare_object is legitimate + return 0 unless $compare_object && ref $compare_object && $compare_object->isa('Insteon::BaseInterface'); + return 1 if $compare_object eq $self; + # if they don't both have device_ids then treat them as identical + return 1 unless $compare_object->device_id && $self->device_id; + if ($compare_object->device_id eq $self->device_id) + { + return 1; + } + else + { + return 0; + } +} + +sub _is_duplicate +{ + my ($self, $cmd) = @_; + return 1 if ($self->active_message && $self->active_message->interface_data eq $cmd); + my $duplicate_detected = 0; + # check for duplicates of $cmd already in command_stack and ignore if they exist + foreach my $message (@{$$self{command_stack2}}) { + if ($message->interface_data eq $cmd) { + $duplicate_detected = 1; + last; + } + } + return $duplicate_detected; +} + +sub has_link +{ + my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + my $key = lc $insteon_object->device_id . $group . $is_controller; + return (defined $$self{links}{$key}) ? 1 : 0; +} + +sub active_message +{ + my ($self, $message) = @_; + if (defined $message) + { + $$self{active_message} = $message; + } + return $$self{active_message}; +} + +sub clear_active_message +{ + my ($self) = @_; + $$self{active_message} = undef; +# $self->_clear_timeout('command'); + $$self{xmit_in_progress} = 0; +} + +sub retry_active_message +{ + my ($self) = @_; +# $self->_clear_timeout('command'); + $$self{xmit_in_progress} = 0; +} + +sub queue_message +{ + my ($self, $message) = @_; + + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size unless $message; + + #queue any new command + if (defined $message) + { + my $setby = $message->setby; + if ($self->_is_duplicate($message->interface_data) && !($message->isa('Insteon::X10Message'))) { + &main::print_log("[Insteon_PLM] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; + } else { + my $queue_size = @{$$self{command_stack2}}; +# &main::print_log("[Insteon_PLM] Command stack size: $queue_size") if $queue_size > 0 and $main::Debug{insteon}; + $message->queue_time($::Time); + if ($setby and ref($setby) and $setby->can('set_retry_timeout') + and $setby->get_object_name) { + $message->callback($setby->get_object_name . "->set_retry_timeout()"); + } + unshift(@{$$self{command_stack2}}, $message); + } + } + # and, begin processing either this entry or the oldest one in the queue + $self->process_queue(); +} + +sub process_queue +{ + my ($self) = @_; + + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size unless !($$self{xmit_in_progress}); + + # get pending command record + my $pending_message = $self->active_message; + + if (!($pending_message)) { + $pending_message = pop(@{$$self{command_stack2}}); + $self->active_message($pending_message) if $pending_message; + #put the command back into the stack.. Its not our job to tamper with this array + # push(@{$$self{command_stack2}},$pending_message) if $pending_message; + } + + #we dont transmit on top of another xmit + if (!($$self{xmit_in_progress})) { # && ($self->_check_timeout('command')!=0)) { + #always send the oldest command first + if ($pending_message) + { + if (!($self->_check_timeout('xmit')==0)) { + + if ($self->active_message->send($self) == 0) + { + &::print_log("[Insteon_PLM] WARN: number of retries (" + . $self->active_message->send_attempts + . ") for " . $self->active_message->to_string() + . " exceeds limit. Now moving on...") if $main::Debug{insteon}; + # !!!!!!!!! TO-DO - handle failure timeout ??? + + # clear active message and try again + $self->clear_active_message(); + $self->process_queue(); + } + } + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size; + } + else + { + # clear the timer + $self->_clear_timeout('command'); + return 0; + } + } else { +# &::print_log("[Insteon_PLM] active transmission; moving on...") if $main::Debug{insteon}; + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size; + } + my $command_queue_size = @{$$self{command_stack2}}; + return $command_queue_size; +} + +sub device_id { + my ($self, $p_deviceid) = @_; + $$self{deviceid} = $p_deviceid if defined $p_deviceid; + return $$self{deviceid}; +} + +sub get_device +{ + my ($self, $p_deviceid, $p_group) = @_; + foreach my $device (&Insteon::find_members('Insteon::BaseDevice')) { + if (lc $device->device_id eq lc $p_deviceid and lc $device->group eq lc $p_group) { + return $device; + } + } +} + +sub restore_string +{ + my ($self) = @_; + my $restore_string = $self->SUPER::restore_string(); + $restore_string .= $self->_adlb->restore_string(); + return $restore_string; +} + +sub restore_linktable +{ + my ($self,$aldb) = @_; + if ($self->_aldb and $aldb) { + $self->_aldb->restore_linktable($aldb); + } +} + + +sub log_alllink_table +{ + my ($self) = @_; + $self->_aldb->log_alllink_table if $self->_aldb; +} + +sub delete_orphan_links +{ + my ($self) = @_; + return $self->_aldb->delete_orphan_links if $self->_aldb; +} + + ###################### + ### EVENT HANDLERS ### +###################### + +sub on_interface_info_received +{ + my ($self) = @_; + &::print_log("[Insteon_PLM] PLM id: " . $self->device_id . + " firmware: " . $self->firmware) + if $main::Debug{insteon}; + $self->clear_active_message(); +} + + +sub on_standard_insteon_received +{ + my ($self, $message_data) = @_; + my %msg = &Insteon::InsteonMessage::command_to_hash($message_data); + if (%msg) + { + # get the matching object + my $object = &Insteon::get_object($msg{source}, $msg{group}); + if (defined $object) + { + if ($msg{type} ne 'broadcast') + { + $msg{command} = $object->message_type($msg{cmd_code}); + &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") + if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; + } +# &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; + $object->_process_message($self, %msg); + if ($msg{is_ack} or $msg{is_nack}) + { + $self->clear_active_message(); + } + } + else + { + &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); + } + # treat the message as legitimate even if an object match did not occur + } +} + +sub on_extended_insteon_received +{ + my ($self, $message_data) = @_; + my %msg = &Insteon::InsteonMessage::command_to_hash($message_data); + if (%msg) + { + # get the matching object + my $object = &Insteon::get_object($msg{source}, $msg{group}); + if (defined $object) + { + if ($msg{type} ne 'broadcast') + { + $msg{command} = $object->message_type($msg{cmd_code}); + &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") + if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; + } + &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; + $object->_process_message($self, %msg); + if ($msg{is_ack} or $msg{is_nack}) + { + $self->clear_active_message(); + } + } + else + { + &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); + } + # treat the message as legitimate even if an object match did not occur + } + +} + + ################################# + ### INTERNAL METHODS/FUNCTION ### +################################# + +sub _set_timeout +{ + my ($self, $timeout_name, $timeout_in_millis) = @_; + my $tickcount = &main::get_tickcount + $timeout_in_millis; + $tickcount += 2**32 if $tickcount < 0; # force a wrap; to be handleded by check timeout + $$self{"_timeout_$timeout_name"} = $tickcount; +} + +sub _check_timeout +{ + my ($self, $timeout_name) = @_; + return 0 unless $timeout_name; + return -1 unless defined $$self{"_timeout_$timeout_name"}; + my $current_tickcount = &main::get_tickcount; + return 0 if (($current_tickcount >= 2**16) and ($$self{"_timeout_$timeout_name"} < 2**16)); + return ($current_tickcount > $$self{"_timeout_$timeout_name"}) ? 1 : 0; +} + +sub _clear_timeout +{ + my ($self, $timeout_name) = @_; + $$self{"_timeout_$timeout_name"} = undef; +} + +sub _aldb +{ + my ($self) = @_; + return $$self{aldb}; +} + + +1 \ No newline at end of file From bfe802639cc60099d666c261e8b9e7a75765301b Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 21 Jan 2011 21:49:30 +0000 Subject: [PATCH 027/150] Revise object comparison to use new "equals" method when determining if a cached object already exists. Necessary when mh reloads. --- lib/Insteon.pm | 965 +++++++++++++++++++++++++------------------------ 1 file changed, 489 insertions(+), 476 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index d6bdc8bac..5396f74ac 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -1,476 +1,489 @@ -package Insteon; - -use strict; - -# Category=Insteon - -#@ This module creates voice commands for all insteon related items. - -my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_scan_failure_cnt,$_sync_cnt,$_sync_failure_cnt); -my $init_complete; -my (@_scan_devices); - -#my $_scan_link_tables_v = new Voice_Cmd 'Scan all link tables'; - -#if ($_scan_link_tables_v->state_now()) { -# &_get_next_linkscan(); # unless $_scan_cnt; # prevent multiple concurrent scans -#} - -sub _get_next_linkscan -{ - my ($current_name, $prior_failure) = @_; - if ($prior_failure) { - $_scan_failure_cnt++; - } else { - $_scan_failure_cnt = 0; - } - if (!(scalar(@_scan_devices))) { - push @_scan_devices, &Insteon::active_interface; - push @_scan_devices, &Insteon::find_members("Insteon::BaseDevice"); - $_scan_cnt = 0; - } - - return unless scalar(@_scan_devices); - - my $current_obj = $_scan_devices[0]; - my $next_obj = $current_obj; - if ($_scan_failure_cnt == 0) { - # get the next - $next_obj = shift @_scan_devices; - $_scan_cnt += 1; - # remove the queue_timer_callback -# my $current_obj = &main::get_object_by_name($current_name); - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); - } - # don't try to scan devices that are not responders - while (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') - and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { - &main::print_log("[Scan all link tables] " . $next_obj->get_object_name . " is not a candidate for scanning. Moving to next"); - $next_obj = shift @_scan_devices; - } - } elsif ($_scan_failure_cnt == 1) { - # try again -# $next_name = $current_name; - $next_obj = $current_obj; - &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " . $current_obj->get_object_name . ". Trying again..."); -# $_scan_cnt = $i + 1; - } else { - # skip because this is a repeat failure -# $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - $next_obj = shift @_scan_devices; - &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " . $current_obj->get_object_name . ". Moving on..."); - $_scan_failure_cnt = 0; # reset failure counter -# $_scan_cnt += $i + 2; - # remove the queue_timer_callback -# my $current_obj = &main::get_object_by_name($current_name); - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); - } - } -# last; -# } -# } -# } else { -# if ($dev_cnt) { -# $next_name = $devices[0]; -# $_scan_cnt = 1; -# } -# } - - if ($next_obj) { -# my $obj = &main::get_object_by_name($next_name); - if ($next_obj) { - &main::print_log("[Scan all link tables] Now scanning: " . $next_obj->get_object_name . " ($_scan_cnt of ?)"); -# $next_obj->queue_timer_callback('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\',1)') unless $next_obj->isa('Insteon_PLM'); - $next_obj->scan_link_table('&Insteon::_get_next_linkscan(\'' . $next_obj->get_object_name . '\')'); - } - } else { - $_scan_cnt = 0; - return undef; - } -} - -#my $_sync_links_v = new Voice_Cmd 'Sync all links'; - -#if ($_sync_links_v->state_now()) { -# &_process_sync_links(); # unless $_sync_cnt; -#} - -sub _process_sync_links -{ - my ($current_name, $prior_failure) = @_; - if ($prior_failure) { - $_sync_failure_cnt++; - } else { - $_sync_failure_cnt = 0; - } - my @devices = (); - push @devices,@_insteon_link; - my $dev_cnt = @devices; - my $return_next = ($current_name) ? 0 : 1; - my $next_name = undef; - - if ($current_name) { - for (my $i=0; $i<$dev_cnt; $i++) { - if ($devices[$i] eq $current_name) { - if ($_sync_failure_cnt ==0) { - # get the next - $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - $_sync_cnt = $i + 2; - # remove the queue_timer_callback - my $current_obj = &main::get_object_by_name($current_name); - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); - } - # don't try to scan devices that are not responders - my $next_obj = &main::get_object_by_name($next_name); - if (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') - and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { - &main::print_log("[Sync all links] $next_name is not a candidate for syncing. Moving to next"); - $current_name = $next_name; - # move on - next; - } - } elsif ($_sync_cnt == 1) { - #try again - $next_name = $current_name; - &main::print_log("[Sync all links] WARN: failure occurred when syncing $current_name. Trying again..."); - $_sync_cnt = $i + 1; - } else { - # skip because this is a repeat failure - $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - &main::print_log("[Sync all links] WARN: failure occurred when syncing $current_name. Moving on..."); - $_sync_failure_cnt = 0; # reset failure counter - $_sync_cnt = $i + 2; - # remove the queue_timer_callback - my $current_obj = &main::get_object_by_name($current_name); - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); - } - } - } - } - } elsif ($dev_cnt) { - $next_name = $devices[0]; - $_sync_cnt = 1; - } - - if ($next_name) { - my $obj = &main::get_object_by_name($next_name); - if ($obj) { - &main::print_log("[Sync all links] Now syncing links: " . $obj->get_object_name . " ($_sync_cnt of $dev_cnt)"); -# $obj->queue_timer_callback('&main::_process_sync_links(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); - $obj->sync_links('&Insteon::_process_sync_links(\'' . $next_name . '\')'); - } - } else { - $_sync_cnt = 0; - return undef; - } -} - - -sub uninstall_insteon_item_commands { - &main::trigger_delete('scan insteon link tables'); -} - -sub init { - - # only run once - return if $init_complete; - $init_complete = 1; - - # initialize scan and sync counters - $_scan_cnt = 0; - $_sync_cnt = 0; - @_scan_devices = (); - - # create trigger - my $trig_cmd = "time_cron '00 02 * * *'"; - &main::trigger_set($trig_cmd,'&_get_next_linkscan()','NoExpire','scan insteon link tables') - unless &main::trigger_get('scan insteon link tables'); - - @_insteon_plm = (); - @_insteon_device = (); - @_insteon_link = (); - -} - -sub generate_voice_commands -{ - - my $insteon_menu_states = $main::config_parms{insteon_menu_states} if $main::config_parms{insteon_menu_states}; - &main::print_log("Generating Voice commands for all Insteon objects"); - my $object_string; - for my $object (&main::list_all_objects) { - next unless ref $object; - next unless $object->isa('Insteon::BaseInterface') or $object->isa('Insteon::BaseObject'); - my $object_name = $object->get_object_name; - # ignore the thermostat - next if $object->isa('Insteon_Thermostat'); - my $command = $object_name; - $command =~ s/^\$//; - $command =~ tr/_/ /; - my $object_name_v = $object_name . '_v'; - $object_string .= "use vars '${object_name}_v';\n"; - my $states = 'on,off'; - my $group = ($object->isa('Insteon_PLM')) ? '' : $object->group; - if ($object->isa('Insteon::BaseController')) { - $states = 'on,off,sync links'; #,resume,enroll,unenroll,manual'; - my $cmd_states = $states; - if ($object->isa('Insteon::InterfaceController')) { - $cmd_states .= ',initiate linking as controller,cancel linking'; - } else { - $cmd_states .= ",link to interface,unlink with interface"; - } - if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { - $cmd_states .= ",status,scan link table,log links"; - push @_scannable_link, $object_name; - } - $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->initiate_linking_as_controller(\"$group\")', 'initiate linking as controller');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->interface()->cancel_linking','cancel linking');\n\n"; - if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { - $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; - } - $object_string .= "$object_name_v -> tie_event('$object_name->sync_links()','sync links');\n\n"; - $object_string .= "$object_name_v -> tie_items($object_name, 'on');\n\n"; - $object_string .= "$object_name_v -> tie_items($object_name, 'off');\n\n"; - $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_link_commands'); - push @_insteon_link, $object_name; - } elsif ($object->isa('Insteon::BaseDevice')) { - $states = $insteon_menu_states if $insteon_menu_states - && ($object->can('is_dimmable') && $object->is_dimmable); - my $cmd_states = "$states,status,scan link table,log links,update onlevel/ramprate"; #,on level,ramp rate"; - $cmd_states .= ",link to interface,unlink with interface" if $object->isa("Insteon::BaseController") || $object->is_controller; - $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - foreach my $state (split(/,/,$states)) { - $object_string .= "$object_name_v -> tie_items($object_name, '$state');\n\n"; - } - $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->update_local_properties','update onlevel/ramprate');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; - if ($object->isa("Insteon::BaseController") || $object->is_controller) { - $object_string .= "$object_name_v -> tie_event('$object_name->link_to_interface','link to interface');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->unlink_to_interface','unlink with interface');\n\n"; - } -# the remote_set_button_taps provide incorrect/inconsistent results -# $object_string .= "$object_name_v -> tie_event('$object_name->remote_set_button_tap(1)','on level');\n\n"; -# $object_string .= "$object_name_v -> tie_event('$object_name->remote_set_button_tap(2)','ramp rate');\n\n"; - $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); - push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate - } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,log links,delete orphan links,scan all link tables,debug on, debug off"; - $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->cancel_linking','cancel linking');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','log links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','debug on');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','debug off');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::_get_next_linkscan','scan all link tables');\n\n"; - $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); - push @_insteon_plm, $object_name; - } - } - - package main; - eval $object_string; - print "Error in insteon_item_commands: $@\n" if $@; - package Insteon; -} - -sub add -{ - my ($object) = @_; - - my $insteon_manager = InsteonManager->instance(); - if ($insteon_manager->remove_item($object)) { - # print out debug info - } - $insteon_manager->add_item($object); -} - -sub find_members -{ - my ($name) = @_; - - my $insteon_manager = InsteonManager->instance(); - return $insteon_manager->find_members($name); -} - - -sub get_object -{ - my ($p_deviceid, $p_group) = @_; - - my $retObj = undef; - - my $insteon_manager = InsteonManager->instance(); - my @search_objects = (); - push @search_objects, $insteon_manager->find_members('Insteon::BaseObject'); - for my $obj (@search_objects) - { - #Match on Insteon objects only - # if ($obj->isa("Insteon::Insteon_Device")) - # { - if (lc $obj->device_id() eq lc $p_deviceid) - { - if ($p_group) - { - if (lc $p_group eq lc $obj->group) - { - $retObj = $obj; - last; - } - } else { - $retObj = $obj; - last; - } - } - # } - } - - return $retObj; -} - -sub active_interface -{ - my ($interface) = @_; - my $insteon_manager = InsteonManager->instance(); - - $insteon_manager->_active_interface($interface) if $interface; -#print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; - return $insteon_manager->_active_interface; - -} - -package InsteonManager; - -use strict; -use base 'Class::Singleton'; - -sub _new_instance -{ - my $class = shift; - my $self = bless {}, $class; - - return $self; -} - -sub _active_interface -{ - my ($self, $interface) = @_; - # setup hooks the first time that an interface is made active - if (!($$self{active_interface}) and $interface) { - &main::print_log("[Insteon] Setting up initialization hooks") if $main::Debug{insteon}; - &main::MainLoop_pre_add_hook(\&Insteon::BaseInterface::check_for_data, 1); - &main::Reload_post_add_hook(\&Insteon::BaseInterface::poll_all, 1); - $Insteon::init_complete = 0; - &main::MainLoop_pre_add_hook(\&Insteon::init, 1); - &main::Reload_post_add_hook(\&Insteon::generate_voice_commands, 1); - } - $$self{active_interface} = $interface if $interface; - return $$self{active_interface}; -} - -sub add -{ - my ($self,@p_objects) = @_; - - my @l_objects; - - for my $l_object (@p_objects) { - if ($l_object->isa('Group_Item') ) { - @l_objects = $$l_object{members}; - for my $obj (@l_objects) { - $self->add($obj); - } - } else { - $self->add_item($l_object); - } - } -} - -sub add_item -{ - my ($self,$p_object) = @_; - - push @{$$self{objects}}, $p_object; - if ($p_object->isa('Insteon::BaseInterface') and !($self->_active_interface)) { - $self->_active_interface($p_object); - } - return $p_object; -} - -sub remove_all_items { - my ($self) = @_; - - if (ref $$self{objects}) { - foreach (@{$$self{objects}}) { - # $_->untie_items($self); - } - } - delete $self->{objects}; -} - -sub add_item_if_not_present { - my ($self, $p_object) = @_; - - if (ref $$self{objects}) { - foreach (@{$$self{objects}}) { - if ($_ eq $p_object) { - return 0; - } - } - } - $self->add_item($p_object); - return 1; -} - -sub remove_item { - my ($self, $p_object) = @_; - - if (ref $$self{objects}) { - for (my $i = 0; $i < scalar(@{$$self{objects}}); $i++) { - if ($$self{objects}->[$i] eq $p_object) { - splice @{$$self{objects}}, $i, 1; - return 1; - } - } - } - return 0; -} - - -sub is_member { - my ($self, $p_object) = @_; - - my @l_objects = @{$$self{objects}}; - for my $l_object (@l_objects) { - if ($l_object eq $p_object) { - return 1; - } - } - return 0; -} - -sub find_members { - my ($self,$p_type) = @_; - - my @l_found; - my @l_objects = @{$$self{objects}}; - for my $l_object (@l_objects) { - if ($l_object->isa($p_type)) { - push @l_found, $l_object; - } - } - return @l_found; -} - -1 +package Insteon; + +use strict; + +# Category=Insteon + +#@ This module creates voice commands for all insteon related items. + +my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_scan_failure_cnt,$_sync_cnt,$_sync_failure_cnt); +my $init_complete; +my (@_scan_devices); + +sub scan_all_linktables +{ + my @candidate_devices = (); + # clear @_scan_devices + @_scan_devices = (); + # alwayws include the active interface (e.g., plm) + push @_scan_devices, &Insteon::active_interface; + + push @candidate_devices, &Insteon::find_members("Insteon::BaseDevice"); + + # don't try to scan devices that are not responders + foreach (@candidate_devices) + { + my $candidate_object = $_; + if (!($candidate_object->isa('Insteon::RemoteLinc') + or $candidate_object->isa('Insteon::InterfaceController') + or $candidate_object->isa('Insteon::MotionSensor'))) + { + push @_scan_devices, $candidate_object; + } + else + { + &main::print_log("[Scan all linktables] Note: " + . $candidate_object->get_object_name + . " is not a candidate for scanning."); + } + } + $_scan_cnt = scalar @_scan_devices; + + $_scan_failure_cnt = 0; + &_get_next_linkscan(); + +} + +sub _get_next_linkscan +{ + my ($prior_failure) = @_; + if ($prior_failure) + { + $_scan_failure_cnt++; + } + else + { + $_scan_failure_cnt = 0; + } + + + my $current_obj = $_scan_devices[0]; + my $next_obj = $current_obj; + if ($_scan_failure_cnt == 0) + { + # get the next + $next_obj = shift @_scan_devices; + # remove the queue_timer_callback + if (!($current_obj->isa('Insteon_PLM'))) + { +# $current_obj->queue_timer_callback(''); + } + } + elsif ($_scan_failure_cnt == 1) + { + # try again +# $next_name = $current_name; + $next_obj = $current_obj; + &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " + . $current_obj->get_object_name . ". Trying again..."); +# $_scan_cnt = $i + 1; + } + else + { + # skip because this is a repeat failure + $next_obj = shift @_scan_devices; + &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " + . $current_obj->get_object_name . ". Moving on..."); + $_scan_failure_cnt = 0; # reset failure counter + # remove the queue_timer_callback + if (!($current_obj->isa('Insteon_PLM'))) { +# $current_obj->queue_timer_callback(''); + } + } + + if ($next_obj) + { + &main::print_log("[Scan all link tables] Now scanning: " + . $next_obj->get_object_name . " (" + . ($_scan_cnt - scalar @_scan_devices) + . " of $_scan_cnt)"); + $next_obj->scan_link_table('&Insteon::_get_next_linkscan()'); + } else { + return undef; + } +} + +#my $_sync_links_v = new Voice_Cmd 'Sync all links'; + +#if ($_sync_links_v->state_now()) { +# &_process_sync_links(); # unless $_sync_cnt; +#} + +sub _process_sync_links +{ + my ($current_name, $prior_failure) = @_; + if ($prior_failure) { + $_sync_failure_cnt++; + } else { + $_sync_failure_cnt = 0; + } + my @devices = (); + push @devices,@_insteon_link; + my $dev_cnt = @devices; + my $return_next = ($current_name) ? 0 : 1; + my $next_name = undef; + + if ($current_name) { + for (my $i=0; $i<$dev_cnt; $i++) { + if ($devices[$i] eq $current_name) { + if ($_sync_failure_cnt ==0) { + # get the next + $next_name = $devices[$i+1] if $i+1 < $dev_cnt; + $_sync_cnt = $i + 2; + # remove the queue_timer_callback + my $current_obj = &main::get_object_by_name($current_name); + if (!($current_obj->isa('Insteon_PLM'))) { +# $current_obj->queue_timer_callback(''); + } + # don't try to scan devices that are not responders + my $next_obj = &main::get_object_by_name($next_name); + if (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') + and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { + &main::print_log("[Sync all links] $next_name is not a candidate for syncing. Moving to next"); + $current_name = $next_name; + # move on + next; + } + } elsif ($_sync_cnt == 1) { + #try again + $next_name = $current_name; + &main::print_log("[Sync all links] WARN: failure occurred when syncing $current_name. Trying again..."); + $_sync_cnt = $i + 1; + } else { + # skip because this is a repeat failure + $next_name = $devices[$i+1] if $i+1 < $dev_cnt; + &main::print_log("[Sync all links] WARN: failure occurred when syncing $current_name. Moving on..."); + $_sync_failure_cnt = 0; # reset failure counter + $_sync_cnt = $i + 2; + # remove the queue_timer_callback + my $current_obj = &main::get_object_by_name($current_name); + if (!($current_obj->isa('Insteon_PLM'))) { +# $current_obj->queue_timer_callback(''); + } + } + } + } + } elsif ($dev_cnt) { + $next_name = $devices[0]; + $_sync_cnt = 1; + } + + if ($next_name) { + my $obj = &main::get_object_by_name($next_name); + if ($obj) { + &main::print_log("[Sync all links] Now syncing links: " . $obj->get_object_name . " ($_sync_cnt of $dev_cnt)"); +# $obj->queue_timer_callback('&main::_process_sync_links(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); + $obj->sync_links('&Insteon::_process_sync_links(\'' . $next_name . '\')'); + } + } else { + $_sync_cnt = 0; + return undef; + } +} + + +sub uninstall_insteon_item_commands { + &main::trigger_delete('scan insteon link tables'); +} + +sub init { + + # only run once + return if $init_complete; + $init_complete = 1; + + # initialize scan and sync counters + $_scan_cnt = 0; + $_sync_cnt = 0; + @_scan_devices = (); + + # create trigger + my $trig_cmd = "time_cron '00 02 * * *'"; + &main::trigger_set($trig_cmd,'&Insteon::scan_all_linktables()','NoExpire','scan insteon link tables') + unless &main::trigger_get('scan insteon link tables'); + + @_insteon_plm = (); + @_insteon_device = (); + @_insteon_link = (); + +} + +sub generate_voice_commands +{ + + my $insteon_menu_states = $main::config_parms{insteon_menu_states} if $main::config_parms{insteon_menu_states}; + &main::print_log("Generating Voice commands for all Insteon objects"); + my $object_string; + for my $object (&main::list_all_objects) { + next unless ref $object; + next unless $object->isa('Insteon::BaseInterface') or $object->isa('Insteon::BaseObject'); + my $object_name = $object->get_object_name; + # ignore the thermostat + next if $object->isa('Insteon_Thermostat'); + my $command = $object_name; + $command =~ s/^\$//; + $command =~ tr/_/ /; + my $object_name_v = $object_name . '_v'; + $object_string .= "use vars '${object_name}_v';\n"; + my $states = 'on,off'; + my $group = ($object->isa('Insteon_PLM')) ? '' : $object->group; + if ($object->isa('Insteon::BaseController')) { + $states = 'on,off,sync links'; #,resume,enroll,unenroll,manual'; + my $cmd_states = $states; + if ($object->isa('Insteon::InterfaceController')) { + $cmd_states .= ',initiate linking as controller,cancel linking'; + } else { + $cmd_states .= ",link to interface,unlink with interface"; + } + if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { + $cmd_states .= ",status,scan link table,log links"; + push @_scannable_link, $object_name; + } + $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->initiate_linking_as_controller(\"$group\")', 'initiate linking as controller');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->interface()->cancel_linking','cancel linking');\n\n"; + if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { + $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; + } + $object_string .= "$object_name_v -> tie_event('$object_name->sync_links()','sync links');\n\n"; + $object_string .= "$object_name_v -> tie_items($object_name, 'on');\n\n"; + $object_string .= "$object_name_v -> tie_items($object_name, 'off');\n\n"; + $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_link_commands'); + push @_insteon_link, $object_name; + } elsif ($object->isa('Insteon::BaseDevice')) { + $states = $insteon_menu_states if $insteon_menu_states + && ($object->can('is_dimmable') && $object->is_dimmable); + my $cmd_states = "$states,status,scan link table,log links,update onlevel/ramprate"; #,on level,ramp rate"; + $cmd_states .= ",link to interface,unlink with interface" if $object->isa("Insteon::BaseController") || $object->is_controller; + $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; + foreach my $state (split(/,/,$states)) { + $object_string .= "$object_name_v -> tie_items($object_name, '$state');\n\n"; + } + $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->update_local_properties','update onlevel/ramprate');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; + if ($object->isa("Insteon::BaseController") || $object->is_controller) { + $object_string .= "$object_name_v -> tie_event('$object_name->link_to_interface','link to interface');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->unlink_to_interface','unlink with interface');\n\n"; + } +# the remote_set_button_taps provide incorrect/inconsistent results +# $object_string .= "$object_name_v -> tie_event('$object_name->remote_set_button_tap(1)','on level');\n\n"; +# $object_string .= "$object_name_v -> tie_event('$object_name->remote_set_button_tap(2)','ramp rate');\n\n"; + $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); + push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate + } elsif ($object->isa('Insteon_PLM')) { + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,log links,delete orphan links,scan all link tables,debug on, debug off"; + $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->cancel_linking','cancel linking');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','log links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','debug on');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','debug off');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all link tables');\n\n"; + $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); + push @_insteon_plm, $object_name; + } + } + + package main; + eval $object_string; + print "Error in insteon_item_commands: $@\n" if $@; + package Insteon; +} + +sub add +{ + my ($object) = @_; + + my $insteon_manager = InsteonManager->instance(); + if ($insteon_manager->remove_item($object)) { + # print out debug info + } + $insteon_manager->add_item($object); +} + +sub find_members +{ + my ($name) = @_; + + my $insteon_manager = InsteonManager->instance(); + return $insteon_manager->find_members($name); +} + + +sub get_object +{ + my ($p_deviceid, $p_group) = @_; + + my $retObj = undef; + + my $insteon_manager = InsteonManager->instance(); + my @search_objects = (); + push @search_objects, $insteon_manager->find_members('Insteon::BaseObject'); + for my $obj (@search_objects) + { + #Match on Insteon objects only + # if ($obj->isa("Insteon::Insteon_Device")) + # { + if (lc $obj->device_id() eq lc $p_deviceid) + { + if ($p_group) + { + if (lc $p_group eq lc $obj->group) + { + $retObj = $obj; + last; + } + } else { + $retObj = $obj; + last; + } + } + # } + } + + return $retObj; +} + +sub active_interface +{ + my ($interface) = @_; + my $insteon_manager = InsteonManager->instance(); + + $insteon_manager->_active_interface($interface) + if $interface && ref $interface && $interface->isa('Insteon::BaseInterface'); +#print "############### active interface is: " . $insteon_manager->_active_interface->get_object_name . "\n"; + return $insteon_manager->_active_interface; + +} + +package InsteonManager; + +use strict; +use base 'Class::Singleton'; + +sub _new_instance +{ + my $class = shift; + my $self = bless {}, $class; + + return $self; +} + +sub _active_interface +{ + my ($self, $interface) = @_; + # setup hooks the first time that an interface is made active + if (!($$self{active_interface}) and $interface) { + &main::print_log("[Insteon] Setting up initialization hooks") if $main::Debug{insteon}; + &main::MainLoop_pre_add_hook(\&Insteon::BaseInterface::check_for_data, 1); + &main::Reload_post_add_hook(\&Insteon::BaseInterface::poll_all, 1); + $Insteon::init_complete = 0; + &main::MainLoop_pre_add_hook(\&Insteon::init, 1); + &main::Reload_post_add_hook(\&Insteon::generate_voice_commands, 1); + } + $$self{active_interface} = $interface if $interface; + return $$self{active_interface}; +} + +sub add +{ + my ($self,@p_objects) = @_; + + my @l_objects; + + for my $l_object (@p_objects) { + if ($l_object->isa('Group_Item') ) { + @l_objects = $$l_object{members}; + for my $obj (@l_objects) { + $self->add($obj); + } + } else { + $self->add_item($l_object); + } + } +} + +sub add_item +{ + my ($self,$p_object) = @_; + + push @{$$self{objects}}, $p_object; + if ($p_object->isa('Insteon::BaseInterface') and !($self->_active_interface)) { + $self->_active_interface($p_object); + } + return $p_object; +} + +sub remove_all_items { + my ($self) = @_; + + if (ref $$self{objects}) { + foreach (@{$$self{objects}}) { + # $_->untie_items($self); + } + } + delete $self->{objects}; +} + +sub add_item_if_not_present { + my ($self, $p_object) = @_; + + if (ref $$self{objects}) { + foreach (@{$$self{objects}}) { + if ($_ eq $p_object) { + return 0; + } + } + } + $self->add_item($p_object); + return 1; +} + +sub remove_item { + my ($self, $p_object) = @_; + return 0 unless $p_object and ref $p_object; + if (ref $$self{objects}) { + for (my $i = 0; $i < scalar(@{$$self{objects}}); $i++) { + if ($p_object->equals($$self{objects}->[$i])) { + splice @{$$self{objects}}, $i, 1; + return 1; + } + } + } + return 0; +} + + +sub is_member { + my ($self, $p_object) = @_; + + my @l_objects = @{$$self{objects}}; + for my $l_object (@l_objects) { + if ($l_object eq $p_object) { + return 1; + } + } + return 0; +} + +sub find_members { + my ($self,$p_type) = @_; + + my @l_found; + my @l_objects = @{$$self{objects}}; + for my $l_object (@l_objects) { + if ($l_object->isa($p_type)) { + push @l_found, $l_object; + } + } + return @l_found; +} + +1 \ No newline at end of file From a3341ad11d516ba918d138de270ea4d65f9a4bd9 Mon Sep 17 00:00:00 2001 From: peloy Date: Mon, 24 Jan 2011 04:35:07 +0000 Subject: [PATCH 028/150] Merge r1818 (EIO board voice commands) from trunk --- code/public/eio1.pl | 185 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 185 insertions(+) create mode 100644 code/public/eio1.pl diff --git a/code/public/eio1.pl b/code/public/eio1.pl new file mode 100644 index 000000000..7391ee9d7 --- /dev/null +++ b/code/public/eio1.pl @@ -0,0 +1,185 @@ +# Category=Other +# $Author$ +# $Id$ +# $Date$ +# Revision$ +# +# This routine interfaces the EIO board manufactured by Hugh Duff, VA3TO +# Paul Caccamo, VA3PC - 2010-Jan-12 +# Comments to: paul at ciinet dot org +# This routine assumes that you have initialized the board +# with an IP address and it works with the windows EIO software +# to do - modify the code with placeholders in case of more than one board +# this was working on a LAMP ClearOS server. ymmv if you use windows + +# initialize poll rate , looptimeout and hex byte relay control commands +# logfile required if you want the board relays to reload after a power bump. +my $eio1PollRate = 1; # the poll rate (in seconds) that you want updates +my $loop1timeout = 150; # the number of unresponsive code loops +# where you consider the board not responding +# on my P3-933 this is about 6 seconds +my @R1on = (0x0001, 0x0000 ); # this turns the relays on or off +my @R2on = (0x0002, 0x0000 ); # in vax style hex bytes +my @R3on = (0x0003, 0x0000 ); +my @R4on = (0x0004, 0x0000 ); +my @R1of = (0x00a1, 0x0000 ); +my @R2of = (0x00a2, 0x0000 ); +my @R3of = (0x00a3, 0x0000 ); +my @R4of = (0x00a4, 0x0000 ); + +# modify the following items and code for more than one board in the system +# misterhouse is installed in /opt/misterhouse as suggested in faq's +my $eio1DataLog = '/opt/misterhouse/data/logs/eio1data'; +my $client1_address = '192.168.36.61:5000'; # my EIO board address and port + +# set up the output states for the socket port +$eio1 = new Socket_Item ("SEND INFORMATION NOW\n", "status", $client1_address, "EIO-1", 'udp', 'rawout'); +$eio1 -> add (pack('v*',@R1on), "E1R1 on"); # relay control commands +$eio1 -> add (pack('v*',@R2on), "E1R2 on"); +$eio1 -> add (pack('v*',@R3on), "E1R3 on"); +$eio1 -> add (pack('v*',@R4on), "E1R4 on"); +$eio1 -> add (pack('v*',@R1of), "E1R1 off"); +$eio1 -> add (pack('v*',@R2of), "E1R2 off"); +$eio1 -> add (pack('v*',@R3of), "E1R3 off"); +$eio1 -> add (pack('v*',@R4of), "E1R4 off"); + +# set up generic items for the inputs / outputs web page display +$eio1I1 = new Generic_Item; +$eio1I2 = new Generic_Item; +$eio1I3 = new Generic_Item; +$eio1I4 = new Generic_Item; +$eio1R1 = new Generic_Item; +$eio1R2 = new Generic_Item; +$eio1R3 = new Generic_Item; +$eio1R4 = new Generic_Item; + +# set up control items for the voice commands +$v_eio1R1 = new Voice_Cmd("EIO1 Relay 1 [on,off]"); +$v_eio1R2 = new Voice_Cmd("EIO1 Relay 2 [on,off]"); +$v_eio1R3 = new Voice_Cmd("EIO1 Relay 3 [on,off]"); +$v_eio1R4 = new Voice_Cmd("EIO1 Relay 4 [on,off]"); + +# initialize temp variables. +use vars '$eio1last','$loop1count'; + +# if the EIO board commus are not active, start the port +if ($Startup || $Reload){ + start $eio1; + print_log "Comms with EIO1 established"; + &reload_board1; +} + +# poll the board for the current status at eioPollRate (secs) +if ( new_second $eio1PollRate ){ + set $eio1 "status"; +} +# increment the loop counter +$loop1count++; + +# determine the current point status when the board replies +# compare it to the last known status and note any differences in the log file +# re-evaluate the data on each reply in order to set the flags on the web page. +# do this if the board hasn't timed out, if it has, reset the relays to last state +if (my $eio1data = said $eio1){ # first check to see if the board responds + if ($loop1count > $loop1timeout){ # the board previously timed out - its back + &reload_board1; # reload the last known state + } + elsif ($eio1data ne $eio1last){ # (no timeout) new data since last response + $eio1last = $eio1data; # save the new data for next pass thru + my $eio1out = substr( $eio1data, 0, -10);# parse the reply of extra characters + logit( $eio1DataLog , $eio1out, 12); # append change to the logfile + # update the changed status icons on the web page + if ((state $eio1I4 == OFF) && (substr($eio1data, 1, 1) eq "0")) {set $eio1I4 ON;} + elsif ((state $eio1I4 == ON ) && (substr($eio1data, 1, 1) eq "1")) {set $eio1I4 OFF;} + if ((state $eio1I3 == OFF) && (substr($eio1data, 2, 1) eq "0")) {set $eio1I3 ON;} + elsif ((state $eio1I3 == ON ) && (substr($eio1data, 2, 1) eq "1")) {set $eio1I3 OFF;} + if ((state $eio1I2 == OFF) && (substr($eio1data, 3, 1) eq "0")) {set $eio1I2 ON;} + elsif ((state $eio1I2 == ON ) && (substr($eio1data, 3, 1) eq "1")) {set $eio1I2 OFF;} + if ((state $eio1I1 == OFF) && (substr($eio1data, 4, 1) eq "0")) {set $eio1I1 ON;} + elsif ((state $eio1I1 == ON ) && (substr($eio1data, 4, 1) eq "1")) {set $eio1I1 OFF;} + if ((state $eio1R4 == OFF) && (substr($eio1data, 6, 1) eq "1")) {set $eio1R4 ON;} + elsif ((state $eio1R4 == ON ) && (substr($eio1data, 6, 1) eq "0")) {set $eio1R4 OFF;} + if ((state $eio1R3 == OFF) && (substr($eio1data, 7, 1) eq "1")) {set $eio1R3 ON;} + elsif ((state $eio1R3 == ON ) && (substr($eio1data, 7, 1) eq "0")) {set $eio1R3 OFF;} + if ((state $eio1R2 == OFF) && (substr($eio1data, 8, 1) eq "1")) {set $eio1R2 ON;} + elsif ((state $eio1R2 == ON ) && (substr($eio1data, 8, 1) eq "0")) {set $eio1R2 OFF;} + if ((state $eio1R1 == OFF) && (substr($eio1data, 9, 1) eq "1")) {set $eio1R1 ON;} + elsif ((state $eio1R1 == ON ) && (substr($eio1data, 9, 1) eq "0")) {set $eio1R1 OFF;} + } + $loop1count = 0; # reset the loop counter +} + +# voice command the relays +if ($state = said $v_eio1R1){ + if ($state eq ON){ +# print_log "setting Relay 1 on\n"; + set $eio1 "E1R1 on"; + } + elsif ($state eq OFF){ +# print_log "setting Relay 1 off\n"; + set $eio1 "E1R1 off"; + } +} + +elsif ($state = said $v_eio1R2){ + if ($state eq ON){ +# print_log "setting Relay 2 on\n"; + set $eio1 "E1R2 on"; + } + elsif ($state eq OFF){ +# print_log "setting Relay 2 off\n"; + set $eio1 "E1R2 off"; + } +} + +elsif ($state = said $v_eio1R3){ + if ($state eq ON){ +# print_log "setting Relay 3 on\n"; + set $eio1 "E1R3 on"; + } + elsif ($state eq OFF){ +# print_log "setting Relay 3 off\n"; + set $eio1 "E1R3 off"; + } +} + +elsif ($state = said $v_eio1R4){ + if ($state eq ON){ +# print_log "setting Relay 4 on\n"; + set $eio1 "E1R4 on"; + } + elsif ($state eq OFF){ +# print_log "setting Relay 4 off\n"; + set $eio1 "E1R4 off"; + } +} + +sub reload_board1 +{ + my $log1file = $eio1DataLog; #determine the last used datafile (log rotation) + if (file_size($log1file) == 0 ) { $log1file .= ".1";} #in case logs have rotated + print_log "selected logfile: $log1file"; #diagnostic + my $oldstate = file_tail($log1file,1); #get last line (previous state) + print_log "EIO-1 reloaded - Oldstate: $oldstate"; + # set relays and input, output display variables for webpage + if (substr($oldstate,21,1) eq "0") {set $eio1I4 ON;} else {set $eio1I4 OFF;} + if (substr($oldstate,22,1) eq "0") {set $eio1I3 ON;} else {set $eio1I3 OFF;} + if (substr($oldstate,23,1) eq "0") {set $eio1I2 ON;} else {set $eio1I2 OFF;} + if (substr($oldstate,24,1) eq "0") {set $eio1I1 ON;} else {set $eio1I1 OFF;} + if (substr($oldstate,26,1) eq "1") { + set $eio1 "E1R4 on"; + set $eio1R4 ON; } + else { set $eio1R4 OFF; } + if (substr($oldstate,27,1) eq "1") { + set $eio1 "E1R3 on"; + set $eio1R3 ON; } + else { set $eio1R3 OFF; } + if (substr($oldstate,28,1) eq "1") { + set $eio1 "E1R2 on"; + set $eio1R2 ON; } + else { set $eio1R2 OFF; } + if (substr($oldstate,29,1) eq "1") { + set $eio1 "E1R1 on"; + set $eio1R1 ON; } + else { set $eio1R1 OFF; } +} From e8d49bc7d79d603a4d6756fffb1db8425b0bd6bf Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 24 Jan 2011 15:20:11 +0000 Subject: [PATCH 029/150] Properly fix state validation by comparing against object's hash. Remove duplicate scan_link_table method. --- lib/Insteon/BaseInsteon.pm | 9 +- lib/Insteon/BaseInterface.pm | 17 +- lib/Insteon/Lighting.pm | 675 ++++++++++++++++++----------------- 3 files changed, 355 insertions(+), 346 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 643c3c3f9..014c0ffeb 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -566,7 +566,7 @@ sub _is_valid_state } # confirm that the resulting $msg is legitimate - if (!(defined($message_types{$msg}))) { + if (!(defined($$self{message_types}{$msg}))) { return 0; } else { return 1; @@ -989,13 +989,6 @@ sub local_ramprate } - -sub scan_link_table -{ - my ($self,$callback) = @_; - $self->_aldb->scan_link_table($callback) if $self->_aldb; -} - sub delete_orphan_links { my ($self) = @_; diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 4122e7deb..51bbabe44 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -175,11 +175,24 @@ sub process_queue . ") for " . $self->active_message->to_string() . " exceeds limit. Now moving on...") if $main::Debug{insteon}; # !!!!!!!!! TO-DO - handle failure timeout ??? - - # clear active message and try again + my $failed_message = $self->active_message; + # clear active message $self->clear_active_message(); + + # may instead want a "failure" callback separate from success callback + if ($failed_message->callback) { + package main; + eval $failed_message->callback; + &::print_log("[Insteon::BaseInterface] problem w/ retry callback: $@") if $@; + package Insteon::BaseInterface; + } + $self->process_queue(); } + else + { + # may want to move "success" callback handling from message to here + } } my $command_queue_size = @{$$self{command_stack2}}; return $command_queue_size; diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index 92d9cf136..2f58a4a31 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -1,336 +1,339 @@ -package Insteon::BaseLight; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::BaseLight::ISA = ('Insteon::BaseDevice'); - -#my %message_types = ( -# %SUPER::message_types -#); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::BaseDevice($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -sub level -{ - my ($self, $p_level) = @_; - if (defined $p_level) { - my $level = 100; - if ($p_level eq 'off') - { - $level = 0; - } - $$self{level} = $level; - } - return $$self{level}; - -} - -package Insteon::DimmableLight; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::DimmableLight::ISA = ('Insteon::BaseLight'); - -my %message_types = ( - %SUPER::message_types, - bright => 0x15, - dim => 0x16 -); - -my %ramp_h2n = ( - '00' => 540, - '01' => 480, - '02' => 420, - '03' => 360, - '04' => 300, - '05' => 270, - '06' => 240, - '07' => 210, - '08' => 180, - '09' => 150, - '0a' => 120, - '0b' => 90, - '0c' => 60, - '0d' => 47, - '0e' => 43, - '0f' => 39, - '10' => 34, - '11' => 32, - '12' => 30, - '13' => 28, - '14' => 26, - '15' => 23.5, - '16' => 21.5, - '17' => 19, - '18' => 8.5, - '19' => 6.5, - '1a' => 4.5, - '1b' => 2, - '1c' => .5, - '1d' => .3, - '1e' => .2, - '1f' => .1 -); - -sub convert_ramp -{ - my ($ramp_in_seconds) = @_; - if ($ramp_in_seconds) { - foreach my $rampkey (sort keys %ramp_h2n) { - return $rampkey if $ramp_in_seconds >= $ramp_h2n{$rampkey}; - } - } else { - return '1f'; - } -} - -sub get_ramp_from_code -{ - my ($ramp_code) = @_; - if ($ramp_code) { - return $ramp_h2n{$ramp_code}; - } else { - return 0; - } -} - -sub convert_level -{ - my ($on_level) = @_; - my $level = 'ff'; - if (defined ($on_level)) { - if ($on_level eq '100') { - $level = 'ff'; - } elsif ($on_level eq '0') { - $level = '00'; - } else { - $level = sprintf('%02X',$on_level * 2.55); - } - } - return $level; -} - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::BaseLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -sub level -{ - my ($self, $p_level) = @_; - if (defined $p_level) { - my $level = undef; - if ($p_level eq 'on') - { - # set the level based on any locally defined on level - $level = $self->local_onlevel if $self->can('local_onlevel'); - # set to 100 if a local on level is not defined - $level=100 unless defined($level); - } elsif ($p_level eq 'off') - { - $level = 0; - } elsif ($p_level =~ /^([1]?[0-9]?[0-9])%?$/) - { - if ($1 < 1) { - $level = 0; - } else { - $level = $1; - } - } - $$self{level} = $level if defined $level; - } - return $$self{level}; - -} - - -package Insteon::ApplianceLinc; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::ApplianceLinc::ISA = ('Insteon::BaseLight'); - -#my %message_types = ( -# %SUPER::message_types -#); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::BaseLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - - - -package Insteon::LampLinc; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::LampLinc::ISA = ('Insteon::DimmableLight'); - - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -package Insteon::SwitchLincRelay; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::SwitchLincRelay::ISA = ('Insteon::DeviceController','Insteon::BaseLight'); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::BaseLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - - -package Insteon::SwitchLinc; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::SwitchLinc::ISA = ('Insteon::DeviceController','Insteon::DimmableLight'); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - - -package Insteon::KeyPadLincRelay; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::KeyPadLincRelay::ISA = ('Insteon::DeviceController', 'Insteon::BaseLight'); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::BaseLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -sub set -{ - my ($self, $p_state, $p_setby, $p_respond) = @_; - - my $link_state = &Insteon::BaseObject::derive_link_state($p_state); - - if (!($self->is_root)) - { - my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); - return $rslt_code if $rslt_code; - - if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) - { - $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); - } - elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) - { - $$self{surrogate}->set($link_state, $p_setby, $p_respond) - unless ref $p_setby and $p_setby eq $self; - } - else - { - &::print_log("[Insteon::KeyPadLinc] You may not directly attempt to set a keypadlinc's button " - . "unless you have defined a reverse link with the \"surrogate\" keyword"); - } - } - else - { - return $self->Insteon::DeviceController::set($link_state, $p_setby, $p_respond); - } - - return 0; - -} - - -package Insteon::KeyPadLinc; - -use strict; -use Insteon::BaseInsteon; - -@Insteon::KeyPadLinc::ISA = ('Insteon::DeviceController', 'Insteon::DimmableLight'); - -sub new -{ - my ($class,$p_deviceid,$p_interface) = @_; - - my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); - bless $self,$class; - return $self; -} - -sub set -{ - my ($self, $p_state, $p_setby, $p_respond) = @_; - - if (!($self->is_root)) - { - my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); - return $rslt_code if $rslt_code; - - my $link_state = &Insteon::BaseObject::derive_link_state($p_state); - - if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) - { - $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); - } - elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) - { - $$self{surrogate}->set($link_state, $p_setby, $p_respond) - unless ref $p_setby and $p_setby eq $self; - } - else - { - &::print_log("[Insteon::KeyPadLinc] You may not directly attempt to set a keypadlinc's button " - . "unless you have defined a reverse link with the \"surrogate\" keyword"); - } - } - else - { - return $self->Insteon::DeviceController::set($p_state, $p_setby, $p_respond); - } - - return 0; - -} - -1 +package Insteon::BaseLight; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::BaseLight::ISA = ('Insteon::BaseDevice'); + +#my %message_types = ( +# %SUPER::message_types +#); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseDevice($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub level +{ + my ($self, $p_level) = @_; + if (defined $p_level) { + my $level = 100; + if ($p_level eq 'off') + { + $level = 0; + } + $$self{level} = $level; + } + return $$self{level}; + +} + +package Insteon::DimmableLight; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::DimmableLight::ISA = ('Insteon::BaseLight'); + +my %message_types = ( + %SUPER::message_types, + bright => 0x15, + dim => 0x16 +); + +my %ramp_h2n = ( + '00' => 540, + '01' => 480, + '02' => 420, + '03' => 360, + '04' => 300, + '05' => 270, + '06' => 240, + '07' => 210, + '08' => 180, + '09' => 150, + '0a' => 120, + '0b' => 90, + '0c' => 60, + '0d' => 47, + '0e' => 43, + '0f' => 39, + '10' => 34, + '11' => 32, + '12' => 30, + '13' => 28, + '14' => 26, + '15' => 23.5, + '16' => 21.5, + '17' => 19, + '18' => 8.5, + '19' => 6.5, + '1a' => 4.5, + '1b' => 2, + '1c' => .5, + '1d' => .3, + '1e' => .2, + '1f' => .1 +); + +sub convert_ramp +{ + my ($ramp_in_seconds) = @_; + if ($ramp_in_seconds) { + foreach my $rampkey (sort keys %ramp_h2n) { + return $rampkey if $ramp_in_seconds >= $ramp_h2n{$rampkey}; + } + } else { + return '1f'; + } +} + +sub get_ramp_from_code +{ + my ($ramp_code) = @_; + if ($ramp_code) { + return $ramp_h2n{$ramp_code}; + } else { + return 0; + } +} + +sub convert_level +{ + my ($on_level) = @_; + my $level = 'ff'; + if (defined ($on_level)) { + if ($on_level eq '100') { + $level = 'ff'; + } elsif ($on_level eq '0') { + $level = '00'; + } else { + $level = sprintf('%02X',$on_level * 2.55); + } + } + return $level; +} + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub level +{ + my ($self, $p_level) = @_; + if (defined $p_level) { + my $level = undef; + if ($p_level eq 'on') + { + # set the level based on any locally defined on level + $level = $self->local_onlevel if $self->can('local_onlevel'); + # set to 100 if a local on level is not defined + $level=100 unless defined($level); + } elsif ($p_level eq 'off') + { + $level = 0; + } elsif ($p_level =~ /^([1]?[0-9]?[0-9])%?$/) + { + if ($1 < 1) { + $level = 0; + } else { + $level = $1; + } + } + $$self{level} = $level if defined $level; + } + return $$self{level}; + +} + + +package Insteon::ApplianceLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::ApplianceLinc::ISA = ('Insteon::BaseLight'); + +#my %message_types = ( +# %SUPER::message_types +#); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + + +package Insteon::LampLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::LampLinc::ISA = ('Insteon::DimmableLight'); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +package Insteon::SwitchLincRelay; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::SwitchLincRelay::ISA = ('Insteon::DeviceController','Insteon::BaseLight'); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + +package Insteon::SwitchLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::SwitchLinc::ISA = ('Insteon::DeviceController','Insteon::DimmableLight'); + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + + +package Insteon::KeyPadLincRelay; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::KeyPadLincRelay::ISA = ('Insteon::DeviceController', 'Insteon::BaseLight'); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::BaseLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + if (!($self->is_root)) + { + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) + { + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + } + elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) + { + $$self{surrogate}->set($link_state, $p_setby, $p_respond) + unless ref $p_setby and $p_setby eq $self; + } + else + { + &::print_log("[Insteon::KeyPadLinc] You may not directly attempt to set a keypadlinc's button " + . "unless you have defined a reverse link with the \"surrogate\" keyword"); + } + } + else + { + return $self->Insteon::DeviceController::set($link_state, $p_setby, $p_respond); + } + + return 0; + +} + + +package Insteon::KeyPadLinc; + +use strict; +use Insteon::BaseInsteon; + +@Insteon::KeyPadLinc::ISA = ('Insteon::DeviceController', 'Insteon::DimmableLight'); + + +sub new +{ + my ($class,$p_deviceid,$p_interface) = @_; + + my $self = new Insteon::DimmableLight($p_deviceid,$p_interface); + bless $self,$class; + return $self; +} + +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + if (!($self->is_root)) + { + my $rslt_code = $self->Insteon::BaseController::set($p_state, $p_setby, $p_respond); + return $rslt_code if $rslt_code; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + if (ref $p_setby and $p_setby->isa('Insteon::BaseDevice')) + { + $self->Insteon::BaseObject::set($p_state, $p_setby, $p_respond); + } + elsif (ref $$self{surrogate} && ($$self{surrogate}->isa('Insteon::InterfaceController'))) + { + $$self{surrogate}->set($link_state, $p_setby, $p_respond) + unless ref $p_setby and $p_setby eq $self; + } + else + { + &::print_log("[Insteon::KeyPadLinc] You may not directly attempt to set a keypadlinc's button " + . "unless you have defined a reverse link with the \"surrogate\" keyword"); + } + } + else + { + return $self->Insteon::DeviceController::set($p_state, $p_setby, $p_respond); + } + + return 0; + +} + +1 \ No newline at end of file From 01e1ed3ea254d283fcd19e7f8c27c0a8a4eaa1c2 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 24 Jan 2011 20:43:23 +0000 Subject: [PATCH 030/150] Fix broken references to adlb (should be aldb). --- lib/Insteon/AllLinkDatabase.pm | 10 +++++----- lib/Insteon/BaseInsteon.pm | 14 +++++++------- lib/Insteon/BaseInterface.pm | 28 +++++++++++++++++++--------- 3 files changed, 31 insertions(+), 21 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index ac3af0c26..68fa47abc 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -76,7 +76,7 @@ sub restore_string $aldb .= $record; } # &::print_log("[AllLinkDataBase] aldb restore string: $aldb") if $main::Debug{insteon}; - $restore_string .= $$self{device}->get_object_name . "->_adlb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_adlb;\n"; + $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_adlb;\n"; } return $restore_string; } @@ -771,7 +771,7 @@ sub add_link # get the address via lookup into the hash my $key = lc $device_id . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if (!($subaddress eq '00' or $subaddress eq '01')) { + if !($subaddress eq '00' or $subaddress eq '01') { $key .= $subaddress; } if (defined $$self{aldb}{$key}{inuse}) { @@ -832,7 +832,7 @@ sub update_link # get the address via lookup into the hash my $key = lc $deviceid . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if (!($subaddress eq '00' or $subaddress eq '01')) { + if !($subaddress eq '00' or $subaddress eq '01') { $key .= $subaddress; } my $address = $$self{aldb}{$key}{address}; @@ -937,7 +937,7 @@ sub has_link } $subaddress = '00' unless $subaddress; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if (!($subaddress eq '00' or $subaddress eq '01')) { + if !($subaddress eq '00' or $subaddress eq '01') { $key .= $subaddress; } return (defined $$self{aldb}{$key}) ? 1 : 0; @@ -1386,4 +1386,4 @@ sub has_link -1; +1; \ No newline at end of file diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 014c0ffeb..d04833937 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -1122,25 +1122,25 @@ sub sync_links my $requires_update = 0; $tgt_on_level =~ s/(\d+)%?/$1/; $tgt_ramp_rate =~ s/(\d)s?/$1/; - my $adlbkey = lc $insteon_object->device_id . $self->group . '0'; + my $aldbkey = lc $insteon_object->device_id . $self->group . '0'; if (($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) and $linkmember->group ne '01') { - $adlbkey .= $linkmember->group; + $aldbkey .= $linkmember->group; } if (!($member->isa('Insteon::DimmableLight'))) { - if ($tgt_on_level >= 1 and $$member{adlb}{$adlbkey}{data1} ne 'ff') { + if ($tgt_on_level >= 1 and $$member{aldb}{$aldbkey}{data1} ne 'ff') { $requires_update = 1; $tgt_on_level = 100; - } elsif ($tgt_on_level == 0 and $$member{adlb}{$adlbkey}{data1} ne '00') { + } elsif ($tgt_on_level == 0 and $$member{aldb}{$aldbkey}{data1} ne '00') { $requires_update = 1; } - if ($$member{adlb}{$adlbkey}{data2} ne '00') { + if ($$member{aldb}{$aldbkey}{data2} ne '00') { $tgt_ramp_rate = 0; } } else { $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; - my $link_on_level = hex($$member{adlb}{$adlbkey}{data1})/2.55; - my $raw_ramp_rate = $$member{adlb}{$adlbkey}{data2}; + my $link_on_level = hex($$member{aldb}{$aldbkey}{data1})/2.55; + my $raw_ramp_rate = $$member{aldb}{$aldbkey}{data2}; my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); if ($raw_ramp_rate != $raw_tgt_ramp_rate) { $requires_update = 1; diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 51bbabe44..6d3572523 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -41,14 +41,14 @@ sub poll_all { sub new { - my ($class) = @_; - - my $self = {}; - @{$$self{command_stack2}} = (); - @{$$self{command_history}} = (); - bless $self, $class; -# &Insteon::add($self); - return $self; + my ($class) = @_; + + my $self = {}; + @{$$self{command_stack2}} = (); + @{$$self{command_history}} = (); + bless $self, $class; +# $self->debug(0) unless $self->debug; + return $self; } sub equals @@ -69,6 +69,16 @@ sub equals } } +sub debug +{ + my ($self, $debug) = @_; + if (defined $debug) + { + $$self{debug} = $debug; + } + return $$self{debug}; +} + sub _is_duplicate { my ($self, $cmd) = @_; @@ -232,7 +242,7 @@ sub restore_string { my ($self) = @_; my $restore_string = $self->SUPER::restore_string(); - $restore_string .= $self->_adlb->restore_string(); + $restore_string .= $self->_aldb->restore_string(); return $restore_string; } From c105fa62135b2b91527907b8f0ba76419f661da5 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 24 Jan 2011 20:44:54 +0000 Subject: [PATCH 031/150] Make cosmetic changes to menus, etc. Fix broken adlb references (should be aldb). --- lib/Insteon.pm | 76 +-- lib/Insteon_PLM.pm | 1190 ++++++++++++++++++++++---------------------- 2 files changed, 614 insertions(+), 652 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 5396f74ac..a2f45b146 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -41,7 +41,6 @@ sub scan_all_linktables $_scan_failure_cnt = 0; &_get_next_linkscan(); - } sub _get_next_linkscan @@ -56,40 +55,17 @@ sub _get_next_linkscan $_scan_failure_cnt = 0; } - my $current_obj = $_scan_devices[0]; - my $next_obj = $current_obj; - if ($_scan_failure_cnt == 0) - { - # get the next - $next_obj = shift @_scan_devices; - # remove the queue_timer_callback - if (!($current_obj->isa('Insteon_PLM'))) - { -# $current_obj->queue_timer_callback(''); - } - } - elsif ($_scan_failure_cnt == 1) - { - # try again -# $next_name = $current_name; - $next_obj = $current_obj; - &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " - . $current_obj->get_object_name . ". Trying again..."); -# $_scan_cnt = $i + 1; - } - else + my $next_obj = shift @_scan_devices; + if ($_scan_failure_cnt > 0) { - # skip because this is a repeat failure - $next_obj = shift @_scan_devices; &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " . $current_obj->get_object_name . ". Moving on..."); - $_scan_failure_cnt = 0; # reset failure counter - # remove the queue_timer_callback - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); - } } + # remove the queue_timer_callback +# if (!($current_obj->isa('Insteon_PLM'))) { +# $current_obj->queue_timer_callback(''); +# } if ($next_obj) { @@ -103,11 +79,6 @@ sub _get_next_linkscan } } -#my $_sync_links_v = new Voice_Cmd 'Sync all links'; - -#if ($_sync_links_v->state_now()) { -# &_process_sync_links(); # unless $_sync_cnt; -#} sub _process_sync_links { @@ -181,11 +152,6 @@ sub _process_sync_links } } - -sub uninstall_insteon_item_commands { - &main::trigger_delete('scan insteon link tables'); -} - sub init { # only run once @@ -197,6 +163,12 @@ sub init { $_sync_cnt = 0; @_scan_devices = (); + # delete the existing trigger if it exists + if (&main::trigger_get('scan insteon link tables')) + { + &main::trigger_delete('scan insteon link tables'); + } + # create trigger my $trig_cmd = "time_cron '00 02 * * *'"; &main::trigger_set($trig_cmd,'&Insteon::scan_all_linktables()','NoExpire','scan insteon link tables') @@ -275,17 +247,17 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,log links,delete orphan links,scan all link tables,debug on, debug off"; + my $cmd_states = "this: complete linking as responder,this: cancel linking,this: delete link with PLM,this: scan link table,this: show link table to log,this: messaging debug on,this: messaging debug off,all: delete orphan links,all: scan link tables"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->cancel_linking','cancel linking');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','log links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','debug on');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','debug off');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all link tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','this: complete linking as responder');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','this: initiate unlinking');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->cancel_linking','this: cancel linking');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','this: show link table to log');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','this: scan link table');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','all: delete orphan links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','this: messaging debug on');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','this: messaging debug off');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','all: scan link tables');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } @@ -437,7 +409,7 @@ sub add_item_if_not_present { if (ref $$self{objects}) { foreach (@{$$self{objects}}) { - if ($_ eq $p_object) { + if ($_->equals($p_object)) { return 0; } } @@ -466,7 +438,7 @@ sub is_member { my @l_objects = @{$$self{objects}}; for my $l_object (@l_objects) { - if ($l_object eq $p_object) { + if ($l_object->equals($p_object)) { return 1; } } diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 579b77a6d..4c9bd19fd 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -1,600 +1,590 @@ -=begin comment -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - -File: - Insteon_PLM.pm - -Description: - - This is the base interface class for Insteon Power Line Modem (PLM) - - For more information regarding the technical details of the PLM: - http://www.smarthome.com/manuals/2412sdevguide.pdf - -Author(s): - Jason Sharpee / jason@sharpee.com - Gregg Liming / gregg@limings.net - -License: - This free software is licensed under the terms of the GNU public license. GPLv2 - -Usage: - Use these mh.ini parameters to enable this code: - - Insteon_PLM_serial_port=/dev/ttyS4 - - Example initialization: - - -Notes: - -Special Thanks to: - Brian Warren for significant testing and patches - Bruce Winter - MH - -@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ - - -=cut - - -package Insteon_PLM; - -use strict; -use Insteon::BaseInterface; -use Insteon::BaseInsteon; -use Insteon::AllLinkDatabase; - -@Insteon_PLM::ISA = ('Serial_Item','Insteon::BaseInterface'); - - -my %prefix = ( -#PLM Serial Commands - insteon_received => '0250', - insteon_ext_received => '0251', - x10_received => '0252', - all_link_complete => '0253', - plm_button_event => '0254', - user_user_reset => '0255', - all_link_clean_failed => '0256', - all_link_record => '0257', - all_link_clean_status => '0258', - plm_info => '0260', - all_link_send => '0261', - insteon_send => '0262', - insteon_ext_send => '0262', - x10_send => '0263', - all_link_start => '0264', - all_link_cancel => '0265', - plm_reset => '0267', - all_link_first_rec => '0269', - all_link_next_rec => '026a', - plm_set_config => '026b', - plm_led_on => '026d', - plm_led_off => '026e', - all_link_manage_rec => '026f', - insteon_nak => '0270', - insteon_ack => '0271', - rf_sleep => '0272', - plm_get_config => '0273' -); - - -sub serial_startup { - my ($instance) = @_; - my $port = $::config_parms{$instance . "_serial_port"}; - my $speed = 19200; - - &::print_log("[Insteon_PLM] serial:$port:$speed"); - &::serial_port_create($instance, $port, $speed,'none','raw'); - -} - -sub new { - my ($class, $port_name, $p_deviceid) = @_; - $port_name = 'Insteon_PLM' if !$port_name; - my $port = $::config_parms{$port_name . "_serial_port"}; - - my $self = new Insteon::BaseInterface(); - $$self{state} = ''; - $$self{said} = ''; - $$self{state_now} = ''; - $$self{port_name} = $port_name; - $$self{port} = $port; - $$self{last_command} = ''; - $$self{xmit_in_progress} = 0; - $$self{_prior_data_fragment} = ''; - bless $self, $class; - $$self{aldb} = new Insteon::ALDB_PLM($self); - $self->debug(0); - - &Insteon::add($self); - - $self->device_id($p_deviceid) if defined $p_deviceid; - - $$self{xmit_delay} = $::config_parms{Insteon_PLM_xmit_delay}; - $$self{xmit_delay} = 0.25 unless defined $$self{xmit_delay}; # and $$self{xmit_delay} > 0.125; - &::print_log("[Insteon_PLM] setting default xmit delay to: $$self{xmit_delay}"); - $$self{xmit_x10_delay} = $::config_parms{Insteon_PLM_xmit_x10_delay}; - $$self{xmit_x10_delay} = 0.5 unless defined $$self{xmit_x10_delay} and $$self{xmit_x10_delay} > 0.5; - &::print_log("[Insteon_PLM] setting x10 xmit delay to: $$self{xmit_x10_delay}"); - $self->_clear_timeout('xmit'); - $self->_clear_timeout('command'); - - return $self; -} - -sub debug -{ - my ($self, $debug) = @_; - if (defined $debug) - { - $$self{debug} = $debug; - } - return $$self{debug}; -} - -sub restore_string -{ - my ($self) = @_; - my $restore_string = $self->SUPER::restore_string(); - if ($self->_aldb) { - $restore_string .= $self->_aldb->restore_string(); - } - return $restore_string; -} - -sub check_for_data { - - my ($self) = @_; - my $port_name = $$self{port_name}; - &::check_for_generic_serial_data($port_name) if $::Serial_Ports{$port_name}{object}; - my $data = $::Serial_Ports{$port_name}{data}; - # always check for data first; if it exists, then process; otherwise check if pending commands exist - if ($data) - { - #lets turn this into Hex. I hate perl binary funcs - my $data = unpack "H*", $data; - - my $processedNibs; - $processedNibs = $self->_parse_data($data); - $processedNibs = 0 unless $processedNibs; -# &::print_log("PLM Proc:$processedNibs:" . length($data)); - if (length($data) > $processedNibs) - { - $main::Serial_Ports{$port_name}{data}=pack("H*",substr($data,$processedNibs,length($data)-$processedNibs)); - } - else - { - $main::Serial_Ports{$port_name}{data} = ''; - } - - # if no data being received, then check if any timeouts have expired - } - elsif (defined $self) - { - if ($self->_check_timeout('command') == 1) - { - $self->_clear_timeout('command'); - if ($$self{xmit_in_progress}) { -# &::print_log("[Insteon_PLM] WARN: No acknowledgement from PLM to last command requires forced abort of current command." -# . " This may reflect a problem with your environment."); - $$self{xmit_in_progress} = 0; -# pop(@{$$self{command_stack2}}); # pop the active command off the queue - $self->retry_active_message(); - $self->process_queue(); - } - else - { - &::print_log("[Insteon_PLM] PLM command timer expired but no transmission in place. Moving on...") if $main::Debug{insteon}; - $self->clear_active_message(); - $self->process_queue(); - } - } - elsif ($self->_check_timeout('xmit') == 1) - { - $self->_clear_timeout('xmit'); - if (!($$self{xmit_in_progress})) - { - $self->process_queue(); - } - } - } -} - - -sub set -{ - my ($self,$p_state,$p_setby,$p_response) = @_; - - my @x10_commands = &Insteon::X10Message::generate_commands($p_state, $p_setby); - foreach my $command (@x10_commands) - { - $self->queue_message(new Insteon::X10Message($command)); - } -} - -sub complete_linking_as_responder -{ - my ($self, $group) = @_; - - # it is not clear that group should be anything as the group will be taken from the controller - $group = '01' unless $group; - # set up the PLM as the responder - my $cmd = '00'; # responder code - $cmd .= $group; # WARN - must be 2 digits and in hex!! - my $message = new Insteon::InsteonMessage('all_link_start', $self); - $message->interface_data($cmd); - $self->queue_message($message) -} - -sub log_alllink_table -{ - my ($self) = @_; - $self->_aldb->log_alllink_table if $self->_aldb; -} - -sub scan_link_table -{ - my ($self,$callback) = @_; - #$$self{links} = undef; # clear out the old - $$self{adlb} = undef; - $$self{aldb} = new Insteon::ALDB_PLM($self); - $$self{_mem_activity} = 'scan'; - $$self{_mem_callback} = ($callback) ? $callback : undef; - $self->_aldb->get_first_alllink(); -} - -sub initiate_linking_as_controller -{ - my ($self, $group) = @_; - - $group = 'FF' unless $group; - # set up the PLM as the responder - my $cmd = '01'; # controller code - $cmd .= $group; # WARN - must be 2 digits and in hex!! - my $message = new Insteon::InsteonMessage('all_link_start', $self); - $message->interface_data($cmd); - $self->queue_message($message); -} - -sub initiate_unlinking_as_controller -{ - my ($self, $group) = @_; - - $group = 'FF' unless $group; - # set up the PLM as the responder - my $cmd = 'FF'; # controller code - $cmd .= $group; # WARN - must be 2 digits and in hex!! - my $message = new Insteon::InsteonMessage('all_link_start', $self); - $message->interface_data($cmd); - $self->queue_message($message); -} - - -sub cancel_linking -{ - my ($self) = @_; - $self->queue_message(new Insteon::InsteonMessage('all_link_cancel', $self)); -} - -sub _aldb -{ - my ($self) = @_; - return $$self{aldb}; -} - - - -sub _send_cmd { - my ($self, $message, $cmd_timeout) = @_; - my $instance = $$self{port_name}; - if (!(ref $main::Serial_Ports{$instance}{object})) { - print "WARN: Insteon_PLM serial port not initialized!\n"; - return; - } - unshift(@{$$self{command_history}},$::Time); - $$self{xmit_in_progress} = 1; - - my $command = $message->interface_data; - my $delay = $$self{xmit_delay}; - if ($message->isa('Insteon::X10Message')) { # is x10; so, be slow - $command = $prefix{x10_send} . $command; - $delay = $$self{xmit_x10_delay}; - # clear command timeout so that we don't wait for an insteon ack before sending the next command - } else { - my $command_type = $message->command_type; - $command = $prefix{$command_type} . $command; - $self->_set_timeout('command', $cmd_timeout); # a commmand needs to be PLM ack'd w/i 3 seconds or it gets dropped - } - - my $data = pack("H*",$command); -# &::print_log("PLM: Executing command:$command:") unless $main::config_parms{no_log} =~/Insteon_PLM/; - $main::Serial_Ports{$instance}{object}->write($data) if $main::Serial_Ports{$instance}; - - - if ($delay) { - $self->_set_timeout('xmit',$delay * 1000); - } - $$self{'last_change'} = $main::Time; -} - - -sub _parse_data { - my ($self, $data) = @_; - my ($name, $val); - - my $processedNibs=0; - - # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it - if ($$self{_data_fragment}) { - &::print_log("[Insteon_PLM] Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; - $$self{_prior_data_fragment} = $$self{_data_fragment}; - $data = $$self{_data_fragment} . $data; - $$self{_data_fragment} = ''; - } - &::print_log( "[Insteon_PLM] Parsing serial data: $data") if $self->debug; - - # begin by pulling out any PLM ack/nacks - my $prev_cmd = ''; - my $pending_message = $self->active_message; - if ($pending_message) { - $prev_cmd = lc $pending_message->interface_data; - if ($pending_message->isa('Insteon::X10Message')) - { - $prev_cmd = $prefix{x10_send} . $prev_cmd; - } else { - my $command_type = $pending_message->command_type; - $prev_cmd = $prefix{$command_type} . $prev_cmd; - } - } - - my $residue_data = ''; - my $process_next_command = 1; - my $nack_count = 0; - my $entered_ack_loop; - if (defined $prev_cmd and $prev_cmd ne '') - { - my $ackcmd = $prev_cmd . '06'; - my $nackcmd = $prev_cmd . '15'; - my $badcmd = $prev_cmd . '0f'; - foreach my $data_1 (split(/($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)/,$data)) - { - #ignore blanks.. the split does odd things - next if $data_1 eq ''; - $entered_ack_loop = 1; - if ($data_1 =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) - { - $processedNibs+=length($data_1); - my $ret_code = substr($data_1,length($data_1)-2,2); - my $record_type = substr($data_1,0,4); - my $message_data = substr($data_1,4,length($data_1)-4); - if ($ret_code eq '06') - { - if ($record_type eq $prefix{plm_info}) - { - $self->device_id(substr($message_data,0,6)); - $self->firmware(substr($message_data,10,2)); - $self->on_interface_info_received(); - } - elsif ($record_type eq $prefix{all_link_first_rec} - or $record_type eq $prefix{all_link_next_rec}) - { - $$self{_next_link_ok} = 1; - } - else - { - &::print_log("[Insteon_PLM] DEBUG: received interface acknowledge: " - . $pending_message->to_string) if $self->debug; - } - - if ($data_1 =~ /$prefix{x10_send}\w{4}06/) - { - $self->clear_active_message(); - } - - if (($record_type eq $prefix{all_link_manage_rec}) and $$self{_mem_callback}) - { - my $callback = $$self{_mem_callback}; - $$self{_mem_callback} = undef; - package main; - eval ($callback); - &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; - } - } - elsif ($ret_code eq '15' or $ret_code eq '0f') - { #NAK or "bad" command received - $self->clear_active_message(); # regardless, we're not retrying as we'll just get the same - - if ($record_type eq $prefix{all_link_first_rec} - or $record_type eq $prefix{all_link_next_rec}) - { - # both of these conditions are ok as it just means - # we've reached the end of the memory - $$self{_next_link_ok} = 0; - $$self{_mem_activity} = undef; - if ($$self{_mem_callback}) - { - my $callback = $$self{_mem_callback}; - $$self{_mem_callback} = undef; - package main; - eval ($callback); - &::print_log("[Insteon_PLM] error encountered during nack callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; - } - } else { - &::print_log("[Insteon_PLM] WARN: received NACK for " - . $pending_message->to_string() - . ". If this is a light fixture, check bulb"); - } - } - else - { - # We have a problem (Usually we stepped on another X10 command) - &::print_log("[Insteon_PLM] ERROR: encountered $data_1. " - . $pending_message->to_string()); -# $$self{xmit_in_progress} = 0; - $self->retry_active_message(); - #move it off the top of the stack and re-transmit later! - #TODO: We should keep track of an errored command and kill it if it fails twice. prevent an infinite loop here - } - } - else - { - $residue_data .= $data_1; - } - } - - $residue_data = $data unless $entered_ack_loop or $residue_data; - } - else - { - $residue_data = $data unless $residue_data; - } - - my $entered_rcv_loop = 0; - - foreach my $data_1 (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})/,$residue_data)) - { - #ignore blanks.. the split does odd things - next if $data_1 eq ''; - - $entered_rcv_loop = 1; - - #we found a matching command in stream, add to processed bytes - $processedNibs+=length($data_1); - - my $parsed_prefix = substr($data_1,0,4); - my $message_length = length($data_1); - - my $message_data = substr($data_1,4,length($data_1)-4); - - if ($parsed_prefix eq $prefix{insteon_received} and ($message_length == 22)) - { #Insteon Standard Received - $self->on_standard_insteon_received($message_data); - } - elsif ($parsed_prefix eq $prefix{insteon_ext_received} and ($message_length == 50)) - { #Insteon Extended Received - $self->on_extended_insteon_received($message_data); - } - elsif($parsed_prefix eq $prefix{x10_received} and ($message_length == 8)) - { #X10 Received - my $x10_message = new Insteon::X10Message($message_data); - my $x10_data = $x10_message->get_formatted_data(); - &::print_log("[Insteon_PLM] received x10 data: $x10_data") if $main::Debug{insteon} - &::process_serial_data($x10_data,undef,$self); - } - elsif ($parsed_prefix eq $prefix{all_link_complete} and ($message_length == 20)) - { #ALL-Linking Completed - my $link_address = substr($message_data,4,6); - &::print_log("[Insteon_PLM] ALL-Linking Completed with $link_address ($message_data)") if $main::Debug{insteon}; - $self->clear_active_message(); - } - elsif ($parsed_prefix eq $prefix{all_link_clean_failed} and ($message_length == 14)) - { #ALL-Link Cleanup Failure Report - $self->retry_active_message(); - # extract out the pertinent parts of the message for display purposes - # bytes 0-1 - ignore; 2-3 - group; 4-9 device address - my $failure_group = substr($message_data,2,2); - my $failure_device = substr($message_data,4,6); - - &::print_log("[Insteon_PLM] Recieved all-link cleanup failure from device: " - . "$failure_device and group: failure_group") if $main::Debug{insteon}; - } - elsif ($parsed_prefix eq $prefix{all_link_record} and ($message_length == 20)) - { #ALL-Link Record Response - &::print_log("[Insteon_PLM] ALL-Link Record Response:$message_data") if $main::Debug{insteon}; - $self->_aldb->parse_alllink($message_data); - # before doing the next, make sure that the pending command - # (if it sitll exists) is pulled from the queue - $self->clear_active_message(); - - $self->_aldb->get_next_alllink(); - } - elsif ($parsed_prefix eq $prefix{all_link_clean_status} and ($message_length == 6)) - { #ALL-Link Cleanup Status Report - my $cleanup_ack = substr($message_data,0,2); - if ($cleanup_ack eq '15') - { - my $delay_in_seconds = 1.0; # this may need to be tweaked - &::print_log("[Insteon_PLM] Received all-link cleanup failure for current message." - . " Attempting resend in " . $delay_in_seconds . " seconds.") - if $main::Debug{insteon}; - $self->retry_active_message(); - # except that we should cause a bit of a delay to let things settle out - $self->_set_timeout('xmit',$delay_in_seconds * 1000); - $process_next_command = 0; - } - else - { - my $message_to_string = ($self->active_message) ? $self->active_message->to_string() : ""; - &::print_log("[Insteon_PLM] Received all-link cleanup success: $message_to_string") - if $main::Debug{insteon}; - - # attempt to process the message by the link object; this acknowledgement will reset - # the auto-retry timer - if ($self->active_message && ($self->active_message->command_type == 'all_link_send')) - { - my $group = substr($self->active_message->interface_data,0,2); - my $link = &Insteon::get_object('000000',$group); - if ($link) - { - my %msg = ('type' => 'cleanup', - 'group' => $group, - 'is_ack' => 1, - 'command' => 'cleanup' - ); - $link->_process_message($self, %msg); - } - } - $self->clear_active_message(); - } - } - elsif (substr($data_1,0,2) eq '15') - { #NAK Received - if (!($nack_count)) - { - my $nack_delay = ($::config_parms{Insteon_PLM_disable_throttling}) ? 0.3 : 1.0; - &::print_log("[Insteon_PLM] Interface extremely busy. Resending command" - . " after delaying for $nack_delay second") if $main::Debug{insteon}; - $self->_set_timeout('xmit',$nack_delay * 1000); - $self->retry_active_message(); -# $$self{xmit_in_progress} = 0; - $process_next_command = 0; - $nack_count++; - } - } - else - { - # it's probably a fragment; so, handle it - # it it's the same as last time, then drop it as we can't recover - $$self{_data_fragment} .= $data_1 unless $data_1 eq $$self{_prior_data_fragment}; - } - } - - $$self{_data_fragment} = $residue_data unless $entered_rcv_loop or $$self{_data_fragment}; - - if ($process_next_command) { - $self->process_queue(); - } - - return $processedNibs; -} - -# dummy sub required to support the X10 integrtion - -sub add_id_state { - # do nothing -} - -sub firmware { - my ($self, $p_firmware) = @_; - $$self{firmware} = $p_firmware if defined $p_firmware; - return $$self{firmware}; -} - - -1; +=begin comment +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +File: + Insteon_PLM.pm + +Description: + + This is the base interface class for Insteon Power Line Modem (PLM) + + For more information regarding the technical details of the PLM: + http://www.smarthome.com/manuals/2412sdevguide.pdf + +Author(s): + Jason Sharpee / jason@sharpee.com + Gregg Liming / gregg@limings.net + +License: + This free software is licensed under the terms of the GNU public license. GPLv2 + +Usage: + Use these mh.ini parameters to enable this code: + + Insteon_PLM_serial_port=/dev/ttyS4 + + Example initialization: + + +Notes: + +Special Thanks to: + Brian Warren for significant testing and patches + Bruce Winter - MH + +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + +=cut + + +package Insteon_PLM; + +use strict; +use Insteon::BaseInterface; +use Insteon::BaseInsteon; +use Insteon::AllLinkDatabase; + +@Insteon_PLM::ISA = ('Serial_Item','Insteon::BaseInterface'); + + +my %prefix = ( +#PLM Serial Commands + insteon_received => '0250', + insteon_ext_received => '0251', + x10_received => '0252', + all_link_complete => '0253', + plm_button_event => '0254', + user_user_reset => '0255', + all_link_clean_failed => '0256', + all_link_record => '0257', + all_link_clean_status => '0258', + plm_info => '0260', + all_link_send => '0261', + insteon_send => '0262', + insteon_ext_send => '0262', + x10_send => '0263', + all_link_start => '0264', + all_link_cancel => '0265', + plm_reset => '0267', + all_link_first_rec => '0269', + all_link_next_rec => '026a', + plm_set_config => '026b', + plm_led_on => '026d', + plm_led_off => '026e', + all_link_manage_rec => '026f', + insteon_nak => '0270', + insteon_ack => '0271', + rf_sleep => '0272', + plm_get_config => '0273' +); + + +sub serial_startup { + my ($instance) = @_; + my $port = $::config_parms{$instance . "_serial_port"}; + my $speed = 19200; + + &::print_log("[Insteon_PLM] serial:$port:$speed"); + &::serial_port_create($instance, $port, $speed,'none','raw'); + +} + +sub new { + my ($class, $port_name, $p_deviceid) = @_; + $port_name = 'Insteon_PLM' if !$port_name; + my $port = $::config_parms{$port_name . "_serial_port"}; + + my $self = new Insteon::BaseInterface(); + $$self{state} = ''; + $$self{said} = ''; + $$self{state_now} = ''; + $$self{port_name} = $port_name; + $$self{port} = $port; + $$self{last_command} = ''; + $$self{xmit_in_progress} = 0; + $$self{_prior_data_fragment} = ''; + bless $self, $class; + $self->restore_data('debug'); + $$self{aldb} = new Insteon::ALDB_PLM($self); + + &Insteon::add($self); + + $self->device_id($p_deviceid) if defined $p_deviceid; + + $$self{xmit_delay} = $::config_parms{Insteon_PLM_xmit_delay}; + $$self{xmit_delay} = 0.25 unless defined $$self{xmit_delay}; # and $$self{xmit_delay} > 0.125; + &::print_log("[Insteon_PLM] setting default xmit delay to: $$self{xmit_delay}"); + $$self{xmit_x10_delay} = $::config_parms{Insteon_PLM_xmit_x10_delay}; + $$self{xmit_x10_delay} = 0.5 unless defined $$self{xmit_x10_delay} and $$self{xmit_x10_delay} > 0.5; + &::print_log("[Insteon_PLM] setting x10 xmit delay to: $$self{xmit_x10_delay}"); + $self->_clear_timeout('xmit'); + $self->_clear_timeout('command'); + + return $self; +} + + +sub restore_string +{ + my ($self) = @_; + my $restore_string = $self->SUPER::restore_string(); + if ($self->_aldb) { + $restore_string .= $self->_aldb->restore_string(); + } + return $restore_string; +} + +sub check_for_data { + + my ($self) = @_; + my $port_name = $$self{port_name}; + &::check_for_generic_serial_data($port_name) if $::Serial_Ports{$port_name}{object}; + my $data = $::Serial_Ports{$port_name}{data}; + # always check for data first; if it exists, then process; otherwise check if pending commands exist + if ($data) + { + #lets turn this into Hex. I hate perl binary funcs + my $data = unpack "H*", $data; + + my $processedNibs; + $processedNibs = $self->_parse_data($data); + $processedNibs = 0 unless $processedNibs; +# &::print_log("PLM Proc:$processedNibs:" . length($data)); + if (length($data) > $processedNibs) + { + $main::Serial_Ports{$port_name}{data}=pack("H*",substr($data,$processedNibs,length($data)-$processedNibs)); + } + else + { + $main::Serial_Ports{$port_name}{data} = ''; + } + + # if no data being received, then check if any timeouts have expired + } + elsif (defined $self) + { + if ($self->_check_timeout('command') == 1) + { + $self->_clear_timeout('command'); + if ($$self{xmit_in_progress}) { +# &::print_log("[Insteon_PLM] WARN: No acknowledgement from PLM to last command requires forced abort of current command." +# . " This may reflect a problem with your environment."); + $$self{xmit_in_progress} = 0; +# pop(@{$$self{command_stack2}}); # pop the active command off the queue + $self->retry_active_message(); + $self->process_queue(); + } + else + { + &::print_log("[Insteon_PLM] PLM command timer expired but no transmission in place. Moving on...") if $main::Debug{insteon}; + $self->clear_active_message(); + $self->process_queue(); + } + } + elsif ($self->_check_timeout('xmit') == 1) + { + $self->_clear_timeout('xmit'); + if (!($$self{xmit_in_progress})) + { + $self->process_queue(); + } + } + } +} + + +sub set +{ + my ($self,$p_state,$p_setby,$p_response) = @_; + + my @x10_commands = &Insteon::X10Message::generate_commands($p_state, $p_setby); + foreach my $command (@x10_commands) + { + $self->queue_message(new Insteon::X10Message($command)); + } +} + +sub complete_linking_as_responder +{ + my ($self, $group) = @_; + + # it is not clear that group should be anything as the group will be taken from the controller + $group = '01' unless $group; + # set up the PLM as the responder + my $cmd = '00'; # responder code + $cmd .= $group; # WARN - must be 2 digits and in hex!! + my $message = new Insteon::InsteonMessage('all_link_start', $self); + $message->interface_data($cmd); + $self->queue_message($message) +} + +sub log_alllink_table +{ + my ($self) = @_; + $self->_aldb->log_alllink_table if $self->_aldb; +} + +sub scan_link_table +{ + my ($self,$callback) = @_; + #$$self{links} = undef; # clear out the old + $$self{aldb} = new Insteon::ALDB_PLM($self); + $$self{_mem_activity} = 'scan'; + $$self{_mem_callback} = ($callback) ? $callback : undef; + $self->_aldb->get_first_alllink(); +} + +sub initiate_linking_as_controller +{ + my ($self, $group) = @_; + + $group = 'FF' unless $group; + # set up the PLM as the responder + my $cmd = '01'; # controller code + $cmd .= $group; # WARN - must be 2 digits and in hex!! + my $message = new Insteon::InsteonMessage('all_link_start', $self); + $message->interface_data($cmd); + $self->queue_message($message); +} + +sub initiate_unlinking_as_controller +{ + my ($self, $group) = @_; + + $group = 'FF' unless $group; + # set up the PLM as the responder + my $cmd = 'FF'; # controller code + $cmd .= $group; # WARN - must be 2 digits and in hex!! + my $message = new Insteon::InsteonMessage('all_link_start', $self); + $message->interface_data($cmd); + $self->queue_message($message); +} + + +sub cancel_linking +{ + my ($self) = @_; + $self->queue_message(new Insteon::InsteonMessage('all_link_cancel', $self)); +} + +sub _aldb +{ + my ($self) = @_; + return $$self{aldb}; +} + + + +sub _send_cmd { + my ($self, $message, $cmd_timeout) = @_; + my $instance = $$self{port_name}; + if (!(ref $main::Serial_Ports{$instance}{object})) { + print "WARN: Insteon_PLM serial port not initialized!\n"; + return; + } + unshift(@{$$self{command_history}},$::Time); + $$self{xmit_in_progress} = 1; + + my $command = $message->interface_data; + my $delay = $$self{xmit_delay}; + if ($message->isa('Insteon::X10Message')) { # is x10; so, be slow + $command = $prefix{x10_send} . $command; + $delay = $$self{xmit_x10_delay}; + # clear command timeout so that we don't wait for an insteon ack before sending the next command + } else { + my $command_type = $message->command_type; + $command = $prefix{$command_type} . $command; + $self->_set_timeout('command', $cmd_timeout); # a commmand needs to be PLM ack'd w/i 3 seconds or it gets dropped + } + + my $data = pack("H*",$command); +# &::print_log("PLM: Executing command:$command:") unless $main::config_parms{no_log} =~/Insteon_PLM/; + $main::Serial_Ports{$instance}{object}->write($data) if $main::Serial_Ports{$instance}; + + + if ($delay) { + $self->_set_timeout('xmit',$delay * 1000); + } + $$self{'last_change'} = $main::Time; +} + + +sub _parse_data { + my ($self, $data) = @_; + my ($name, $val); + + my $processedNibs=0; + + # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it + if ($$self{_data_fragment}) { + &::print_log("[Insteon_PLM] DEBUG: Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; + $$self{_prior_data_fragment} = $$self{_data_fragment}; + $data = $$self{_data_fragment} . $data; + $$self{_data_fragment} = ''; + } + &::print_log( "[Insteon_PLM] DEBUG: Parsing serial data: $data") if $self->debug; + + # begin by pulling out any PLM ack/nacks + my $prev_cmd = ''; + my $pending_message = $self->active_message; + if ($pending_message) { + $prev_cmd = lc $pending_message->interface_data; + if ($pending_message->isa('Insteon::X10Message')) + { + $prev_cmd = $prefix{x10_send} . $prev_cmd; + } else { + my $command_type = $pending_message->command_type; + $prev_cmd = $prefix{$command_type} . $prev_cmd; + } + } + + my $residue_data = ''; + my $process_next_command = 1; + my $nack_count = 0; + my $entered_ack_loop; + if (defined $prev_cmd and $prev_cmd ne '') + { + my $ackcmd = $prev_cmd . '06'; + my $nackcmd = $prev_cmd . '15'; + my $badcmd = $prev_cmd . '0f'; + foreach my $data_1 (split(/($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)/,$data)) + { + #ignore blanks.. the split does odd things + next if $data_1 eq ''; + $entered_ack_loop = 1; + if ($data_1 =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) + { + $processedNibs+=length($data_1); + my $ret_code = substr($data_1,length($data_1)-2,2); + my $record_type = substr($data_1,0,4); + my $message_data = substr($data_1,4,length($data_1)-4); + if ($ret_code eq '06') + { + if ($record_type eq $prefix{plm_info}) + { + $self->device_id(substr($message_data,0,6)); + $self->firmware(substr($message_data,10,2)); + $self->on_interface_info_received(); + } + elsif ($record_type eq $prefix{all_link_first_rec} + or $record_type eq $prefix{all_link_next_rec}) + { + $$self{_next_link_ok} = 1; + } + else + { + &::print_log("[Insteon_PLM] DEBUG: received interface acknowledge: " + . $pending_message->to_string) if $self->debug; + } + + if ($data_1 =~ /$prefix{x10_send}\w{4}06/) + { + $self->clear_active_message(); + } + + if (($record_type eq $prefix{all_link_manage_rec}) and $$self{_mem_callback}) + { + my $callback = $$self{_mem_callback}; + $$self{_mem_callback} = undef; + package main; + eval ($callback); + &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + } + elsif ($ret_code eq '15' or $ret_code eq '0f') + { #NAK or "bad" command received + $self->clear_active_message(); # regardless, we're not retrying as we'll just get the same + + if ($record_type eq $prefix{all_link_first_rec} + or $record_type eq $prefix{all_link_next_rec}) + { + # both of these conditions are ok as it just means + # we've reached the end of the memory + $$self{_next_link_ok} = 0; + $$self{_mem_activity} = undef; + if ($$self{_mem_callback}) + { + my $callback = $$self{_mem_callback}; + $$self{_mem_callback} = undef; + package main; + eval ($callback); + &::print_log("[Insteon_PLM] error encountered during nack callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + } else { + &::print_log("[Insteon_PLM] WARN: received NACK for " + . $pending_message->to_string() + . ". If this is a light fixture, check bulb"); + } + } + else + { + # We have a problem (Usually we stepped on another X10 command) + &::print_log("[Insteon_PLM] ERROR: encountered $data_1. " + . $pending_message->to_string()); +# $$self{xmit_in_progress} = 0; + $self->retry_active_message(); + #move it off the top of the stack and re-transmit later! + #TODO: We should keep track of an errored command and kill it if it fails twice. prevent an infinite loop here + } + } + else + { + $residue_data .= $data_1; + } + } + + $residue_data = $data unless $entered_ack_loop or $residue_data; + } + else + { + $residue_data = $data unless $residue_data; + } + + my $entered_rcv_loop = 0; + + foreach my $data_1 (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})/,$residue_data)) + { + #ignore blanks.. the split does odd things + next if $data_1 eq ''; + + $entered_rcv_loop = 1; + + #we found a matching command in stream, add to processed bytes + $processedNibs+=length($data_1); + + my $parsed_prefix = substr($data_1,0,4); + my $message_length = length($data_1); + + my $message_data = substr($data_1,4,length($data_1)-4); + + if ($parsed_prefix eq $prefix{insteon_received} and ($message_length == 22)) + { #Insteon Standard Received + $self->on_standard_insteon_received($message_data); + } + elsif ($parsed_prefix eq $prefix{insteon_ext_received} and ($message_length == 50)) + { #Insteon Extended Received + $self->on_extended_insteon_received($message_data); + } + elsif($parsed_prefix eq $prefix{x10_received} and ($message_length == 8)) + { #X10 Received + my $x10_message = new Insteon::X10Message($message_data); + my $x10_data = $x10_message->get_formatted_data(); + &::print_log("[Insteon_PLM] received x10 data: $x10_data") if $main::Debug{insteon} + &::process_serial_data($x10_data,undef,$self); + } + elsif ($parsed_prefix eq $prefix{all_link_complete} and ($message_length == 20)) + { #ALL-Linking Completed + my $link_address = substr($message_data,4,6); + &::print_log("[Insteon_PLM] ALL-Linking Completed with $link_address ($message_data)") if $main::Debug{insteon}; + $self->clear_active_message(); + } + elsif ($parsed_prefix eq $prefix{all_link_clean_failed} and ($message_length == 14)) + { #ALL-Link Cleanup Failure Report + $self->retry_active_message(); + # extract out the pertinent parts of the message for display purposes + # bytes 0-1 - ignore; 2-3 - group; 4-9 device address + my $failure_group = substr($message_data,2,2); + my $failure_device = substr($message_data,4,6); + + &::print_log("[Insteon_PLM] Recieved all-link cleanup failure from device: " + . "$failure_device and group: failure_group") if $main::Debug{insteon}; + } + elsif ($parsed_prefix eq $prefix{all_link_record} and ($message_length == 20)) + { #ALL-Link Record Response + &::print_log("[Insteon_PLM] ALL-Link Record Response:$message_data") if $main::Debug{insteon}; + $self->_aldb->parse_alllink($message_data); + # before doing the next, make sure that the pending command + # (if it sitll exists) is pulled from the queue + $self->clear_active_message(); + + $self->_aldb->get_next_alllink(); + } + elsif ($parsed_prefix eq $prefix{all_link_clean_status} and ($message_length == 6)) + { #ALL-Link Cleanup Status Report + my $cleanup_ack = substr($message_data,0,2); + if ($cleanup_ack eq '15') + { + my $delay_in_seconds = 1.0; # this may need to be tweaked + &::print_log("[Insteon_PLM] Received all-link cleanup failure for current message." + . " Attempting resend in " . $delay_in_seconds . " seconds.") + if $main::Debug{insteon}; + $self->retry_active_message(); + # except that we should cause a bit of a delay to let things settle out + $self->_set_timeout('xmit',$delay_in_seconds * 1000); + $process_next_command = 0; + } + else + { + my $message_to_string = ($self->active_message) ? $self->active_message->to_string() : ""; + &::print_log("[Insteon_PLM] Received all-link cleanup success: $message_to_string") + if $main::Debug{insteon}; + + # attempt to process the message by the link object; this acknowledgement will reset + # the auto-retry timer + if ($self->active_message && ($self->active_message->command_type == 'all_link_send')) + { + my $group = substr($self->active_message->interface_data,0,2); + my $link = &Insteon::get_object('000000',$group); + if ($link) + { + my %msg = ('type' => 'cleanup', + 'group' => $group, + 'is_ack' => 1, + 'command' => 'cleanup' + ); + $link->_process_message($self, %msg); + } + } + $self->clear_active_message(); + } + } + elsif (substr($data_1,0,2) eq '15') + { #NAK Received + if (!($nack_count)) + { + my $nack_delay = ($::config_parms{Insteon_PLM_disable_throttling}) ? 0.3 : 1.0; + &::print_log("[Insteon_PLM] Interface extremely busy. Resending command" + . " after delaying for $nack_delay second") if $main::Debug{insteon}; + $self->_set_timeout('xmit',$nack_delay * 1000); + $self->retry_active_message(); +# $$self{xmit_in_progress} = 0; + $process_next_command = 0; + $nack_count++; + } + } + else + { + # it's probably a fragment; so, handle it + # it it's the same as last time, then drop it as we can't recover + $$self{_data_fragment} .= $data_1 unless $data_1 eq $$self{_prior_data_fragment}; + } + } + + $$self{_data_fragment} = $residue_data unless $entered_rcv_loop or $$self{_data_fragment}; + + if ($process_next_command) { + $self->process_queue(); + } + + return $processedNibs; +} + +# dummy sub required to support the X10 integrtion + +sub add_id_state { + # do nothing +} + +sub firmware { + my ($self, $p_firmware) = @_; + $$self{firmware} = $p_firmware if defined $p_firmware; + return $$self{firmware}; +} + + +1; \ No newline at end of file From 32d437983984b48e5392affb7a987f6d2c5ca535 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 24 Jan 2011 20:49:42 +0000 Subject: [PATCH 032/150] Fix parenthesis typos. --- lib/Insteon/AllLinkDatabase.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 68fa47abc..4797e6df9 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -771,7 +771,7 @@ sub add_link # get the address via lookup into the hash my $key = lc $device_id . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if !($subaddress eq '00' or $subaddress eq '01') { + if (!($subaddress eq '00' or $subaddress eq '01')) { $key .= $subaddress; } if (defined $$self{aldb}{$key}{inuse}) { @@ -832,7 +832,7 @@ sub update_link # get the address via lookup into the hash my $key = lc $deviceid . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if !($subaddress eq '00' or $subaddress eq '01') { + if (!($subaddress eq '00' or $subaddress eq '01')) { $key .= $subaddress; } my $address = $$self{aldb}{$key}{address}; @@ -937,7 +937,7 @@ sub has_link } $subaddress = '00' unless $subaddress; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if !($subaddress eq '00' or $subaddress eq '01') { + if (!($subaddress eq '00' or $subaddress eq '01')) { $key .= $subaddress; } return (defined $$self{aldb}{$key}) ? 1 : 0; From f6bd3e4a02e08657de30ec9c19d393f93d303e79 Mon Sep 17 00:00:00 2001 From: peloy Date: Wed, 26 Jan 2011 18:35:55 +0000 Subject: [PATCH 033/150] r1822 by Gregg attempted to clarify, through the name of voice commands, whether commands apply to the PLM or to all devices. For example, we'd have "this: show link table to log", or "all: scan link tables" in the PLM menu in the "Insteon" category in the web interface. The problem with adding "this:" and "all:" to the voice command names is twofold: 1. The Tk interface fails to load because the ':' character has special meaning there, so adding a ':' to a command name confuses some part of the Tk interface, causing it to fail to load. 2. Voice commands become awkward since now we'd have commands like: "plm this: show link table to log" "plm all: scan link tables" For now I am reverting the changes that add "this:" and "all:" to voice commands so the Tk interface loads again. We still can use a character different from ':', e.g. use "this-" and "all-", and that'd solve (1) above, but would still leave (2). Will leave up to Gregg to decide when he gets a chance whether he wants to keep "this" and "all" in the voice command names. --- lib/Insteon.pm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index a2f45b146..7172871fa 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -247,17 +247,17 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "this: complete linking as responder,this: cancel linking,this: delete link with PLM,this: scan link table,this: show link table to log,this: messaging debug on,this: messaging debug off,all: delete orphan links,all: scan link tables"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,scan link tables"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','this: complete linking as responder');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','this: initiate unlinking');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->cancel_linking','this: cancel linking');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','this: show link table to log');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','this: scan link table');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','all: delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','this: messaging debug on');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','this: messaging debug off');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','all: scan link tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->cancel_linking','cancel linking');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','show link table to log');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','messaging debug on');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','messaging debug off');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan link tables');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } @@ -458,4 +458,4 @@ sub find_members { return @l_found; } -1 \ No newline at end of file +1 From 8424e93acefd3b09eec13066f372a224b24e8d9c Mon Sep 17 00:00:00 2001 From: peloy Date: Thu, 27 Jan 2011 21:32:50 +0000 Subject: [PATCH 034/150] Add missing help text for telnet commands --- code/common/telnet.pl | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/code/common/telnet.pl b/code/common/telnet.pl index 9cba96fa2..04b7cec3c 100644 --- a/code/common/telnet.pl +++ b/code/common/telnet.pl @@ -158,12 +158,15 @@ sub telnet_log { $telnet_flags{$client}{auth} = 'set_password'; set_echo $telnet_server '*'; } - elsif ($telnet_flags{$client}{data} =~ /^help/) { + elsif ($telnet_flags{$client}{data} =~ /^(help|\?)/) { $msg = "Type any of the following:\n\r"; - $msg .= " logon => logon with password\n\r" if !$telnet_flags{$client}{auth} && !&password_check( undef, 'server_telnet'); - $msg .= " find: xyz => finds commands that match xyz\n\r"; + $msg .= " logon => logon with password\n\r" if !$telnet_flags{$client}{auth} && !&password_check( undef, 'server_telnet'); + $msg .= " find: xyz => find and report commands that match xyz\n\r"; $msg .= " log: xyz => xyz is a filter of what to log. Can print, speak, play, speak|play, all, and stop\n\r"; - $msg .= " any valid MisterHouse voice command(e.g. What time is it)\n\r"; + $msg .= " whoami: => display currently logged in user\n\r"; + $msg .= " exit|bye: => exit from admin or family mode, or close telnet connection\n\r"; + $msg .= " help|?: => this help text\n\r"; + $msg .= " any valid MisterHouse voice command (e.g. What time is it)\n\r"; } elsif ($telnet_flags{$client}{data} =~ /^find:(.+)/) { my $search = $1; From caafe9fd4cba0acf249b96227cb654d039d1129b Mon Sep 17 00:00:00 2001 From: peloy Date: Fri, 28 Jan 2011 03:54:34 +0000 Subject: [PATCH 035/150] Re-write Insteon::ALDB_i1::log_alllink_table() so links are logged to the print log sorted by the address of ALDB entries. Before this re-write, links were being logged in random ALDB order, which made it difficult to visualize the structure of devices' ALDBs. New Insteon::ALDB_i1::log_alllink_table() was code-reviewed by Gregg. In this commit there's also one adlb -> aldb rename that Gregg seems to have missed in a previous commit that did a mass adlb -> aldb rename. --- lib/Insteon/AllLinkDatabase.pm | 127 +++++++++++++++++++++------------ 1 file changed, 81 insertions(+), 46 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 4797e6df9..366cf7729 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -76,7 +76,7 @@ sub restore_string $aldb .= $record; } # &::print_log("[AllLinkDataBase] aldb restore string: $aldb") if $main::Debug{insteon}; - $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_adlb;\n"; + $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_aldb;\n"; } return $restore_string; } @@ -845,58 +845,93 @@ sub update_link sub log_alllink_table { my ($self) = @_; + my %aldb; + &::print_log("[Insteon::ALDB_i1] link table for " . $$self{device}->get_object_name . " (devcat: $$self{devcat}):"); - foreach my $aldbkey (sort(keys(%{$$self{aldb}}))) { - next if $aldbkey eq 'empty' or $aldbkey eq 'duplicates'; - my ($device); - my $is_controller = $$self{aldb}{$aldbkey}{is_controller}; - if ($$self{device}->interface()->device_id() and ($$self{device}->interface()->device_id() eq $$self{aldb}{$aldbkey}{deviceid})) { - $device = $$self{device}->interface; - } else { - $device = &Insteon::get_object($$self{aldb}{$aldbkey}{deviceid},'01'); - } - my $object_name = ($device) ? $device->get_object_name : $$self{aldb}{$aldbkey}{deviceid}; - my $on_level = 'unknown'; - if (defined $$self{aldb}{$aldbkey}{data1}) { - if ($$self{aldb}{$aldbkey}{data1}) { - $on_level = int((hex($$self{aldb}{$aldbkey}{data1})*100/255) + .5) . "%"; - } else { - $on_level = '0%'; - } + # We want to log links sorted by ALDB address. Since the ALDB + # addresses are scattered throughout the %{$$self{aldb}} hash, + # and it is not easy to obtain them in a linear manner, + # we build a new data structure that will allow us to easily + # traverse the ALDB by address in a sorted manner. The new + # data structure is a bidimensional hash (%aldb) where rows + # are the ALDB addresses and the columns can be "empty" + # (indicates that the ALDB at the corresponding address is + # empty), "duplicate" (indicates that the ALDB at the + # corresponding address is a duplicate), or a hash key (which + # indicates that the ALDB at corresponding address contains + # a link). + foreach my $aldbkey (keys %{$$self{aldb}}) { + if ($aldbkey eq "empty") { + foreach my $address (@{$$self{aldb}{empty}}) { + $aldb{$address}{empty} = undef; # Any value will do + } + } elsif ($aldbkey eq "duplicates") { + foreach my $address (@{$$self{aldb}{duplicates}}) { + $aldb{$address}{duplicate} = undef; # Any value will do } + } else { + $aldb{$$self{aldb}{$aldbkey}{address} }{$aldbkey} = $$self{aldb}{$aldbkey}; + } + } - my $rspndr_group = $$self{aldb}{$aldbkey}{data3}; - $rspndr_group = '01' if $rspndr_group eq '00'; + # Finally traverse the ALDB, but this time sorted by ALDB address + foreach my $address (sort keys %aldb) { + my $log_msg = "[Insteon::ALDB_i1] [0x$address] "; - my $ramp_rate = 'unknown'; - if ($$self{aldb}{$aldbkey}{data2}) { - if (!($$self{device}->isa('Insteon::DimmableLight')) or (!($is_controller) and ($rspndr_group != '01'))) { - $ramp_rate = 'none'; - if ($on_level eq '0%') { - $on_level = 'off'; - } else { - $on_level = 'on'; - } - } else { - $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($$self{aldb}{$aldbkey}{data2}) . "s"; - } + if (exists $aldb{$address}{empty}) { + $log_msg .= "is empty"; + } elsif (exists $aldb{$address}{duplicate}) { + $log_msg .= "holds a duplicate entry"; + } else { + my ($key) = keys %{$aldb{$address} }; # There's only 1 key + my $aldb_entry = $aldb{$address}{$key}; + my $is_controller = $aldb_entry->{is_controller}; + my $device; + + if ($$self{device}->interface()->device_id() + && $$self{device}->interface()->device_id() eq $aldb_entry->{deviceid}) { + $device = $$self{device}->interface; + } else { + $device = &Insteon::get_object($aldb_entry->{deviceid},'01'); + } + my $object_name = ($device) ? $device->get_object_name : $aldb_entry->{deviceid}; + + my $on_level = 'unknown'; + if (defined $aldb_entry->{data1}) { + if ($aldb_entry->{data1}) { + $on_level = int((hex($aldb_entry->{data1})*100/255) + .5) . "%"; + } else { + $on_level = '0%'; + } + } + + my $rspndr_group = $aldb_entry->{data3}; + $rspndr_group = '01' if $rspndr_group eq '00'; + + my $ramp_rate = 'unknown'; + if ($aldb_entry->{data2}) { + if (!($$self{device}->isa('Insteon::DimmableLight')) or (!$is_controller and ($rspndr_group != '01'))) { + $ramp_rate = 'none'; + $on_level = $on_level eq '0%' ? 'off' : 'on'; + } else { + $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($aldb_entry->{data2}) . "s"; + } + } + + $log_msg .= $is_controller ? "contlr($aldb_entry->{group}) " + . "record to $object_name ($rspndr_group), " + . "(d1:$aldb_entry->{data1}, " + . "d2:$aldb_entry->{data2}, " + . "d3:$aldb_entry->{data3})" + : "rspndr($rspndr_group) record to $object_name " + . "($aldb_entry->{group}): onlevel=$on_level " + . "and ramp=$ramp_rate " + . "(d3:$aldb_entry->{data3})"; } - &::print_log("[Insteon::ALDB_i1] [0x" . $$self{aldb}{$aldbkey}{address} . "] " . - (($$self{aldb}{$aldbkey}{is_controller}) ? "contlr($$self{aldb}{$aldbkey}{group}) record to " - . $object_name . "($rspndr_group), (d1:$$self{aldb}{$aldbkey}{data1}, d2:$$self{aldb}{$aldbkey}{data2}, d3:$$self{aldb}{$aldbkey}{data3})" - : "rspndr($rspndr_group) record to " . $object_name . "($$self{aldb}{$aldbkey}{group})" - . ": onlevel=$on_level and ramp=$ramp_rate (d3:$$self{aldb}{$aldbkey}{data3})")) if $main::Debug{insteon}; + &::print_log($log_msg); } - foreach my $address (@{$$self{aldb}{empty}}) { - &::print_log("[Insteon::ALDB_i1] [0x$address] is empty"); - } - - foreach my $address (@{$$self{aldb}{duplicates}}) { - &::print_log("[Insteon::ALDB_i1] [0x$address] holds a duplicate entry"); - } - } sub update_local_properties @@ -1386,4 +1421,4 @@ sub has_link -1; \ No newline at end of file +1; From 7a6ff85a05a73e947b07e747ff1c205ada94e884 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 7 Feb 2011 17:52:20 +0000 Subject: [PATCH 036/150] --- lib/Insteon/Lighting.pm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index 2f58a4a31..ab3b7046f 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -15,6 +15,9 @@ sub new my $self = new Insteon::BaseDevice($p_deviceid,$p_interface); bless $self,$class; + # include very basic states + @{$$self{states}} = ('on','off'); + return $self; } From dff2beaeb1d4791a559c7efc358a3a2ab9beb34a Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 7 Feb 2011 20:42:48 +0000 Subject: [PATCH 037/150] Add support for sending 'toggle' as a viable set param. --- lib/Insteon/BaseInsteon.pm | 38 ++++++++++++++++++++++++++++++++------ 1 file changed, 32 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index d04833937..399c4b4fa 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -182,6 +182,18 @@ sub set if (($p_state eq 'dim' or $p_state eq 'bright') and !($self->isa('Insteon::DimmableLight'))) { $p_state = 'on'; } + elsif ($p_state eq 'toggle') + { + if ($self->state_now eq 'on') + { + $p_state = 'off'; + } + elsif ($self->state_now eq 'off') + { + $p_state = 'on'; + } + } + my $setby_name = $p_setby; $setby_name = $p_setby->get_object_name() if (ref $p_setby and $p_setby->can('get_object_name')); if (ref $p_setby and (($p_setby eq $self->interface()) @@ -564,6 +576,17 @@ sub _is_valid_state $msg='on'; } } + elsif ($msg eq 'toggle') + { + if ($self->state_now eq 'on') + { + $msg = 'off'; + } + elsif ($self->state_now eq 'off') + { + $msg = 'on'; + } + } # confirm that the resulting $msg is legitimate if (!(defined($$self{message_types}{$msg}))) { @@ -757,7 +780,8 @@ sub unlink_to_interface sub _aldb { my ($self) = @_; - return $$self{aldb}; + my $root_obj = $self->get_root(); + return $$root_obj{aldb}; } @@ -1128,19 +1152,21 @@ sub sync_links $aldbkey .= $linkmember->group; } if (!($member->isa('Insteon::DimmableLight'))) { - if ($tgt_on_level >= 1 and $$member{aldb}{$aldbkey}{data1} ne 'ff') { + my $member_aldb = $member->_aldb; + if ($tgt_on_level >= 1 and $$member_aldb{$aldbkey}{data1} ne 'ff') { $requires_update = 1; $tgt_on_level = 100; - } elsif ($tgt_on_level == 0 and $$member{aldb}{$aldbkey}{data1} ne '00') { + } elsif ($tgt_on_level == 0 and $$member_aldb{$aldbkey}{data1} ne '00') { $requires_update = 1; } - if ($$member{aldb}{$aldbkey}{data2} ne '00') { + if ($$member_aldb{$aldbkey}{data2} ne '00') { $tgt_ramp_rate = 0; } } else { + my $member_aldb = $member->_aldb; $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; - my $link_on_level = hex($$member{aldb}{$aldbkey}{data1})/2.55; - my $raw_ramp_rate = $$member{aldb}{$aldbkey}{data2}; + my $link_on_level = hex($$member_aldb{$aldbkey}{data1})/2.55; + my $raw_ramp_rate = $$member_aldb{$aldbkey}{data2}; my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); if ($raw_ramp_rate != $raw_tgt_ramp_rate) { $requires_update = 1; From 387248ec41974d2ea04a6b735fd2cb5cd471f325 Mon Sep 17 00:00:00 2001 From: peloy Date: Mon, 7 Feb 2011 21:58:51 +0000 Subject: [PATCH 038/150] Thanks to Gregg for committing a change so SET?device=toggle can be used from the web interface. His commit used the state_now() method instead of the state() method to figure out what state we are in. However, state_now() is normally the empty string and only has a state value during the loop iteration following the object's state change. Use state() instead of state_now() to figure out what state the object is in. --- lib/Insteon/BaseInsteon.pm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 399c4b4fa..01dd95667 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -184,11 +184,11 @@ sub set } elsif ($p_state eq 'toggle') { - if ($self->state_now eq 'on') + if ($self->state eq 'on') { $p_state = 'off'; } - elsif ($self->state_now eq 'off') + elsif ($self->state eq 'off') { $p_state = 'on'; } @@ -578,11 +578,11 @@ sub _is_valid_state } elsif ($msg eq 'toggle') { - if ($self->state_now eq 'on') + if ($self->state eq 'on') { $msg = 'off'; } - elsif ($self->state_now eq 'off') + elsif ($self->state eq 'off') { $msg = 'on'; } @@ -1588,4 +1588,4 @@ sub is_root return 0; } -1; \ No newline at end of file +1; From bef0260bd556e14e9a53511fe4c8c5d791145c19 Mon Sep 17 00:00:00 2001 From: gliming Date: Sat, 12 Feb 2011 18:05:08 +0000 Subject: [PATCH 039/150] Add better message for NACKs received from PLM on all link send. --- lib/Insteon_PLM.pm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 4c9bd19fd..c01c253ea 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -415,7 +415,14 @@ sub _parse_data { if $@ and $main::Debug{insteon}; package Insteon_PLM; } - } else { + } + elsif ($record_type eq $prefix{all_link_send}) + { + &::print_log("[Insteon_PLM] WARN: PLM memory does not contain link for: " + . $pending_message->to_string . $@) + } + else + { &::print_log("[Insteon_PLM] WARN: received NACK for " . $pending_message->to_string() . ". If this is a light fixture, check bulb"); @@ -447,7 +454,7 @@ sub _parse_data { my $entered_rcv_loop = 0; - foreach my $data_1 (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})/,$residue_data)) + foreach my $data_1 (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})|($prefix{plm_button_event}\w{2})/,$residue_data)) { #ignore blanks.. the split does odd things next if $data_1 eq ''; From 004c0e862fa9d3487f859061001f8c508efebe67 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 7 Mar 2011 21:27:42 +0000 Subject: [PATCH 040/150] Notify the sending object if it fails due to timeout. --- lib/Insteon/BaseInterface.pm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 6d3572523..04f4ad603 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -180,12 +180,14 @@ sub process_queue if ($self->active_message->send($self) == 0) { - &::print_log("[Insteon_PLM] WARN: number of retries (" + &::print_log("[Insteon::BaseInterface] WARN: number of retries (" . $self->active_message->send_attempts . ") for " . $self->active_message->to_string() . " exceeds limit. Now moving on...") if $main::Debug{insteon}; # !!!!!!!!! TO-DO - handle failure timeout ??? my $failed_message = $self->active_message; + # make sure to let the sending object know!!! + $failed_message->setby->is_acknowledged(0); # clear active message $self->clear_active_message(); @@ -294,7 +296,7 @@ sub on_standard_insteon_received if ($msg{type} ne 'broadcast') { $msg{command} = $object->message_type($msg{cmd_code}); - &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") + &::print_log("[Insteon::BaseInterface] command:$msg{command}; type:$msg{type}; group: $msg{group}") if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; } # &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; @@ -306,7 +308,7 @@ sub on_standard_insteon_received } else { - &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); + &::print_log("[Insteon::BaseInterface] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); } # treat the message as legitimate even if an object match did not occur } @@ -325,10 +327,10 @@ sub on_extended_insteon_received if ($msg{type} ne 'broadcast') { $msg{command} = $object->message_type($msg{cmd_code}); - &::print_log("[Insteon::Message] command:$msg{command}; type:$msg{type}; group: $msg{group}") + &::print_log("[Insteon::BaseInterface] command:$msg{command}; type:$msg{type}; group: $msg{group}") if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; } - &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; + &::print_log("[Insteon::BaseInterface] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; $object->_process_message($self, %msg); if ($msg{is_ack} or $msg{is_nack}) { @@ -337,7 +339,7 @@ sub on_extended_insteon_received } else { - &::print_log("[Insteon_PLM] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); + &::print_log("[Insteon::BaseInterface] Warn! Unable to locate object for source: $msg{source} and group: $msg{group}"); } # treat the message as legitimate even if an object match did not occur } From 7b4d6475b434eb8e51c89842e6648e84aac2f5b7 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 7 Mar 2011 21:45:26 +0000 Subject: [PATCH 041/150] Implement more robust form of is_acknowledged so that object doesn't continue waiting for ACK on timeout. --- lib/Insteon/BaseInsteon.pm | 63 +++++++++++++++++++++++++++----------- 1 file changed, 45 insertions(+), 18 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 01dd95667..54ce1d390 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -230,13 +230,23 @@ sub set sub is_acknowledged { my ($self, $p_ack) = @_; - $$self{is_acknowledged} = $p_ack if defined $p_ack; - if ($p_ack) { - $self->set_receive($$self{pending_state},$$self{pending_setby}, $$self{pending_response}) if defined $$self{pending_state}; + if (defined $p_ack) + { + if ($p_ack) + { + $self->set_receive($$self{pending_state},$$self{pending_setby}, $$self{pending_response}) if defined $$self{pending_state}; + } + else + { + # if we are not acknowledged, then clear the awaiting acknowledgement flag + # we won't do the converse as it is set in _process_command_stack + $$self{awaiting_ack} = 0; + } + $$self{is_acknowledged} = $p_ack; $$self{pending_state} = undef; $$self{pending_setby} = undef; $$self{pending_response} = undef; - } + } return $$self{is_acknowledged}; } @@ -430,27 +440,37 @@ sub _process_message $$self{m_is_locally_set} = 1 if $msg{source} eq lc $self->device_id; if ($msg{is_ack}) { my $pending_cmd = ($$self{_prior_msg}) ? $$self{_prior_msg}->command : $msg{command}; - if ($$self{awaiting_ack}) { + if ($$self{awaiting_ack}) + { my $ack_setby = (ref $$self{m_status_request_pending}) ? $$self{m_status_request_pending} : $p_setby; - if ($self->_is_info_request($pending_cmd,$ack_setby,%msg)) { + if ($self->_is_info_request($pending_cmd,$ack_setby,%msg)) + { $self->is_acknowledged(1); $$self{m_status_request_pending} = 0; $self->_process_command_stack(%msg); - } elsif (($pending_cmd eq 'peek') or ($pending_cmd eq 'set_address_msb')) { + } + elsif (($pending_cmd eq 'peek') or ($pending_cmd eq 'set_address_msb')) + { $self->_aldb->_on_peek(%msg) if $self->_aldb; $self->_process_command_stack(%msg); - } elsif (($pending_cmd eq 'poke') or ($pending_cmd eq 'set_address_msb')) { + } + elsif (($pending_cmd eq 'poke') or ($pending_cmd eq 'set_address_msb')) + { $self->_aldb->_on_poke(%msg) if $self->_aldb; $self->_process_command_stack(%msg); - } else { + } + else + { $self->is_acknowledged(1); # signal receipt of message to the command stack in case commands are queued $self->_process_command_stack(%msg); &::print_log("[Insteon::BaseObject] received command/state (awaiting) acknowledge from " . $self->{object_name} . ": $pending_cmd and data: $msg{extra}") if $main::Debug{insteon}; } - } else { + } + else + { # allow non-synchronous messages to also use the _is_info_request hook $self->_is_info_request($pending_cmd,$p_setby,%msg); $self->is_acknowledged(1); @@ -460,12 +480,17 @@ sub _process_message . ": " . (($msg{command}) ? $msg{command} : "(unknown)") . " and data: $msg{extra}") if $main::Debug{insteon}; } - } elsif ($msg{is_nack}) { - if ($$self{awaiting_ack}) { + } + elsif ($msg{is_nack}) + { +# if ($$self{awaiting_ack}) +# { # NOTE!!! NACKs are usually a sign of a burnt-out bulb!! - &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} - . " ... waiting for retry"); - } else { +# &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} +# . " ... waiting for retry"); +# } +# else +# { if ($self->isa('Insteon::BaseLight')) { &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} @@ -478,8 +503,10 @@ sub _process_message } $self->is_acknowledged(0); $self->_process_command_stack(%msg); - } - } elsif ($msg{command} eq 'start_manual_change') { +# } + } + elsif ($msg{command} eq 'start_manual_change') + { # do nothing; although, maybe anticipate change? we should always get a stop } elsif ($msg{command} eq 'stop_manual_change') { # request status so that the final state can be known @@ -1588,4 +1615,4 @@ sub is_root return 0; } -1; +1; \ No newline at end of file From 7e6c700a5e8d98cf9105ae632759afb6019ba856 Mon Sep 17 00:00:00 2001 From: peloy Date: Wed, 9 Mar 2011 18:25:46 +0000 Subject: [PATCH 042/150] Do not unconditionally delete our "scan insteon link tables" trigger since we would overwrite what the user has done with the trigger (disable it, change trigger run time) when we re-create the trigger after deleting it. Instead, our strategy now is to determine if the trigger exists, if it exists we then save the current trigger information, and then re-create the trigger. Doing it this way preserves users' preferences for our trigger. --- lib/Insteon.pm | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 7172871fa..cb557cbfb 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -163,16 +163,31 @@ sub init { $_sync_cnt = 0; @_scan_devices = (); - # delete the existing trigger if it exists - if (&main::trigger_get('scan insteon link tables')) - { - &main::trigger_delete('scan insteon link tables'); + ################################################################# + ## Trigger creation + ################################################################# + my ($trigger_event, $trigger_code, $trigger_type); + + my @trigger_info = &main::trigger_get('scan insteon link tables'); + if (@trigger_info) { + # Trigger exists; modify just the minimum so the trigger continues + # to work if we change the trigger code, but respect everything + # else (trigger type and time to run). This prevents unconditionally + # re-enabling the trigger if the user has disabled it. + $trigger_event = $trigger_info[0]; + $trigger_type = $trigger_info[2]; + } else { + # Trigger does not exist; create one with our default values. + $trigger_event = "time_cron '00 02 * * *'"; + $trigger_type = 'NoExpire'; } - # create trigger - my $trig_cmd = "time_cron '00 02 * * *'"; - &main::trigger_set($trig_cmd,'&Insteon::scan_all_linktables()','NoExpire','scan insteon link tables') - unless &main::trigger_get('scan insteon link tables'); + $trigger_code = '&Insteon::scan_all_linktables()'; + + # Create/update trigger for a nightly link table scan + &main::trigger_set($trigger_event, $trigger_code, $trigger_type, + 'scan insteon link tables', 1); + ################################################################# @_insteon_plm = (); @_insteon_device = (); From c59cf7face4849f72100b9799f0b9d60635fd438 Mon Sep 17 00:00:00 2001 From: dnorwood2 Date: Sat, 12 Mar 2011 03:29:42 +0000 Subject: [PATCH 043/150] I think I messed up %Debug processing with my last svn commit, so I have backed out my changes to bin/mh. I think my mod to code/common/mh_control.pl actually fixed Jim's problem (and didn't have anything to do with perl 5.12). --- bin/mh | 74 ++++++++++++++++++++++----------------------- lib/Generic_Item.pm | 1 + 2 files changed, 38 insertions(+), 37 deletions(-) diff --git a/bin/mh b/bin/mh index 321ba760b..761b248fc 100755 --- a/bin/mh +++ b/bin/mh @@ -362,14 +362,14 @@ EOF $config_parms{$parm} = $config_parms_startup{$parm}; } - $config_parms{debug} = $config_parms{debug_old} if exists $config_parms{debug_old}; + $config_parms{debug} = $config_parms{debug_old} if defined $config_parms{debug_old}; &set_debug_data; # Populate %Debug } sub set_debug_data { - if (exists $config_parms{debug}) { - if (!exists $Debug{debug_previous} or $config_parms{debug} ne $Debug{debug_previous}) { + 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 @@ -1007,8 +1007,8 @@ sub setup { $exit_flag = 0; - $config_parms{sleep_time} = 50 unless exists $config_parms{sleep_time}; - $config_parms{sleep_count} = 2 unless exists $config_parms{sleep_count}; + $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) @@ -1081,8 +1081,8 @@ sub setup { # 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 exists $config_parms{max_log_entries}; - $config_parms{max_state_log_entries} = 10 unless exists $config_parms{max_state_log_entries}; + $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"; @@ -1186,7 +1186,7 @@ sub register_custom_window { $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"} = (exists $custom_child_windows{"$app $window"})?$custom_child_windows{"$app $window"} + 1:1; + $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; } @@ -1311,7 +1311,7 @@ sub ${location}_hooks { return run_hooks_( '$location', \@_ ) } $type = '0' unless $type; $type = 'persistent' if $type eq '1'; # Grandfathered syntax - unless( exists( $hook_locations{$location} ) ){ + unless( defined( $hook_locations{$location} ) ){ print "add_hook: Invalid hook location, loc=$location hook=$hook\n"; return 0; } @@ -1321,7 +1321,7 @@ sub ${location}_hooks { return run_hooks_( '$location', \@_ ) } return 0; } - $hook_pointers{$location} = [] unless exists ($hook_pointers{$location}); + $hook_pointers{$location} = [] unless defined ($hook_pointers{$location}); if ($type =~ /first/) { unshift( @{$hook_pointers{$location}}, [$hook, $type, @parms] ); @@ -1336,12 +1336,12 @@ sub ${location}_hooks { return run_hooks_( '$location', \@_ ) } sub drop_hook_ { my($location, $hook ) = @_; - unless( exists( $hook_locations{$location} ) ){ + unless( defined( $hook_locations{$location} ) ){ print "drop_hook: Invalid hook location, loc=$location hook=$hook\n"; return 0; } - if( exists ($hook_pointers{$location}) ){ + if( defined ($hook_pointers{$location}) ){ my($h)=$hook_pointers{$location}; my($i)=-1; @@ -1362,7 +1362,7 @@ sub ${location}_hooks { return run_hooks_( '$location', \@_ ) } sub get_hooks_ { my($location) = @_; - return exists $hook_pointers{$location} ? @{$hook_pointers{$location}} : (); + return defined $hook_pointers{$location} ? @{$hook_pointers{$location}} : (); } # call all hooks with user specified args, if any @@ -1526,7 +1526,7 @@ sub check_for_action { for (sort keys %Run_Members) { $Tk_objects{menu_modules}->checkbutton(-label => $_, -variable => \$Run_Members{$_}); - last if $i++ > ((exists $config_parms{tk_module_menu_max} and $config_parms{tk_module_menu_max})?$config_parms{tk_module_menu_max}:50); + last if $i++ > ((defined $config_parms{tk_module_menu_max} and $config_parms{tk_module_menu_max})?$config_parms{tk_module_menu_max}:50); } @@ -1844,8 +1844,8 @@ sub check_for_generic_serial_data { if defined $data and ($Debug{serial} or $Debug{$port_name}); # Check to see if we have a carrage return yet - if (exists $Serial_Ports{$port_name}{data}) { - if (exists($Serial_Ports{$port_name}{datatype}) and $Serial_Ports{$port_name}{datatype} eq 'raw') { + 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 { @@ -1946,7 +1946,7 @@ sub check_for_keyboard_input { '1b5b31357e' => 'F5', '1b5b31377e' => 'F6', '1b5b31387e' => 'F7', '1b5b31397e' => 'F8', '1b5b32317e' => 'F10', '1b5b32337e' => 'F11', '1b5b32347e' => 'F12' ); - $Keyboard = $keymap{$Keyboard} if exists $keymap{$Keyboard}; + $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) { @@ -2023,7 +2023,7 @@ sub add_proxy { } sub drop_proxy { - if (exists $proxy_servers{$_[0]}) { + if (defined $proxy_servers{$_[0]}) { $proxy_servers{$_[0]}->stop; delete $proxy_servers{$_[0]}; &print_log("Removed proxy server: " . $_[0]); @@ -2063,8 +2063,8 @@ sub check_for_proxy_data { if ($type eq 'serial') { # If port was named, store in that hash, otherwise process if ($data[1]) { -# if (exists($Serial_Ports{$data[1]}{object}) and $Serial_Ports{$data[1]}{object} eq 'proxy') { - if (exists($Serial_Ports{$data[1]}{datatype}) and $Serial_Ports{$data[1]}{datatype} eq 'raw') { +# 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 { @@ -2422,7 +2422,7 @@ sub check_for_tied_events { $object1->{set_by} eq $$object2{object_name} ) ) { # $object2->{set_by} = $object1->{object_name}; # $object2->{set_by} = $object1; - my $Set_By = $object1->{set_by}; + 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); @@ -2441,10 +2441,10 @@ sub check_for_tied_events { 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) + print "Event link: state=$state set_by=$Set_By object=$object->{object_name} eval event=$event\n" if $Debug{events}; $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) @@ -2462,7 +2462,7 @@ sub check_for_tied_filters { if ($$self{tied_filters}) { my $searchstate = $state; - $searchstate = lc($searchstate) unless exists $self->{states_casesensitive}; + $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 @@ -2670,7 +2670,7 @@ sub convert_direction { sub display { my %parms = &parse_func_parms(@_); - unless (exists $parms{text} and $parms{text} ne '') { + unless (defined $parms{text} and $parms{text} ne '') { ($parms{text}, $parms{time}, $parms{title}, $parms{font}, $parms{window_name}, $parms{append}) = @_; } @@ -2723,7 +2723,7 @@ sub display { $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 !exists $parms{time} and exists $parms{target} and $parms{target} =~ /^web/); + 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/); @@ -2739,7 +2739,7 @@ sub display { - if (exists($parms{window_name}) and $custom_child_windows{"$parms{app} $parms{window_name}"}) { + 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()"; } @@ -3006,7 +3006,7 @@ sub file_changed { # 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 (exists $file_change_times{$file}) { + unless (defined $file_change_times{$file}) { $file_change_times{$file} = $file_time; return undef; } @@ -3871,7 +3871,7 @@ sub play { } } elsif ($sound_program =~ /play$/) { - if (exists $parms{volume}) { + if (defined $parms{volume}) { my $pervol = $parms{volume} / 100; $sound_program .= " -v $pervol"; } @@ -4950,7 +4950,7 @@ sub read_user_code { # Default the order of user files after common files, # so we can override functions if neede - unless (exists $member_sort_order{$member_name}) { + unless (defined $member_sort_order{$member_name}) { $member_sort_order{$member_name} = ($file =~ /$config_parms{code_dir_common}/) ? 8 : 9; } @@ -6028,7 +6028,7 @@ sub speak { # 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 !exists $parms{$parm}; + $parms{$parm} = $value if defined $value and !defined $parms{$parm}; } if ($phrase =~ /\.wav$/) { @@ -6139,7 +6139,7 @@ sub speak { &net_mail_send(%parms); } elsif ($echo_conduit eq 'telnet') { &respond_telnet(%parms); - } elsif (!(exists($parms{display_rooms}))) { + } elsif (!(defined($parms{display_rooms}))) { my $func = "display_$echo_conduit"; if ($main::{$func}) { no strict 'refs'; @@ -6147,7 +6147,7 @@ sub speak { } } } - if (exists($parms{display_rooms})) { + if (defined($parms{display_rooms})) { &main::route_display_rooms(%parms); } } @@ -6203,11 +6203,11 @@ sub route_display_rooms { &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})) { + if (defined($display_groups{$room})) { # then expand the group my @groups = split(/[,;|]/, $display_groups{$room}); for my $group_room (@groups) { - if (!(exists($targets{$group_room}))) { # prevent duplicates on expansion + if (!(defined($targets{$group_room}))) { # prevent duplicates on expansion my %room_parms = &parse_func_parms($display_rooms{$group_room}); %{$targets{$group_room}} =%room_parms; } @@ -6215,13 +6215,13 @@ sub route_display_rooms { } 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 + if (!(defined($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 + if (!(defined($targets{$room}))) { # prevent duplicates on expansion my %room_parms = &parse_func_parms($display_rooms{$room}); %{$targets{$room}} = %room_parms; } @@ -6483,7 +6483,7 @@ sub toggle_security_mode { sub ras_connect { - if (exists $config_parms{net_connect_entry} and $config_parms{net_connect_entry}) { + 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!) diff --git a/lib/Generic_Item.pm b/lib/Generic_Item.pm index 52b18f769..108f57803 100644 --- a/lib/Generic_Item.pm +++ b/lib/Generic_Item.pm @@ -1199,6 +1199,7 @@ sub xPL_enable { If the state of the generic_item changes, then code will trigger, with the variable $state getting expanded. +The code is a string that will be eval'd. (optional) Setting state limits this tied code to run only when the given state is set. From ceeb0c5305688206477dd8cf956628edebbdac60 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 14 Mar 2011 16:18:06 +0000 Subject: [PATCH 044/150] Guard against objects that are not defined or do not have an is_acknowledged method. --- lib/Insteon/BaseInterface.pm | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 04f4ad603..991387973 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -187,7 +187,15 @@ sub process_queue # !!!!!!!!! TO-DO - handle failure timeout ??? my $failed_message = $self->active_message; # make sure to let the sending object know!!! - $failed_message->setby->is_acknowledged(0); + if (defined($failed_message->setby) and $failed_message->can('is_acknowledged')) + { + $failed_message->setby->is_acknowledged(0); + } + else + { + &main::print_log("[Insteon::BaseInterface] WARN! Unable to clear acknowledge for " + . ((defined($failed_message->setby)) ? $failed_message->setby->get_object_name : "undefined")); + } # clear active message $self->clear_active_message(); @@ -381,4 +389,4 @@ sub _aldb } -1 \ No newline at end of file +1 From 00f4a36f4d5f9089820ee1fdd32781d913399b82 Mon Sep 17 00:00:00 2001 From: jduda Date: Wed, 30 Mar 2011 00:04:00 +0000 Subject: [PATCH 045/150] Update how the polling loops work with DS18S20 and DS2450. Add support for DS2405 and DS2408 devices. --- lib/Owfs_Item.pm | 473 +++++++++++++++++++++++++++++++++++++---------- 1 file changed, 380 insertions(+), 93 deletions(-) diff --git a/lib/Owfs_Item.pm b/lib/Owfs_Item.pm index d2ecbf651..5aa6cbde7 100644 --- a/lib/Owfs_Item.pm +++ b/lib/Owfs_Item.pm @@ -25,18 +25,16 @@ owfs_port = 3030 # defined port where the owfs server is listening Example Usage: - $item = new Owfs_Item ( "", , , ); + $item = new Owfs_Item ( "", ); - of the form family.address; identifies the one-wire device - ASCII string identifier providing a useful name for device_id - - used for devices with multiple ports - - used for devices with multiple channels - $frontDoorBell = new Owfs_Item ( "12.487344000000", "Front DoorBell", undef, "A"); + $frontDoorBell = new Owfs_Item ( "12.487344000000", "Front DoorBell"); $sensor = new Owfs_Item ( "05.4D212A000000"); Owfs_Item can be used as a baseclass and extended for specific one wire devices. - For example, refer to Owfs_DS2450.pm which describes a one wire A/D device. + For example, refer to package Owfs_DS2450 which describes a one wire A/D device. Any of the fields in the one-wire device can be access via the set and get methods. @@ -55,42 +53,43 @@ Example Usage: package Owfs_Item; -@Owfs::ISA = ('Generic_Item'); +@Owfs_Item::ISA = ('Generic_Item'); use OW; my (%objects_by_id); +my $port = undef; sub new { - my ($class, $device, $location, $port, $channel) = @_; + my ($class, $device, $location) = @_; my $self = { }; bless $self,$class; $device =~ /(.*)\.(.*)/; my $family = $1; my $id = $2; + + # Initialize the OWFS perl interface ( server tcp port ) + + if (!defined $port) { + $port = 3030; + $port = "$main::config_parms{owfs_port}" if exists $main::config_parms{owfs_port}; + &main::print_log ("Owfs_Item:: Initializing port: $port $location") if $main::Debug{owfs}; + OW::init ( "$port" ); + } + $self->{device} = $device; $self->{location} = $location; - $self->{port} = $port; - $self->{channel} = $channel; + $self->{present} = undef; $self->{root} = &_find ( $family, $id, 0, "/" ); $self->{path} = $self->{root} . $family . "." . $id . "/"; if (defined $self->{path}) { - $objects_by_id{path} = $self; - &_load ( $self, $self->{path} ); + $objects_by_id{path} = $self; + &_load ( $self, $self->{path} ); } $$self{state} = ''; # Will only be listed on web page if state is defined - if ($self->{type} eq 'DS2405' ) { - push(@{$$self{states}}, 'on', 'off'); - } &dump ( $self ) if ($main::Debug{owfs}); - # Initialize the OWFS perl interface ( server tcp port ) - my $port = 3030; - $port = "$main::config_parms{owfs_port}" if exists $main::config_parms{owfs_port}; - &main::print_log ("Owfs_Item:: Initializing port: $port $location") if $main::Debug{owfs}; - OW::init ( "$port" ); - return $self; } @@ -118,6 +117,12 @@ sub get { return $result; } +sub get_present { + my ($self) = @_; + $self->{present} = $self->get("present"); + return $self->{present}; +} + sub get_root { my ($self, $token) = @_; my $path = $self->{root} . $token; @@ -149,11 +154,11 @@ sub get_location { sub dump { my $self = shift; &main::print_log ( "\n") if $main::Debug{owfs}; - &main::print_log ( "root: \t\t$$self{root}\n") if $main::Debug{owfs}; - &main::print_log ( "path: \t\t$$self{path}\n") if $main::Debug{owfs}; - &main::print_log ( "family: \t$$self{family}\n") if $main::Debug{owfs}; - &main::print_log ( "id: \t\t$$self{id}\n") if $main::Debug{owfs}; - &main::print_log ( "type: \t\t$$self{type}\n") if $main::Debug{owfs}; + &main::print_log ( "root: \t\t$$self{root}") if $main::Debug{owfs}; + &main::print_log ( "path: \t\t$$self{path}") if $main::Debug{owfs}; + &main::print_log ( "family: \t$$self{family}") if $main::Debug{owfs}; + &main::print_log ( "id: \t\t$$self{id}") if $main::Debug{owfs}; + &main::print_log ( "type: \t\t$$self{type}") if $main::Debug{owfs}; for my $key (sort keys %$self) { next if ($key eq "root"); @@ -161,7 +166,7 @@ sub dump { next if ($key eq "family"); next if ($key eq "id"); next if ($key eq "type"); - &main::print_log ( "$key:\t\t$$self{$key}\n") if $main::Debug{owfs}; + &main::print_log ( "$key:\t\t$$self{$key}") if $main::Debug{owfs}; } &main::print_log ( "\n") if $main::Debug{owfs}; } @@ -169,7 +174,7 @@ sub dump { sub _find { my ($family, $id,$lev,$path) = @_; my $result = OW::get($path) or return ; -# &main::print_log ( "_find:: family: $family id: $id lev: $lev path: $path\n") if $main::Debug{owfs}; + #&main::print_log ( "_find:: family: $family id: $id lev: $lev path: $path") if $main::Debug{owfs}; my @tokens = split(',',$result); foreach my $token (@tokens) { if ( $token =~ /\/$/ ) { @@ -189,7 +194,7 @@ sub _find { sub _load { my ($self, $path) = @_; -# &main::print_log ( "_load:: path: $path\n") if $main::Debug{owfs}; +# &main::print_log ( "_load:: path: $path") if $main::Debug{owfs}; my $result = OW::get($path) or return ; my @tokens = split(',',$result); foreach my $token (@tokens) { @@ -220,7 +225,7 @@ Usage: - of the form family.address; identifies the one-wire device - ASCII string identifier providing a useful name for device_id - - seconds between acquisitions + - Optional (defaults to 10). Number of seconds between measurements. Example: @@ -236,54 +241,295 @@ package Owfs_DS18S20; @Owfs_DS18S20::ISA = ('Owfs_Item'); +my @clients = (); +my $index = 0; +my $timer = undef; + sub new { my ($class, $ds18S20, $location, $interval) = @_; - my $self = new Owfs_Item ( $ds18S20, $location ); + my $self = new Owfs_Item ( $ds18S20, $location, $interval ); bless $self,$class; - $interval = 10 unless $interval; - $interval = 10 if ($interval < 10); - $self->{interval} = $interval; + $self->{interval} = 10; + if (defined $interval && ($interval > 1)) { + $self->{interval} = $interval; + } + $self->{present} = 0; + $self->{temperature} = undef; + + if (!defined $timer) { + &::Reload_pre_add_hook(\&Owfs_DS18S20::reload_hook, 1); + $index = 0; + $timer = new Timer; + $timer->set($self->{interval}, sub {&Owfs_DS18S20::run_loop}); + } + + push (@clients,$self); + + if ($self->{interval} < $clients[0]->get_interval( )) { + $clients[0]->set_interval($self->{interval}); + } - $self->{timer} = new Timer; - $self->{timer}->set($self->{interval}, sub {&Owfs_DS18S20::run_loop($self)}); - $self->{temperature} = 0; - $self->{index} = 0; return $self; } +sub get_present { + my ($self) = @_; + return $self->{present}; +} + +sub set_interval { + my ($self,$interval) = @_; + $self->{interval} = $interval if defined $interval; +} + +sub get_interval { + my ($self) = @_; + return $self->{interval}; +} + sub get_temperature { - my $self = shift; - return ($self->{temperature}); + my $self = shift; + return ($self->{temperature}); } -sub state { - my $self = shift; - return ($self->{temperature}); +sub reload_hook { + @clients = (); + my $num = @clients; + &main::print_log( "Owfs_DS18S20::reload_hook $num") if $main::Debug{owfs}; + $timer->set(10, sub {&Owfs_DS18S20::run_loop}); } sub run_loop { - my $self = shift; - my $index = $self->{index}; - &main::print_log ( "Owfs_DS18S20:: index: $index") if $main::Debug{owfs}; + + # exit if we don't have any clients. + return unless @clients; # issue simultaneous to start a conversion - if ($self->{index} == 0) { - $self->set_root ( "simultaneous/temperature", "1" ); + if ($index == 0) { + my $self = $clients[0]; + &main::print_log ( "Owfs_DS18S20:: $index simultaneous") if $main::Debug{owfs}; + $self->set_root ( "simultaneous/temperature", "1" ); } else { - $self->{temperature} = $self->get ( "temperature"); - $self->SUPER::set($$self{temperature}); - &main::print_log ("Owfs_DS18S20 temperature: $$self{temperature}") if $main::Debug{owfs}; + my $self = $clients[$index-1]; + $self->{present} = $self->get("present"); + my $temperature = $self->get("temperature"); + $self->{temperature} = $temperature; + if ($main::Debug{owfs}) { + my $device = $self->{device}; + my $location = $self->{location}; + &main::print_log ("Owfs_DS18S20 $index $device $location temperature: $temperature") if $main::Debug{owfs}; + } } # udpate the index - $self->{index} += 1; - if ($self->{index} >= 2) { - $self->{index} = 0; + $index += 1; + if ($index > @clients) { + $index = 0; } # reschedule the timer for next pass - $self->{timer}->set($self->{interval}, sub {&Owfs_DS18S20::run_loop($self)}); + $timer->set($clients[0]->get_interval( ), sub {&Owfs_DS18S20::run_loop}); +} + +#======================================================================================= +# +# Owfs_DS2405 +# +# This package specifically handles the DS2405 Relay / IO controller. +# +#======================================================================================= + +=begin comment + +Usage: + + $sensor = new Owfs_DS2405 ( "", ); + + - of the form family.address; identifies the one-wire device + - ASCII string identifier providing a useful name for device_id + + Examples: + + my $relay = new Owfs_DS2405 ( "20.DB2506000000", "Some Relay", "0" ); + + // Turn on relay + $relay->set_pio("1"); + + // Turn off relay + $realy->set_pio("0"); + + // Detect input transition + my $doorbell = new Owfs_DS2405 ( "20.DB2506000000", "Front Door Bell", "1", 1 ); + if ($doorbell->get_latch( )) { + print_log ("notice,,, someone is at the front door"); + speak (rooms=>"all", text=> "notice,,, someone is at the front door"); +} + +=cut + +use strict; + +package Owfs_DS2405; + +@Owfs_DS2405::ISA = ('Owfs_Item'); + +sub new { + my ($class, $ds2405, $location ) = @_; + my $self = new Owfs_Item ( $ds2405, $location ); + bless $self,$class; + return $self; +} + +sub set_pio { + my ($self,$value) = @_; + $self->set ("PIO", $value); +} + +sub get_pio { + my ($self) = @_; + my $channel = $self->{channel}; + return ($self->get ("PIO")); +} + + +#======================================================================================= +# +# Owfs_DS2408 +# +# This package specifically handles the DS2408 Relay / IO controller. +# +#======================================================================================= + +=begin comment + +Usage: + + $sensor = new Owfs_DS2408 ( "", , , ); + + - of the form family.address; identifies the one-wire device + - ASCII string identifier providing a useful name for device_id + - "0", "1", "2", "3", "4", "5", "6", "7" + - Optional (defaults to 10). Number of seconds between input samples. + + Examples: + + my $relay = new Owfs_DS2408 ( "20.DB2506000000", "Some Relay", "0" ); + + // Turn on relay + $relay->set_pio("1"); + + // Turn off relay + $realy->set_pio("0"); + + // Detect input transition + my $doorbell = new Owfs_DS2408 ( "20.DB2506000000", "Front Door Bell", "1", 1 ); + if ($doorbell->get_latch( )) { + print_log ("notice,,, someone is at the front door"); + speak (rooms=>"all", text=> "notice,,, someone is at the front door"); +} + +=cut + +use strict; + +package Owfs_DS2408; + +@Owfs_DS2408::ISA = ('Owfs_Item'); + +sub new { + my ($class, $ds2408, $location, $channel, $interval) = @_; + my $self = new Owfs_Item ( $ds2408, $location ); + bless $self,$class; + + $self->{interval} = 10; + if (defined $interval && ($interval >= 1)) { + $self->{interval} = $interval; + } + $self->{present} = 0; + $self->{latch} = 0; + $self->{pass_triggered} = 0; + $self->{sensed} = undef; + $self->{channel} = $channel; + + $self->restore_data('latch'); + + &::Reload_pre_add_hook(\&Owfs_DS2408::reload_hook, 1); + + $self->{timer} = new Timer; + $self->{timer}->set($self->{interval}, sub {&Owfs_DS2408::run_loop($self)}); + + return $self; +} + +sub get_present { + my ($self) = @_; + return $self->{present}; +} + +sub set_interval { + my ($self,$interval) = @_; + $self->{interval} = $interval if defined $interval; +} + +sub get_interval { + my ($self) = @_; + return $self->{interval}; +} + +sub set_pio { + my ($self,$value) = @_; + my $channel = $self->{channel}; + $self->set ("PIO.$channel", $value); +} + +sub get_pio { + my ($self) = @_; + my $channel = $self->{channel}; + return ($self->get ("PIO.$channel")); +} + +sub get_latch { + my ($self) = @_; + my $latch = $self->{latch}; + if ($latch) { + $self->{latch} = 0; + $self->{pass_triggered} = 0; + } + return ($latch); +} + +sub get_sensed { + my $self = shift; + return ($self->{sensed}); +} + +sub reload_hook { +} + +sub run_loop { + my $self = shift; + my $channel = $self->{channel}; + my $latch = $self->get ("latch.$channel"); + $self->{present} = $self->get("present"); + $self->{sensed} = $self->get ("sensed.$channel"); + if ($latch) { + $self->{pass_triggered} = $main::Loop_Count; + $self->{latch} = $latch; + $self->set("latch.$channel", "0"); + } elsif ($self->{pass_triggered} && $self->{pass_triggered} < $main::Loop_Count) { + $self->{latch} = 0; + $self->{pass_triggered} = 0; + } + + if ($main::Debug{owfs}) { + my $device = $self->{device}; + my $location = $self->{location}; + &main::print_log ("Owfs_DS2408 $index $device $location $channel latch: $latch"); + } + + # reschedule the timer for next pass + $self->{timer}->set($self->get_interval( ), sub {&Owfs_DS2408::run_loop($self)}); } #======================================================================================= @@ -303,13 +549,13 @@ Usage: - of the form family.address; identifies the one-wire device - ASCII string identifier providing a useful name for device_id - "A", "B", "C", or "D" - - seconds between acquisitions + - Optional (defaults to 10). Number of seconds between measurements. Example: - $ds2350 = new Owfs_DS2350 ( "20.DB2506000000", "Furnace Sensor", "A", 2 ); + $ds2450 = new Owfs_DS2450 ( "20.DB2506000000", "Furnace Sensor", "A" ); - my $voltage = get_voltage $ds2350; + my $voltage = $ds2450->get_voltage( ); =cut @@ -319,62 +565,103 @@ package Owfs_DS2450; @Owfs_DS2450::ISA = ('Owfs_Item'); +my @clients = (); +my $index = 0; +my $timer = undef; + sub new { my ($class, $ds2450, $location, $channel, $interval) = @_; my $self = new Owfs_Item ( $ds2450, $location ); bless $self,$class; - $interval = 10 unless $interval; - $interval = 10 if ($interval < 10); - $self->{interval} = $interval; + $self->{interval} = 10; + if (defined $interval && ($interval > 1)) { + $self->{interval} = $interval if defined $interval; + } + $self->{present} = 0; + $self->{voltage} = undef; + $self->{channel} = $channel; - $self->{timer} = new Timer; - $self->{timer}->set($self->{interval}, sub {&Owfs_DS2450::run_loop($self)}); + if (!defined $timer) { + &::Reload_pre_add_hook(\&Owfs_DS2450::reload_hook, 1); + $index = 0; + $timer = new Timer; + $timer->set($self->{interval}, sub {&Owfs_DS2450::run_loop}); + } - $self->{channel} = $channel; + push (@clients,$self); + + if ($self->{interval} < $clients[0]->get_interval( )) { + $clients[0]->set_interval($self->{interval}); + } $self->set ( "set_alarm/voltlow.$channel", "1.0" ); $self->set ( "set_alarm/low.$channel", "1" ); $self->set ( "power", "1" ); - $self->{voltage} = 0; - - $self->{index} = 0; + $self->set ( "PIO.$channel", "1" ); return $self; } -sub get_voltage { - my $self = shift; - return ($self->{voltage}); +sub get_present { + my ($self) = @_; + return $self->{present}; } -sub run_loop { - my $self = shift; - my $channel = $self->{channel}; - my $index = $self->{index}; - &main::print_log ( "Owfs_DS2450:: channel: $channel index: $index") if $main::Debug{owfs}; +sub set_interval { + my ($self,$interval) = @_; + $self->{interval} = $interval if defined $interval; +} - # issue simultaneous to start a conversion - if ($self->{index} == 0) { - $self->set_root ( "simultaneous/voltage", "1" ); - } else { - my $token = "alarm/volt.$channel"; - my $voltage = $self->get ( "volt.$channel"); - $self->{voltage} = $voltage; - &main::print_log ("Owfs_DS2450 $channel $token volt: $voltage") if $main::Debug{owfs}; - my $token = "alarm/low.$channel"; - my $trigger = $self->get ( $token ); - &main::print_log ("Owfs_DS2450 $channel $token alarm low: $trigger") if $main::Debug{owfs}; - } +sub get_interval { + my ($self) = @_; + return $self->{interval}; +} - # udpate the index - $self->{index} += 1; - if ($self->{index} >= 2) { - $self->{index} = 0; - } +sub get_voltage { + my $self = shift; + return ($self->{voltage}); +} - # reschedule the timer for next pass - $self->{timer}->set($self->{interval}, sub {&Owfs_DS2450::run_loop($self)}); +sub reload_hook { + @clients = (); + my $num = @clients; + &main::print_log( "Owfs_DS2450::reload_hook $num") if $main::Debug{owfs}; + $timer->set(10, sub {&Owfs_DS2450::run_loop}); +} + +sub run_loop { + + # exit if we don't have any clients. + return unless @clients; + + # issue simultaneous to start a conversion + if ($index == 0) { + my $self = $clients[0]; + my $channel = $self->{channel}; + &main::print_log ( "Owfs_DS2450:: $index simultaneous: $channel index: $index") if $main::Debug{owfs}; + $self->set_root ( "simultaneous/voltage", "1" ); + } else { + my $self = $clients[$index-1]; + my $channel = $self->{channel}; + my $voltage = $self->get ("volt.$channel"); + $self->{present} = $self->get("present"); + $self->{voltage} = $voltage; + if ($main::Debug{owfs}) { + my $device = $self->{device}; + my $location = $self->{location}; + &main::print_log ("Owfs_DS2450 $index $device $location $channel volt: $voltage"); + } + } + + # udpate the index + $index += 1; + if ($index > @clients) { + $index = 0; + } + + # reschedule the timer for next pass + $timer->set($clients[0]->get_interval( ), sub {&Owfs_DS2450::run_loop}); } 1; From 2b1993c4b2076bfc003b263df8ce647bef97a2e9 Mon Sep 17 00:00:00 2001 From: peloy Date: Sun, 17 Apr 2011 16:44:53 +0000 Subject: [PATCH 046/150] Do not hardcode path to .wav file in the web server cache directory when speaking to a .wav file from the web interface. Instead, call html_alias('/cache') to obtain the correct cache directory, which will most likely be "$config_parms{data_dir}/cache" (i.e. outside of the MH distribution which may be read-only), and store the temporary .wav file there. --- lib/http_server.pl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/http_server.pl b/lib/http_server.pl index 62c37e7aa..e7208cd07 100644 --- a/lib/http_server.pl +++ b/lib/http_server.pl @@ -1020,7 +1020,7 @@ sub http_speak_to_wav_start { # Try to To minimized the problem of multiple web browsers # talking at the same time by using a semi-random .wav file name - my $wav_file = "cache/http_server." . int(($Second * rand) * 10000) . ".wav"; + my $wav_file = "http_server." . int(($Second * rand) * 10000) . ".wav"; # Skip if on the local box or empty text (why is empty text passed at all?) @@ -1045,14 +1045,14 @@ sub http_speak_to_wav_start { $tts_text = substr($tts_text, 0, 500) . '. Stopped. Speech Truncated.' if length $tts_text > 500; ($compression = (&is_local_address()) ? 'low' : 'high') unless $compression; - &Voice_Text::speak_text(voice => $voice, to_file => "$config_parms{html_dir}/$wav_file", + &Voice_Text::speak_text(voice => $voice, to_file => &html_alias('/cache') . "/$wav_file", text => $tts_text, compression => $compression, async => 1) unless $webmute; # Some browsers (e.g. Audrey) do not echo port in Host data my $ref = "http://$Http{Host}"; # $ref .= ":$config_parms{http_port}" if $config_parms{http_port} and $ref !~/$config_parms{http_port}$/; $ref .= ":$config_parms{http_port}" if $config_parms{http_port} and $ref !~ /\:/; - $ref .= "/$wav_file"; + $ref .= "/cache/$wav_file"; return $ref; } From 88cd837572165808af2bde3c8adc5ce02c1d56fa Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 20 May 2011 21:09:23 +0000 Subject: [PATCH 047/150] Incorporate failure callback. --- lib/Insteon/BaseInterface.pm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 991387973..a582e5350 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -187,7 +187,7 @@ sub process_queue # !!!!!!!!! TO-DO - handle failure timeout ??? my $failed_message = $self->active_message; # make sure to let the sending object know!!! - if (defined($failed_message->setby) and $failed_message->can('is_acknowledged')) + if (defined($failed_message->setby) and $failed_message->setby->can('is_acknowledged')) { $failed_message->setby->is_acknowledged(0); } @@ -200,9 +200,11 @@ sub process_queue $self->clear_active_message(); # may instead want a "failure" callback separate from success callback - if ($failed_message->callback) { + if ($failed_message->failure_callback) { + &::print_log("[Insteon::BaseInterface] WARN: Now calling callback: " . + $failed_message->failure_callback) if $main::Debug{insteon}; package main; - eval $failed_message->callback; + eval $failed_message->failure_callback; &::print_log("[Insteon::BaseInterface] problem w/ retry callback: $@") if $@; package Insteon::BaseInterface; } @@ -389,4 +391,4 @@ sub _aldb } -1 +1 \ No newline at end of file From dd35c9869c460ea05ea87bb15bc6e47625e038f8 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 20 May 2011 21:10:04 +0000 Subject: [PATCH 048/150] Incorporate success callback. --- lib/Insteon/AllLinkDatabase.pm | 69 ++++++++++++++++++++++++---------- 1 file changed, 50 insertions(+), 19 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 366cf7729..1141812e8 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -156,42 +156,49 @@ sub _on_poke $$self{_mem_action} = 'aldb_group'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_group') { $$self{_mem_action} = 'aldb_devhi'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_devhi') { $$self{_mem_action} = 'aldb_devmid'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_devmid') { $$self{_mem_action} = 'aldb_devlo'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_devlo') { $$self{_mem_action} = 'aldb_data1'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_data1') { $$self{_mem_action} = 'aldb_data2'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_data2') { $$self{_mem_action} = 'aldb_data3'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_data3') { @@ -232,10 +239,10 @@ sub _on_poke } # clear out mem_activity flag $$self{_mem_activity} = undef; - if (defined $$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; + if (defined $$self{_success_callback}) { + my $callback = $$self{_success_callback}; # clear it out *before* the eval - $$self{_mem_callback} = undef; + $$self{_success_callback} = undef; package main; eval ($callback); package Insteon::ALDB_i1; @@ -248,6 +255,7 @@ sub _on_poke $$self{_mem_lsb} = '21'; $$self{_mem_action} = 'local_ramprate'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'local_ramprate') { @@ -261,6 +269,7 @@ sub _on_poke } elsif ($$self{_mem_activity} eq 'update_flags') { # update from eeprom--only a kpl issue $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'delete') { @@ -278,16 +287,16 @@ sub _on_poke delete $$self{aldb}{$key}; } - if (defined $$self{_mem_callback}) { - my $callback = $$self{_mem_callback}; + if (defined $$self{_success_callback}) { + my $callback = $$self{_success_callback}; # clear it out *before* the eval - $$self{_mem_callback} = undef; + $$self{_success_callback} = undef; package main; eval ($callback); &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) if $@ and $main::Debug{insteon}; package Insteon::ALDB_i1; - $$self{_mem_callback} = undef; + $$self{_success_callback} = undef; } } # @@ -326,6 +335,7 @@ sub _on_peek $$self{_mem_action} = 'aldb_flag'; } $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'aldb_flag') { @@ -342,13 +352,13 @@ sub _on_peek $$self{_mem_activity} = undef; &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " completed link memory scan") if $main::Debug{insteon}; - if (defined $$self{_mem_callback}) { + if (defined $$self{_success_callback}) { package main; - eval ($$self{_mem_callback}); + eval ($$self{_success_callback}); &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . ": error during scan callback $@") if $@ and $main::Debug{insteon}; package Insteon::ALDB_i1; - $$self{_mem_callback} = undef; + $$self{_success_callback} = undef; } # ping the device as part of the scan if we don't already have a devcat # if (!($self->{devcat})) { @@ -361,6 +371,7 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_group'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } @@ -369,11 +380,13 @@ sub _on_peek $$self{pending_aldb}{flag} = $flag; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($flag); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $flag, 'is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'delete') { $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra('02'); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => '02', 'is_synchronous' => 1); } @@ -383,12 +396,14 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devhi'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, # 'is_synchronous' => 1); } else { $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{group}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{group}, # 'is_synchronous' => 1); @@ -399,12 +414,14 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devmid'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'add') { my $devid = substr($$self{pending_aldb}{deviceid},0,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); } @@ -414,12 +431,14 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devlo'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'add') { my $devid = substr($$self{pending_aldb}{deviceid},2,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); } @@ -429,12 +448,14 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_data1'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'add') { my $devid = substr($$self{pending_aldb}{deviceid},4,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); } @@ -444,12 +465,14 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{pending_aldb}{data1} = $msg{extra}; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { # poke the new value $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{data1}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data1}, 'is_synchronous' => 1); } @@ -459,12 +482,14 @@ sub _on_peek $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_data3'; $message->extra($$self{_mem_lsb}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { # poke the new value $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{data2}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data2}, 'is_synchronous' => 1); } @@ -501,6 +526,7 @@ sub _on_peek # poke the new value $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{data3}); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data3}, 'is_synchronous' => 1); } @@ -509,6 +535,7 @@ sub _on_peek $on_level = &Insteon::DimmableLight::convert_level($on_level); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($on_level); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $on_level, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'local_ramprate') { @@ -516,12 +543,14 @@ sub _on_peek $ramp_rate = '1f' unless $ramp_rate; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($ramp_rate); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $ramp_rate, 'is_synchronous' => 1); } elsif ($$self{_mem_action} eq 'update_flags') { my $flags = $$self{_operating_flags}; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($flags); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'poke', 'extra' => $flags, 'is_synchronous' => 1); } @@ -534,9 +563,10 @@ sub _on_peek sub scan_link_table { - my ($self,$callback) = @_; + my ($self,$success_callback,$failure_callback) = @_; $$self{_mem_activity} = 'scan'; - $$self{_mem_callback} = ($callback) ? $callback : undef; + $$self{_success_callback} = ($success_callback) ? $success_callback : undef; + $$self{_failure_callback} = ($failure_callback) ? $failure_callback : undef; $self->_peek('0FF8',0); } @@ -551,7 +581,7 @@ sub delete_link %link_parms = &main::parse_func_parms($parms_text); } if ($link_parms{address}) { - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $$self{_mem_activity} = 'delete'; $$self{pending_aldb}{address} = $link_parms{address}; $self->_peek($link_parms{address},0); @@ -574,7 +604,7 @@ sub delete_link &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$address] with the following data" . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); # now, alter the flags byte such that the in_use flag is set to 0 - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $$self{_mem_activity} = 'delete'; $$self{pending_aldb}{deviceid} = lc $deviceid; $$self{pending_aldb}{group} = $groupid; @@ -803,7 +833,7 @@ sub add_link my $address = pop @{$$self{aldb}{empty}}; # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails $$self{_mem_activity} = 'add'; - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); } } @@ -837,7 +867,7 @@ sub update_link } my $address = $$self{aldb}{$key}{address}; $$self{_mem_activity} = 'update'; - $$self{_mem_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $self->_write_link($address, $deviceid, $group, $is_controller, $data1, $data2, $data3); } @@ -1025,6 +1055,7 @@ sub _peek &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " accessing memory at location: 0x" . $address); my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'set_address_msb'); $message->extra($msb); + $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'set_address_msb', 'extra' => $msb, 'is_synchronous' => 1); } @@ -1324,7 +1355,7 @@ sub delete_link . $$self{aldb}{$linkkey}{data1} . $$self{aldb}{$linkkey}{data2} . $$self{aldb}{$linkkey}{data3}; - $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; + $$self{_success_callback} = $link_parms{callback} if $link_parms{callback}; delete $$self{aldb}{$linkkey}; $num_deleted = 1; my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); @@ -1392,7 +1423,7 @@ sub add_link . $data1 . $data2 . $data3; - $$self{_mem_callback} = $link_parms{callback} if $link_parms{callback}; + $$self{_success_callback} = $link_parms{callback} if $link_parms{callback}; $$self{aldb}{$linkkey}{flags} = lc $flags; $$self{aldb}{$linkkey}{group} = lc $group; $$self{aldb}{$linkkey}{is_controller} = $is_controller; @@ -1421,4 +1452,4 @@ sub has_link -1; +1; \ No newline at end of file From 19458a3fd0e78a378096eb50f6f69623af502746 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 20 May 2011 21:10:34 +0000 Subject: [PATCH 049/150] Incorporate failure callback. --- lib/Insteon/BaseInsteon.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 54ce1d390..7d38313c7 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -913,11 +913,11 @@ sub add_link sub scan_link_table { - my ($self, $callback) = @_; + my ($self, $success_callback, $failure_callback) = @_; my $aldb = $self->get_root()->_aldb; if ($aldb) { - return $aldb->scan_link_table($callback); + return $aldb->scan_link_table($success_callback, $failure_callback); } } From f5ff506def3306942f6309aebbf5f3f344190743 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 20 May 2011 21:11:44 +0000 Subject: [PATCH 050/150] Incorporate failure callback facility as well as other bug fixes. --- lib/Insteon/Message.pm | 1238 ++++++++++++++++++++-------------------- 1 file changed, 624 insertions(+), 614 deletions(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 6d7ed666c..448d53f01 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -1,614 +1,624 @@ - -package Insteon::BaseMessage; - -use strict; -use Insteon; - -sub new -{ - my ($class) = @_; - my $self={}; - bless $self,$class; - - $$self{send_attempts} = 0; - - return $self; -} - -sub interface_data -{ - my ($self, $interface_data) = @_; - if ($interface_data) - { - $$self{interface_data} = $interface_data; - } - return $$self{interface_data}; -} - -sub queue_time -{ - my ($self, $queue_time) = @_; - if ($queue_time) - { - $$self{queue_time} = $queue_time; - } - return $$self{queue_time}; -} - -sub callback -{ - my ($self, $callback) = @_; - if ($callback) - { - $$self{callback} = $callback; - } - return $$self{callback}; -} - -sub send_attempts -{ - my ($self, $send_attempts) = @_; - if ($send_attempts) - { - $$self{send_attempts} = $send_attempts; - } - return $$self{send_attempts}; -} - -sub setby -{ - my ($self, $setby) = @_; - if ($setby) - { - $$self{setby} = $setby; - } - return $$self{setby}; -} - -sub respond -{ - my ($self, $respond) = @_; - if ($respond) - { - $$self{respond} = $respond; - } - return $$self{respond}; -} - -sub send -{ - my ($self, $interface) = @_; - if ($self->send_attempts < 5) - { - - if ($self->send_attempts > 0) - { - &::print_log("[Insteon::BaseMessage] WARN: now resending " - . $self->to_string() . " after " . $self->send_attempts - . " attempts.") if $main::Debug{insteon}; - } - - # need to set timeout as a function of retries; also need to alter hop count - - $self->send_attempts($self->send_attempts + 1); - $interface->_send_cmd($self, $self->send_timeout); - if ($self->callback) { - package main; - eval $self->callback; - &::print_log("[Insteon::BaseMessage] problem w/ retry callback: $@") if $@; - package Insteon::Message; - } - return 1; - } - else - { - return 0; - } - -} - -sub send_timeout -{ - my ($self, $timeout) = @_; - $$self{send_timeout} = $timeout if defined $timeout; - return $$self{send_timeout}; -} - -sub to_string -{ - my ($self) = @_; - return $self->interface_data; -} - -package Insteon::InsteonMessage; -use strict; -use Insteon; - -@Insteon::InsteonMessage::ISA = ('Insteon::BaseMessage'); - -sub new -{ - my ($class, $command_type, $setby, $command, $extra) = @_; - my $self= new Insteon::BaseMessage(); - bless $self,$class; - - $self->command_type($command_type); - $self->setby($setby); - $self->command($command); - $self->extra($extra); - $self->send_timeout(2000); - - return $self; -} - - -sub command_to_hash -{ - my ($p_state) = @_; - my %msg = (); - my $hopflag = hex(uc substr($p_state,13,1)); - $msg{hopsleft} = $hopflag >> 2; - my $msgflag = hex(uc substr($p_state,12,1)); - $msg{is_extended} = (0x01 & $msgflag) ? 1 : 0; - if ($msg{is_extended}) { - $msg{source} = substr($p_state,0,6); - $msg{destination} = substr($p_state,6,6); - $msg{extra} = substr($p_state,16,16); - } else { - $msg{source} = substr($p_state,0,6); - $msgflag = $msgflag >> 1; - if ($msgflag == 4) { - $msg{type} = 'broadcast'; - $msg{devcat} = substr($p_state,6,4); - $msg{firmware} = substr($p_state,10,2); - $msg{is_master} = substr($p_state,16,2); - $msg{dev_attribs} = substr($p_state,18,2); - } elsif ($msgflag ==6) { - $msg{type} = 'alllink'; - $msg{group} = substr($p_state,10,2); - } else { - $msg{destination} = substr($p_state,6,6); - if ($msgflag == 2) { - $msg{type} = 'cleanup'; - $msg{group} = substr($p_state,16,2); - } elsif ($msgflag == 3) { - $msg{type} = 'cleanup'; - $msg{is_ack} = 1; - } elsif ($msgflag == 7) { - $msg{type} = 'cleanup'; - $msg{is_nack} = 1; - } elsif ($msgflag == 0) { - $msg{type} = 'direct'; - $msg{extra} = substr($p_state,16,2); - } elsif ($msgflag == 1) { - $msg{type} = 'direct'; - $msg{is_ack} = 1; - $msg{extra} = substr($p_state,16,2); - } elsif ($msgflag == 5) { - $msg{type} = 'direct'; - $msg{is_nack} = 1; - } - } - } - $msg{cmd_code} = substr($p_state,14,2); - - return %msg; -} - - -sub command -{ - my ($self, $command) = @_; - $$self{command} = $command if $command; - return $$self{command}; -} - -sub command_type -{ - my ($self, $command_type) = @_; - $$self{command_type} = $command_type if $command_type; - return $$self{command_type}; -} - -sub extra -{ - my ($self, $extra) = @_; - $$self{extra} = $extra if $extra; - return $$self{extra}; -} - -sub send_timeout -{ -# hop timing in seconds; this method returns timeout in millisconds -# hops standard extended -# ---- -------- -------- -# 0 1.40 2.22 -# 1 1.70 2.69 -# 2 1.90 3.01 -# 3 2.00 3.17 - - my ($self, $ignore) = @_; - if ($self->command_type eq 'all_link_send') - { - # note, the following was set to 2000 and that was insufficient - return 3000; - } - elsif ($self->command_type eq 'insteon_ext_send') - { - if ($self->send_attempts == 1) - { - return 2220; - } - elsif ($self->send_attempts == 2) - { - return 2690; - } - elsif ($self->send_attempts == 3) - { - return 3000; - } - elsif ($self->send_attempts >= 4) - { - return 3170; - } - } - else - { - if ($self->send_attempts == 1) - { - return 1400; - } - elsif ($self->send_attempts == 2) - { - return 1700; - } - elsif ($self->send_attempts == 3) - { - return 1900; - } - elsif ($self->send_attempts >= 4) - { - return 2000; - } - } -} - -sub to_string -{ - my ($self) = @_; - my $result = ''; - if ($self->setby) - { - $result .= 'obj=' . $self->setby->get_object_name; - } - if ($result) - { - $result .= '; '; - } - $result .= 'command=' . $self->command; - if ($self->extra) - { - $result .= '; extra=' . $self->extra; - } - - return $result; -} - -sub interface_data -{ - my ($self, $interface_data) = @_; - my $result = $self->SUPER::interface_data($interface_data); - if (!($result) && - (($self->command_type eq 'insteon_send') - or ($self->command_type eq 'insteon_ext_send') - or ($self->command_type eq 'all_link_send'))) - { - return $self->_derive_interface_data(); - } - else - { - return $result; - } -} - -sub _derive_interface_data -{ - - my ($self) = @_; - my $cmd = ''; - my $level; - if ($self->command_type =~ /all_link_send/i) { - $cmd.=$self->setby->group; - } else { - $cmd.=$self->setby->device_id(); - if ($self->command_type =~ /insteon_ext_send/i) { - if ($self->send_attempts == 1) - { - $cmd.='15'; - } - elsif ($self->send_attempts == 2) - { - $cmd.='1A'; - } - elsif ($self->send_attempts >= 3) - { - $cmd.='1F'; - } - } else { - if ($self->send_attempts == 1) - { - $cmd.='05'; - } - elsif ($self->send_attempts == 2) - { - $cmd.='0A'; - } - elsif ($self->send_attempts >= 3) - { - $cmd.='0F'; - } - } - } - $cmd.= unpack("H*",pack("C",$self->setby->message_type_code($self->command))); - if ($self->extra) - { - $cmd.= $self->extra; - } - elsif ($self->command_type eq 'insteon_send') - { # auto append '00' if no extra defined for a standard insteon send - $cmd .= '00'; - } - - return $cmd; - -} - -package Insteon::X10Message; -use strict; -use Insteon; - -@Insteon::X10Message::ISA = ('Insteon::BaseMessage'); - -my %x10_house_codes = ( - a => 0x6, - b => 0xE, - c => 0x2, - d => 0xA, - e => 0x1, - f => 0x9, - g => 0x5, - h => 0xD, - i => 0x7, - j => 0xF, - k => 0x3, - l => 0xB, - m => 0x0, - n => 0x8, - o => 0x4, - p => 0xC -); - -my %mh_house_codes = ( - '6' => 'a', - 'e' => 'b', - '2' => 'c', - 'a' => 'd', - '1' => 'e', - '9' => 'f', - '5' => 'g', - 'd' => 'h', - '7' => 'i', - 'f' => 'j', - '3' => 'k', - 'b' => 'l', - '0' => 'm', - '8' => 'n', - '4' => 'o', - 'c' => 'p' -); - -my %x10_unit_codes = ( - 1 => 0x6, - 2 => 0xE, - 3 => 0x2, - 4 => 0xA, - 5 => 0x1, - 6 => 0x9, - 7 => 0x5, - 8 => 0xD, - 9 => 0x7, - 10 => 0xF, - a => 0xF, - 11 => 0x3, - b => 0x3, - 12 => 0xB, - c => 0xB, - 13 => 0x0, - d => 0x0, - 14 => 0x8, - e => 0x8, - 15 => 0x4, - f => 0x4, - 16 => 0xC, - g => 0xC - -); - -my %mh_unit_codes = ( - '6' => '1', - 'e' => '2', - '2' => '3', - 'a' => '4', - '1' => '5', - '9' => '6', - '5' => '7', - 'd' => '8', - '7' => '9', - 'f' => 'a', - '3' => 'b', - 'b' => 'c', - '0' => 'd', - '8' => 'e', - '4' => 'f', - 'c' => 'g' -); - -my %x10_commands = ( - on => 0x2, - j => 0x2, - off => 0x3, - k => 0x3, - bright => 0x5, - l => 0x5, - dim => 0x4, - m => 0x4, - preset_dim1 => 0xA, - preset_dim2 => 0xB, - all_off => 0x0, - p => 0x0, - all_lights_on => 0x1, - o => 0x1, - all_lights_off => 0x6, - status => 0xF, - status_on => 0xD, - status_off => 0xE, - hail_ack => 0x9, - ext_code => 0x7, - ext_data => 0xC, - hail_request => 0x8 -); - -my %mh_commands = ( - '2' => 'J', - '3' => 'K', - '5' => 'L', - '4' => 'M', - 'a' => 'preset_dim1', - 'b' => 'preset_dim2', -# '0' => 'all_off', - '0' => 'P', -# '1' => 'all_lights_on', - '1' => 'O', - '6' => 'all_lights_off', - 'f' => 'status', - 'd' => 'status_on', - 'e' => 'status_off', - '9' => 'hail_ack', - '7' => 'ext_code', - 'c' => 'ext_data', - '8' => 'hail_request' -); - -sub new -{ - my ($class, $interface_data) = @_; - my $self= new Insteon::BaseMessage(); - bless $self,$class; - - $self->interface_data($interface_data); - $self->send_timeout(2000); - - return $self; -} - -sub get_formatted_data -{ - my ($self) = @_; - - my $data = $self->interface_data; - - my $msg=undef; - if (uc(substr($data,length($data)-2,2)) eq '00') - { - $msg = "X"; - $msg.= uc($mh_house_codes{substr($data,4,1)}); - $msg.= uc($mh_unit_codes{substr($data,5,1)}); - for (my $index =6; $index{id_by_state}{$cmd}); - - my $hc = lc(substr($p_setby->{x10_id},1,1)); - my $uc = lc(substr($p_setby->{x10_id},2,1)); - - if ($hc eq undef) { - &main::print_log("[Insteon::Message] Object:$p_setby Doesnt have an x10 id (yet)"); - return undef; - } - - if ($uc eq undef) { - &main::print_log("[Insteon::Message] Message is for entire HC") if $main::Debug{insteon}; - } - else { - - #Every X10 message starts with the House and unit code - $msg = substr(unpack("H*",pack("C",$x10_house_codes{substr($id,1,1)})),1,1); - $msg.= substr(unpack("H*",pack("C",$x10_unit_codes{substr($id,2,1)})),1,1); - $msg.= "00"; - &main::print_log("[Insteon_PLM] x10 sending code: " . uc($hc . $uc) . " as insteon msg: " - . $msg) if $main::Debug{insteon}; - - push @data, $msg; - } - - my $ecmd; - #Iterate through the rest of the pairs of nibbles - my $spos = 3; - if ($uc eq undef) {$spos=1;} -# &::print_log("PLM:PAIR:$id:$spos:$ecmd:"); - for (my $pos = $spos; $possend_attempts < 5) + { + + if ($self->send_attempts > 0) + { + &::print_log("[Insteon::BaseMessage] WARN: now resending " + . $self->to_string() . " after " . $self->send_attempts + . " attempts.") if $main::Debug{insteon}; + } + + # need to set timeout as a function of retries; also need to alter hop count + + $self->send_attempts($self->send_attempts + 1); + $interface->_send_cmd($self, $self->send_timeout); + if ($self->callback) { + package main; + eval $self->callback; + &::print_log("[Insteon::BaseMessage] problem w/ retry callback: $@") if $@; + package Insteon::Message; + } + return 1; + } + else + { + return 0; + } + +} + +sub send_timeout +{ + my ($self, $timeout) = @_; + $$self{send_timeout} = $timeout if defined $timeout; + return $$self{send_timeout}; +} + +sub to_string +{ + my ($self) = @_; + return $self->interface_data; +} + +package Insteon::InsteonMessage; +use strict; +use Insteon; + +@Insteon::InsteonMessage::ISA = ('Insteon::BaseMessage'); + +sub new +{ + my ($class, $command_type, $setby, $command, $extra) = @_; + my $self= new Insteon::BaseMessage(); + bless $self,$class; + + $self->command_type($command_type); + $self->setby($setby); + $self->command($command); + $self->extra($extra); + $self->send_timeout(2000); + + return $self; +} + + +sub command_to_hash +{ + my ($p_state) = @_; + my %msg = (); + my $hopflag = hex(uc substr($p_state,13,1)); + $msg{hopsleft} = $hopflag >> 2; + my $msgflag = hex(uc substr($p_state,12,1)); + $msg{is_extended} = (0x01 & $msgflag) ? 1 : 0; + if ($msg{is_extended}) { + $msg{source} = substr($p_state,0,6); + $msg{destination} = substr($p_state,6,6); + $msg{extra} = substr($p_state,16,16); + } else { + $msg{source} = substr($p_state,0,6); + $msgflag = $msgflag >> 1; + if ($msgflag == 4) { + $msg{type} = 'broadcast'; + $msg{devcat} = substr($p_state,6,4); + $msg{firmware} = substr($p_state,10,2); + $msg{is_master} = substr($p_state,16,2); + $msg{dev_attribs} = substr($p_state,18,2); + } elsif ($msgflag ==6) { + $msg{type} = 'alllink'; + $msg{group} = substr($p_state,10,2); + } else { + $msg{destination} = substr($p_state,6,6); + if ($msgflag == 2) { + $msg{type} = 'cleanup'; + $msg{group} = substr($p_state,16,2); + } elsif ($msgflag == 3) { + $msg{type} = 'cleanup'; + $msg{is_ack} = 1; + } elsif ($msgflag == 7) { + $msg{type} = 'cleanup'; + $msg{is_nack} = 1; + } elsif ($msgflag == 0) { + $msg{type} = 'direct'; + $msg{extra} = substr($p_state,16,2); + } elsif ($msgflag == 1) { + $msg{type} = 'direct'; + $msg{is_ack} = 1; + $msg{extra} = substr($p_state,16,2); + } elsif ($msgflag == 5) { + $msg{type} = 'direct'; + $msg{is_nack} = 1; + } + } + } + $msg{cmd_code} = substr($p_state,14,2); + + return %msg; +} + + +sub command +{ + my ($self, $command) = @_; + $$self{command} = $command if $command; + return $$self{command}; +} + +sub command_type +{ + my ($self, $command_type) = @_; + $$self{command_type} = $command_type if $command_type; + return $$self{command_type}; +} + +sub extra +{ + my ($self, $extra) = @_; + $$self{extra} = $extra if $extra; + return $$self{extra}; +} + +sub send_timeout +{ +# hop timing in seconds; this method returns timeout in millisconds +# hops standard extended +# ---- -------- -------- +# 0 1.40 2.22 +# 1 1.70 2.69 +# 2 1.90 3.01 +# 3 2.00 3.17 + + my ($self, $ignore) = @_; + if ($self->command_type eq 'all_link_send') + { + # note, the following was set to 2000 and that was insufficient + return 3000; + } + elsif ($self->command_type eq 'insteon_ext_send') + { + if ($self->send_attempts == 1) + { + return 2220; + } + elsif ($self->send_attempts == 2) + { + return 2690; + } + elsif ($self->send_attempts == 3) + { + return 3000; + } + elsif ($self->send_attempts >= 4) + { + return 3170; + } + } + else + { + if ($self->send_attempts == 1) + { + return 1400; + } + elsif ($self->send_attempts == 2) + { + return 1700; + } + elsif ($self->send_attempts == 3) + { + return 1900; + } + elsif ($self->send_attempts >= 4) + { + return 2000; + } + } +} + +sub to_string +{ + my ($self) = @_; + my $result = ''; + if ($self->setby) + { + $result .= 'obj=' . $self->setby->get_object_name; + } + if ($result) + { + $result .= '; '; + } + $result .= 'command=' . $self->command; + if ($self->extra) + { + $result .= '; extra=' . $self->extra; + } + + return $result; +} + +sub interface_data +{ + my ($self, $interface_data) = @_; + my $result = $self->SUPER::interface_data($interface_data); + if (!($result) && + (($self->command_type eq 'insteon_send') + or ($self->command_type eq 'insteon_ext_send') + or ($self->command_type eq 'all_link_send'))) + { + return $self->_derive_interface_data(); + } + else + { + return $result; + } +} + +sub _derive_interface_data +{ + + my ($self) = @_; + my $cmd = ''; + my $level; + if ($self->command_type =~ /all_link_send/i) { + $cmd.=$self->setby->group; + } else { + $cmd.=$self->setby->device_id(); + if ($self->command_type =~ /insteon_ext_send/i) { + if ($self->send_attempts == 1) + { + $cmd.='15'; + } + elsif ($self->send_attempts == 2) + { + $cmd.='1A'; + } + elsif ($self->send_attempts >= 3) + { + $cmd.='1F'; + } + } else { + if ($self->send_attempts == 1) + { + $cmd.='05'; + } + elsif ($self->send_attempts == 2) + { + $cmd.='0A'; + } + elsif ($self->send_attempts >= 3) + { + $cmd.='0F'; + } + } + } + $cmd.= unpack("H*",pack("C",$self->setby->message_type_code($self->command))); + if ($self->extra) + { + $cmd.= $self->extra; + } + elsif ($self->command_type eq 'insteon_send') + { # auto append '00' if no extra defined for a standard insteon send + $cmd .= '00'; + } + + return $cmd; + +} + +package Insteon::X10Message; +use strict; +use Insteon; + +@Insteon::X10Message::ISA = ('Insteon::BaseMessage'); + +my %x10_house_codes = ( + a => 0x6, + b => 0xE, + c => 0x2, + d => 0xA, + e => 0x1, + f => 0x9, + g => 0x5, + h => 0xD, + i => 0x7, + j => 0xF, + k => 0x3, + l => 0xB, + m => 0x0, + n => 0x8, + o => 0x4, + p => 0xC +); + +my %mh_house_codes = ( + '6' => 'a', + 'e' => 'b', + '2' => 'c', + 'a' => 'd', + '1' => 'e', + '9' => 'f', + '5' => 'g', + 'd' => 'h', + '7' => 'i', + 'f' => 'j', + '3' => 'k', + 'b' => 'l', + '0' => 'm', + '8' => 'n', + '4' => 'o', + 'c' => 'p' +); + +my %x10_unit_codes = ( + 1 => 0x6, + 2 => 0xE, + 3 => 0x2, + 4 => 0xA, + 5 => 0x1, + 6 => 0x9, + 7 => 0x5, + 8 => 0xD, + 9 => 0x7, + 10 => 0xF, + a => 0xF, + 11 => 0x3, + b => 0x3, + 12 => 0xB, + c => 0xB, + 13 => 0x0, + d => 0x0, + 14 => 0x8, + e => 0x8, + 15 => 0x4, + f => 0x4, + 16 => 0xC, + g => 0xC + +); + +my %mh_unit_codes = ( + '6' => '1', + 'e' => '2', + '2' => '3', + 'a' => '4', + '1' => '5', + '9' => '6', + '5' => '7', + 'd' => '8', + '7' => '9', + 'f' => 'a', + '3' => 'b', + 'b' => 'c', + '0' => 'd', + '8' => 'e', + '4' => 'f', + 'c' => 'g' +); + +my %x10_commands = ( + on => 0x2, + j => 0x2, + off => 0x3, + k => 0x3, + bright => 0x5, + l => 0x5, + dim => 0x4, + m => 0x4, + preset_dim1 => 0xA, + preset_dim2 => 0xB, + all_off => 0x0, + p => 0x0, + all_lights_on => 0x1, + o => 0x1, + all_lights_off => 0x6, + status => 0xF, + status_on => 0xD, + status_off => 0xE, + hail_ack => 0x9, + ext_code => 0x7, + ext_data => 0xC, + hail_request => 0x8 +); + +my %mh_commands = ( + '2' => 'J', + '3' => 'K', + '5' => 'L', + '4' => 'M', + 'a' => 'preset_dim1', + 'b' => 'preset_dim2', +# '0' => 'all_off', + '0' => 'P', +# '1' => 'all_lights_on', + '1' => 'O', + '6' => 'all_lights_off', + 'f' => 'status', + 'd' => 'status_on', + 'e' => 'status_off', + '9' => 'hail_ack', + '7' => 'ext_code', + 'c' => 'ext_data', + '8' => 'hail_request' +); + +sub new +{ + my ($class, $interface_data) = @_; + my $self= new Insteon::BaseMessage(); + bless $self,$class; + + $self->interface_data($interface_data); + $self->send_timeout(2000); + + return $self; +} + +sub get_formatted_data +{ + my ($self) = @_; + + my $data = $self->interface_data; + + my $msg=undef; + if (uc(substr($data,length($data)-2,2)) eq '00') + { + $msg = "X"; + $msg.= uc($mh_house_codes{substr($data,4,1)}); + $msg.= uc($mh_unit_codes{substr($data,5,1)}); + for (my $index =6; $index{id_by_state}{$cmd}); + + my $hc = lc(substr($p_setby->{x10_id},1,1)); + my $uc = lc(substr($p_setby->{x10_id},2,1)); + + if ($hc eq undef) { + &main::print_log("[Insteon::Message] Object:$p_setby Doesnt have an x10 id (yet)"); + return undef; + } + + if ($uc eq undef) { + &main::print_log("[Insteon::Message] Message is for entire HC") if $main::Debug{insteon}; + } + else { + + #Every X10 message starts with the House and unit code + $msg = substr(unpack("H*",pack("C",$x10_house_codes{substr($id,1,1)})),1,1); + $msg.= substr(unpack("H*",pack("C",$x10_unit_codes{substr($id,2,1)})),1,1); + $msg.= "00"; + &main::print_log("[Insteon_PLM] x10 sending code: " . uc($hc . $uc) . " as insteon msg: " + . $msg) if $main::Debug{insteon}; + + push @data, $msg; + } + + my $ecmd; + #Iterate through the rest of the pairs of nibbles + my $spos = 3; + if ($uc eq undef) {$spos=1;} +# &::print_log("PLM:PAIR:$id:$spos:$ecmd:"); + for (my $pos = $spos; $pos Date: Fri, 20 May 2011 21:14:27 +0000 Subject: [PATCH 051/150] Incorporate improved error tracking and handling when scanning link tables. --- lib/Insteon.pm | 76 +++++++++++++++++++++++++++++--------------------- 1 file changed, 44 insertions(+), 32 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index cb557cbfb..8b8a95735 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -6,15 +6,23 @@ use strict; #@ This module creates voice commands for all insteon related items. -my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_scan_failure_cnt,$_sync_cnt,$_sync_failure_cnt); +my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_sync_cnt,$_sync_failure_cnt); my $init_complete; -my (@_scan_devices); +my (@_scan_devices,@_scan_device_failures,$current_scan_device); sub scan_all_linktables { + if ($current_scan_device) + { + &main::print_log("[Scan all linktables] WARN: link already underway. Ignoring request for new scan ..."); + return; + } + my @candidate_devices = (); # clear @_scan_devices @_scan_devices = (); + @_scan_device_failures = (); + $current_scan_device = undef; # alwayws include the active interface (e.g., plm) push @_scan_devices, &Insteon::active_interface; @@ -24,58 +32,62 @@ sub scan_all_linktables foreach (@candidate_devices) { my $candidate_object = $_; - if (!($candidate_object->isa('Insteon::RemoteLinc') + if ($candidate_object->is_root and + !($candidate_object->isa('Insteon::RemoteLinc') or $candidate_object->isa('Insteon::InterfaceController') or $candidate_object->isa('Insteon::MotionSensor'))) { push @_scan_devices, $candidate_object; + &main::print_log("[Scan all linktables] INFO: " + . $candidate_object->get_object_name + . " will be scanned.") if $main::Debug{insteon}; } else { - &main::print_log("[Scan all linktables] Note: " + &main::print_log("[Scan all linktables] INFO: !!! " . $candidate_object->get_object_name - . " is not a candidate for scanning."); + . " is NOT a candidate for scanning."); } } $_scan_cnt = scalar @_scan_devices; - $_scan_failure_cnt = 0; &_get_next_linkscan(); } -sub _get_next_linkscan +sub _get_next_linkscan_failure { - my ($prior_failure) = @_; - if ($prior_failure) - { - $_scan_failure_cnt++; - } - else - { - $_scan_failure_cnt = 0; - } + push @_scan_device_failures, $current_scan_device; + &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " + . $current_scan_device->get_object_name . ". Moving on..."); + &_get_next_linkscan(); - my $current_obj = $_scan_devices[0]; - my $next_obj = shift @_scan_devices; - if ($_scan_failure_cnt > 0) - { - &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " - . $current_obj->get_object_name . ". Moving on..."); - } - # remove the queue_timer_callback -# if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); -# } +} - if ($next_obj) +sub _get_next_linkscan +{ + $current_scan_device = shift @_scan_devices; + + if ($current_scan_device) { &main::print_log("[Scan all link tables] Now scanning: " - . $next_obj->get_object_name . " (" + . $current_scan_device->get_object_name . " (" . ($_scan_cnt - scalar @_scan_devices) . " of $_scan_cnt)"); - $next_obj->scan_link_table('&Insteon::_get_next_linkscan()'); + # pass first the success callback followed by the failure callback + $current_scan_device->scan_link_table('&Insteon::_get_next_linkscan()','&Insteon::_get_next_linkscan_failure()'); } else { - return undef; + &main::print_log("[Scan all link tables] All tables have completed scanning"); + my $_scan_failure_cnt = scalar @_scan_device_failures; + if ($_scan_failure_cnt) + { + &main::print_log("[Scan all link tables] However, some failures were noted:"); + for my $failed_obj (@_scan_device_failures) + { + &main::print_log("[Scan all link tables] WARN: failure occurred when scanning " + . $failed_obj->get_object_name); + } + } + } } @@ -473,4 +485,4 @@ sub find_members { return @l_found; } -1 +1 \ No newline at end of file From 79d8a6047b22a61afa11ca2b9c59043a4fa0dbf1 Mon Sep 17 00:00:00 2001 From: jduda Date: Thu, 9 Jun 2011 23:57:59 +0000 Subject: [PATCH 052/150] Fix the get_sensed( ) method in Owfs_DS2408. This method was not returning 0 when the input was low. --- lib/Owfs_Item.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Owfs_Item.pm b/lib/Owfs_Item.pm index 5aa6cbde7..94b26aa4a 100644 --- a/lib/Owfs_Item.pm +++ b/lib/Owfs_Item.pm @@ -501,7 +501,7 @@ sub get_latch { sub get_sensed { my $self = shift; - return ($self->{sensed}); + return ($self->{sensed} eq 1 ? 1 : 0); } sub reload_hook { @@ -521,7 +521,7 @@ sub run_loop { $self->{latch} = 0; $self->{pass_triggered} = 0; } - + if ($main::Debug{owfs}) { my $device = $self->{device}; my $location = $self->{location}; From cc7ab68ef0b5a931a02a3b91334a9bf124cf57f7 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 10 Jun 2011 16:58:51 +0000 Subject: [PATCH 053/150] Adjust "to_string" method to report interface_data instead of "command" to provide better diagnostic for PLM-specific commands. --- lib/Insteon/Message.pm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 448d53f01..64b83d7f2 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -295,7 +295,14 @@ sub to_string { $result .= '; '; } - $result .= 'command=' . $self->command; + if ($self->command) + { + $result .= 'command=' . $self->command; + } + else + { + $result .= 'interface_data=' . $self->interface_data; + } if ($self->extra) { $result .= '; extra=' . $self->extra; From 7f624efecbce1bc4901d5a31c0c580bc5828944f Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 10 Jun 2011 16:59:30 +0000 Subject: [PATCH 054/150] Major problems with linking--too numerous to elaborate. --- lib/Insteon/AllLinkDatabase.pm | 279 +++++++++++++++++++++++---------- 1 file changed, 197 insertions(+), 82 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 1141812e8..c4db0e2cf 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -627,7 +627,7 @@ sub delete_link sub delete_orphan_links { - my ($self) = @_; + my ($self, $audit_mode) = @_; @{$$self{delete_queue}} = (); # reset the work queue my $selfname = $$self{device}->get_object_name; my $num_deleted = 0; @@ -638,30 +638,49 @@ sub delete_orphan_links my $group = $$self{aldb}{$linkkey}{group}; my $is_controller = $$self{aldb}{$linkkey}{is_controller}; my $data3 = $$self{aldb}{$linkkey}{data3}; + # $device is the object that is referenced by the ALDB record's deviceid my $device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface : &Insteon::get_object($deviceid,'01'); if (!($device)) { -# &::print_log("[AllLinkDataBase] " . $self->get_object_name . " now deleting orphaned link w/ details: " -# . (($is_controller) ? "controller" : "responder") -# . ", deviceid=$deviceid, group=$group"); - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + # no device is known by mh with the ADLB record's deviceid + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " + . (($is_controller) ? "controller" : "responder") + . ", deviceid=$deviceid, group=$group"); + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, callback => "$selfname->_process_delete_queue()", cause => "no device could be found"); - push @{$$self{delete_queue}}, \%delete_req; + push @{$$self{delete_queue}}, \%delete_req; + } } elsif ($device->isa("Insteon::BaseInterface") and $is_controller) { # ignore since this is just a link back to the PLM } elsif ($device->isa("Insteon::BaseInterface")) { # does the PLM have a link point back? If not, the delete this one - if (!($device->has_link($self,$group,1))) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; + if (!($device->has_link($$self{device},$group,1))) { + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) " . $device->get_object_name . + " now deleting orphaned link w/ details: " + . (($is_controller) ? "controller" : "responder") + . ", deviceid=$deviceid, group=$group, data=$data3"); + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3, + cause => 'PLM does not have a link pointing back to device'); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } } # is there an entry in the items.mht that corresponds to this link? if ($is_controller) { # TO-DO: handle this case } else { - my $plm_link = $device->get_device('000000',$group); + my $plm_link = &Insteon::get_object('000000', $group); if ($plm_link) { my $is_invalid = 1; foreach my $member_ref (keys %{$$plm_link{members}}) { @@ -672,7 +691,7 @@ sub delete_orphan_links $member = @lights[0]; # pick the first } } - if ($member->device_id eq $self->device_id) { + if ($member->device_id eq $$self{device}->device_id) { if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { $is_invalid = 0; last; @@ -680,31 +699,62 @@ sub delete_orphan_links } } if ($is_invalid) { + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan link because none defined for PLM controlled scene " + . $device->get_object_name . + " details: " + . (($is_controller) ? "controller" : "responder") + . ", deviceid=$deviceid, group=$group, data=$data3"); + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link is defined for the plm controlled scene", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + } else { + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no PLM link defined to: " + . (($is_controller) ? "controller" : "responder") + . "=$selfname" . "($group), data=$data3"); + } + else + { + # delete the link since it doesn't exist my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no link is defined for the plm controlled scene", data3 => $data3); + cause => "no plm link could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; - } - } else { - # delete the link since it doesn't exist - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no plm link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; + } } } } else { if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no PLM link defined " + . $device->get_object_name . + " details: " + . (($is_controller) ? "controller" : "responder") + . ", deviceid=$deviceid, group=$group, data=$data3"); + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, callback => "$selfname->_process_delete_queue()", object => $device, cause => "no link to the device could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } } else { my $is_invalid = 1; - my $link = ($is_controller) ? &Insteon::get_object($self->device_id,$group) + my $link = ($is_controller) ? &Insteon::get_object($$self{device}->device_id,$group) : &Insteon::get_object($device->device_id,$group); if ($link) { foreach my $member_ref (keys %{$$link{members}}) { @@ -715,36 +765,62 @@ sub delete_orphan_links $member = @lights[0]; # pick the first } } - if ($member->isa('Insteon::BaseDevice') and !($member->is_root)) { + if ($member->isa('Insteon::BaseDevice') && !($member->is_root)) + { $member = $member->get_root; } - if ($member->isa('Insteon::BaseDevice') and !($is_controller) and ($member->device_id eq $self->device_id)) { + + if ($member->isa('Insteon::BaseDevice') && !($is_controller) + && ($member->device_id eq $$self{device}->device_id)) + { $is_invalid = 0; last; - } elsif ($member->isa('Insteon::BaseDevice') and $is_controller and ($member->device_id eq $device->device_id)) { + } + elsif ($member->isa('Insteon::BaseDevice') && $is_controller + && ($member->device_id eq $device->device_id)) + { $is_invalid = 0; last; } - } } if ($is_invalid) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no reverse link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT ) Delete orphan because no reverse link could be found " + . $device->get_object_name . + " details: " + . (($is_controller) ? "controller" : "responder") + . ", deviceid=$deviceid, group=$group, data=$data3"); + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no reverse link could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } } } } } elsif ($linkkey eq 'duplicates') { my $address = pop @{$$self{aldb}{duplicates}}; while ($address) { - my %delete_req = (address => $address, - callback => "$selfname->_process_delete_queue()", - cause => "duplicate record found"); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because duplicate found " + . $$self{device}->get_object_name + . " address=$address"); + } + else + { + my %delete_req = (address => $address, + callback => "$selfname->_process_delete_queue()", + cause => "duplicate record found"); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } $address = pop @{$$self{aldb}{duplicates}}; } } @@ -757,23 +833,26 @@ sub delete_orphan_links sub _process_delete_queue { my ($self) = @_; my $num_in_queue = @{$$self{delete_queue}}; - if ($num_in_queue) { + if ($num_in_queue) + { my $delete_req_ptr = shift(@{$$self{delete_queue}}); my %delete_req = %$delete_req_ptr; if ($delete_req{address}) { - &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting duplicate record at address " + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " now deleting duplicate record at address " . $delete_req{address}); } else { - &::print_log("[AllLinkDataBase] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " . (($delete_req{is_controller}) ? "controller" : "responder") . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); } - $self->delete_link(%delete_req); +# $self->delete_link(%delete_req); $$self{delete_queue_processed}++; - } else { - $self->interface->_process_delete_queue($$self{delete_queue_processed}); } +# else +# { +# $$self{device}->interface->_aldb->_process_delete_queue($$self{delete_queue_processed}); +# } } sub add_link @@ -827,7 +906,7 @@ sub add_link . " light level controlled by " . $insteon_object->get_object_name . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; my $data1 = &Insteon::DimmableLight::convert_level($on_level); - my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data2 = ($$self{device}->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; # get the first available memory location my $address = pop @{$$self{aldb}{empty}}; @@ -855,7 +934,7 @@ sub update_link my $data1 = sprintf('%02X',$on_level * 2.55); $data1 = 'ff' if $on_level eq '100'; $data1 = '00' if $on_level eq '0'; - my $data2 = ($self->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data2 = ($$self{device}->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; my $deviceid = $insteon_object->device_id; my $subaddress = $data3; @@ -997,7 +1076,7 @@ sub has_link my $key = ""; if ($insteon_object->isa('Insteon::BaseObject') || $insteon_object->isa('Insteon::BaseInterface')) { $key = lc $insteon_object->device_id . $group . $is_controller; - } else { + } elsif ($insteon_object->isa('Insteon::AllLinkDatabase')) { $key = lc $$insteon_object{device}->device_id . $group . $is_controller; } $subaddress = '00' unless $subaddress; @@ -1210,7 +1289,7 @@ sub get_next_alllink sub delete_orphan_links { - my ($self) = @_; + my ($self, $audit_mode) = @_; @{$$self{delete_queue}} = (); # reset the work queue my $selfname = $$self{device}->get_object_name; my $num_deleted = 0; @@ -1222,10 +1301,20 @@ sub delete_orphan_links my $device = &Insteon::get_object($deviceid,'01'); # if a PLM link (regardless of responder or controller) exists to a device that is not known, then delete if (!($device)) { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $self, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete Orphan Link to non-existant device " . + " device: " . + $deviceid . "; group: $group; is_controller: $is_controller, data: $data3") + if $main::Debug{insteon}; + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $self, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } } else { my $is_invalid = 1; my $link = undef; @@ -1235,53 +1324,79 @@ sub delete_orphan_links $link = &Insteon::get_object('000000',$group); if (!($link)) { # a reference in the PLM's linktable does not match a scene member target - $is_invalid = 1; - } else { + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete Orphan PLM controller link ($group) to: " + . $device->get_object_name() . "($data3)") + if $main::Debug{insteon}; + } + else + { + my %delete_req = (object => $device, group => $group, is_controller => 1, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $self, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } + } + else + { # iterate over all of the members of the Insteon_Link item - foreach my $member_ref (keys %{$$link{members}}) { + foreach my $member_ref (keys %{$$link{members}}) + { my $member = $$link{members}{$member_ref}{object}; # member will correspond to a scene member item # and, if it is a light item, then get the real device - if ($member->isa('Light_Item')) { + if ($member->isa('Light_Item')) + { my @lights = $member->find_members('Insteon::BaseLight'); - if (@lights) { + if (@lights) + { $member = @lights[0]; # pick the first } } - if ($member->isa('Insteon::BaseDevice')) { + if ($member->isa('Insteon::BaseDevice')) + { my $linkmember = $member; # make sure that this is a root device - if (!($member->is_root)) { + if (!($member->is_root)) + { $member = $member->get_root; } - if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) { + if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) + { # at this point, the forward link is ok; but, only if the reverse # link also exists. So, check: - if ($member->has_link($self, $group, 0, $data3)) { + if ($member->has_link($self, $group, 0, $data3)) + { $is_invalid = 0; } last; } - } else { + } + else + { $is_invalid = 0; } - } + } # foreach $$link{members} if ($is_invalid) { # then, there is a good chance that a reciprocal link exists; if so, delet it too if ($device->has_link($self,$group,0, $data3)) { - my %delete_req = (object => $self, group => $group, is_controller => 0, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $device, data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete Orphan PLM responder link ($group) from: " . + $device->get_object_name() . "($data3)") + if $main::Debug{insteon}; + } + else + { + my %delete_req = (object => $self, group => $group, is_controller => 0, + callback => "$selfname->_process_delete_queue(1)", + linkdevice => $device, data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + } } - } - } - if ($is_invalid) { - my %delete_req = (object => $device, group => $group, is_controller => 1, - callback => "$selfname->_process_delete_queue(1)", - linkdevice => $self, data3 => $data3); -# push @{$$self{delete_queue}}, \%delete_req; - } + } # if $is_invalid + } # else } } } @@ -1289,14 +1404,14 @@ sub delete_orphan_links $$self{delete_queue_processed} = 0; # reset the counter # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links - for my $obj (&Insteon::find_members('Insteon::BaseObject')) + for my $obj (&Insteon::find_members('Insteon::BaseDevice')) { #Match on real objects only if (($obj->is_root)) { -# $num_deleted += $obj->delete_orphan_links(); -# my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); -# push @{$$self{delete_queue}}, \%delete_req; + $num_deleted += $obj->delete_orphan_links($audit_mode); + my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); + push @{$$self{delete_queue}}, \%delete_req; } } $self->_process_delete_queue(); @@ -1398,7 +1513,7 @@ sub add_link my $linkkey = lc $device_id . $group . $is_controller; if (defined $$self{aldb}{$linkkey}) { &::print_log("[Insteon::ALDB_PLM] WARN: attempt to add link to PLM that already exists! " - . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); + . "deviceid=" . $device_id . ", group=$group, is_controller=$is_controller"); if ($link_parms{callback}) { package main; eval ($link_parms{callback}); From 06cf1416e7ecc3e6f426f6624f55d6533862667c Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 10 Jun 2011 17:00:22 +0000 Subject: [PATCH 055/150] Multiple changes to address linking problems. --- lib/Insteon/BaseInterface.pm | 53 ++++++++++++++++++++++++++---------- 1 file changed, 39 insertions(+), 14 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index a582e5350..7af40d326 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -97,8 +97,43 @@ sub _is_duplicate sub has_link { my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; - my $key = lc $insteon_object->device_id . $group . $is_controller; - return (defined $$self{links}{$key}) ? 1 : 0; + if ($self->_aldb) + { + return $self->_aldb->has_link($insteon_object, $group, $is_controller, $subaddress); + } + return 0; +} + +sub add_link +{ + my ($self, $parms_text) = @_; + if ($self->_aldb) + { + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + $self->_aldb->add_link(%link_parms); + } +} + +sub delete_link +{ + my ($self, $parms_text) = @_; + if ($self->_aldb) + { + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + $self->_aldb->delete_link(%link_parms); + } } sub active_message @@ -240,16 +275,6 @@ sub device_id { return $$self{deviceid}; } -sub get_device -{ - my ($self, $p_deviceid, $p_group) = @_; - foreach my $device (&Insteon::find_members('Insteon::BaseDevice')) { - if (lc $device->device_id eq lc $p_deviceid and lc $device->group eq lc $p_group) { - return $device; - } - } -} - sub restore_string { my ($self) = @_; @@ -275,8 +300,8 @@ sub log_alllink_table sub delete_orphan_links { - my ($self) = @_; - return $self->_aldb->delete_orphan_links if $self->_aldb; + my ($self, $audit_mode) = @_; + return $self->_aldb->delete_orphan_links($audit_mode) if $self->_aldb; } ###################### From ed8a6a13e8a486eb55859796b80fb6ad93603469 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 10 Jun 2011 17:01:13 +0000 Subject: [PATCH 056/150] Multiple changes to address linking problems. --- lib/Insteon/BaseInsteon.pm | 43 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 41 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 7d38313c7..00a55554c 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -120,6 +120,10 @@ sub interface if (defined $p_interface) { $$self{interface} = $p_interface; } + elsif (!($$self{interface})) + { + $$self{interface} = &Insteon::active_interface; + } return $$self{interface}; } @@ -911,6 +915,40 @@ sub add_link } +sub update_link +{ + my ($self, $parms_text) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + $aldb->update_link(%link_parms); + } +} + +sub delete_link +{ + my ($self, $parms_text) = @_; + my $aldb = $self->get_root()->_aldb; + if ($aldb) + { + my %link_parms; + if (@_ > 2) { + shift @_; + %link_parms = @_; + } else { + %link_parms = &main::parse_func_parms($parms_text); + } + $aldb->delete_link(%link_parms); + } +} + sub scan_link_table { my ($self, $success_callback, $failure_callback) = @_; @@ -974,6 +1012,7 @@ sub restore_string } $restore_string .= $self->{object_name} . "->restore_states(q~$states~);\n"; } + return $restore_string; } @@ -1042,8 +1081,8 @@ sub local_ramprate sub delete_orphan_links { - my ($self) = @_; - return $self->_aldb->delete_orphan_links if $self->_aldb; + my ($self, $audit_mode) = @_; + return $self->_aldb->delete_orphan_links($audit_mode) if $self->_aldb; } sub _process_delete_queue { From f21607621e5816732bfb18bf18d0a33fda48d482 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 10 Jun 2011 17:02:25 +0000 Subject: [PATCH 057/150] Switch inheritance ordering for SwitchLinc and KeypadLinc classes to that restore_data (after reload) works properly. --- lib/Insteon/Lighting.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index ab3b7046f..468548a9d 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -204,7 +204,7 @@ package Insteon::SwitchLincRelay; use strict; use Insteon::BaseInsteon; -@Insteon::SwitchLincRelay::ISA = ('Insteon::DeviceController','Insteon::BaseLight'); +@Insteon::SwitchLincRelay::ISA = ('Insteon::BaseLight','Insteon::DeviceController'); sub new @@ -222,7 +222,7 @@ package Insteon::SwitchLinc; use strict; use Insteon::BaseInsteon; -@Insteon::SwitchLinc::ISA = ('Insteon::DeviceController','Insteon::DimmableLight'); +@Insteon::SwitchLinc::ISA = ('Insteon::DimmableLight','Insteon::DeviceController'); sub new { @@ -292,7 +292,7 @@ package Insteon::KeyPadLinc; use strict; use Insteon::BaseInsteon; -@Insteon::KeyPadLinc::ISA = ('Insteon::DeviceController', 'Insteon::DimmableLight'); +@Insteon::KeyPadLinc::ISA = ('Insteon::DimmableLight','Insteon::DeviceController'); sub new From a06a1ee3c2ce929ea3188c65bc1fc40e3570c802 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 10 Jun 2011 17:03:18 +0000 Subject: [PATCH 058/150] Add "AUDIT" mode for the orphan links command. --- lib/Insteon.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 8b8a95735..deaae0484 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -274,7 +274,7 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,scan link tables"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,AUDIT: delete orphan links,scan link tables"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -282,6 +282,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','show link table to log');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT: delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','messaging debug on');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','messaging debug off');\n\n"; $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan link tables');\n\n"; From 64ab720f3df24ca2f4974c6bbe927c0ce79a5691 Mon Sep 17 00:00:00 2001 From: jduda Date: Sat, 11 Jun 2011 15:13:08 +0000 Subject: [PATCH 059/150] Add support for the DS2413 device. --- lib/Owfs_Item.pm | 140 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 139 insertions(+), 1 deletion(-) diff --git a/lib/Owfs_Item.pm b/lib/Owfs_Item.pm index 94b26aa4a..e6937a233 100644 --- a/lib/Owfs_Item.pm +++ b/lib/Owfs_Item.pm @@ -392,7 +392,6 @@ sub get_pio { return ($self->get ("PIO")); } - #======================================================================================= # # Owfs_DS2408 @@ -532,6 +531,145 @@ sub run_loop { $self->{timer}->set($self->get_interval( ), sub {&Owfs_DS2408::run_loop($self)}); } +#======================================================================================= +# +# Owfs_DS2413 +# +# This package specifically handles the DS2413 Dual Channel Addressable Switch. +# +#======================================================================================= + +=begin comment + +Usage: + + $sensor = new Owfs_DS2413 ( "", , , ); + + - of the form family.address; identifies the one-wire device + - ASCII string identifier providing a useful name for device_id + - Channel identifier, "A" or "B" + - Optional (defaults to 10). Number of seconds between input samples. + + Examples: + + my $switch = new Owfs_DS2413 ( "20.DB2506000000", "Some Switch", "A" ); + + // Turn on switch + $switch->set_pio("1"); + + // Turn off switch + $switch->set_pio("0"); + + // Detect input transition + my $doorbell = new Owfs_DS2413 ( "20.DB2506000000", "Front Door Bell", "A", 1 ); + if ($doorbell->get_latch( )) { + print_log ("notice,,, someone is at the front door"); + speak (rooms=>"all", text=> "notice,,, someone is at the front door"); +} + +=cut + +use strict; + +package Owfs_DS2413; + +@Owfs_DS2413::ISA = ('Owfs_Item'); + +sub new { + my ($class, $ds2413, $location, $channel, $interval) = @_; + my $self = new Owfs_Item ( $ds2413, $location ); + bless $self,$class; + + $self->{interval} = 10; + if (defined $interval && ($interval >= 1)) { + $self->{interval} = $interval; + } + $self->{present} = 0; + $self->{latch} = 0; + $self->{pass_triggered} = 0; + $self->{sensed} = undef; + $self->{channel} = $channel; + + $self->restore_data('latch'); + + &::Reload_pre_add_hook(\&Owfs_DS2413::reload_hook, 1); + + $self->{timer} = new Timer; + $self->{timer}->set($self->{interval}, sub {&Owfs_DS2413::run_loop($self)}); + + return $self; +} + +sub get_present { + my ($self) = @_; + return $self->{present}; +} + +sub set_interval { + my ($self,$interval) = @_; + $self->{interval} = $interval if defined $interval; +} + +sub get_interval { + my ($self) = @_; + return $self->{interval}; +} + +sub set_pio { + my ($self,$value) = @_; + my $channel = $self->{channel}; + $self->set ("PIO.$channel", $value); +} + +sub get_pio { + my ($self) = @_; + my $channel = $self->{channel}; + return ($self->get ("PIO.$channel")); +} + +sub get_latch { + my ($self) = @_; + my $latch = $self->{latch}; + if ($latch) { + $self->{latch} = 0; + $self->{pass_triggered} = 0; + } + return ($latch); +} + +sub get_sensed { + my $self = shift; + return ($self->{sensed} eq 1 ? 1 : 0); +} + +sub reload_hook { +} + +sub run_loop { + my $self = shift; + my $channel = $self->{channel}; + my $latch = $self->get ("latch.$channel"); + $self->{present} = $self->get("present"); + $self->{sensed} = $self->get ("sensed.$channel"); + if ($latch) { + $self->{pass_triggered} = $main::Loop_Count; + $self->{latch} = $latch; + $self->set("latch.$channel", "0"); + } elsif ($self->{pass_triggered} && $self->{pass_triggered} < $main::Loop_Count) { + $self->{latch} = 0; + $self->{pass_triggered} = 0; + } + + if ($main::Debug{owfs}) { + my $device = $self->{device}; + my $location = $self->{location}; + &main::print_log ("Owfs_DS2413 $index $device $location $channel latch: $latch"); + } + + # reschedule the timer for next pass + $self->{timer}->set($self->get_interval( ), sub {&Owfs_DS2413::run_loop($self)}); +} + #======================================================================================= # # Owfs_DS2450 From 65a80eb713b5c59cde28ea6a7dcb9b4c116d9286 Mon Sep 17 00:00:00 2001 From: jduda Date: Sun, 12 Jun 2011 14:08:29 +0000 Subject: [PATCH 060/150] The DS2413 does not have an input latch, so remove the get_latch method from DS2413. --- lib/Owfs_Item.pm | 25 +------------------------ 1 file changed, 1 insertion(+), 24 deletions(-) diff --git a/lib/Owfs_Item.pm b/lib/Owfs_Item.pm index e6937a233..4c017270d 100644 --- a/lib/Owfs_Item.pm +++ b/lib/Owfs_Item.pm @@ -585,13 +585,9 @@ sub new { $self->{interval} = $interval; } $self->{present} = 0; - $self->{latch} = 0; - $self->{pass_triggered} = 0; $self->{sensed} = undef; $self->{channel} = $channel; - $self->restore_data('latch'); - &::Reload_pre_add_hook(\&Owfs_DS2413::reload_hook, 1); $self->{timer} = new Timer; @@ -627,16 +623,6 @@ sub get_pio { return ($self->get ("PIO.$channel")); } -sub get_latch { - my ($self) = @_; - my $latch = $self->{latch}; - if ($latch) { - $self->{latch} = 0; - $self->{pass_triggered} = 0; - } - return ($latch); -} - sub get_sensed { my $self = shift; return ($self->{sensed} eq 1 ? 1 : 0); @@ -648,22 +634,13 @@ sub reload_hook { sub run_loop { my $self = shift; my $channel = $self->{channel}; - my $latch = $self->get ("latch.$channel"); $self->{present} = $self->get("present"); $self->{sensed} = $self->get ("sensed.$channel"); - if ($latch) { - $self->{pass_triggered} = $main::Loop_Count; - $self->{latch} = $latch; - $self->set("latch.$channel", "0"); - } elsif ($self->{pass_triggered} && $self->{pass_triggered} < $main::Loop_Count) { - $self->{latch} = 0; - $self->{pass_triggered} = 0; - } if ($main::Debug{owfs}) { my $device = $self->{device}; my $location = $self->{location}; - &main::print_log ("Owfs_DS2413 $index $device $location $channel latch: $latch"); + &main::print_log ("Owfs_DS2413 $index $device $location $channel"); } # reschedule the timer for next pass From 33a88f73cd6c3dbdceefa0c4f0ce027912f282c5 Mon Sep 17 00:00:00 2001 From: peloy Date: Mon, 13 Jun 2011 16:34:19 +0000 Subject: [PATCH 061/150] Replace ':' with '-' in voice command "AUDIT: delete orphan links" since using ':' as a word delimiter breaks the Tk interface, apparently because ':' has some special significance for Tk. --- lib/Insteon.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index deaae0484..6c805ede4 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -274,7 +274,7 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,AUDIT: delete orphan links,scan link tables"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,AUDIT - delete orphan links,scan link tables"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -282,7 +282,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table','show link table to log');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT: delete orphan links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','messaging debug on');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','messaging debug off');\n\n"; $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan link tables');\n\n"; @@ -486,4 +486,4 @@ sub find_members { return @l_found; } -1 \ No newline at end of file +1 From bc20513bf2cc8d0e5be08d9d08702dd3c3be4150 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 14 Jun 2011 19:53:45 +0000 Subject: [PATCH 062/150] Explicitly specify set methods for SwitchLinc and SwitchLincRelay since automatic inheritance doesn't apply. --- lib/Insteon/Lighting.pm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index 468548a9d..289a3ea5b 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -216,6 +216,14 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + return $self->Insteon::DeviceController::set($link_state, $p_setby, $p_respond); +} package Insteon::SwitchLinc; @@ -233,6 +241,12 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + return $self->Insteon::DeviceController::set($p_state, $p_setby, $p_respond); +} package Insteon::KeyPadLincRelay; From eb00566488f858115f449b8890a9ea7cf13dae74 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 14 Jun 2011 19:54:20 +0000 Subject: [PATCH 063/150] Change inheritance order to ensure proper link restoration on reload. --- lib/Insteon/Controller.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon/Controller.pm b/lib/Insteon/Controller.pm index 478f2f890..3d11e6786 100755 --- a/lib/Insteon/Controller.pm +++ b/lib/Insteon/Controller.pm @@ -4,7 +4,7 @@ package Insteon::RemoteLinc; use strict; use Insteon::BaseInsteon; -@Insteon::RemoteLinc::ISA = ('Insteon::DeviceController','Insteon::BaseDevice'); +@Insteon::RemoteLinc::ISA = ('Insteon::BaseDevice','Insteon::DeviceController'); my %message_types = ( %Insteon::BaseDevice::message_types, From a9b6947634311f1d925ec088f4c857bc99bb08cd Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 14 Jun 2011 19:54:52 +0000 Subject: [PATCH 064/150] Improve logging--especially audit mode. --- lib/Insteon/AllLinkDatabase.pm | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index c4db0e2cf..a2e586dad 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -738,11 +738,23 @@ sub delete_orphan_links if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { if ($audit_mode) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no PLM link defined " - . $device->get_object_name . - " details: " - . (($is_controller) ? "controller" : "responder") - . ", deviceid=$deviceid, group=$group, data=$data3"); + if ($is_controller) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reciprocal link defined for: " + . $$self{device}->get_object_name + . "($group) as controller and " + . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + ); + } + else + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reverse link defined for: " + . $$self{device}->get_object_name + . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " + . $device->get_object_name . "($group)" + ); + } + } else { @@ -1104,7 +1116,7 @@ sub _write_link $$self{pending_aldb}{data2} = (defined $data2) ? lc $data2 : '00'; # Note: if device is a KeypadLinc, then $data3 must be assigned the value of the applicable button (01) if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) { - &::print_log("[Insteon::ALDB_i1] setting data3 to " . $self->group . " for this keypadlinc") + &::print_log("[Insteon::ALDB_i1] setting data3 to " . $$self{device}->group . " for this keypadlinc") if $main::Debug{insteon}; $data3 = $self->group; } From 4e4b04dd31512b4ac750ed62726fddd7fcb5d19f Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 14 Jun 2011 20:47:49 +0000 Subject: [PATCH 065/150] Force state tracking for ApplianceLinc to be same as for *Relay classes. --- lib/Insteon/Lighting.pm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index 289a3ea5b..fa3632119 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -180,6 +180,14 @@ sub new return $self; } +sub set +{ + my ($self, $p_state, $p_setby, $p_respond) = @_; + + my $link_state = &Insteon::BaseObject::derive_link_state($p_state); + + return $self->Insteon::BaseDevice::set($link_state, $p_setby, $p_respond); +} package Insteon::LampLinc; From 5ae0282163745359a0572979f5f7c81579f303c1 Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 15 Jun 2011 03:04:36 +0000 Subject: [PATCH 066/150] Modify set_linked_devices to adjust state to only be on or off if a non-dimmable light. --- lib/Insteon/BaseInsteon.pm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 00a55554c..0f4b9ad9c 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -1390,6 +1390,10 @@ sub set_linked_devices $$self{members}{$member_ref}{resume_state} = $member->state; # if they are Insteon_Device objects, then simply set_receive their state to # the member on level + if (!($member->isa('Insteon::DimmableLight')) and $member->isa('Insteon::BaseLight')) + { + $local_state = &Insteon::BaseObject::derive_link_state($local_state); + } $member->set_receive($local_state,$self); } } From dfdf605f9e495962bee6d8b7c5d9cae538fe83ff Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 15 Jun 2011 03:05:10 +0000 Subject: [PATCH 067/150] Adjust inheritance order for KeypadLincRelay as well. --- lib/Insteon/Lighting.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index fa3632119..6dbd15f74 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -261,7 +261,7 @@ package Insteon::KeyPadLincRelay; use strict; use Insteon::BaseInsteon; -@Insteon::KeyPadLincRelay::ISA = ('Insteon::DeviceController', 'Insteon::BaseLight'); +@Insteon::KeyPadLincRelay::ISA = ('Insteon::BaseLight','Insteon::DeviceController'); sub new From 5028c4d2a9543f15bc50c9621fc04017f40ea0a2 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 23 Jun 2011 20:34:19 +0000 Subject: [PATCH 068/150] Revise delete_orphan_links to use health data from scan_links. Also, avoid pre-emptive orphan delete of "deaf" devices. --- lib/Insteon/AllLinkDatabase.pm | 425 ++++++++++++++++++++++----------- 1 file changed, 281 insertions(+), 144 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index a2e586dad..b3793cdf4 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -33,6 +33,7 @@ sub new my $self={}; bless $self,$class; $$self{device} = $device; + $self->health("unknown"); # unknown return $self; } @@ -42,6 +43,24 @@ sub _send_cmd $$self{device}->_send_cmd($msg); } +sub health +{ + # corrupt + # unknown + # empty + # good + my ($self, $health) = @_; + $$self{health} = $health if defined $health; + return $$self{health}; +} + +sub scandatetime +{ + my ($self, $scandatetime) = @_; + $$self{scandatetime} = $scandatetime if defined $scandatetime; + return $$self{scandatetime}; +} + sub restore_string { my ($self) = @_; @@ -76,6 +95,13 @@ sub restore_string $aldb .= $record; } # &::print_log("[AllLinkDataBase] aldb restore string: $aldb") if $main::Debug{insteon}; + if (defined $self->scandatetime) + { + $restore_string .= $$self{device}->get_object_name . "->_aldb->scandatetime(q~" . $self->scandatetime . "~) if " + . $$self{device}->get_object_name . "->_aldb;\n"; + } + $restore_string .= $$self{device}->get_object_name . "->_aldb->health(q~" . $self->health . "~) if " + . $$self{device}->get_object_name . "->_aldb;\n"; $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_aldb(q~$aldb~) if " . $$self{device}->get_object_name . "->_aldb;\n"; } return $restore_string; @@ -350,6 +376,15 @@ sub _on_peek $$self{_mem_action} = undef; # clear out mem_activity flag $$self{_mem_activity} = undef; + if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { + # set health as empty for now + $self->health("empty"); + } + else + { + $self->health("good"); + } + &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " completed link memory scan") if $main::Debug{insteon}; if (defined $$self{_success_callback}) { @@ -567,6 +602,8 @@ sub scan_link_table $$self{_mem_activity} = 'scan'; $$self{_success_callback} = ($success_callback) ? $success_callback : undef; $$self{_failure_callback} = ($failure_callback) ? $failure_callback : undef; + $self->scandatetime(&main::get_tickcount); + $self->health('corrupt'); # allow acknowledge to set otherwise $self->_peek('0FF8',0); } @@ -631,6 +668,17 @@ sub delete_orphan_links @{$$self{delete_queue}} = (); # reset the work queue my $selfname = $$self{device}->get_object_name; my $num_deleted = 0; + + # first, make sure that the health of ALDB is ok + if ($self->health ne 'good') + { + &::print_log("[Insteon::ALDB_i1] Delete orphan links: skipping $selfname because health: " + . $self->health . ". Please rescan this device!!") + if ($self->health ne 'empty'); + + return $num_deleted; # no links deleted + } + for my $linkkey (keys %{$$self{aldb}}) { if ($linkkey ne 'empty' and $linkkey ne 'duplicates') { my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; @@ -659,7 +707,8 @@ sub delete_orphan_links # ignore since this is just a link back to the PLM } elsif ($device->isa("Insteon::BaseInterface")) { # does the PLM have a link point back? If not, the delete this one - if (!($device->has_link($$self{device},$group,1))) { + if (!($device->has_link($$self{device},$group,1))) + { if ($audit_mode) { &::print_log("[Insteon::ALDB_i1] (AUDIT) " . $device->get_object_name . @@ -677,35 +726,41 @@ sub delete_orphan_links } } # is there an entry in the items.mht that corresponds to this link? - if ($is_controller) { + if ($is_controller) + { # TO-DO: handle this case - } else { + } + else + { my $plm_link = &Insteon::get_object('000000', $group); - if ($plm_link) { + if ($plm_link) + { my $is_invalid = 1; foreach my $member_ref (keys %{$$plm_link{members}}) { my $member = $$plm_link{members}{$member_ref}{object}; if ($member->isa('Light_Item')) { my @lights = $member->find_members('Insteon::BaseLight'); - if (@lights) { + if (@lights) + { $member = @lights[0]; # pick the first } } if ($member->device_id eq $$self{device}->device_id) { - if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { - $is_invalid = 0; - last; + if ($data3 eq '00' or (lc $data3 eq lc $member->group)) + { + $is_invalid = 0; + last; } } } if ($is_invalid) { if ($audit_mode) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan link because none defined for PLM controlled scene " - . $device->get_object_name . - " details: " - . (($is_controller) ? "controller" : "responder") - . ", deviceid=$deviceid, group=$group, data=$data3"); + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan responder link from " + . $$self{device}->get_object_name + . " to PLM because no SCENE_MEMBER entry could be found " + . "in items.mht for INSTEON_ICONTROLLER: " + . $plm_link->get_object_name); } else { @@ -733,92 +788,126 @@ sub delete_orphan_links $num_deleted++; } } - } - } else { - if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { - if ($audit_mode) - { - if ($is_controller) - { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reciprocal link defined for: " + } # is not a controller + } + else # is a non-PLM device + { + if ($device->isa('Insteon::RemoteLinc') or $device->isa('Insteon::MotionSensor')) + { + &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from 'deaf' device: " . $device->get_object_name); + } + # make sure that the health of the device's ALDB is ok + if ($device->_aldb->health ne 'good') + { + &::print_log("[Insteon::ALDB_i1] Delete orphan links: skipping check for reciprocal links from " + . $device->get_object_name . " because health: " + . $device->_aldb->health . ". Please rescan this device!!") + if ($device->_aldb->health ne 'empty'); + } + else + { + # does the device fail to have a reciprocal link? + if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) + { + if ($audit_mode) + { + if ($is_controller) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reciprocal link defined for: " . $$self{device}->get_object_name . "($group) as controller and " . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" - ); - } - else - { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reverse link defined for: " + ); + } + else # is a responder + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reverse link defined for: " . $$self{device}->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " . $device->get_object_name . "($group)" - ); - } + ); + } - } - else - { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + } + else # non-audit mode + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, callback => "$selfname->_process_delete_queue()", object => $device, cause => "no link to the device could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } else { - my $is_invalid = 1; - my $link = ($is_controller) ? &Insteon::get_object($$self{device}->device_id,$group) + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + else # device does have reciprocal link + { + my $is_invalid = 1; + my $link = ($is_controller) ? &Insteon::get_object($$self{device}->device_id,$group) : &Insteon::get_object($device->device_id,$group); - if ($link) { - foreach my $member_ref (keys %{$$link{members}}) { - my $member = $$link{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { - my @lights = $member->find_members('Insteon::BaseLight'); - if (@lights) { - $member = @lights[0]; # pick the first - } - } - if ($member->isa('Insteon::BaseDevice') && !($member->is_root)) - { - $member = $member->get_root; - } - - if ($member->isa('Insteon::BaseDevice') && !($is_controller) - && ($member->device_id eq $$self{device}->device_id)) - { - $is_invalid = 0; - last; - } - elsif ($member->isa('Insteon::BaseDevice') && $is_controller - && ($member->device_id eq $device->device_id)) + if ($link) + { + foreach my $member_ref (keys %{$$link{members}}) { - $is_invalid = 0; - last; - } + my $member = $$link{members}{$member_ref}{object}; + if ($member->isa('Light_Item')) + { + my @lights = $member->find_members('Insteon::BaseLight'); + if (@lights) + { + $member = @lights[0]; # pick the first + } + } + if ($member->isa('Insteon::BaseDevice') && !($member->is_root)) + { + $member = $member->get_root; + } + if ($member->isa('Insteon::RemoteLinc') or $member->isa('Insteon::MotionSensor')) + { + &::print_log("[Insteon::ALDB_i1] ignoring link from " . $link->get_object_name . " to " . + $member->get_object_name); + $is_invalid = 0; + } + elsif ($member->isa('Insteon::BaseDevice') && !($is_controller) + && ($member->device_id eq $$self{device}->device_id)) + { + $is_invalid = 0; + last; + } + elsif ($member->isa('Insteon::BaseDevice') && $is_controller + && ($member->device_id eq $device->device_id)) + { + $is_invalid = 0; + last; + } + } # foreach } - } - if ($is_invalid) { - if ($audit_mode) - { - &::print_log("[Insteon::ALDB_i1] (AUDIT ) Delete orphan because no reverse link could be found " + if ($is_invalid) + { + if ($audit_mode) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reverse link could be found " . $device->get_object_name . " details: " . (($is_controller) ? "controller" : "responder") . ", deviceid=$deviceid, group=$group, data=$data3"); - } - else - { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + } + else + { + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, callback => "$selfname->_process_delete_queue()", object => $device, cause => "no reverse link could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; - } - } + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } + } + } } } - } elsif ($linkkey eq 'duplicates') { + } + elsif ($linkkey eq 'duplicates') + { my $address = pop @{$$self{aldb}{duplicates}}; - while ($address) { + while ($address) + { if ($audit_mode) { &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because duplicate found " @@ -968,7 +1057,9 @@ sub log_alllink_table my ($self) = @_; my %aldb; - &::print_log("[Insteon::ALDB_i1] link table for " . $$self{device}->get_object_name . " (devcat: $$self{devcat}):"); + &::print_log("[Insteon::ALDB_i1] Link table for " + . $$self{device}->get_object_name + . " health: " . $self->health); # We want to log links sorted by ALDB address. Since the ALDB # addresses are scattered throughout the %{$$self{aldb}} hash, @@ -997,50 +1088,71 @@ sub log_alllink_table } # Finally traverse the ALDB, but this time sorted by ALDB address - foreach my $address (sort keys %aldb) { - my $log_msg = "[Insteon::ALDB_i1] [0x$address] "; + if ($self->health eq 'good') + { + foreach my $address (sort keys %aldb) + { + my $log_msg = "[Insteon::ALDB_i1] [0x$address] "; - if (exists $aldb{$address}{empty}) { - $log_msg .= "is empty"; - } elsif (exists $aldb{$address}{duplicate}) { - $log_msg .= "holds a duplicate entry"; - } else { - my ($key) = keys %{$aldb{$address} }; # There's only 1 key - my $aldb_entry = $aldb{$address}{$key}; - my $is_controller = $aldb_entry->{is_controller}; - my $device; - - if ($$self{device}->interface()->device_id() - && $$self{device}->interface()->device_id() eq $aldb_entry->{deviceid}) { - $device = $$self{device}->interface; - } else { - $device = &Insteon::get_object($aldb_entry->{deviceid},'01'); - } - my $object_name = ($device) ? $device->get_object_name : $aldb_entry->{deviceid}; - - my $on_level = 'unknown'; - if (defined $aldb_entry->{data1}) { - if ($aldb_entry->{data1}) { - $on_level = int((hex($aldb_entry->{data1})*100/255) + .5) . "%"; - } else { - $on_level = '0%'; - } - } - - my $rspndr_group = $aldb_entry->{data3}; - $rspndr_group = '01' if $rspndr_group eq '00'; - - my $ramp_rate = 'unknown'; - if ($aldb_entry->{data2}) { - if (!($$self{device}->isa('Insteon::DimmableLight')) or (!$is_controller and ($rspndr_group != '01'))) { - $ramp_rate = 'none'; - $on_level = $on_level eq '0%' ? 'off' : 'on'; - } else { - $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($aldb_entry->{data2}) . "s"; - } - } - - $log_msg .= $is_controller ? "contlr($aldb_entry->{group}) " + if (exists $aldb{$address}{empty}) + { + $log_msg .= "is empty"; + } + elsif (exists $aldb{$address}{duplicate}) + { + $log_msg .= "holds a duplicate entry"; + } + else + { + my ($key) = keys %{$aldb{$address} }; # There's only 1 key + my $aldb_entry = $aldb{$address}{$key}; + my $is_controller = $aldb_entry->{is_controller}; + my $device; + + if ($$self{device}->interface()->device_id() + && ($$self{device}->interface()->device_id() + eq $aldb_entry->{deviceid})) + { + $device = $$self{device}->interface; + } + else + { + $device = &Insteon::get_object($aldb_entry->{deviceid},'01'); + } + my $object_name = ($device) ? $device->get_object_name : $aldb_entry->{deviceid}; + + my $on_level = 'unknown'; + if (defined $aldb_entry->{data1}) + { + if ($aldb_entry->{data1}) + { + $on_level = int((hex($aldb_entry->{data1})*100/255) + .5) . "%"; + } + else + { + $on_level = '0%'; + } + } + + my $rspndr_group = $aldb_entry->{data3}; + $rspndr_group = '01' if $rspndr_group eq '00'; + + my $ramp_rate = 'unknown'; + if ($aldb_entry->{data2}) + { + if (!($$self{device}->isa('Insteon::DimmableLight')) + or (!$is_controller and ($rspndr_group != '01'))) + { + $ramp_rate = 'none'; + $on_level = $on_level eq '0%' ? 'off' : 'on'; + } + else + { + $ramp_rate = &Insteon::DimmableLight::get_ramp_from_code($aldb_entry->{data2}) . "s"; + } + } + + $log_msg .= $is_controller ? "contlr($aldb_entry->{group}) " . "record to $object_name ($rspndr_group), " . "(d1:$aldb_entry->{data1}, " . "d2:$aldb_entry->{data2}, " @@ -1049,10 +1161,14 @@ sub log_alllink_table . "($aldb_entry->{group}): onlevel=$on_level " . "and ramp=$ramp_rate " . "(d3:$aldb_entry->{data3})"; - } + } - &::print_log($log_msg); - } + &::print_log($log_msg); + } + } + else + { + } } sub update_local_properties @@ -1211,6 +1327,13 @@ sub restore_string } $restore_string .= $$self{device}->get_object_name . "->_aldb->restore_linktable(q~$link~) if " . $$self{device}->get_object_name . "->_aldb;\n"; } + if (defined $self->scandatetime) + { + $restore_string .= $$self{device}->get_object_name . "->_aldb->scandatetime(q~" . $self->scandatetime . "~) if " + . $$self{device}->get_object_name . "->_aldb;\n"; + } + $restore_string .= $$self{device}->get_object_name . "->_aldb->health(q~" . $self->health . "~) if " + . $$self{device}->get_object_name . "->_aldb;\n"; return $restore_string; } @@ -1240,6 +1363,7 @@ sub restore_linktable sub log_alllink_table { my ($self) = @_; + &::print_log("[Insteon::ALDB_PLM] Link table health: " . $self->health); foreach my $linkkey (sort(keys(%{$$self{aldb}}))) { my $data3 = $$self{aldb}{$linkkey}{data3}; my $is_controller = $$self{aldb}{$linkkey}{is_controller}; @@ -1263,8 +1387,7 @@ sub log_alllink_table . $object_name : "responder record to " . $object_name . "($$self{aldb}{$linkkey}{group})") . " (d1=$$self{aldb}{$linkkey}{data1}, d2=$$self{aldb}{$linkkey}{data2}, " - . "d3=$data3)") - if $main::Debug{insteon}; + . "d3=$data3)"); } } @@ -1290,6 +1413,8 @@ sub parse_alllink sub get_first_alllink { my ($self) = @_; + $self->scandatetime(&main::get_tickcount); + $self->health('corrupt'); # set as corrupt and allow acknowledge to set otherwise $$self{device}->queue_message(new Insteon::InsteonMessage('all_link_first_rec', $$self{device})); } @@ -1368,22 +1493,31 @@ sub delete_orphan_links } if ($member->isa('Insteon::BaseDevice')) { - my $linkmember = $member; - # make sure that this is a root device - if (!($member->is_root)) + if ($member->isa('Insteon::RemoteLinc') or $member->isa('Insteon::MotionSensor')) { - $member = $member->get_root; - } - if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) + &::print_log("[Insteon::ALDB_PLM] ignoring link from PLM to " . + $member->get_object_name); + $is_invalid = 0; + } + else { - # at this point, the forward link is ok; but, only if the reverse - # link also exists. So, check: - if ($member->has_link($self, $group, 0, $data3)) - { - $is_invalid = 0; + my $linkmember = $member; + # make sure that this is a root device + if (!($member->is_root)) + { + $member = $member->get_root; } - last; - } + if (lc $member->device_id eq $$self{aldb}{$linkkey}{deviceid}) + { + # at this point, the forward link is ok; but, only if the reverse + # link also exists. So, check: + if ($member->has_link($self, $group, 0, $data3)) + { + $is_invalid = 0; + } + last; + } + } } else { @@ -1395,9 +1529,12 @@ sub delete_orphan_links if ($device->has_link($self,$group,0, $data3)) { if ($audit_mode) { - &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete Orphan PLM responder link ($group) from: " . - $device->get_object_name() . "($data3)") - if $main::Debug{insteon}; + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan controller link from PLM to " + . $device->get_object_name() + . " because no SCENE_MEMBER entry could be found " + . "in items.mht for INSTEON_ICONTROLLER: " + . $link->get_object_name()); + } else { @@ -1529,7 +1666,7 @@ sub add_link if ($link_parms{callback}) { package main; eval ($link_parms{callback}); - &::print_log("[Insteon_PLM] error in add link callback: " . $@) + &::print_log("[Insteon::ALDB_PLM] error in add link callback: " . $@) if $@ and $main::Debug{insteon}; package Insteon_PLM; } From d0c84ef59f27f4114072adc62fa0f80b6c719860 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 23 Jun 2011 20:35:15 +0000 Subject: [PATCH 069/150] Support ALDB health function. --- lib/Insteon_PLM.pm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index c01c253ea..8026ba2a6 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -405,6 +405,14 @@ sub _parse_data { # we've reached the end of the memory $$self{_next_link_ok} = 0; $$self{_mem_activity} = undef; + if ($record_type eq $prefix{all_link_first_rec}) + { + $self->_aldb->health("empty"); + } + else + { + $self->_aldb->health("good"); + } if ($$self{_mem_callback}) { my $callback = $$self{_mem_callback}; @@ -412,7 +420,7 @@ sub _parse_data { package main; eval ($callback); &::print_log("[Insteon_PLM] error encountered during nack callback: " . $@) - if $@ and $main::Debug{insteon}; + if $@ and $main::Debug{insteon}; package Insteon_PLM; } } From 47627ce5a706f8c51491d74f17b11e442feec7ca Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Fri, 24 Jun 2011 05:18:39 +0000 Subject: [PATCH 070/150] Added iolinc conversion support and more comments. --- lib/Insteon/convert_insteon_config | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lib/Insteon/convert_insteon_config b/lib/Insteon/convert_insteon_config index 16d40153d..9219e67f0 100755 --- a/lib/Insteon/convert_insteon_config +++ b/lib/Insteon/convert_insteon_config @@ -19,11 +19,24 @@ while (<>) s#IPLL,#INSTEON_SWITCHLINC|SWITCHLINCRELAY|KEYPADLINC|REMOTELINC,#i; s#IPLD,#INSTEON_LAMPLINC|APPLIANCELINC|MOTIONSENSOR,#i; + # the regexes below do some magic based on my insteon.mht file which + # has comments stating what each device actually is, so I use this to + # turn refine the check above to state which of the 3 or 4 devices we + # actually got: +#IPLL, 11.E1.9D:01, mbr_kpl, All_Lights, PLM, # v1.8 keypadlinc dimmer +#IPLL, 0E.07.49:02, fmr_kpl_kitchen_kpl, fmr_kplB|buttons, PLM, +#IPLL, 0F.B7.05:01, mbr_lamp2, All_Lights|mbr_both, PLM, # v4.2 switchlink dimmer +#IPLD, 0F.6E.C2, mbr_lamp3, All_Lights, PLM, # v4.3 lamplinc +#IPLD, 11.8E.1C, gar_mos1, Sensors, PLM,1001 # v1.1 +#IPLL, 15.E7.62:01, iolinc_garside, iolincs, PLM,0007 # v1.4 iolinc + # those are local hacks to do the right replaces with my config file s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*switchlin. dimmer)#INSTEON_SWITCHLINC$1#i; s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*switchlin. relay)#INSTEON_SWITCHLINCRELAY$1#i; s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*_kpl)#INSTEON_KEYPADLINC$1#i; s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*rlink)#INSTEON_REMOTELINC$1#i; + # IOLINC isn't supported yet, but it does look like a switchlinc relay. + s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*iolin)#INSTEON_SWITCHLINCRELAY$1#i; s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*lamplin)#INSTEON_LAMPLINC$1#i; s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*appliance lin)#INSTEON_APPLIANCELINC$1#i; From 9c404d45526db4cb8653cc7c8d216269e85dc2a6 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 28 Jun 2011 17:33:29 +0000 Subject: [PATCH 071/150] Commit Mark's request for an override for retry attempts. --- lib/Insteon/Message.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 64b83d7f2..6a8ffb9e0 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -88,7 +88,7 @@ sub respond sub send { my ($self, $interface) = @_; - if ($self->send_attempts < 5) + if ($self->send_attempts < ($::config_parms{'Insteon_retry_count'} || 5) { if ($self->send_attempts > 0) From 5e3c6c2e90e0ddb38bd725931d2a14e09898c20e Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 28 Jun 2011 17:34:27 +0000 Subject: [PATCH 072/150] Various logging fixes and rewording to be more obvious. Prevent automatic removal of links in delete ophan links where no reciprocal link exists; warn instead. --- lib/Insteon/AllLinkDatabase.pm | 58 +++++++++++++++++++++++++--------- 1 file changed, 43 insertions(+), 15 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index b3793cdf4..051a20710 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -707,14 +707,16 @@ sub delete_orphan_links # ignore since this is just a link back to the PLM } elsif ($device->isa("Insteon::BaseInterface")) { # does the PLM have a link point back? If not, the delete this one + # These are all responder links if (!($device->has_link($$self{device},$group,1))) { if ($audit_mode) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) " . $device->get_object_name . - " now deleting orphaned link w/ details: " - . (($is_controller) ? "controller" : "responder") - . ", deviceid=$deviceid, group=$group, data=$data3"); + &::print_log("[Insteon::ALDB_i1] (AUDIT) Now deleting orphaned responder link in " + . $$self{device}->get_object_name + . (($data3 eq '00' or $data3 eq '01') ? "" : " [button:" . $data3 . "]") + . " because PLM does not have a corresponding controller record " + . "with group ($group)"); } else { @@ -732,20 +734,25 @@ sub delete_orphan_links } else { + # find the corresponding PLM scene that has this group my $plm_link = &Insteon::get_object('000000', $group); if ($plm_link) { my $is_invalid = 1; - foreach my $member_ref (keys %{$$plm_link{members}}) { + # now, iterate over the PLM scene members to see if a match exists + foreach my $member_ref (keys %{$$plm_link{members}}) + { my $member = $$plm_link{members}{$member_ref}{object}; - if ($member->isa('Light_Item')) { + if ($member->isa('Light_Item')) + { my @lights = $member->find_members('Insteon::BaseLight'); if (@lights) { $member = @lights[0]; # pick the first } } - if ($member->device_id eq $$self{device}->device_id) { + if ($member->device_id eq $$self{device}->device_id) + { if ($data3 eq '00' or (lc $data3 eq lc $member->group)) { $is_invalid = 0; @@ -758,6 +765,7 @@ sub delete_orphan_links { &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan responder link from " . $$self{device}->get_object_name + . (($data3 eq '00' or $data3 eq '01') ? "" : " [button:" . $data3 . "]") . " to PLM because no SCENE_MEMBER entry could be found " . "in items.mht for INSTEON_ICONTROLLER: " . $plm_link->get_object_name); @@ -797,7 +805,7 @@ sub delete_orphan_links &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from 'deaf' device: " . $device->get_object_name); } # make sure that the health of the device's ALDB is ok - if ($device->_aldb->health ne 'good') + elsif ($device->_aldb->health ne 'good') { &::print_log("[Insteon::ALDB_i1] Delete orphan links: skipping check for reciprocal links from " . $device->get_object_name . " because health: " @@ -813,29 +821,49 @@ sub delete_orphan_links { if ($is_controller) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reciprocal link defined for: " + &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reciprocal link defined for: " . $$self{device}->get_object_name . "($group) as controller and " . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + . " Please sync links with the applicable device; this link will not be deleted." ); } else # is a responder { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reverse link defined for: " + &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reverse link defined for: " . $$self{device}->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " . $device->get_object_name . "($group)" + . " Please sync links with the applicable device; this link will not be deleted." ); } } else # non-audit mode { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, - cause => "no link to the device could be found", data3 => $data3); - push @{$$self{delete_queue}}, \%delete_req; - $num_deleted++; + if ($is_controller) + { + &::print_log("[Insteon::ALDB_i1] WARNING: no reciprocal link defined for: " + . $$self{device}->get_object_name + . "($group) as controller and " + . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + . " Please sync links with the applicable device; this link will not be deleted." + ); + } + else # is a responder + { + &::print_log("[Insteon::ALDB_i1] WARNING: no reverse link defined for: " + . $$self{device}->get_object_name + . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " + . $device->get_object_name . "($group)" + . " Please sync links with the applicable device; this link will not be deleted." + ); + } +# my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, +# callback => "$selfname->_process_delete_queue()", object => $device, +# cause => "no link to the device could be found", data3 => $data3); +# push @{$$self{delete_queue}}, \%delete_req; +# $num_deleted++; } } else # device does have reciprocal link From 3b2dac55f9ebaf1ae58ca13564774f6a01f38035 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 28 Jun 2011 17:49:03 +0000 Subject: [PATCH 073/150] Replace obsolete insteon items with new ones. --- web/bin/items.pl | 59 ++++++++++++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 25 deletions(-) diff --git a/web/bin/items.pl b/web/bin/items.pl index b6d91422c..f814aa2d3 100644 --- a/web/bin/items.pl +++ b/web/bin/items.pl @@ -52,8 +52,8 @@ sub web_items_list { my $default = File::Spec->catfile(@Code_Dirs[0], "items.mht"); push @file_paths, $default unless @file_paths[0]; # Create new items file if none - $web_item_file_name = @file_paths[0] unless $web_item_file_name; # Default to first mht file found - $web_item_file_name = $1 if $ARGV[0] =~ /^file=(.+)$/; # User selected another mht file + $web_item_file_name = @file_paths[0] unless $web_item_file_name; # Default to first mht file found + $web_item_file_name = $1 if $ARGV[0] =~ /^file=(.+)$/; # User selected another mht file # Create a form to pick which file $html .= "
    Which .mht file to edit?\n"; @@ -62,18 +62,20 @@ sub web_items_list { # Create form to add an item my $form_type = &html_form_select('type', 0, 'X10 Light (X10I)', - 'Analog Sensor (ANALOG_SENSOR)', 'AUDIOTRON', 'COMPOOL', - 'EIB Switch (EIB1)', 'EIB Switch Group (EIB1G)', 'EIB Dimmer (EIB2)', + 'Analog Sensor (ANALOG_SENSOR)', 'AUDIOTRON', 'COMPOOL', + 'EIB Switch (EIB1)', 'EIB Switch Group (EIB1G)', 'EIB Dimmer (EIB2)', 'EIB Value (EIB5)', 'EIB Drive (EIB7)', - 'GENERIC', 'IBUTTON', 'INSTEON_PLM','Insteon Device (IPLD)','Insteon Link (IPLL)', - 'MP3PLAYER', 'One-Wire xAP Connector (OWX)', 'RF', 'SERIAL', - 'SG485LCD', 'SG485RCSTHRM', 'STARGATEDIN', 'STARGATEVAR', - 'STARGATEFLAG', 'STARGATERELAY', 'STARGATETHERM', 'STARGATEPHONE', - 'VOICE', 'WEATHER', + 'GENERIC', 'IBUTTON', 'INSTEON_PLM','INSTEON_LAMPLINC','INSTEON_APPLIANCELINC', + 'INSTEON_SWITCHLINC','INSTEON_SWITCHLINCRELAY','INSTEON_KEYPADLINC','INSTEON_KEYPADLINCRELAY', + 'INSTEON_REMOTELINC','INSTEON_MOTIONSENSOR','INSTEON_ICONTROLLER', + 'MP3PLAYER', 'One-Wire xAP Connector (OWX)', 'RF', 'SERIAL', + 'SG485LCD', 'SG485RCSTHRM', 'STARGATEDIN', 'STARGATEVAR', + 'STARGATEFLAG', 'STARGATERELAY', 'STARGATETHERM', 'STARGATEPHONE', + 'VOICE', 'WEATHER', 'X10 Appliance (X10A)', 'X10 Light (X10I)', 'X10 Ote (X10O)', 'X10 SwitchLinc (X10SL)', 'X10 Garage Door (X10G)', 'X10 Irrigation (X10S)', 'X10 RCS (X10T)', 'X10 Motion Sensor (X10MS)', 'X10 6 Button Remote (X106BUTTON)', - 'XANTECH', + 'XANTECH', ); #form action='/bin/items.pl?add' method=post> @@ -117,7 +119,7 @@ sub web_items_list { $html .= "
    \n"; # Define fields by type - my %headers = ( + my %headers = ( ANALOG_SENSOR => ['Identifier', 'Name', 'Conduit', 'Groups', 'Type', 'Tokens'], EIB1 => ['Address', 'Name', 'Groups', 'Mode'], EIB1G => ['Address', 'Name', 'Groups', 'Addresses'], @@ -133,12 +135,19 @@ sub web_items_list { X10SL => [qw(Address Name Groups Interface Options)], X10MS => [qw(Address Name Groups Type)], X106BUTTON => [qw(Address Name)], - UPBPIM => [qw(Name NetworkID Password Address)], - UPBD => [qw(Name Interface NetworkID Address Groups)], - UPBL => [qw(Name Interface NetworkID Address Groups)], - INSTEON_PLM => [qw(Name)], - IPLD => [qw(Address Name Groups Interface Options)], - IPLL => [qw(Address Name Groups Interface Options)], + UPBPIM => [qw(Name NetworkID Password Address)], + UPBD => [qw(Name Interface NetworkID Address Groups)], + UPBL => [qw(Name Interface NetworkID Address Groups)], + INSTEON_PLM => [qw(Name)], + INSTEON_LAMPLINC => [qw(Address Name Groups)], + INSTEON_APPLIANCELINC => [qw(Address Name Groups)], + INSTEON_SWITCHLINC => [qw(Address Name Groups)], + INSTEON_SWITCHLINCRELAY => [qw(Address Name Groups)], + INSTEON_KEYPADLINC => [qw(Address Name Groups)], + INSTEON_KEYPADLINCRELAY => [qw(Address Name Groups)], + INSTEON_REMOTELINC => [qw(Address Name Groups)], + INSTEON_MOTIONSENSOR => [qw(Address Name Groups)], + INSTEON_ICONTROLLER => [qw(Address Name Groups)], SCENE_MEMBER => [qw(MemberName LinkName OnLevel RampRate)], default => [qw(Address Name Groups Other)] ); @@ -189,19 +198,19 @@ sub web_item_set_field { $data =~ s/\s*$//; $data =~ s/^\s*//; $data =~ s/,//g; - if ($field == 2) { # name + if ($field == 2) { # name $data =~ s/ +/_/g; $data =~ s/[^a-z0-9_]//ig; } - # Get current item record and split into fields + # Get current item record and split into fields my $record = @file_data[$pos]; my @item_info = split(',\s*', $record); - # Replace the updated field + # Replace the updated field $item_info[$field] = $data; - # Rebuild the record with updated field + # Rebuild the record with updated field $record = ''; while (@item_info) { my $item = shift @item_info; @@ -210,7 +219,7 @@ sub web_item_set_field { } $record =~ s/ *$//; - # Replace the updated record and write out mht file + # Replace the updated record and write out mht file $file_data[$pos] = $record; # print "db2 p=$pos f=$field d=$data r=$record\n"; @@ -259,8 +268,8 @@ sub web_item_add { $name =~ s/[^a-z0-9_,]//ig; $other2 =~ s/,$//; - # write out new record to mht file - $file_data[@file_data] = sprintf("%-20s%-20s%-20s%-20s%-20s%s", + # write out new record to mht file + $file_data[@file_data] = sprintf("%-20s%-20s%-20s%-20s%-20s%s", $type, $address, $name, $group, $other1, $other2); &mht_item_file_write($web_item_file_name, \@file_data); @@ -292,4 +301,4 @@ sub web_item_help { return $help; -} +} \ No newline at end of file From 45111961f94b95dfeba135ba0b2a8b7038b3a084 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 28 Jun 2011 17:49:32 +0000 Subject: [PATCH 074/150] Fix typo that crashes lib. --- lib/Insteon/Message.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 6a8ffb9e0..7ddb59953 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -88,7 +88,7 @@ sub respond sub send { my ($self, $interface) = @_; - if ($self->send_attempts < ($::config_parms{'Insteon_retry_count'} || 5) + if ($self->send_attempts < ($::config_parms{'Insteon_retry_count'} || 5)) { if ($self->send_attempts > 0) From e8a7d9b23fbf7fcd2be3b1ed3dfc915e134b3ff6 Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 29 Jun 2011 17:16:26 +0000 Subject: [PATCH 075/150] Various minor changes to menu options. --- lib/Insteon.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 6c805ede4..de0249c8f 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -274,7 +274,7 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,AUDIT - delete orphan links,scan link tables"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,AUDIT - delete orphan links,scan all device link tables"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -285,7 +285,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','messaging debug on');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','messaging debug off');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan link tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all devicelink tables');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } From ed358571b81711bfe9f8af7ac391a71d153b09d6 Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 29 Jun 2011 17:17:14 +0000 Subject: [PATCH 076/150] Improve logging message to include additional remedial actions. --- lib/Insteon/AllLinkDatabase.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 051a20710..24c2603a8 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -716,7 +716,8 @@ sub delete_orphan_links . $$self{device}->get_object_name . (($data3 eq '00' or $data3 eq '01') ? "" : " [button:" . $data3 . "]") . " because PLM does not have a corresponding controller record " - . "with group ($group)"); + . "with group ($group). Try resyncing the scene corresponding to PLM:$group " + . "if the mht scene entry exists."); } else { From 668c24e99ed68cac13975afaf4b584788e9527b2 Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 29 Jun 2011 17:18:18 +0000 Subject: [PATCH 077/150] Ensure that repeats do not occur for any "start all linking" message. --- lib/Insteon_PLM.pm | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 8026ba2a6..b393b3df6 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -372,6 +372,13 @@ sub _parse_data { { $$self{_next_link_ok} = 1; } + elsif ($record_type eq $prefix{all_link_start}) + { + &::print_log("[Insteon_PLM] PLM successfully completed requested operation: " + . $pending_message->to_string) if $main::Debug{insteon}; + # clear the active message because we're done + $self->clear_active_message(); + } else { &::print_log("[Insteon_PLM] DEBUG: received interface acknowledge: " @@ -426,8 +433,15 @@ sub _parse_data { } elsif ($record_type eq $prefix{all_link_send}) { - &::print_log("[Insteon_PLM] WARN: PLM memory does not contain link for: " - . $pending_message->to_string . $@) + &::print_log("[Insteon_PLM] WARN: PLM memory does not contain link for: " + . $pending_message->to_string . $@) + } + elsif ($record_type eq $prefix{all_link_start}) + { + &::print_log("[Insteon_PLM] WARN: PLM unable to complete requested operation: " + . $pending_message->to_string . $@); + # clear the active message because we're done + $self->clear_active_message(); } else { From 615338bb78dba60831b5a1d9888ccde01b461dde Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 29 Jun 2011 17:48:01 +0000 Subject: [PATCH 078/150] Adjust handling of NACKs received for managing PLM links. --- lib/Insteon_PLM.pm | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index b393b3df6..135609d4b 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -374,8 +374,6 @@ sub _parse_data { } elsif ($record_type eq $prefix{all_link_start}) { - &::print_log("[Insteon_PLM] PLM successfully completed requested operation: " - . $pending_message->to_string) if $main::Debug{insteon}; # clear the active message because we're done $self->clear_active_message(); } @@ -443,6 +441,41 @@ sub _parse_data { # clear the active message because we're done $self->clear_active_message(); } + elsif ($record_type eq $prefix{all_link_manage_rec}) + { + # parse out the data + my $failed_cmd_code = substr($pending_message->interface_data(),0,2); + my $failed_cmd = 'unknown'; + if ($failed_cmd_code eq '40') + { + $failed_cmd = 'update/add controller record'; + } + elsif ($failed_cmd_code eq '41') + { + $failed_cmd = 'update/add responder record'; + } + elsif ($failed_cmd_code eq '80') + { + $failed_cmd = 'delete record'; + } + my $failed_group = substr($pending_message->interface_data(),4,2); + my $failed_deviceid = substr($pending_message->interface_data(),6,6); + &::print_log("[Insteon_PLM] WARN: PLM unable to complete requested " + . "PLM link table update ($failed_cmd) for " + . "group: $failed_group and deviceid: $failed_deviceid" ); + if ($$self{_mem_callback}) + { + my $callback = $$self{_mem_callback}; + $$self{_mem_callback} = undef; + package main; + eval ($callback); + &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } + # clear the active message because we're done + # $self->clear_active_message(); + } else { &::print_log("[Insteon_PLM] WARN: received NACK for " From fcd79dcd37fda89058244f59199725a67b2b94e5 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 30 Jun 2011 18:51:32 +0000 Subject: [PATCH 079/150] Minor cosmetic mods and commenting. --- lib/Insteon/BaseInterface.pm | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 7af40d326..0d46ab5da 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -199,22 +199,23 @@ sub process_queue # get pending command record my $pending_message = $self->active_message; - if (!($pending_message)) { + if (!($pending_message)) + { # no prior message remains; so, get one from the queue $pending_message = pop(@{$$self{command_stack2}}); $self->active_message($pending_message) if $pending_message; - #put the command back into the stack.. Its not our job to tamper with this array - # push(@{$$self{command_stack2}},$pending_message) if $pending_message; } #we dont transmit on top of another xmit - if (!($$self{xmit_in_progress})) { # && ($self->_check_timeout('command')!=0)) { - #always send the oldest command first + if (!($$self{xmit_in_progress})) + { # no transmission is progress that has not already been acked or nacked by the PLM if ($pending_message) - { - if (!($self->_check_timeout('xmit')==0)) { + { # a message exists to be sent (whether previously sent or queued) + if (!($self->_check_timeout('xmit')==0)) + { # only send a message if the xmit timer has timed out if ($self->active_message->send($self) == 0) - { + { # this only occurs if the retry count has been exceeded + # which also means that there wasn't a message actually sent &::print_log("[Insteon::BaseInterface] WARN: number of retries (" . $self->active_message->send_attempts . ") for " . $self->active_message->to_string() @@ -235,7 +236,8 @@ sub process_queue $self->clear_active_message(); # may instead want a "failure" callback separate from success callback - if ($failed_message->failure_callback) { + if ($failed_message->failure_callback) + { &::print_log("[Insteon::BaseInterface] WARN: Now calling callback: " . $failed_message->failure_callback) if $main::Debug{insteon}; package main; @@ -250,17 +252,19 @@ sub process_queue { # may want to move "success" callback handling from message to here } - } + } # if xmit timer has expired my $command_queue_size = @{$$self{command_stack2}}; return $command_queue_size; } - else + else # no pending message { # clear the timer $self->_clear_timeout('command'); return 0; } - } else { + } + else # transmit in progress + { # &::print_log("[Insteon_PLM] active transmission; moving on...") if $main::Debug{insteon}; my $command_queue_size = @{$$self{command_stack2}}; return $command_queue_size; @@ -393,6 +397,11 @@ sub _set_timeout $$self{"_timeout_$timeout_name"} = $tickcount; } +# +# return -1 if timeout_name does not match an existing timer +# return 0 if timer has not expired +# return 1 if timer has expired +# sub _check_timeout { my ($self, $timeout_name) = @_; From cd63d0ed871b8174a2d4694379246a9614dd4f48 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 30 Jun 2011 18:52:45 +0000 Subject: [PATCH 080/150] Revised fragment processing to guard against fragment duplicates. --- lib/Insteon_PLM.pm | 59 +++++++++++++++++++++++++++------------------- 1 file changed, 35 insertions(+), 24 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 135609d4b..a3ecf6c9f 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -319,8 +319,11 @@ sub _parse_data { # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it if ($$self{_data_fragment}) { &::print_log("[Insteon_PLM] DEBUG: Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; + # maintain a copy of the parsed data fragment $$self{_prior_data_fragment} = $$self{_data_fragment}; - $data = $$self{_data_fragment} . $data; + # append if not a repeat + $data = $$self{_data_fragment} . $data; # unless $$self{_data_fragment} eq $data; + # and, clear it out $$self{_data_fragment} = ''; } &::print_log( "[Insteon_PLM] DEBUG: Parsing serial data: $data") if $self->debug; @@ -348,17 +351,17 @@ sub _parse_data { my $ackcmd = $prev_cmd . '06'; my $nackcmd = $prev_cmd . '15'; my $badcmd = $prev_cmd . '0f'; - foreach my $data_1 (split(/($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)/,$data)) + foreach my $parsed_data (split(/($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)/,$data)) { #ignore blanks.. the split does odd things - next if $data_1 eq ''; + next if $parsed_data eq ''; $entered_ack_loop = 1; - if ($data_1 =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) + if ($parsed_data =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) { - $processedNibs+=length($data_1); - my $ret_code = substr($data_1,length($data_1)-2,2); - my $record_type = substr($data_1,0,4); - my $message_data = substr($data_1,4,length($data_1)-4); + $processedNibs+=length($parsed_data); + my $ret_code = substr($parsed_data,length($parsed_data)-2,2); + my $record_type = substr($parsed_data,0,4); + my $message_data = substr($parsed_data,4,length($parsed_data)-4); if ($ret_code eq '06') { if ($record_type eq $prefix{plm_info}) @@ -383,7 +386,7 @@ sub _parse_data { . $pending_message->to_string) if $self->debug; } - if ($data_1 =~ /$prefix{x10_send}\w{4}06/) + if ($parsed_data =~ /$prefix{x10_send}\w{4}06/) { $self->clear_active_message(); } @@ -438,8 +441,6 @@ sub _parse_data { { &::print_log("[Insteon_PLM] WARN: PLM unable to complete requested operation: " . $pending_message->to_string . $@); - # clear the active message because we're done - $self->clear_active_message(); } elsif ($record_type eq $prefix{all_link_manage_rec}) { @@ -486,7 +487,7 @@ sub _parse_data { else { # We have a problem (Usually we stepped on another X10 command) - &::print_log("[Insteon_PLM] ERROR: encountered $data_1. " + &::print_log("[Insteon_PLM] ERROR: encountered $parsed_data. " . $pending_message->to_string()); # $$self{xmit_in_progress} = 0; $self->retry_active_message(); @@ -494,11 +495,19 @@ sub _parse_data { #TODO: We should keep track of an errored command and kill it if it fails twice. prevent an infinite loop here } } - else + else # no match occurred--which is the "leftovers" { - $residue_data .= $data_1; + # is $parsed_data an accidental anomoly? (there are other cases; but, this is a good start) + if ($parsed_data =~ /^($prefix{insteon_send}\w{12}06)|($prefix{insteon_send}\w{12}15)$/) + { + &::print_log("[Insteon_PLM] ERROR: encountered '$parsed_data' but expected '$ackcmd'."); + } + else + { + $residue_data .= $parsed_data; + } } - } + } #foreach - split across the incoming data $residue_data = $data unless $entered_ack_loop or $residue_data; } @@ -509,20 +518,20 @@ sub _parse_data { my $entered_rcv_loop = 0; - foreach my $data_1 (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})|($prefix{plm_button_event}\w{2})/,$residue_data)) + foreach my $parsed_data (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})|($prefix{plm_button_event}\w{2})/,$residue_data)) { #ignore blanks.. the split does odd things - next if $data_1 eq ''; + next if $parsed_data eq ''; $entered_rcv_loop = 1; #we found a matching command in stream, add to processed bytes - $processedNibs+=length($data_1); + $processedNibs+=length($parsed_data); - my $parsed_prefix = substr($data_1,0,4); - my $message_length = length($data_1); + my $parsed_prefix = substr($parsed_data,0,4); + my $message_length = length($parsed_data); - my $message_data = substr($data_1,4,length($data_1)-4); + my $message_data = substr($parsed_data,4,length($parsed_data)-4); if ($parsed_prefix eq $prefix{insteon_received} and ($message_length == 22)) { #Insteon Standard Received @@ -605,8 +614,9 @@ sub _parse_data { $self->clear_active_message(); } } - elsif (substr($data_1,0,2) eq '15') - { #NAK Received + elsif (substr($parsed_data,0,2) eq '15') + { # Indicates that the PLM can't receive more commands at the moment + # so, slow things down if (!($nack_count)) { my $nack_delay = ($::config_parms{Insteon_PLM_disable_throttling}) ? 0.3 : 1.0; @@ -623,7 +633,8 @@ sub _parse_data { { # it's probably a fragment; so, handle it # it it's the same as last time, then drop it as we can't recover - $$self{_data_fragment} .= $data_1 unless $data_1 eq $$self{_prior_data_fragment}; + $$self{_data_fragment} .= $parsed_data + unless (($parsed_data eq $$self{_prior_data_fragment}) or ($parsed_data eq $$self{_data_fragment})); } } From f41c382f9191b8cf8041f043c185b4090a322d5b Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 1 Jul 2011 17:38:43 +0000 Subject: [PATCH 081/150] Remove init of a message's queue_time; handled elsewhere now. --- lib/Insteon/BaseInterface.pm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 0d46ab5da..7940dbe89 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -174,12 +174,14 @@ sub queue_message my $setby = $message->setby; if ($self->_is_duplicate($message->interface_data) && !($message->isa('Insteon::X10Message'))) { &main::print_log("[Insteon_PLM] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; - } else { + } + else + { my $queue_size = @{$$self{command_stack2}}; # &main::print_log("[Insteon_PLM] Command stack size: $queue_size") if $queue_size > 0 and $main::Debug{insteon}; - $message->queue_time($::Time); if ($setby and ref($setby) and $setby->can('set_retry_timeout') - and $setby->get_object_name) { + and $setby->get_object_name) + { $message->callback($setby->get_object_name . "->set_retry_timeout()"); } unshift(@{$$self{command_stack2}}, $message); From ff20b75c86a78dc6f336762dae9d19dbdfc9230d Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 1 Jul 2011 17:39:33 +0000 Subject: [PATCH 082/150] Implement seconds_delayed method to track time between initialization and usage when sending. --- lib/Insteon/Message.pm | 89 ++++++++++++++++++++++++++++++------------ 1 file changed, 63 insertions(+), 26 deletions(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 7ddb59953..7fe5ba284 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -10,6 +10,7 @@ sub new my $self={}; bless $self,$class; + $$self{queue_time} = &main::get_tickcount; $$self{send_attempts} = 0; return $self; @@ -96,13 +97,26 @@ sub send &::print_log("[Insteon::BaseMessage] WARN: now resending " . $self->to_string() . " after " . $self->send_attempts . " attempts.") if $main::Debug{insteon}; + # revise default hop count to reflect retries + if (ref $self->setby && $self->setby->isa('Insteon::BaseObject')) + { + if (($self->send_attempts > $self->setby->default_hop_count) + and ($self->send_attempts <= 3)) + { + &main::print_log("[Insteon::Message] Now setting default hop count for " + . $self->setby->get_object_name . " to " + . $self->send_attempts); + $self->setby->default_hop_count($self->send_attempts); + } + } } # need to set timeout as a function of retries; also need to alter hop count $self->send_attempts($self->send_attempts + 1); $interface->_send_cmd($self, $self->send_timeout); - if ($self->callback) { + if ($self->callback) + { package main; eval $self->callback; &::print_log("[Insteon::BaseMessage] problem w/ retry callback: $@") if $@; @@ -117,6 +131,20 @@ sub send } +sub seconds_delayed +{ + my ($self) = @_; + my $current_tickcount = &main::get_tickcount; + my $delay_time = $current_tickcount - $self->queue_time; + if ($self->queue_time > $current_tickcount) + { + return 'unknown'; + } + + $delay_time = $delay_time / 1000; + return $delay_time; +} + sub send_timeout { my ($self, $timeout) = @_; @@ -151,7 +179,6 @@ sub new return $self; } - sub command_to_hash { my ($p_state) = @_; @@ -238,6 +265,9 @@ sub send_timeout # 3 2.00 3.17 my ($self, $ignore) = @_; + my $hop_count = (ref $self->setby and $self->setby->isa('Insteon::BaseObject')) ? + $self->send_attempts + $self->setby->default_hop_count - 1 + : $self->send_attempts; if ($self->command_type eq 'all_link_send') { # note, the following was set to 2000 and that was insufficient @@ -245,38 +275,38 @@ sub send_timeout } elsif ($self->command_type eq 'insteon_ext_send') { - if ($self->send_attempts == 1) + if ($hop_count == 1) { return 2220; } - elsif ($self->send_attempts == 2) + elsif ($hop_count == 2) { return 2690; } - elsif ($self->send_attempts == 3) + elsif ($hop_count == 3) { return 3000; } - elsif ($self->send_attempts >= 4) + elsif ($hop_count >= 4) { return 3170; } } else { - if ($self->send_attempts == 1) + if ($hop_count == 1) { return 1400; } - elsif ($self->send_attempts == 2) + elsif ($hop_count == 2) { return 1700; } - elsif ($self->send_attempts == 3) + elsif ($hop_count == 3) { return 1900; } - elsif ($self->send_attempts >= 4) + elsif ($hop_count >= 4) { return 2000; } @@ -334,35 +364,42 @@ sub _derive_interface_data my ($self) = @_; my $cmd = ''; my $level; - if ($self->command_type =~ /all_link_send/i) { + if ($self->command_type =~ /all_link_send/i) + { $cmd.=$self->setby->group; - } else { + } + else + { + my $hop_count = $self->send_attempts + $self->setby->default_hop_count - 1; $cmd.=$self->setby->device_id(); - if ($self->command_type =~ /insteon_ext_send/i) { - if ($self->send_attempts == 1) + if ($self->command_type =~ /insteon_ext_send/i) + { + if ($hop_count == 1) { - $cmd.='15'; + $cmd.='15'; } - elsif ($self->send_attempts == 2) + elsif ($hop_count == 2) { - $cmd.='1A'; + $cmd.='1A'; } - elsif ($self->send_attempts >= 3) + elsif ($hop_count >= 3) { - $cmd.='1F'; + $cmd.='1F'; } - } else { - if ($self->send_attempts == 1) + } + else + { + if ($hop_count == 1) { - $cmd.='05'; + $cmd.='05'; } - elsif ($self->send_attempts == 2) + elsif ($hop_count == 2) { - $cmd.='0A'; + $cmd.='0A'; } - elsif ($self->send_attempts >= 3) + elsif ($hop_count >= 3) { - $cmd.='0F'; + $cmd.='0F'; } } } From 60abcd7af74b62be5561537fdf588d6901274af9 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 1 Jul 2011 17:40:28 +0000 Subject: [PATCH 083/150] Implement default hop count method to be used to adjust the starting hop count for sent messages. --- lib/Insteon/BaseInsteon.pm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 0f4b9ad9c..206577a7d 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -82,7 +82,7 @@ sub new $self->interface(&Insteon::active_interface()); } - $self->restore_data('level'); + $self->restore_data('level','default_hop_count'); $self->initialize(); $$self{level} = undef; @@ -95,6 +95,7 @@ sub new @{$$self{command_stack}} = (); $$self{_onlevel} = undef; $$self{is_responder} = 1; + $$self{default_hop_count} = 1; &Insteon::add($self); return $self; @@ -146,6 +147,13 @@ sub group return $$self{m_group}; } +sub default_hop_count +{ + my ($self, $hop_count) = @_; + $$self{default_hop_count} = $hop_count if $hop_count; + return $$self{default_hop_count}; +} + sub equals { my ($self, $compare_object) = @_; From 9d0c193e89cd0ae9eddb4b3ce386d33a3b41c9d7 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 1 Jul 2011 17:41:41 +0000 Subject: [PATCH 084/150] Display message's queue time as well as default hop count. --- lib/Insteon_PLM.pm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index a3ecf6c9f..5ad79d477 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -288,6 +288,14 @@ sub _send_cmd { my $command = $message->interface_data; my $delay = $$self{xmit_delay}; + + # determine the delay from the point that the message was created to + # the point that it is queued + my $incurred_delay_time = $message->seconds_delayed; + &main::print_log("[Insteon_PLM] DEBUG: Sending " . $message->to_string . " incurred delay of " + . sprintf('%.2f',$incurred_delay_time) . " seconds; starting hop-count: " + . ((ref $message->setby && $message->setby->isa('Insteon::BaseObject')) ? $message->setby->default_hop_count : "?")) if $self->debug; + if ($message->isa('Insteon::X10Message')) { # is x10; so, be slow $command = $prefix{x10_send} . $command; $delay = $$self{xmit_x10_delay}; @@ -382,7 +390,7 @@ sub _parse_data { } else { - &::print_log("[Insteon_PLM] DEBUG: received interface acknowledge: " + &::print_log("[Insteon_PLM] DEBUG: Received PLM acknowledge: " . $pending_message->to_string) if $self->debug; } From 181fb67b36bf2121403a14432f23f9a3d10b4ca4 Mon Sep 17 00:00:00 2001 From: peloy Date: Sat, 2 Jul 2011 00:18:10 +0000 Subject: [PATCH 085/150] Fix typo introduced in r1922 that prevented the "plm scan all device link tables" from working. --- lib/Insteon.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index de0249c8f..14bef339c 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -285,7 +285,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','messaging debug on');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','messaging debug off');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all devicelink tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all device link tables');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } From 0b862dbcd893dbeac86609d3b5216e6967e3f039 Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Sat, 2 Jul 2011 21:47:59 +0000 Subject: [PATCH 086/150] New code to talk to CM15A and CM19A via mochad. --- lib/X10_CMxx.pm | 210 +++++++++++++++++++++++++++++++++ lib/X10_CMxx_mochad-0.1.7.diff | 127 ++++++++++++++++++++ 2 files changed, 337 insertions(+) create mode 100644 lib/X10_CMxx.pm create mode 100644 lib/X10_CMxx_mochad-0.1.7.diff diff --git a/lib/X10_CMxx.pm b/lib/X10_CMxx.pm new file mode 100644 index 000000000..e7e587186 --- /dev/null +++ b/lib/X10_CMxx.pm @@ -0,0 +1,210 @@ + +=begin comment + +This is code will read X10 data received by the +RF CM19A RF USB and CM15A RF and PL USB receiver/transmitters. +Sending data is not supported and data is received by a 3rd party +program, mochad, which writes it to a fifo which this module reads. + +1) Download and install mochad: http://sourceforge.net/projects/mochad/ + + Make sure that your version supports the --raw-data option. + If your mochad is too old (or a version newer than 0.1.7 has not been + released yet), apply this patch to mochad: X10_CMxx_mochad-0.1.7.diff + and see the README. + +2) Use these mh.ini parameters to enable this code: + + CMxx_module = X10_CMxx + CMxx_fifo = /var/run/cm19a + +The way this will work is that at least on linux udev will be configured +to run mochad.scr, which in turn will run mochad and sent its output to +a fifo: /var/run/cm19a, which this module reads from. + + +To monitor keys from an X10 TV/VCR RF remote (UR47A, UR51A, J20A, etc.), +(e.g. Play,Pause, etc), you can use something like this: + + $Remote = new X10_CMxx; + $Remote -> tie_event('print_log "CMxx key: $state"'); + set $TV $state if $state = state_now $Remote; + +For a more general way to handle TV/VCR RF remotes and X10 security +devices, see RF_Item.pm. + +If you want to relay all the of the incoming powerline style RF data +back out to the powerline, use mh/code/common/x10_rf_relay.pl. + +Also see X10_W800.pm for a similar interface. + +=cut + +use strict; +#use Fcntl qw(:DEFAULT) ; +use Fcntl; + +package X10_CMxx; +use X10_RF; + +@X10_CMxx::ISA = ('Generic_Item'); + +my $fifo; + +sub open_fifo { + close(X10_CMxx); + $_ = sysopen(X10_CMxx, "$fifo", Fcntl::O_NONBLOCK|Fcntl::O_RDONLY); + if ($_) { + &::print_log("CMxx: (re)opened $fifo to get data from mochad"); + } else { + &::print_log("CMxx: Failed to open $fifo to get data from mochad: $!"); + } + return $_; +} + +sub startup { + $fifo = $main::config_parms{X10_CMxx_fifo}; + if (not $fifo) { + warn ">>>>> X10_CMxx_fifo unset in mh.ini, X10_CMxx disabled <<<<<\n"; + sleep 5; + return; + } + if (not open_fifo()) { + warn ">>>>> Can't open fifo $fifo: $!. Disabling X10_CMxx module <<<<<\n"; + sleep 5; + } else { + &::MainLoop_pre_add_hook( \&X10_CMxx::check_for_data, 1 ); + } +} + +my ($prev_bad_checksums); +$prev_bad_checksums = 0; +my @msg_buffer = (); + +sub check_for_data { + my ($self) = @_; + + my $buffer; + my $buffersize = 65536; + my $rv = sysread(X10_CMxx, $buffer, $buffersize); + + # sysread returning undefined means fifo is ok, but no data received. + return if (not defined($rv)); + + # When the fifo is closed by the writer (or no one is on the other side, + # buffer receives undefined. + # we need to reopen it until someone starts writing to it. + if (not $buffer) { + # Reopen the fifo every 10 seconds if no one is writing to it. + if (&::new_second(10)) { + &::print_log("CMxx: no writer on fifo, reopening..."); + open_fifo(); + return; + } + } + + + foreach my $line (split(/\n/, $buffer)) { + + if (not $line =~ /.* Raw data received: /) { + &::print_log("CMxx: decoded data received from mochad: $line") if $main::Debug{cmxx}; + return; + } + # Raw data received: 5D 20 60 9F 20 DF + $line =~ s/.* Raw data received: //; + # See mochad's decode.c:cm15a_decode_rf for details on the 2nd byte. + # This accepts X10RF (20) and X10Sec (29). + if (not $line =~ s/^5D 2[09] //) + { + # Unknown data isn't bad, it should just be recognized if it's valid data with a different + # prefix, or ignored otherwise. + warn("Received $line from mochad, but does not start with known '5D 20/29', please fix me"); + next; + } + my $data = $line; + + # Data gets sent multiple times + # - Check time + # - Process data only on the 2nd occurance, to avoid noise (seems essential) + my $duplicate_threshold = 1; # 2nd occurance; set to 0 to omit duplicate check + my $duplicate_count = duplicate_count($data); + if ($duplicate_count == $duplicate_threshold) { + my @bytes; + my $byteidx = 0; + + &::print_log("CMxx: X10RF data from mochad: $line") if $main::Debug{cmxx}; + foreach my $byte (split(/\s/, $data)) { + #&::print_log("CMxx: set byte $byteidx to $byte") if $main::Debug{cmxx}; + $bytes[$byteidx] = chr(hex($byte)); + $byteidx++; + } + + my $state = X10_RF::decode_rf_bytes('X10_CMxx', @bytes); + # If the decode_rf_bytes routine didn't like the data that it got, + # we just drop the data (it's been preprocessed by mochad, so we can't hope to fix + # it by dropping bytes or whatever, we just leave that work to mochad). + &::print_log("CMxx: bad checksum, rejected $data") if ($state eq 'BADCHECKSUM'); + } elsif ($duplicate_count == 0) { + # Ignore the first send so that we can filter RF noise by confirming 2 identical frames in a row. + &::print_log("CMxx: Ignoring first send of X10RF data from mochad (looking for confirmation resend): $line") if $main::Debug{cmxx}; + } else { + &::print_log("CMxx: Ignoring duplicate X10RF data from mochad (dupe cnt >= $duplicate_count): $line") if $main::Debug{cmxx}; + } + } +} + +sub duplicate_count +{ + my ($raw_msg) = @_; + my $duplicate_count = 0; + my $repeat_time = $main::config_parms{CMxx_multireceive_delay} || 1500; + my $time = &main::get_tickcount; + + if (my $msg_buffer_size = @msg_buffer) { + # most recent messages are always first in the queue + for my $msg_ptr (@msg_buffer) { + my %msg = %$msg_ptr; + if (&X10_CMxx::is_within_timeout($time, $msg{time}, $repeat_time)) { + # a match exists on the data; so, compare against the time stamp + if ($raw_msg eq $msg{data}) { + # it's a duplicate since it's within the multireceive_delay + $duplicate_count++; + } + } else { + # no point in continuing to look at the rest as it's out of the time window + last; + } + } + } + # add to the msg buffer if it is not a duplicate + add_data($raw_msg) unless $duplicate_count > 2; + return $duplicate_count; +} + +sub add_data +{ + my ($data) = @_; + my %msg = (); + $msg{data} = $data; + $msg{time} = &main::get_tickcount; + + my $max_length = 20; + my $msg_buffer_size = @msg_buffer; + while ($msg_buffer_size >= $max_length) { + # most recent messages are always first in the queue + pop @msg_buffer; + $msg_buffer_size = @msg_buffer; + } + unshift @msg_buffer, \%msg; +} + +sub is_within_timeout +{ + my ($time1, $time2, $timeout) = @_; + return 1 if (($time1 >= 2**7) and ($time2 < 2**7)); + return ($time1 < ($time2 + $timeout)) ? 1 : 0; +} + +# vim:sw=4:sts=4 + +1; diff --git a/lib/X10_CMxx_mochad-0.1.7.diff b/lib/X10_CMxx_mochad-0.1.7.diff new file mode 100644 index 000000000..87f955177 --- /dev/null +++ b/lib/X10_CMxx_mochad-0.1.7.diff @@ -0,0 +1,127 @@ +diff -urN mochad-0.1.7.orig/apps/mochad.scr mochad-0.1.7/apps/mochad.scr +--- mochad-0.1.7.orig/apps/mochad.scr 1969-12-31 16:00:00.000000000 -0800 ++++ mochad-0.1.7/apps/mochad.scr 2011-07-02 12:51:46.502164447 -0700 +@@ -0,0 +1,29 @@ ++#!/bin/bash ++ ++# By marc_soft@merlins.org. ++ ++# This script is designed to get mochad raw data to a fifo. ++# This is used as an input source for misterhouse, ++# See misterhouse/lib/X10_CMxx.pm for more details. ++ ++# For this script to be useful linux with udev, you'll want ++# to edit /etc/udev/rules.d/91-usb-x10-controllers.rules ++# and make sure this script is run instead of the mochad binary. ++ ++FIFO=/var/run/CM19a ++ ++# Kill left over daemon just in case. ++killall mochad 2>/dev/null ++ ++/bin/rm $FIFO 2>/dev/null ++mkfifo $FIFO ++ ++# mochad forks off. ++/usr/local/bin/mochad --raw-data ++ ++( while : ++do ++ nc localhost 1099 > $FIFO ++ # This will restart nc as long as the mochad daemon is running. ++ pgrep -f '/usr/local/bin/mochad --raw-data' > /dev/null || break ++done ) & +diff -urN mochad-0.1.7.orig/decode.c mochad-0.1.7/decode.c +--- mochad-0.1.7.orig/decode.c 2011-03-27 16:20:49.000000000 -0700 ++++ mochad-0.1.7/decode.c 2011-07-01 10:46:01.419570619 -0700 +@@ -875,8 +875,10 @@ + *p = 0x5d; + memcpy(p+1, buf, len); + len++; +- cm15a_decode_rf(fd, p, len); +- return; ++ } ++ ++ if (raw_data) { ++ mh_sockhexdump(fd, p, len); + } + + switch (*p) +diff -urN mochad-0.1.7.orig/decode.h mochad-0.1.7/decode.h +--- mochad-0.1.7.orig/decode.h 2011-03-20 22:58:48.000000000 -0700 ++++ mochad-0.1.7/decode.h 2011-07-01 10:46:44.801939582 -0700 +@@ -17,6 +17,8 @@ + * along with mochad. If not, see . + */ + ++extern int raw_data; ++ + const char *findSecEventName(unsigned char secev); + + const char *findSecRemoteKeyName(unsigned char secev); +diff -urN mochad-0.1.7.orig/mochad.c mochad-0.1.7/mochad.c +--- mochad-0.1.7.orig/mochad.c 2011-03-21 03:19:43.000000000 -0700 ++++ mochad-0.1.7/mochad.c 2011-07-01 10:46:58.343742575 -0700 +@@ -164,6 +164,16 @@ + sockprintf(fd, "%s\n", buf); + } + ++// Output Raw data with header for parsing by misterhouse ++void mh_sockhexdump(int fd, void *p, size_t len) ++{ ++ char buf[(3*100)+1]; ++ ++ _hexdump(p, len, buf, sizeof(buf)); ++ sockprintf(fd, "Raw data received: %s\n", buf); ++} ++ ++ + static int Do_exit = 0; + static int Reattach = 0; + +@@ -685,6 +695,9 @@ + fflush(NULL); + } + ++// This affects whether decode.c will show raw frame data for debugging RF connectivity ++// as well as providing raw data for parsing by users like misterhouse's X10_CMxx module. ++int raw_data = 0; + int main(int argc, char *argv[]) + { + int rc, i; +@@ -698,6 +711,8 @@ + for (i = 1; i < argc; i++) { + if (strcmp(argv[i], "-d") == 0) + foreground = 1; ++ if (strcmp(argv[i], "--raw-data") == 0) ++ raw_data = 1; + else if (strcmp(argv[i], "--version") == 0) { + printf("%s\n", PACKAGE_STRING); + printcopy(); +diff -urN mochad-0.1.7.orig/README mochad-0.1.7/README +--- mochad-0.1.7.orig/README 2010-12-21 17:45:11.000000000 -0800 ++++ mochad-0.1.7/README 2011-07-01 23:35:09.255139648 -0700 +@@ -85,6 +85,23 @@ + Please see http://sourceforge.net/apps/mediawiki/mochad/index.php?title=Main_Page + for more details on command and event messages. + ++ ++If you want to debug X10 RF, or gateway raw frames to another program, you can ++use the --raw-data argument. ++See apps/mochad.scr for an example on how to gateway frames with misterhouse. ++ ++Another use is to simply be able to get all the raw RF frames to see if the ++multiple copies received are identical (good), off by a few bits (RF marginal), ++or nonsensical (bad). ++ ++ 07/01 23:34:42 Rx RF HouseUnit: A1 Func: Off ++ 07/01 23:34:42 Raw data received: 5D 20 60 9F 20 DF ++ 07/01 23:34:42 Raw data received: 5D 20 60 9F 20 DF ++ 07/01 23:34:43 Raw data received: 5D 20 60 9F 20 DF ++ 07/01 23:34:43 Raw data received: 5D 20 60 9F 20 DF ++ 07/01 23:34:43 Raw data received: 5D 20 60 9F 20 DF ++ ++ + == Multiple controllers + + The Perl program mochamon.pl shows how to monitor more than one instance of From c9b5d0eb7f29ea63587a533cbaaff8b5fbb9fe96 Mon Sep 17 00:00:00 2001 From: gliming Date: Sat, 2 Jul 2011 23:41:52 +0000 Subject: [PATCH 087/150] Compare received message id with active message to prevent accidental clearing. --- lib/Insteon/BaseInterface.pm | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 7940dbe89..53e5b6b96 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -344,7 +344,20 @@ sub on_standard_insteon_received $object->_process_message($self, %msg); if ($msg{is_ack} or $msg{is_nack}) { - $self->clear_active_message(); + # need to confirm that this message corresponds to the current active one before clearing it + # TO-DO!!! This is a brute force and poor compare technique; needs to be replaced by full compare + if ($self->active_message && ref $self->active_message->setby) + { + if (lc $self->active_message->setby->device_id eq lc $msg{source}) + { + $self->clear_active_message(); + } + else + { + &main::print_log("[Insteon::BaseInterface] WARN: deviceid of " + . "active message != received message source") if $main::Debug{insteon}; + } + } } } else From 72e33061052b7aa7c6f0d4fc6714dfe1077377b2 Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Sat, 23 Jul 2011 20:10:25 +0000 Subject: [PATCH 088/150] Added code to open CMxx fifo if it didn't work at startup. --- lib/X10_CMxx.pm | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/lib/X10_CMxx.pm b/lib/X10_CMxx.pm index e7e587186..0e018c23e 100644 --- a/lib/X10_CMxx.pm +++ b/lib/X10_CMxx.pm @@ -50,6 +50,7 @@ use X10_RF; @X10_CMxx::ISA = ('Generic_Item'); my $fifo; +my $fifo_opened = 0; sub open_fifo { close(X10_CMxx); @@ -69,12 +70,13 @@ sub startup { sleep 5; return; } - if (not open_fifo()) { - warn ">>>>> Can't open fifo $fifo: $!. Disabling X10_CMxx module <<<<<\n"; + if (not open_fifo()) { + &::print_log(">>>>> CMxx: still can't open fifo $fifo: $!. Will try again later <<<<<<"); sleep 5; } else { - &::MainLoop_pre_add_hook( \&X10_CMxx::check_for_data, 1 ); + $fifo_opened = 1; } + &::MainLoop_pre_add_hook( \&X10_CMxx::check_for_data, 1 ); } my ($prev_bad_checksums); @@ -86,8 +88,18 @@ sub check_for_data { my $buffer; my $buffersize = 65536; - my $rv = sysread(X10_CMxx, $buffer, $buffersize); + my $rv; + if (not $fifo_opened and &::new_minute()) { + &::print_log(">>>>> CMxx: has not yet opened $fifo. Trying again now <<<<<<"); + if (not open_fifo()) { + &::print_log(">>>>> CMxx: still can't open fifo $fifo: $!. Will try again later <<<<<<"); + } else { + $fifo_opened = 1; + } + } + + $rv = sysread(X10_CMxx, $buffer, $buffersize); # sysread returning undefined means fifo is ok, but no data received. return if (not defined($rv)); From 9c5098ede87972f0f72dbde62eab7728fda20a4d Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 6 Sep 2011 15:04:47 +0000 Subject: [PATCH 089/150] Fix incorrect reference to KeyPadlinc index. --- lib/Insteon/AllLinkDatabase.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 24c2603a8..352eb80cc 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -1263,7 +1263,7 @@ sub _write_link if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) { &::print_log("[Insteon::ALDB_i1] setting data3 to " . $$self{device}->group . " for this keypadlinc") if $main::Debug{insteon}; - $data3 = $self->group; + $data3 = $$self{device}->group; } $$self{pending_aldb}{data3} = (defined $data3) ? lc $data3 : '00'; $self->_peek($address); From 14c0649cca90524c18860c372ba343eeb6ffb622 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 6 Sep 2011 15:05:39 +0000 Subject: [PATCH 090/150] Revise processing of serial data after parsing is complete and prior to subsequent/pending command processing. --- lib/Insteon_PLM.pm | 42 +++++++++++++++++++----------------------- 1 file changed, 19 insertions(+), 23 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 5ad79d477..ae0a17c49 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -147,23 +147,11 @@ sub check_for_data { #lets turn this into Hex. I hate perl binary funcs my $data = unpack "H*", $data; - my $processedNibs; - $processedNibs = $self->_parse_data($data); - $processedNibs = 0 unless $processedNibs; -# &::print_log("PLM Proc:$processedNibs:" . length($data)); - if (length($data) > $processedNibs) - { - $main::Serial_Ports{$port_name}{data}=pack("H*",substr($data,$processedNibs,length($data)-$processedNibs)); - } - else - { - $main::Serial_Ports{$port_name}{data} = ''; - } - - # if no data being received, then check if any timeouts have expired + $self->_parse_data($data); } elsif (defined $self) { + # if no data being received, then check if any timeouts have expired if ($self->_check_timeout('command') == 1) { $self->_clear_timeout('command'); @@ -322,8 +310,6 @@ sub _parse_data { my ($self, $data) = @_; my ($name, $val); - my $processedNibs=0; - # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it if ($$self{_data_fragment}) { &::print_log("[Insteon_PLM] DEBUG: Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; @@ -334,7 +320,7 @@ sub _parse_data { # and, clear it out $$self{_data_fragment} = ''; } - &::print_log( "[Insteon_PLM] DEBUG: Parsing serial data: $data") if $self->debug; + &::print_log( "[Insteon_PLM] DEBUG: Received raw PLM data: $data") if $self->debug; # begin by pulling out any PLM ack/nacks my $prev_cmd = ''; @@ -364,9 +350,8 @@ sub _parse_data { #ignore blanks.. the split does odd things next if $parsed_data eq ''; $entered_ack_loop = 1; - if ($parsed_data =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) + if ($parsed_data =~ /^($ackcmd)|($nackcmd) |($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) { - $processedNibs+=length($parsed_data); my $ret_code = substr($parsed_data,length($parsed_data)-2,2); my $record_type = substr($parsed_data,0,4); my $message_data = substr($parsed_data,4,length($parsed_data)-4); @@ -401,6 +386,8 @@ sub _parse_data { if (($record_type eq $prefix{all_link_manage_rec}) and $$self{_mem_callback}) { + # clear the active message because we're done + $self->clear_active_message(); my $callback = $$self{_mem_callback}; $$self{_mem_callback} = undef; package main; @@ -509,6 +496,7 @@ sub _parse_data { if ($parsed_data =~ /^($prefix{insteon_send}\w{12}06)|($prefix{insteon_send}\w{12}15)$/) { &::print_log("[Insteon_PLM] ERROR: encountered '$parsed_data' but expected '$ackcmd'."); + $residue_data .= $parsed_data; } else { @@ -533,9 +521,6 @@ sub _parse_data { $entered_rcv_loop = 1; - #we found a matching command in stream, add to processed bytes - $processedNibs+=length($parsed_data); - my $parsed_prefix = substr($parsed_data,0,4); my $message_length = length($parsed_data); @@ -648,11 +633,22 @@ sub _parse_data { $$self{_data_fragment} = $residue_data unless $entered_rcv_loop or $$self{_data_fragment}; + # now, clear the serial port data so that any subsequent command processing doesn't result in an immediate filling/overwriting + my $port_name = $$self{port_name}; + if (length($residue_data)) + { + $main::Serial_Ports{$port_name}{data}=pack("H*",$$self{_data_fragment}); + } + else + { + $main::Serial_Ports{$port_name}{data} = ''; + } + if ($process_next_command) { $self->process_queue(); } - return $processedNibs; + return; } # dummy sub required to support the X10 integrtion From e67c4b17e92d7feb37e8090a69a39fade44a3415 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 6 Sep 2011 15:48:42 +0000 Subject: [PATCH 091/150] Always clear the serial buffer after getting data. --- lib/Insteon_PLM.pm | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index ae0a17c49..077c8163d 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -144,6 +144,18 @@ sub check_for_data { # always check for data first; if it exists, then process; otherwise check if pending commands exist if ($data) { + # now, clear the serial port data so that any subsequent command processing doesn't result in an immediate filling/overwriting + if (length($$self{_data_fragment})) + { +# $main::Serial_Ports{$port_name}{data}=pack("H*",$$self{_data_fragment}); + # always clear the buffer since we're maintaining the fragment separately + $main::Serial_Ports{$port_name}{data} = ''; + } + else + { + $main::Serial_Ports{$port_name}{data} = ''; + } + #lets turn this into Hex. I hate perl binary funcs my $data = unpack "H*", $data; @@ -633,17 +645,6 @@ sub _parse_data { $$self{_data_fragment} = $residue_data unless $entered_rcv_loop or $$self{_data_fragment}; - # now, clear the serial port data so that any subsequent command processing doesn't result in an immediate filling/overwriting - my $port_name = $$self{port_name}; - if (length($residue_data)) - { - $main::Serial_Ports{$port_name}{data}=pack("H*",$$self{_data_fragment}); - } - else - { - $main::Serial_Ports{$port_name}{data} = ''; - } - if ($process_next_command) { $self->process_queue(); } From a3b8715c67188e02c7390ab4251415eb2fb74868 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 6 Sep 2011 19:11:23 +0000 Subject: [PATCH 092/150] Avoid adding repeat fragments. Allow special case of manage links via manage_link_first_rec and manage_link_next_rec to return 15 rather than the entire sent message. --- lib/Insteon_PLM.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 077c8163d..8286c3dec 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -328,7 +328,7 @@ sub _parse_data { # maintain a copy of the parsed data fragment $$self{_prior_data_fragment} = $$self{_data_fragment}; # append if not a repeat - $data = $$self{_data_fragment} . $data; # unless $$self{_data_fragment} eq $data; + $data = $$self{_data_fragment} . $data unless $$self{_data_fragment} eq $data; # and, clear it out $$self{_data_fragment} = ''; } @@ -362,7 +362,7 @@ sub _parse_data { #ignore blanks.. the split does odd things next if $parsed_data eq ''; $entered_ack_loop = 1; - if ($parsed_data =~ /^($ackcmd)|($nackcmd) |($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)$/) + if ($parsed_data =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($prefix{all_link_first_rec}15)|($prefix{all_link_next_rec}15)|($badcmd)$/) { my $ret_code = substr($parsed_data,length($parsed_data)-2,2); my $record_type = substr($parsed_data,0,4); From c0ef7e4e2815041c62bf40dbb0c8418cb4872f3e Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 7 Sep 2011 19:55:08 +0000 Subject: [PATCH 093/150] Fix references to ALDB and various formatting consistency changes. --- lib/Insteon/BaseInsteon.pm | 232 ++++++++++++++++++++++++++----------- 1 file changed, 167 insertions(+), 65 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 206577a7d..38e7283ec 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -768,11 +768,16 @@ sub is_responder $$self{is_responder} = $is_responder if defined $is_responder; if ($self->is_root) { return $$self{is_responder}; - } else { + } + else + { my $root_obj = $self->get_root(); - if (ref $root_obj) { + if (ref $root_obj) + { return $$root_obj{is_responder}; - } else { + } + else + { return 0; } } @@ -793,7 +798,9 @@ sub link_to_interface $link_info{data3} = $p_data3 if $p_data3; if ($self->_aldb) { $self->_aldb->add_link(%link_info); - } else { + } + else + { &main::print_log("[BaseInsteon] This item " . $self->get_object_name . " does not have an ALDB object. Linking is not permitted."); } @@ -809,7 +816,9 @@ sub unlink_to_interface if ($self->_aldb) { $self->_aldb->delete_link(object => $self->interface, group => $group, is_controller => 1, callback => "$callback_instance->delete_link('$callback_info')"); - } else { + } + else + { &main::print_log("[BaseInsteon] This item " . $self->get_object_name . " does not have an ALDB object. Unlinking is not permitted."); } @@ -827,18 +836,22 @@ sub _aldb sub set_operating_flag { my ($self, $flag) = @_; - if (!(exists($operating_flags{$flag}))) { + if (!(exists($operating_flags{$flag}))) + { &::print_log("[Insteon::BaseDevice] $flag is not a support operating flag"); return; } - if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { + if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) + { # TO-DO: check devcat to determine if the action is supported by the device my $message = new Insteon::InsteonMessage('insteon_send', $self, 'set_operating_flags'); $message->extra($operating_flags{$flag}); $self->_send_cmd($message); # $self->_send_cmd('command' => 'set_operating_flags', 'extra' => $operating_flags{$flag}); - } else { + } + else + { &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); return; } @@ -847,12 +860,15 @@ sub set_operating_flag { sub get_operating_flag { my ($self) = @_; - if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) { + if ($self->is_root and !($self->isa('Insteon::InterfaceController'))) + { # TO-DO: check devcat to determine if the action is supported by the device my $message = new Insteon::InsteonMessage('insteon_send', $self, 'get_operating_flags'); $self->_send_cmd($message); # $self->_send_cmd('command' => 'get_operating_flags'); - } else { + } + else + { &::print_log("[Insteon::BaseDevice] " . $self->get_object_name . " is either not a root device or is a plm controlled scene"); return; } @@ -860,10 +876,14 @@ sub get_operating_flag { sub writable { my ($self, $p_write) = @_; - if (defined $p_write) { - if ($p_write =~ /r/i or $p_write =~/^0/) { + if (defined $p_write) + { + if ($p_write =~ /r/i or $p_write =~/^0/) + { $$self{m_write} = 0; - } else { + } + else + { $$self{m_write} = 1; } } @@ -883,9 +903,12 @@ sub is_root { sub get_root { my ($self) = @_; - if ($self->is_root) { + if ($self->is_root) + { return $self; - } else { + } + else + { return &Insteon::get_object($self->device_id, '01'); } } @@ -912,10 +935,13 @@ sub add_link if ($aldb) { my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } $aldb->add_link(%link_parms); @@ -930,10 +956,13 @@ sub update_link if ($aldb) { my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } $aldb->update_link(%link_parms); @@ -947,10 +976,13 @@ sub delete_link if ($aldb) { my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } $aldb->delete_link(%link_parms); @@ -1009,12 +1041,15 @@ sub restore_string { my ($self) = @_; my $restore_string = $self->SUPER::restore_string(); - if ($self->_aldb) { + if ($self->_aldb) + { $restore_string .= $self->_aldb->restore_string(); } - if ($$self{states}) { + if ($$self{states}) + { my $states = ''; - foreach my $state (@{$$self{states}}) { + foreach my $state (@{$$self{states}}) + { $states .= '|' if $states; $states .= $state; } @@ -1027,7 +1062,8 @@ sub restore_string sub restore_states { my ($self, $states) = @_; - if ($states) { + if ($states) + { @{$$self{states}} = split(/\|/,$states); } } @@ -1035,7 +1071,8 @@ sub restore_states sub restore_aldb { my ($self,$aldb) = @_; - if ($self->_aldb and $aldb) { + if ($self->_aldb and $aldb) + { $self->_aldb->restore_aldb($aldb); } } @@ -1043,9 +1080,11 @@ sub restore_aldb sub devcat { my ($self, $devcat) = @_; - if ($devcat) { + if ($devcat) + { $$self{devcat} = $devcat; - if (($$self{devcat} =~ /^01\w\w/) or ($$self{devcat} =~ /^02\w\w/) && !($self->states)) { + if (($$self{devcat} =~ /^01\w\w/) or ($$self{devcat} =~ /^02\w\w/) && !($self->states)) + { $self->states( 'on,off' ); } } @@ -1055,10 +1094,12 @@ sub devcat sub states { my ($self, $states) = @_; - if ($states) { + if ($states) + { @{$$self{states}} = split(/,/,$states); } - if ($$self{states}) { + if ($$self{states}) + { return @{$$self{states}}; } else { return undef; @@ -1070,7 +1111,8 @@ sub states sub local_onlevel { my ($self, $p_onlevel) = @_; - if (defined $p_onlevel) { + if (defined $p_onlevel) + { my ($onlevel) = $p_onlevel =~ /(\d+)%?/; $$self{_onlevel} = $onlevel; } @@ -1107,9 +1149,12 @@ sub log_alllink_table sub update_local_properties { my ($self) = @_; - if ($self->isa('Insteon::DimmableLight')) { + if ($self->isa('Insteon::DimmableLight')) + { $self->_aldb->update_local_properties() if $self->_aldb; - } else { + } + else + { &::print_log("[Insteon::BaseDevice] update_local_properties may only be applied to dimmable devices!"); } } @@ -1117,7 +1162,8 @@ sub update_local_properties sub update_flags { my ($self, $flags) = @_; - if (!($self->isa('Insteon::KeyPadLinc') or $self->isa('Insteon::KeyPadLincRelay'))) { + if (!($self->isa('Insteon::KeyPadLinc') or $self->isa('Insteon::KeyPadLincRelay'))) + { &::print_log("[Insteon::BaseDevice] Operating flags may only be revised on keypadlincs!"); return; } @@ -1155,18 +1201,25 @@ sub new sub add { my ($self, $obj, $on_level, $ramp_rate) = @_; - if (ref $obj and ($obj->isa('Light_Item') or $obj->isa('Insteon::BaseDevice'))) { - if ($$self{members} && $$self{members}{$obj}) { + if (ref $obj and ($obj->isa('Light_Item') or $obj->isa('Insteon::BaseDevice'))) + { + if ($$self{members} && $$self{members}{$obj}) + { print "[Insteon::BaseController] An object (" . $obj->{object_name} . ") already exists " . "in this scene. Aborting add request.\n"; return; } - if ($on_level =~ /^sur/i) { + if ($on_level =~ /^sur/i) + { $on_level = '100%'; $$obj{surrogate} = $self; - } elsif (lc $on_level eq 'on') { + } + elsif (lc $on_level eq 'on') + { $on_level = '100%'; - } elsif (lc $on_level eq 'off') { + } + elsif (lc $on_level eq 'off') + { $on_level = '0%'; } $on_level = '100%' unless $on_level; @@ -1185,9 +1238,11 @@ sub sync_links @{$$self{sync_queue}} = (); # reset the work queue $$self{sync_queue_callback} = ($callback) ? $callback : undef; my $insteon_object = $self->interface; - if (!($self->isa('Insteon::InterfaceController'))) { + if (!($self->isa('Insteon::InterfaceController'))) + { $insteon_object = &Insteon::get_object($self->device_id,'01'); - if (!(defined($insteon_object))) { + if (!(defined($insteon_object))) + { &main::print_log("[Insteon::BaseController] WARN!! A device w/ insteon address: " . $self->device_id . ":01 could not be found. " . "Please double check your items.mht file."); } @@ -1195,17 +1250,21 @@ sub sync_links my $self_link_name = $self->get_object_name; # abort if $insteon_object doesn't exist $self->_process_sync_queue() unless $insteon_object; - if ($$self{members}) { - foreach my $member_ref (keys %{$$self{members}}) { + if ($$self{members}) + { + foreach my $member_ref (keys %{$$self{members}}) + { my $member = $$self{members}{$member_ref}{object}; # find real device if member is a Light_Item - if ($member->isa('Light_Item')) { + if ($member->isa('Light_Item')) + { my @children = $member->find_members('Insteon::BaseDevice'); $member = $children[0]; } my $linkmember = $member; # find real device if member's group is not '01'; for example, cross-linked KeypadLincs - if ($member->group ne '01') { + if ($member->group ne '01') + { $member = &Insteon::get_object($member->device_id,'01'); } my $tgt_on_level = $$self{members}{$member_ref}{on_level}; @@ -1215,7 +1274,8 @@ sub sync_links $tgt_ramp_rate = '0' unless defined $tgt_ramp_rate; # first, check existance for each link; if found, then perform an update (unless link is to PLM) # if not, then add the link - if ($member->has_link($insteon_object, $self->group, 0, $linkmember->group)) { + if ($member->has_link($insteon_object, $self->group, 0, $linkmember->group)) + { # TO-DO: only update link if the on_level and ramp_rate are different my $requires_update = 0; $tgt_on_level =~ s/(\d+)%?/$1/; @@ -1225,57 +1285,81 @@ sub sync_links and $linkmember->group ne '01') { $aldbkey .= $linkmember->group; } - if (!($member->isa('Insteon::DimmableLight'))) { + if (!($member->isa('Insteon::DimmableLight'))) + { my $member_aldb = $member->_aldb; - if ($tgt_on_level >= 1 and $$member_aldb{$aldbkey}{data1} ne 'ff') { + if ($tgt_on_level >= 1 and $$member_aldb{aldb}{$aldbkey}{data1} ne 'ff') + { $requires_update = 1; $tgt_on_level = 100; - } elsif ($tgt_on_level == 0 and $$member_aldb{$aldbkey}{data1} ne '00') { + } + elsif ($tgt_on_level == 0 and $$member_aldb{aldb}{$aldbkey}{data1} ne '00') + { $requires_update = 1; } - if ($$member_aldb{$aldbkey}{data2} ne '00') { + if ($$member_aldb{aldb}{$aldbkey}{data2} ne '00') + { $tgt_ramp_rate = 0; } - } else { + } + else + { my $member_aldb = $member->_aldb; $tgt_ramp_rate = 0.1 unless $tgt_ramp_rate; - my $link_on_level = hex($$member_aldb{$aldbkey}{data1})/2.55; - my $raw_ramp_rate = $$member_aldb{$aldbkey}{data2}; + my $link_on_level = hex($$member_aldb{aldb}{$aldbkey}{data1})/2.55; + my $raw_ramp_rate = $$member_aldb{aldb}{$aldbkey}{data2}; my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); - if ($raw_ramp_rate != $raw_tgt_ramp_rate) { + if ($raw_ramp_rate != $raw_tgt_ramp_rate) + { $requires_update = 1; - } elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) { + &::print_log("[Insteon::BaseController] DEBUG: flagging " . $self->get_object_name + . " for update because existing ramp rate ($raw_ramp_rate) != target ($raw_tgt_ramp_rate)") + if $main::Debug{insteon}; + + } + elsif (($link_on_level > $tgt_on_level + 1) or ($link_on_level < $tgt_on_level -1)) + { $requires_update = 1; + &::print_log("[Insteon::BaseController] DEBUG: flagging " . $self->get_object_name + . " for update because existing on level ($link_on_level) != target ($tgt_on_level)") + if $main::Debug{insteon}; } } - if ($requires_update) { + if ($requires_update) + { my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, group => $self->group, is_controller => 0, on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, callback => "$self_link_name->_process_sync_queue()" ); # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + { $link_req{data3} = $linkmember->group; } push @{$$self{sync_queue}}, \%link_req; } - } else { + } + else + { my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, group => $self->group, is_controller => 0, on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, callback => "$self_link_name->_process_sync_queue()" ); # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + { $link_req{data3} = $linkmember->group; } push @{$$self{sync_queue}}, \%link_req; } - if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) { + if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) + { my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, group => $self->group, is_controller => 1, callback => "$self_link_name->_process_sync_queue()" ); # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) { + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + { $link_req{data3} = $linkmember->group; } push @{$$self{sync_queue}}, \%link_req; @@ -1283,16 +1367,19 @@ sub sync_links } } # if not a plm controlled link, then confirm that a link back to the plm exists - if (!($self->isa('Insteon::InterfaceController'))) { + if (!($self->isa('Insteon::InterfaceController'))) + { my $subaddress = ($self->isa('Insteon::KeyPadLincRelay') or $self->isa('Insteon::KeyPadLinc')) ? $self->group : '00'; - if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) { + if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) + { my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, group => $self->group, is_controller => 1, callback => "$self_link_name->_process_sync_queue()" ); $link_req{data3} = $self->group if $insteon_object->isa('Insteon::KeyPadLincRelay') or $insteon_object->isa('Insteon::KeyPadLinc'); push @{$$self{sync_queue}}, \%link_req; } - if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) { + if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) + { my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, group => $self->group, is_controller => 0, callback => "$self_link_name->_process_sync_queue()" ); @@ -1300,7 +1387,8 @@ sub sync_links } } my $num_sync_queue = @{$$self{sync_queue}}; - if (!($num_sync_queue)) { + if (!($num_sync_queue)) + { &::print_log("[Insteon::BaseController] Nothing to do when syncing links for " . $self->get_object_name) if $main::Debug{insteon}; } @@ -1511,6 +1599,20 @@ sub find_members } +sub has_member +{ + my ($self, $compare_object) = @_; + foreach my $member_ref (keys %{$$self{members}}) + { + my $member = $$self{members}{$member_ref}{object}; + if ($member eq $compare_object) + { + return 1; + } + } + return 0; +} + #################################### ### ##################### ### DeviceController ############### From 52dce0e9dac016ade045dd40b0296ba0db4011cd Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 7 Sep 2011 19:56:16 +0000 Subject: [PATCH 094/150] Fix references to ALDB. Differentiate one-sided links from being orphaned or incorrect. --- lib/Insteon/AllLinkDatabase.pm | 177 +++++++++++++++++++++++---------- 1 file changed, 124 insertions(+), 53 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 352eb80cc..4576ec4ba 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -679,8 +679,10 @@ sub delete_orphan_links return $num_deleted; # no links deleted } - for my $linkkey (keys %{$$self{aldb}}) { - if ($linkkey ne 'empty' and $linkkey ne 'duplicates') { + for my $linkkey (keys %{$$self{aldb}}) + { + if ($linkkey ne 'empty' and $linkkey ne 'duplicates') + { my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; next unless $deviceid; my $group = $$self{aldb}{$linkkey}{group}; @@ -689,7 +691,8 @@ sub delete_orphan_links # $device is the object that is referenced by the ALDB record's deviceid my $device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface : &Insteon::get_object($deviceid,'01'); - if (!($device)) { + if (!($device)) + { # no device is known by mh with the ADLB record's deviceid if ($audit_mode) { @@ -700,12 +703,16 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", cause => "no device could be found"); + callback => "$selfname->_aldb->_process_delete_queue()", cause => "no device could be found"); push @{$$self{delete_queue}}, \%delete_req; } - } elsif ($device->isa("Insteon::BaseInterface") and $is_controller) { + } + elsif ($device->isa("Insteon::BaseInterface") and $is_controller) + { # ignore since this is just a link back to the PLM - } elsif ($device->isa("Insteon::BaseInterface")) { + } + elsif ($device->isa("Insteon::BaseInterface")) + { # does the PLM have a link point back? If not, the delete this one # These are all responder links if (!($device->has_link($$self{device},$group,1))) @@ -722,7 +729,7 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, data3 => $data3, + callback => "$selfname->_aldb->_process_delete_queue()", object => $device, data3 => $data3, cause => 'PLM does not have a link pointing back to device'); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -774,7 +781,7 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, + callback => "$selfname->_aldb->_process_delete_queue()", object => $device, cause => "no link is defined for the plm controlled scene", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -791,7 +798,7 @@ sub delete_orphan_links { # delete the link since it doesn't exist my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, + callback => "$selfname->_aldb->_process_delete_queue()", object => $device, cause => "no plm link could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -818,53 +825,117 @@ sub delete_orphan_links # does the device fail to have a reciprocal link? if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { + # this may be a case of an impartial link (not yet bidirectional) + # BUT... if is_controller and $device is not a member of $$self{device} + # if not is_controller and $$self{device} is not a member of $device, + # then the dangling link needs to be deleted if ($audit_mode) { if ($is_controller) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reciprocal link defined for: " - . $$self{device}->get_object_name - . "($group) as controller and " - . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" - . " Please sync links with the applicable device; this link will not be deleted." - ); + my $reference_object = &Insteon::get_object($$self{device}->device_id, $group); + my $reverse_object = &Insteon::get_object($device->device_id, ($data3 eq '00') ? '01' : $data3); + if (ref $reference_object and ref $reverse_object and $reference_object->isa("Insteon::BaseController") and $reference_object->has_member($reverse_object)) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reciprocal link defined for: " + . $reference_object->get_object_name + . " as controller and " + . $reverse_object->get_object_name + . ". Please sync links with the applicable device; this link will not be deleted." + ); + } + else + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " + . $$self{device}->get_object_name + . "($group) as controller and " + . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + . " because no reciprocal link exists!" + ); + } } else # is a responder { - &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reverse link defined for: " - . $$self{device}->get_object_name - . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " - . $device->get_object_name . "($group)" - . " Please sync links with the applicable device; this link will not be deleted." - ); - } - + my $reference_object = &Insteon::get_object($$self{device}->device_id, ($data3 eq '00') ? '01' : $data3); + my $reverse_object = &Insteon::get_object($device->device_id, $group ); + if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reverse link defined for: " + . $reference_object->get_object_name + . " as responder and " + . $reverse_object->get_object_name + . ". Please sync links with the applicable device; this link will not be deleted." + ); + } + else + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " + . $$self{device}->get_object_name + . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " + . $device->get_object_name . "($group)" + . " because no reverse links exists!" + ); + } + } } else # non-audit mode { if ($is_controller) { - &::print_log("[Insteon::ALDB_i1] WARNING: no reciprocal link defined for: " - . $$self{device}->get_object_name - . "($group) as controller and " - . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" - . " Please sync links with the applicable device; this link will not be deleted." - ); + my $reference_object = &Insteon::get_object($$self{device}->device_id, $group); + my $reverse_object = &Insteon::get_object($device->device_id, ($data3 eq '00') ? '01' : $data3); + if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) + { + &::print_log("[Insteon::ALDB_i1] WARNING: no reciprocal link defined for: " + . $reference_object->get_object_name + . " as controller and " + . $reverse_object->get_object_name + . ". Please sync links with the applicable device; this link will not be deleted." + ); + } + else + { + &::print_log("[Insteon::ALDB_i1] Deleting link defined for: " + . $$self{device}->get_object_name + . "($group) as controller and " + . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + . " because no reciprocal link exists!" + ); + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link to the device could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } } else # is a responder { - &::print_log("[Insteon::ALDB_i1] WARNING: no reverse link defined for: " - . $$self{device}->get_object_name - . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " - . $device->get_object_name . "($group)" - . " Please sync links with the applicable device; this link will not be deleted." - ); + my $reference_object = &Insteon::get_object($$self{device}->device_id, ($data3 eq '00') ? '01' : $data3); + my $reverse_object = &Insteon::get_object($device->device_id, $group ); + if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) + { + &::print_log("[Insteon::ALDB_i1] WARNING: no reverse link defined for: " + . $reference_object->get_object_name + . " as responder and " + . $reverse_object->get_object_name + . ". Please sync links with the applicable device; this link will not be deleted." + ); + } + else + { + &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " + . $$self{device}->get_object_name + . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " + . $device->get_object_name . "($group)" + . " because no reverse links exists!" + ); + my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", object => $device, + cause => "no link to the device could be found", data3 => $data3); + push @{$$self{delete_queue}}, \%delete_req; + $num_deleted++; + } } -# my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, -# callback => "$selfname->_process_delete_queue()", object => $device, -# cause => "no link to the device could be found", data3 => $data3); -# push @{$$self{delete_queue}}, \%delete_req; -# $num_deleted++; } } else # device does have reciprocal link @@ -922,7 +993,7 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, + callback => "$selfname->_aldb->_process_delete_queue()", object => $device, cause => "no reverse link could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -946,7 +1017,7 @@ sub delete_orphan_links else { my %delete_req = (address => $address, - callback => "$selfname->_process_delete_queue()", + callback => "$selfname->_aldb->_process_delete_queue()", cause => "duplicate record found"); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -976,7 +1047,7 @@ sub _process_delete_queue { . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); } -# $self->delete_link(%delete_req); + $self->delete_link(%delete_req); $$self{delete_queue_processed}++; } # else @@ -1477,7 +1548,7 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue(1)", + callback => "$selfname->_aldb->_process_delete_queue(1)", linkdevice => $self, data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; } @@ -1499,7 +1570,7 @@ sub delete_orphan_links else { my %delete_req = (object => $device, group => $group, is_controller => 1, - callback => "$selfname->_process_delete_queue(1)", + callback => "$selfname->_aldb->_process_delete_queue(1)", linkdevice => $self, data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; } @@ -1568,7 +1639,7 @@ sub delete_orphan_links else { my %delete_req = (object => $self, group => $group, is_controller => 0, - callback => "$selfname->_process_delete_queue(1)", + callback => "$selfname->_aldb->_process_delete_queue(1)", linkdevice => $device, data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; } @@ -1588,7 +1659,7 @@ sub delete_orphan_links if (($obj->is_root)) { $num_deleted += $obj->delete_orphan_links($audit_mode); - my %delete_req = ('root_object' => $obj, callback => "$selfname->_process_delete_queue()"); + my %delete_req = ('root_object' => $obj, callback => "$selfname->_aldb->_process_delete_queue()"); push @{$$self{delete_queue}}, \%delete_req; } } @@ -1648,10 +1719,14 @@ sub delete_link . $$self{aldb}{$linkkey}{data1} . $$self{aldb}{$linkkey}{data2} . $$self{aldb}{$linkkey}{data3}; - $$self{_success_callback} = $link_parms{callback} if $link_parms{callback}; delete $$self{aldb}{$linkkey}; $num_deleted = 1; my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); + if ($link_parms{callback}) + { + $$self{_success_callback} = $link_parms{callback}; + $message->callback($link_parms{callback}); + } $message->interface_data($cmd); $$self{device}->queue_message($message); } else { @@ -1733,12 +1808,8 @@ sub add_link sub has_link { my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; + # note, subaddress is IGNORED!! my $key = lc $insteon_object->device_id . $group . $is_controller; - $subaddress = '00' unless $subaddress; - # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { - $key .= $subaddress; - } return (defined $$self{aldb}{$key}) ? 1 : 0; } From 6e2d6e991155e16ec2dc8a71296eb75ba22f0bfd Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 7 Sep 2011 20:00:53 +0000 Subject: [PATCH 095/150] Prevent clearing active message unless the received insteon message is an acknowledge of a direct message. --- lib/Insteon/BaseInterface.pm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 53e5b6b96..9949d79d8 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -348,14 +348,15 @@ sub on_standard_insteon_received # TO-DO!!! This is a brute force and poor compare technique; needs to be replaced by full compare if ($self->active_message && ref $self->active_message->setby) { - if (lc $self->active_message->setby->device_id eq lc $msg{source}) + if ((lc $self->active_message->setby->device_id eq lc $msg{source}) and ($msg{type} eq 'direct')) { $self->clear_active_message(); } else { &main::print_log("[Insteon::BaseInterface] WARN: deviceid of " - . "active message != received message source") if $main::Debug{insteon}; + . "active message != received message source") + if $msg{type} eq 'direct' and $main::Debug{insteon}; } } } From 0c94da1cfad15cc9636d7be44f3c7086b9970b51 Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 7 Sep 2011 20:02:50 +0000 Subject: [PATCH 096/150] Ensure fragment buffering is cleared. Clear resend timer on clearing active message. --- lib/Insteon_PLM.pm | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 8286c3dec..01b425be9 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -303,7 +303,10 @@ sub _send_cmd { } else { my $command_type = $message->command_type; $command = $prefix{$command_type} . $command; - $self->_set_timeout('command', $cmd_timeout); # a commmand needs to be PLM ack'd w/i 3 seconds or it gets dropped + if ($command_type eq 'all_link_send' or $command_type eq 'insteon_send' or $command_type eq 'insteon_ext_send') + { + $self->_set_timeout('command', $cmd_timeout); # a commmand needs to be PLM ack'd w/i 3 seconds or it gets dropped + } } my $data = pack("H*",$command); @@ -323,7 +326,8 @@ sub _parse_data { my ($name, $val); # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it - if ($$self{_data_fragment}) { + if ($$self{_data_fragment}) + { &::print_log("[Insteon_PLM] DEBUG: Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; # maintain a copy of the parsed data fragment $$self{_prior_data_fragment} = $$self{_data_fragment}; @@ -332,6 +336,12 @@ sub _parse_data { # and, clear it out $$self{_data_fragment} = ''; } + else + { + # clear the memory of any prior data fragment + $$self{_prior_data_fragment} = ''; + } + &::print_log( "[Insteon_PLM] DEBUG: Received raw PLM data: $data") if $self->debug; # begin by pulling out any PLM ack/nacks @@ -396,17 +406,20 @@ sub _parse_data { $self->clear_active_message(); } - if (($record_type eq $prefix{all_link_manage_rec}) and $$self{_mem_callback}) + if ($record_type eq $prefix{all_link_manage_rec}) { # clear the active message because we're done $self->clear_active_message(); - my $callback = $$self{_mem_callback}; + my $callback = $pending_message->callback(); #$$self{_mem_callback}; $$self{_mem_callback} = undef; - package main; - eval ($callback); - &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) - if $@ and $main::Debug{insteon}; - package Insteon_PLM; + if ($callback) + { + package main; + eval ($callback); + &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon}; + package Insteon_PLM; + } } } elsif ($ret_code eq '15' or $ret_code eq '0f') @@ -615,8 +628,9 @@ sub _parse_data { ); $link->_process_message($self, %msg); } + # only clear the active message if this all_link_clean_status corresponds to a all_link_send message + $self->clear_active_message(); } - $self->clear_active_message(); } } elsif (substr($parsed_data,0,2) eq '15') From c5fd5447b5d187b66b1e59fa4939f327167c88fa Mon Sep 17 00:00:00 2001 From: gliming Date: Wed, 7 Sep 2011 21:56:26 +0000 Subject: [PATCH 097/150] Implement debug verbosity levels where ini setting can be debug=insteon:x (where x=1,2 or 3). 3 is most verbose. --- lib/Insteon.pm | 12 ++++----- lib/Insteon/BaseInterface.pm | 10 -------- lib/Insteon_PLM.pm | 48 ++++++++++++++++++------------------ 3 files changed, 29 insertions(+), 41 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 14bef339c..9e83bff14 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -38,9 +38,9 @@ sub scan_all_linktables or $candidate_object->isa('Insteon::MotionSensor'))) { push @_scan_devices, $candidate_object; - &main::print_log("[Scan all linktables] INFO: " + &main::print_log("[Scan all linktables] INFO1: " . $candidate_object->get_object_name - . " will be scanned.") if $main::Debug{insteon}; + . " will be scanned.") if $main::Debug{insteon} >= 1; } else { @@ -274,7 +274,7 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,messaging debug on,messaging debug off,delete orphan links,AUDIT - delete orphan links,scan all device link tables"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,delete orphan links,AUDIT - delete orphan links,scan all device link tables"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -283,9 +283,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(1)','messaging debug on');\n\n"; - $object_string .= "$object_name_v -> tie_event('$object_name->debug(0)','messaging debug off');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all device link tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all devicelink tables');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } @@ -486,4 +484,4 @@ sub find_members { return @l_found; } -1 +1 \ No newline at end of file diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 9949d79d8..de1fea563 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -69,16 +69,6 @@ sub equals } } -sub debug -{ - my ($self, $debug) = @_; - if (defined $debug) - { - $$self{debug} = $debug; - } - return $$self{debug}; -} - sub _is_duplicate { my ($self, $cmd) = @_; diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 01b425be9..a4cbfe1ee 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -177,7 +177,7 @@ sub check_for_data { } else { - &::print_log("[Insteon_PLM] PLM command timer expired but no transmission in place. Moving on...") if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG2: PLM command timer expired but no transmission in place. Moving on...") if $main::Debug{insteon} >= 2; $self->clear_active_message(); $self->process_queue(); } @@ -292,9 +292,9 @@ sub _send_cmd { # determine the delay from the point that the message was created to # the point that it is queued my $incurred_delay_time = $message->seconds_delayed; - &main::print_log("[Insteon_PLM] DEBUG: Sending " . $message->to_string . " incurred delay of " + &main::print_log("[Insteon_PLM] DEBUG2: Sending " . $message->to_string . " incurred delay of " . sprintf('%.2f',$incurred_delay_time) . " seconds; starting hop-count: " - . ((ref $message->setby && $message->setby->isa('Insteon::BaseObject')) ? $message->setby->default_hop_count : "?")) if $self->debug; + . ((ref $message->setby && $message->setby->isa('Insteon::BaseObject')) ? $message->setby->default_hop_count : "?")) if $main::Debug{insteon} >= 2; if ($message->isa('Insteon::X10Message')) { # is x10; so, be slow $command = $prefix{x10_send} . $command; @@ -328,7 +328,7 @@ sub _parse_data { # it is possible that a fragment exists from a previous attempt; so, if it exists, prepend it if ($$self{_data_fragment}) { - &::print_log("[Insteon_PLM] DEBUG: Prepending prior data fragment: $$self{_data_fragment}") if $self->debug or $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG3: Prepending prior data fragment: $$self{_data_fragment}") if $main::Debug{insteon} >= 3; # maintain a copy of the parsed data fragment $$self{_prior_data_fragment} = $$self{_data_fragment}; # append if not a repeat @@ -342,7 +342,7 @@ sub _parse_data { $$self{_prior_data_fragment} = ''; } - &::print_log( "[Insteon_PLM] DEBUG: Received raw PLM data: $data") if $self->debug; + &::print_log( "[Insteon_PLM] DEBUG3: Received raw PLM data: $data") if $main::Debug{insteon} >= 3; # begin by pulling out any PLM ack/nacks my $prev_cmd = ''; @@ -397,8 +397,8 @@ sub _parse_data { } else { - &::print_log("[Insteon_PLM] DEBUG: Received PLM acknowledge: " - . $pending_message->to_string) if $self->debug; + &::print_log("[Insteon_PLM] DEBUG3: Received PLM acknowledge: " + . $pending_message->to_string) if $main::Debug{insteon} >= 3; } if ($parsed_data =~ /$prefix{x10_send}\w{4}06/) @@ -416,8 +416,8 @@ sub _parse_data { { package main; eval ($callback); - &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) - if $@ and $main::Debug{insteon}; + &::print_log("[Insteon_PLM] WARN1: Error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon} >= 1; package Insteon_PLM; } } @@ -447,8 +447,8 @@ sub _parse_data { $$self{_mem_callback} = undef; package main; eval ($callback); - &::print_log("[Insteon_PLM] error encountered during nack callback: " . $@) - if $@ and $main::Debug{insteon}; + &::print_log("[Insteon_PLM] WARN1: Error encountered during nack callback: " . $@) + if $@ and $main::Debug{insteon} >= 1; package Insteon_PLM; } } @@ -490,8 +490,8 @@ sub _parse_data { $$self{_mem_callback} = undef; package main; eval ($callback); - &::print_log("[Insteon_PLM] error encountered during ack callback: " . $@) - if $@ and $main::Debug{insteon}; + &::print_log("[Insteon_PLM] WARN1: Error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon} >= 1; package Insteon_PLM; } # clear the active message because we're done @@ -563,13 +563,13 @@ sub _parse_data { { #X10 Received my $x10_message = new Insteon::X10Message($message_data); my $x10_data = $x10_message->get_formatted_data(); - &::print_log("[Insteon_PLM] received x10 data: $x10_data") if $main::Debug{insteon} + &::print_log("[Insteon_PLM] DEBUG3: received x10 data: $x10_data") if $main::Debug{insteon} >= 3 &::process_serial_data($x10_data,undef,$self); } elsif ($parsed_prefix eq $prefix{all_link_complete} and ($message_length == 20)) { #ALL-Linking Completed my $link_address = substr($message_data,4,6); - &::print_log("[Insteon_PLM] ALL-Linking Completed with $link_address ($message_data)") if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG2: ALL-Linking Completed with $link_address ($message_data)") if $main::Debug{insteon} >= 2; $self->clear_active_message(); } elsif ($parsed_prefix eq $prefix{all_link_clean_failed} and ($message_length == 14)) @@ -580,12 +580,12 @@ sub _parse_data { my $failure_group = substr($message_data,2,2); my $failure_device = substr($message_data,4,6); - &::print_log("[Insteon_PLM] Recieved all-link cleanup failure from device: " - . "$failure_device and group: failure_group") if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG2: Recieved all-link cleanup failure from device: " + . "$failure_device and group: failure_group") if $main::Debug{insteon} >= 2; } elsif ($parsed_prefix eq $prefix{all_link_record} and ($message_length == 20)) { #ALL-Link Record Response - &::print_log("[Insteon_PLM] ALL-Link Record Response:$message_data") if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG2: ALL-Link Record Response:$message_data") if $main::Debug{insteon} >= 2; $self->_aldb->parse_alllink($message_data); # before doing the next, make sure that the pending command # (if it sitll exists) is pulled from the queue @@ -599,9 +599,9 @@ sub _parse_data { if ($cleanup_ack eq '15') { my $delay_in_seconds = 1.0; # this may need to be tweaked - &::print_log("[Insteon_PLM] Received all-link cleanup failure for current message." + &::print_log("[Insteon_PLM] WARN1: Received all-link cleanup failure for current message." . " Attempting resend in " . $delay_in_seconds . " seconds.") - if $main::Debug{insteon}; + if $main::Debug{insteon} >= 1; $self->retry_active_message(); # except that we should cause a bit of a delay to let things settle out $self->_set_timeout('xmit',$delay_in_seconds * 1000); @@ -610,8 +610,8 @@ sub _parse_data { else { my $message_to_string = ($self->active_message) ? $self->active_message->to_string() : ""; - &::print_log("[Insteon_PLM] Received all-link cleanup success: $message_to_string") - if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG2: Received all-link cleanup success: $message_to_string") + if $main::Debug{insteon} >= 2; # attempt to process the message by the link object; this acknowledgement will reset # the auto-retry timer @@ -639,8 +639,8 @@ sub _parse_data { if (!($nack_count)) { my $nack_delay = ($::config_parms{Insteon_PLM_disable_throttling}) ? 0.3 : 1.0; - &::print_log("[Insteon_PLM] Interface extremely busy. Resending command" - . " after delaying for $nack_delay second") if $main::Debug{insteon}; + &::print_log("[Insteon_PLM] DEBUG3: Interface extremely busy. Resending command" + . " after delaying for $nack_delay second") if $main::Debug{insteon} >= 3; $self->_set_timeout('xmit',$nack_delay * 1000); $self->retry_active_message(); # $$self{xmit_in_progress} = 0; From 73e58b931b89e819c2d294be3c0cce2da032400c Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 14 Nov 2011 19:11:26 +0000 Subject: [PATCH 098/150] Fix typo on scan all link tables. --- lib/Insteon.pm | 49 ++++++++++++++++++++++++++++--------------------- 1 file changed, 28 insertions(+), 21 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 9e83bff14..6b53cab12 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -17,7 +17,7 @@ sub scan_all_linktables &main::print_log("[Scan all linktables] WARN: link already underway. Ignoring request for new scan ..."); return; } - + print "######### GOT HERE #############\n"; my @candidate_devices = (); # clear @_scan_devices @_scan_devices = (); @@ -29,26 +29,33 @@ sub scan_all_linktables push @candidate_devices, &Insteon::find_members("Insteon::BaseDevice"); # don't try to scan devices that are not responders - foreach (@candidate_devices) + if (@candidate_devices) { - my $candidate_object = $_; - if ($candidate_object->is_root and - !($candidate_object->isa('Insteon::RemoteLinc') - or $candidate_object->isa('Insteon::InterfaceController') - or $candidate_object->isa('Insteon::MotionSensor'))) - { - push @_scan_devices, $candidate_object; - &main::print_log("[Scan all linktables] INFO1: " - . $candidate_object->get_object_name - . " will be scanned.") if $main::Debug{insteon} >= 1; - } - else - { - &main::print_log("[Scan all linktables] INFO: !!! " - . $candidate_object->get_object_name - . " is NOT a candidate for scanning."); - } - } + foreach (@candidate_devices) + { + my $candidate_object = $_; + if ($candidate_object->is_root and + !($candidate_object->isa('Insteon::RemoteLinc') + or $candidate_object->isa('Insteon::InterfaceController') + or $candidate_object->isa('Insteon::MotionSensor'))) + { + push @_scan_devices, $candidate_object; + &main::print_log("[Scan all linktables] INFO1: " + . $candidate_object->get_object_name + . " will be scanned.") if $main::Debug{insteon} >= 1; + } + else + { + &main::print_log("[Scan all linktables] INFO: !!! " + . $candidate_object->get_object_name + . " is NOT a candidate for scanning."); + } + } + } + else + { + &main::print_log("[Scan all linktables] WARN: No insteon devices could be found"); + } $_scan_cnt = scalar @_scan_devices; &_get_next_linkscan(); @@ -283,7 +290,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; - $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all devicelink tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all device link tables');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } From 1800a6ba005aa1c3f86ab0ae707b5856b0688aed Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Sun, 27 Nov 2011 21:38:07 +0000 Subject: [PATCH 099/150] Small update on converting old PLM entries. --- lib/Insteon/convert_insteon_config | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/Insteon/convert_insteon_config b/lib/Insteon/convert_insteon_config index 9219e67f0..f551f6545 100755 --- a/lib/Insteon/convert_insteon_config +++ b/lib/Insteon/convert_insteon_config @@ -37,6 +37,7 @@ while (<>) s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*rlink)#INSTEON_REMOTELINC$1#i; # IOLINC isn't supported yet, but it does look like a switchlinc relay. s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*iolin)#INSTEON_SWITCHLINCRELAY$1#i; + s#INSTEON_SWITCHLINC\|SWITCHLINCRELAY\|KEYPADLINC\|REMOTELINC(.*PLM)#INSTEON_PLM$1#i; s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*lamplin)#INSTEON_LAMPLINC$1#i; s#INSTEON_LAMPLINC\|APPLIANCELINC\|MOTIONSENSOR(.*appliance lin)#INSTEON_APPLIANCELINC$1#i; From a282cdfc3317e24318607e1719c77328dafddc5a Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Sun, 27 Nov 2011 21:59:54 +0000 Subject: [PATCH 100/150] This has major improvements on serial port data handing to avoid the occasional dies due to poor timing. Details: - stop messing around, and just require Time::Hires (old code could limp around with just 'sleep', but as a result it did a poor job of reliably getting data replies on some occasions). - instead of blindly sleeping for a pre-guessed time before reading a response, read data characters - sleeps are now reduced to the bare minimum required (0.37s for typical reads to 0.80s for full register dumps). - No data gets dropped anymore without suitable logging and serial port data is cleared before sending a command and waiting for an answer. - No more priming hack needed. - die resets cache data so that we don't end up with possible garbage data - filter reminder is fixed to actually return 0 as opposed to "0x0" when the counter expires. - state_now logic was improved somewhat. --- lib/Omnistat.pm | 323 +++++++++++++++++++++++++++--------------------- 1 file changed, 184 insertions(+), 139 deletions(-) diff --git a/lib/Omnistat.pm b/lib/Omnistat.pm index b732cd44d..0ffc4ba6a 100644 --- a/lib/Omnistat.pm +++ b/lib/Omnistat.pm @@ -67,23 +67,19 @@ TODO: The sleep situation has been much improved, but if someone smart could rep Changelog ================================================================================ -2010/07/26 - Marc MERLIN +2011/11/24 - Marc MERLIN ======================== -Minor fixes, but the biggest was modifying bin/mh to support code that occasionally dies -(mh would disable that code after it died 9 times, which is not so good since it killed -all temp and stat logging if you were using that). -It is just hard to never trigger die code, in my case I sometimes have: -Omnistat[1]->send_cmd did not get expected first byte (0x81) in ack reply to command 01 20 48 - 01 6a (got 0x82 in 0x82 0x22 0x48 0x00 0xec 0x81 0x22 0x48 0x00 0xeb ) at ../lib/Omnistat.pm line 544. -this shows that I got a reply from stat #2 when I was expecting a reply from stat #1. -It happens rarely, and it's likely mostly serial port issues that I can't easily fix nor really -care to since they're rare and the code just deals with them. - -As a result, you should put this in mh,private.ini: -omnistat_allowed_errors = 999999999999 -hvac_allowed_errors = 999999999999 -replacing the first word (hvac/omnistat) by your code/module.pl names that use this library. -This will stop mh from disabling your code if the libraries dies every so often. +This has major improvements on serial port data handing to avoid the occasional dies due to poor timing. +Details: +- stop messing around, and just require Time::Hires (old code could limp around with just 'sleep', but as + a result it did a poor job of reliably getting data replies on some occasions). +- instead of blindly sleeping for a pre-guessed time before reading a response, read data characters +- sleeps are now reduced to the bare minimum required (0.37s for typical reads to 0.80s for full register dumps). +- No data gets dropped anymore without suitable logging and serial port + data is cleared before sending a command and waiting for an answer. +- No more priming hack needed. +- die resets cache data so that we don't end up with possible garbage data +- state_now logic was improved somewhat. 2011/01/09 - Mickey Argo/Karl Suchy/Marc MERLIN @@ -404,21 +400,11 @@ package Omnistat; sub omnistat_debug { my ($mesg) = @_; - print "$::Time_Date: $mesg\n" if $::Debug{omnistat}; + &::print_log("$mesg") if $::Debug{omnistat}; + #print "$::Time_Date: $mesg\n" if $::Debug{omnistat}; } -# Load Time::HiRes if it's available -use vars qw($USLEEP); -eval { require Time::HiRes }; -if (not $@) { - Time::HiRes->import( qw(usleep) ); - omnistat_debug("Omnistat found Time::Hires, will use usleep in omni_sleep"); - $USLEEP=1; -} else { - omnistat_debug("Omnistat did NOT find Time::Hires, will NOT use usleep in omni_sleep"); - warn("Omnistat works much better with Time::HiRes, install it if you can"); - $USLEEP=0; -} +use Time::HiRes; # -------------------------------------------------------------- # -------------------- START OF SUBROUTINES -------------------- @@ -426,11 +412,6 @@ if (not $@) { @Omnistat::ISA = ('Serial_Item'); -sub omni_sleep() { - $USLEEP ? usleep($_[0]) : sleep(int($_[0] + 0.99999)); -} - - # My guess is that most people would want to have temperature logging, but you can turn it off with # Omnistat_stat_log=0 in mh.private.ini -- merlin sub omnistat_log { @@ -480,7 +461,7 @@ sub new { foreach my $reg (0x15..0x38, 0x0f, 0x49) { $$self{cache_agelimit}{$reg} = 3600 * 24; # CACHE_TIMEOUT_DAILY } - # setpoints and modes are cached 53 secs so that they are pretty much + # setpoints and modes are cached 54 secs so that they are pretty much # guaranteed to be updated once a minute even with the random +10% offset foreach my $reg (0x3b .. 0x3f) { $$self{cache_agelimit}{$reg} = 54; # CACHE_TIMEOUT_SHORT @@ -497,16 +478,26 @@ sub new { omnistat_debug("Omnistat[$$self{address}] object created"); bless $self,$class; - # This is to work around a timing bug where the first query doesn't get a proper ack - # we just "prime" the device and connection by making one query to it where we ignore the answer - # no idea why this is needed, but it works for me and things are stable afterwards -- merlin - $self->{'PRIME'}=1; - $self->send_cmd("0x01 0x20 0x40 0x01 0x62", 1); - $self->{'PRIME'}=0; + # Clean up left over data on the serial port. + &main::check_for_generic_serial_data('Omnistat'); + $main::Serial_Ports{Omnistat}{data} = ''; + + &::print_log("HAI Thermostat $address initialized"); return $self; } +sub die_reset { + my ($self, $mesg) = @_; + + $self->{cache} = {}; + $self->{cache_updatetime} = {}; + + warn("Resetting cache for ".$self->{address}. " before die\n"); + &::print_log($mesg); + die "$mesg"; +} + # ************************************* # * Add the checksum to the cmd array. # ************************************* @@ -524,6 +515,30 @@ sub add_checksum { return @array; } +sub read_omnistat_serial_data { + my $serial_data; + + &main::check_for_generic_serial_data('Omnistat'); + $serial_data .= $main::Serial_Ports{Omnistat}{data}; + $main::Serial_Ports{Omnistat}{data} = ''; + + return $serial_data; +} + +sub convert_omnistat_serial_data { + my ($serial_data) = @_; + my $len = length($serial_data); + + $serial_data = unpack( "H*", $serial_data ); + + my $rcvd = ''; + for (my $i = 0 ; $i < $len ; $i++ ) { + $rcvd = $rcvd . sprintf( "0x%s ", substr( $serial_data, $i * 2, 2 ) ); + } + + return $rcvd; +} + # ************************************** # * Send the command to the thermostat. # ************************************** @@ -533,77 +548,88 @@ sub add_checksum { # of 1.25s, that said it seems to work ok with the current timings and should work without resends unless your # serial cable wires are crap (use CAT-5) and/or very long -- merlin # -# FIXME, 2-3 times, I had this bug right after starting mh: -# 25/07/2009 10:15:30 : Omnistat[2]->read_cached_reg: reg=0x3b not cached, fetching -# 25/07/2009 10:15:30 : Omnistat->send_cmd string=0x02 0x20 0x3b 0x0e 0x6b (with 833325,us reply delay (14 char(s) to read back)) -# 25/07/2009 10:15:30 : Omnistat->send_cmd got reply "0xff 0x82 0xf2 0x3b 0x8b 0x64 0x03 0x00 0x00 0x78 0x1e 0x0f 0x0a 0x60 0x00 0x00 0x02 0x00 0xb2 " -# The 0xff in the reply didn't belong. No idea where it came from, especially because it was the first command and reply. -# for now it makes the code die, the command fail and then things restart and continue -- merlin sub send_cmd { # if you want to default to a full 2sec wait, pass '-1' as reply_count my ($self, $reply_count, @string) = @_; my $addr = $$self{address}; my $cmd = ''; - # We try to calculate how long we wait for the reply, or default to 2 sec (2M usec) - my $reply_wait = 2000000; + # We try to calculate how long we wait for the reply, but 2sec max (time can be fractional seconds). + my $max_reply_wait = 2; # some experimentation shows on my system that we need to wait 0.3sec + 0.1sec for each 3 registers returned --merlin # 300bps is 30cps, which does equate to 0.0333333s per character. From experimentation, one needs to wait an extra # 11 characters in addition to the payload you're expecting back to get reliable replies (10 almost works but causes # occasional corruption due to timings). -- merlin - # (12+ chars wait instead of 11 might be needed for you. Please increase & let me know if this is too short for you). - my $REPLY_BASE_DELAY = 11; - # While we don't get as many bytes as we sent if we were to set several registers in a row (which is not currently - # supported in this code), the spec says to wait 30ms per register set, so the wait time ends up being able the same - # when setting data than when polling it. - $reply_wait = (33333*($reply_count + $REPLY_BASE_DELAY)) if ($reply_count > -1); + # Waiting a pre-calculated time turned out to still be a bit unrealiable. It's much better to know how many characters + # you're expecting back (4 chars of header/footer + reply payload). + # If no reply count was given, we'll pretend to wait for 20 chars of payload, which will cause the 2sec watchdog + # to kick in. Max reply length is 14 chars AFAIK. + $reply_count = 16 if ($reply_count == -1); + # Omnistat sends 4 bytes of header/footer + payload for a query, or only 3 for a write. + if ($reply_count == 0) + { + $reply_count += 3; + } + else + { + $reply_count += 4; + } + + # Delete any data that might be waiting on the serial port before we send our command. + $_ = convert_omnistat_serial_data( read_omnistat_serial_data() ); + #omnistat_debug("Omnistat[$$self{address}]->send_cmd: Left over serial data before send_cmd (if any): $_"); + if ($_) + { + &::print_log("Omnistat[$$self{address}]->send_cmd: Left over serial data before send_cmd (likely bug/dropped data): $_"); + # I occasionally see this on restart, that's totally fine, it just cleans up leftover data on the port: + # Omnistat[2]->send_cmd: Left over serial data before send_cmd (likely bug/dropped data): 0xfe + } - omnistat_debug("Omnistat[$$self{address}]->send_cmd string=@string (with $reply_wait,us reply delay ($reply_count char(s) to read back))"); + omnistat_debug("Omnistat[$$self{address}]->send_cmd string=@string ($reply_count char(s) to read back)"); foreach my $byte (@string) { $byte =~ s/0x//; # strip off the 0x $cmd = $cmd . pack "H2", $byte; # pack it into 8 bits } - # send it to thermostat + # Send it to thermostat #omnistat_debug("Omnistat->send_cmd will write $cmd"); $main::Serial_Ports{Omnistat}{object}->write($cmd); - # need to wait a bit for the reply - # FIXME: sleep is bad, especially if you're not using usleep from Time::Hires, the only proper way to do this would be to - # have a request queue where one command gets processed every 1-2 seconds, but that would be a big rewrite -- merlin - &Omnistat::omni_sleep($reply_wait); + # Read response. + my $serial_data = ""; + my $rcvd; + my $len; + my $before_time = Time::HiRes::time(); + my $diff_time; - # read response - &main::check_for_generic_serial_data('Omnistat'); - my $temp = $main::Serial_Ports{Omnistat}{data}; - $main::Serial_Ports{Omnistat}{data} = ''; - my $len = length($temp); - $temp = unpack( "H*", $temp ); - my ($i); - my $rcvd = ''; - my $ack_byte = 0x80 + $addr; - for ( $i = 0 ; $i < $len ; $i++ ) { - $rcvd = $rcvd . sprintf( "0x%s ", substr( $temp, $i * 2, 2 ) ); + do + { + # Wait 33ms (to get at least one character). + Time::HiRes::usleep(33333); + $serial_data .= read_omnistat_serial_data(); + $len = length($serial_data); + $diff_time = Time::HiRes::time() - $before_time; + omnistat_debug("Omnistat[$$self{address}]->send_cmd received $len chars back (waiting for $reply_count). $diff_time elapsed out of max $max_reply_wait secs"); } - my $rcvd_ack = hex(substr($rcvd, 0 , 4)); + until ($len == $reply_count or $diff_time > $max_reply_wait); - if ($self->{'PRIME'}) + $rcvd = convert_omnistat_serial_data($serial_data); + if ($diff_time > $max_reply_wait) { - omnistat_debug("Omnistat[$$self{address}]->send_cmd skipping error check and return value during prime"); - return; + &::print_log("WARNING: Omnistat[$$self{address}]->send_cmd packet receive $diff_time exceeded ${max_reply_wait}sec, either a bug or misterhouse hung (Got $len out of $reply_count for command @string)"); + # A long hang can happen if misterhouse hung due to the OS while it was processing the tight loop above. At least the code deal + # with it by reading multiple characters at the same time. + # 26/11/2011 05:04:37 Omnistat[2]->send_cmd received 5 chars back (waiting for 18). 0.368366956710815 elapsed out of max 2 secs + # 26/11/2011 05:04:37 Omnistat[2]->send_cmd received 18 chars back (waiting for 18). 4.18395900726318 elapsed out of max 2 secs + # 26/11/2011 05:04:37 Paused for 4 seconds } - # FIXME? Those two dies aren't ideal, but it happens that you get corruption or bad data on a reply. - # Expected for 01 20 3b 0e 6a is something like - # 0x81 0xf2 0x3b 0x7c 0x71 0x03 0x00 0x00 0x7d 0x07 0x1e 0x0f 0x00 0x00 0x00 0x02 0x0c 0x5d - # but I have seen replies like - # 0x03 0xf2 0x3b 0x7c 0x71 0x03 0x00 0x00 0x7d 0x00 0x1c 0x0f 0x00 0x00 0x00 0x02 0x0c 0x54 (0x81 ack byte is wrong) - # or sync issues like - # 0x64 0x82 0xf2 0x3b 0x8e 0x64 0x00 0x00 0x00 0x7d 0x20 0x29 0x0f 0x60 0x00 0x00 0x00 0x00 0xd6 (0x64 shouldn't be here) - # On my system, this error only seems to happen soon after startup and doesn't seem to happen later -- merlin - die "$::Time_Date: Omnistat[$$self{address}]->send_cmd did not get ack reply to command @string ($rcvd)" unless (length($rcvd) > 3); - die "$::Time_Date: Omnistat[$$self{address}]->send_cmd did not get expected first byte (".sprintf("0x%02x",$ack_byte).") in ack reply to command @string (got ".sprintf("0x%02x", $rcvd_ack)." in $rcvd)" unless ($rcvd_ack eq $ack_byte); + my $ack_byte = 0x80 + $addr; + my $rcvd_ack = hex(substr($rcvd, 0 , 4)); + + $self->die_reset("$::Time_Date: Omnistat[$$self{address}]->send_cmd did not get ack reply to command @string (received: $rcvd). We were expecting $reply_count bytes back.") unless (length($rcvd) > 3); + $self->die_reset("$::Time_Date: Omnistat[$$self{address}]->send_cmd did not get expected first byte (".sprintf("0x%02x",$ack_byte).") in ack reply to command @string (got ".sprintf("0x%02x", $rcvd_ack)." in $rcvd)") unless ($rcvd_ack eq $ack_byte); omnistat_debug("Omnistat[$$self{address}]->send_cmd got reply \"$rcvd\""); return $rcvd; @@ -726,7 +752,7 @@ sub translate_temp { # this is a good place to catch a 14 reg read that happens in read_group1 extended, being off by one character, or returning # bogus 0's. - die "$::Time_Date: Omnistat->translate_temp got an input temperature of 0 = -40F/C, this typically means serial port corruption, bad... You may want to increase REPLY_BASE_DELAY" if (not $settemp or $settemp eq "0x00"); + die "$::Time_Date: Omnistat->translate_temp got an input temperature of 0 = -40F/C, this typically means serial port corruption, bad..." if (not $settemp or $settemp eq "0x00"); # Calculate conversion mathematically rather than using a table so all temps will work (needed for outside temperature) if ( substr( $settemp, 0, 2 ) eq '0x' ) @@ -843,12 +869,14 @@ sub translate_time { sub translate_stat_output { my ( $self, $reg48 ) = @_; - die "Omnistat::translate_stat_output got non hex value in '$reg48'" unless (is_hex($reg48)); - # see reg 0x48 / output register at the top of this file + $self->die_reset("Omnistat::translate_stat_output got non hex value in '$reg48'") unless (is_hex($reg48)); + + # see reg 0x48 / output register in the comments at the top of this file + # "0x0d" is turned into "fan/heat" my $output = "off"; $output = "fan" if (hex($reg48) & 8); - # if stage 1 and stage 2 heat/cool are off, return here + # if stage 1 (heat/coot) and stage 2 are off, return here #&::print_log("pass1: reg48: $reg48, $output"); return $output if (not hex($reg48) & (4+16)); @@ -1431,7 +1459,7 @@ sub get_program_mode { sub get_filter_reminder { my ( $self ) = @_; my $days = $self->read_cached_reg("0x0f",1); - return hex($days); + return (hex($days)); } sub set_filter_reminder { @@ -1476,28 +1504,77 @@ sub get_run_time_this_week { # * Get the run time for last week (in hours) # ************************************** sub get_run_time_last_week { - my ( $self) = @_; + my ( $self ) = @_; my $hours = $self->read_cached_reg("0x11",1); return hex($hours); } +# *************************************************************************** +# * Update the object's state (query with omnistat->state_now to see changes) +# *************************************************************************** + +# Good news is that state changes stack up , i.e. the last change does not overwrite the previous one. +# omnistat->state_now will just unroll changes as a FIFO for situations like these: +# 25/11/2011 23:30:37 Omnistat[2]->read_reg: set state->now to cool_sp_change +# 25/11/2011 23:30:37 Omnistat[2]->read_reg: set state->now to heat_sp_change +# 25/11/2011 23:30:37 Omnistat[2]->read_reg: set state->now to temp_change +sub set_state_change_if_any { + # register MUST be an hex STRING (i.e. "0x21", not 0x21) + my ( $self, $register ) = @_; + + if ($register eq "0x40") { + $self->set_receive('temp_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to temp_change"); + } elsif ($register eq "0x3b") { + $self->set_receive('cool_sp_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to cool_sp_change"); + } elsif ($register eq "0x3c") { + $self->set_receive('heat_sp_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to heat_sp_change"); + } elsif ($register eq "0x3d") { + $self->set_receive('mode_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to mode_change"); + } elsif ($register eq "0x3f") { + $self->set_receive('hold_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to hold_change"); + } elsif ($register eq "0x3e") { + $self->set_receive('fan_mode_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to fan_mode_change"); + } elsif ($register eq "0x0f") { + if ($self->get_filter_reminder eq 0) { + $self->set_receive('filter_reminder_now'); + omnistat_log("Omnistat[$$self{address}]->state_now set to filter_reminder_now"); + } else { + $self->set_receive('filter_reminder_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to filter_reminder_change"); + + } + # We test this one last so that if multiple changes happen at once, ->state shows this as + # the last relevant state, which is typically more important than the other ones. + } elsif ($register eq "0x48") { # this one is read only + $self->set_receive('current_output_change'); + omnistat_log("Omnistat[$$self{address}]->state_now set to current_output_change"); + } +} + # ********************************************* # * Read specified register(s) from Omnistat. # ********************************************* sub read_reg { - # register MUST be an hex STRING (i.e. "0x21", not 0x21) # I added a $whitelisted param to strongly hint that people use the caching call instead # but you can force a non caching call by just adding the whitelisted flag in the caller # yes, $count isn't optional anymore, sorry (but it is optional in read_cached_reg) -- merlin + + # register MUST be an hex STRING (i.e. "0x21", not 0x21) my ( $self, $register, $count, $whitelisted ) = @_; my $addr = $$self{address}; my ( @cmd, $regraw, $reg, $byte, $cnt ); my $i; my @value; - die "Omnistat::read_reg got non hex value in $register" unless (is_hex($register)); + $self->die_reset("Omnistat::read_reg got non hex value in $register") unless (is_hex($register)); warn "You should call read_cached_reg instead of read_reg to avoid hang delays. Adjust CACHE_TIMEOUT_ values in new(), and/or set debug=omnistat in mh.private.ini to adjust caching" if (not $whitelisted); - die "You can only read 14 registers at a time, you asked for $count" if ($count >14); + $self->die_reset("You can only read 14 registers at a time, you asked for $count") if ($count >14); $count = 1 if (not $count); @@ -1508,14 +1585,14 @@ sub read_reg { @cmd = add_checksum(@cmd); $regraw = $self->send_cmd($count, @cmd); $reg = substr( $regraw, 15, $count * 5 ); - die "Omnistat[$$self{address}]->read_reg: got empty response to @cmd (read $count regs from register offset $register), serial port send/read probably failed, check your configuration or you may have a timing issue and may need to increase REPLY_BASE_DELAY" if (not $reg); + $self->die_reset("Omnistat[$$self{address}]->read_reg: got incomplete response to @cmd: $regraw (read $count regs from register offset $register), serial port send/read probably failed, check your configuration or you may have a timing issue") if (not $reg); omnistat_debug("Omnistat[$$self{address}]->read_reg: reg[$register]=$reg"); # Cache the value(s) @value = split ' ', $reg; for ( $i = 0 ; $i < $count ; $i++ ) { - die "Omnistat[$$self{address}]->read_reg: got partial response to @cmd (read $count from $register), response truncated at byte $i. You may have a timing issue and may need to increase REPLY_BASE_DELAY" if (not $value[$i]); + $self->die_reset("Omnistat[$$self{address}]->read_reg: got partial response to @cmd (read $count from $register), response truncated at byte $i. You may have a timing issue.") if (not $value[$i]); my $regoffset = sprintf( "0x%02x", hex($register) + $i); @@ -1528,27 +1605,8 @@ sub read_reg { omnistat_debug("Omnistat[$$self{address}]->read_reg: reg[$regoffset]=$value[$i] updated in cache"); # Update the cache $$self{cache}{hex($regoffset)} = $value[$i]; - - # see if it's a register we care about and register state change if so - if ($regoffset eq "0x40") { - $self->set_receive('temp_change'); - } elsif ($regoffset eq "0x3b") { - $self->set_receive('cool_sp_change'); - } elsif ($regoffset eq "0x3c") { - $self->set_receive('heat_sp_change'); - } elsif ($regoffset eq "0x3d") { - $self->set_receive('mode_change'); - } elsif ($regoffset eq "0x3f") { - $self->set_receive('hold_change'); - } elsif ($regoffset eq "0x3e") { - $self->set_receive('fan_mode_change'); - } elsif ($regoffset eq "0x48") { # this one is read only - $self->set_receive('current_output_change'); - } elsif ($regoffset eq "0x0f") { - if ($value[$i] eq "0x00") { - $self->set_receive('filter_reminder'); - } - } + # Update state_now fifo. + $self->set_state_change_if_any($regoffset); } else { omnistat_debug("Omnistat[$$self{address}]->read_reg: reg[$regoffset]=$value[$i] current in cache"); } @@ -1569,14 +1627,14 @@ sub read_reg { # ********************************************* # * Write specified register to Omnistat. # ********************************************* -#TODO: add ability to set multiple registers at once +#TODO: add ability to set multiple registers at once (if ever needed, I don't have that need) sub set_reg { # register MUST be an hex STRING (i.e. "0x21", not 0x21) my ( $self, $register, $value ) = @_; my $addr = $$self{address}; my (@cmd); - die "Omnistat::set_reg got non hex value in $register <- $value" unless (is_hex($register) and is_hex($value)); + $self->die_reset("Omnistat::set_reg got non hex value in $register <- $value") unless (is_hex($register) and is_hex($value)); $cmd[0] = sprintf( "0x%02x", $addr ); $cmd[1] = "0x21"; $cmd[2] = $register; @@ -1589,25 +1647,8 @@ sub set_reg { { if ($$self{cache}{ hex($register) } ne $value) { - # TODO, merge with above, prevent duplication # register changed, check for state change - if ($register eq "0x40") { - $self->set_receive('temp_change'); - } elsif ($register eq "0x3b") { - $self->set_receive('cool_sp_change'); - } elsif ($register eq "0x3c") { - $self->set_receive('heat_sp_change'); - } elsif ($register eq "0x3d") { - $self->set_receive('mode_change'); - } elsif ($register eq "0x3f") { - $self->set_receive('hold_change'); - } elsif ($register eq "0x3e") { - $self->set_receive('fan_mode_change'); - } elsif ($register eq "0x0f") { - if ($value eq "0x00") { - $self->set_receive('filter_reminder'); - } - } + $self->set_state_change_if_any($register); } } @@ -1631,7 +1672,7 @@ sub read_cached_reg { my $value; my $regval; - die "Omnistat::read_cached_reg got non hex value in $register" unless (is_hex($register)); + $self->die_reset("Omnistat::read_cached_reg got non hex value in $register") unless (is_hex($register)); $count = 1 if (not $count); # First see if we can read from the cache @@ -1709,6 +1750,9 @@ sub read_group1 { # $group1raw = $self->send_cmd(6, @cmd); + # plus_output: Do we fetch enough registers to receive output register too? + # This forces us to fetch more data than needed, but it's not slower than + # querying group1 and then ouput separately. Too bad output isn't part of group1. if ($plus_output) { $group1 = $self->read_cached_reg("0x3b", 14, $maxcachetime); ( $cool_set, $heat_set, $mode, $fan, $hold, $cur, $_, $_, $_, $_, $_, $_, $_, $output ) = split(' ', $group1); @@ -1743,3 +1787,4 @@ sub read_cached_group1 { 1; +# vim:sts=2:sw=2 From a032bd91d17e4b659eb055f8d553bb811d8d43fd Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Sun, 27 Nov 2011 22:04:17 +0000 Subject: [PATCH 101/150] Add a cache of group1 values and output to allow reusing of values that don't need the freshest data and where 1mn old data is good enough. (this is to prevent code from triggering a cache miss at the wrong time and a possible read/collision between several thermostats sharing the same serial cable). --- code/support/hai-omnistat/omnistat.pl | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/code/support/hai-omnistat/omnistat.pl b/code/support/hai-omnistat/omnistat.pl index 6490a9b93..3c5e1da32 100644 --- a/code/support/hai-omnistat/omnistat.pl +++ b/code/support/hai-omnistat/omnistat.pl @@ -9,8 +9,8 @@ # Originally by Kent Noonan, Joel Davidson & Dan Arnold # Close to full rewrite/overhaul by Marc MERLIN 2009/07/22 - -use vars qw(@omnilist @omnistat @omniname @omnioffset $stat_cool_temp $stat_heat_temp $stat_mode $stat_fan $stat_hold +# +use vars qw(%omnicache @omnilist @omnistat @omniname @omnioffset $stat_cool_temp $stat_heat_temp $stat_mode $stat_fan $stat_hold $stat_indoor_temp $cmd $stat_model @v_omnistat_fan @v_omnistat_resume @v_omnistat_hold @v_omnistat_mode @v_omnistat_cool_sp @v_omnistat_heat_sp @v_omnistat_setting @stat_reset_timer $house_stat $mbr_stat $test_stat @v_omnistat_background); @@ -104,6 +104,17 @@ # we make the extended group1 call that also retreives the stat's output status my ($cool_sp, $heat_sp, $mode, $fan, $hold, $temp, $output) = $omnistat[$omnistat]->read_group1("true"); my $stat_type = $omnistat[$omnistat]->get_stat_type; + # Remember this in our own cache so that we don't query this from other places unless + # necessary (this is important in a multiple thermostat sharing the same cable situation + # where querying two stats in code later will cause collisions on the cable). + $omnicache{$omniname[$omnistat]}->{'cool_sp'} = $cool_sp; + $omnicache{$omniname[$omnistat]}->{'heat_sp'} = $heat_sp; + $omnicache{$omniname[$omnistat]}->{'mode'} = $mode; + $omnicache{$omniname[$omnistat]}->{'fan'} = $fan; + $omnicache{$omniname[$omnistat]}->{'hold'} = $hold; + $omnicache{$omniname[$omnistat]}->{'temp'} = $temp; + $omnicache{$omniname[$omnistat]}->{'output'} = $output; + $omnicache{$omniname[$omnistat]}->{'stat_type'} = $stat_type; # This mashes $hold and $mode together from registers cached in the group1 call and outputs a combined string $mode = $omnistat[$omnistat]->get_mode; @@ -215,10 +226,14 @@ } } - if ($state = $omnistat[$omnistat]->state_now) { - # this may or many not be useful to you, you can comment it out if you're not planning on using state changes for coding - Omnistat::omnistat_log("".$omniname[$omnistat]." Omnistat State set to: $state", 3); - } + # WARNING: Reading state_now here empties the 'state_now' flag. If you need it elsewhere, that won't work. + # For debugging, Omnistat.pl will also output state changes like so: + # 25/11/2011 23:30:37 Omnistat[2]->read_reg: set state->now to temp_change + + # If you plan on using state_now elsewhere in your code, you should leave this commented this out: + # if ($state = $omnistat[$omnistat]->state_now) { + # Omnistat::omnistat_log("".$omniname[$omnistat]." Omnistat State set to: $state", 3); + # } } #vim:sts=4:sw=4 From 884cee9a25f9191096dd8da626c0639822c6117e Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Sun, 27 Nov 2011 22:05:48 +0000 Subject: [PATCH 102/150] Fixed comment. --- code/support/hai-omnistat/omnistat.pl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/code/support/hai-omnistat/omnistat.pl b/code/support/hai-omnistat/omnistat.pl index 3c5e1da32..dd23ca76b 100644 --- a/code/support/hai-omnistat/omnistat.pl +++ b/code/support/hai-omnistat/omnistat.pl @@ -104,8 +104,8 @@ # we make the extended group1 call that also retreives the stat's output status my ($cool_sp, $heat_sp, $mode, $fan, $hold, $temp, $output) = $omnistat[$omnistat]->read_group1("true"); my $stat_type = $omnistat[$omnistat]->get_stat_type; - # Remember this in our own cache so that we don't query this from other places unless - # necessary (this is important in a multiple thermostat sharing the same cable situation + # Remember the queried values in our own cache so that we don't query this from other places unless + # necessary (this is important in a multiple thermostat sharing the same cable situation # where querying two stats in code later will cause collisions on the cable). $omnicache{$omniname[$omnistat]}->{'cool_sp'} = $cool_sp; $omnicache{$omniname[$omnistat]}->{'heat_sp'} = $heat_sp; From 7fbd5620c5b5cf4305f41747a5f700e4a8072a2c Mon Sep 17 00:00:00 2001 From: jduda Date: Thu, 2 Feb 2012 01:49:38 +0000 Subject: [PATCH 103/150] IV reorganized how the audreyspeak works with Voice_Text.pm. This was necessary to allow other services, like android_server, to use the same output of the voice synthesizer, to avoid calling the synthesizer multiple times. I have also provided the first version of android_server.pl, which does for android devices the same as what audreyspeak.pl does for audrey devices. --- bin/mh | 23 +++- bin/mh.ini | 8 ++ code/common/android_server.pl | 140 ++++++++++++++++++++++ code/common/audreyspeak.pl | 155 +++++++++--------------- lib/Voice_Text.pm | 220 ++++++++++++++++++++-------------- 5 files changed, 357 insertions(+), 189 deletions(-) create mode 100644 code/common/android_server.pl diff --git a/bin/mh b/bin/mh index 27a7a05a1..46ce7fd3c 100755 --- a/bin/mh +++ b/bin/mh @@ -118,7 +118,7 @@ use vars qw(%User_Code @Code_Dirs @Generic_Serial_Ports %Misc); use vars qw(%Run_Members); my ($Pgm_PathU); -my ($Loop_Speed, @Loop_Speeds, $Loop_Sleep_Time, $Loop_Tk_Passes); +my ($Loop_Speed, @Loop_Speeds, $Loop_Sleep_Time, $Loop_Tk_Passes, $Web_Play_Index); 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); @@ -1032,6 +1032,7 @@ sub setup { $Loop_Tk_Passes = $config_parms{tk_passes}; $Loop_Sleep_Time = $config_parms{sleep_time}; + $Web_Play_Index = 0; $Time = time; @@ -3811,7 +3812,7 @@ sub play { } } } - print "playing file=$file parm=$play_parm\n" if $Debug{play}; + &print_log ("playing file=$file parm=$play_parm") if $Debug{play}; # system($config_parms{sound_program_prescript}) if $config_parms{sound_program_prescript}; @@ -3835,6 +3836,22 @@ sub play { last; } + # Support for audrey, android, and other web based clients which + # played wav files are provided for. + if ($parms{web_file} eq "web_file") { + $parms{web_file} = "playToWeb" . $Web_Play_Index . ".wav"; + print_log("play: $parms{web_file}"); + my $toFile = $::config_parms{html_dir} . "/$parms{web_file}"; + copy $file, $toFile; + if (defined $parms{web_hook}) { + foreach my $web_hook (@{$parms{web_hook}}) { + &$web_hook(%parms); + } + } + $Web_Play_Index++; + $Web_Play_Index = $Web_Play_Index % 10; + } + if (!$OS_win) { next if $file =~ /^System/; if ($config_parms{sound_program} =~ /vv_tts/i) { # use vv_tts for play also @@ -3849,7 +3866,7 @@ sub play { if ($parms{sound_program} ) { $sound_program = $parms{sound_program}; } - print "running: $sound_program $file\n"; + print_log ("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 diff --git a/bin/mh.ini b/bin/mh.ini index 0e798099f..447621401 100644 --- a/bin/mh.ini +++ b/bin/mh.ini @@ -1212,6 +1212,14 @@ pocketsphinx_asleep_phrase={go to sleep,change to sleep mode} pocketsphinx_asleep_response=talk to you later pocketsphinx_timeout_response=talk to you later +@ - If you want to interface the misterhouse android appliation with the misterhouse +@ server, you must setup the android to use the server port defined in +@ android_server_port. The default is port "4444", but can be any port number. +@ This port must be open on the server internet firewall. Alternatively, if you +@ do not want to open this this, you can forward the information to this port +@ through ssh using the host configuration check box in the android application. + +server_android_port=4444 @ Set to localhost if festival is on your local computer festival_host=localhost diff --git a/code/common/android_server.pl b/code/common/android_server.pl new file mode 100644 index 000000000..c7738c896 --- /dev/null +++ b/code/common/android_server.pl @@ -0,0 +1,140 @@ +# Category = Android + +# $Date: 2007-08-04 20:37:08 -0400 (Sat, 04 Aug 2007) $ +# $Revision: 1146 $ + +#@ This module allows MisterHouse to capture and send all speech and played +#@ wav files to an Android internet appliance. See the detailed instructions +#@ in the script for Android set-up information. + +=begin comment + +androidspeak.pl + +This script allows MisterHouse to capture and send speech and played +wav files to an Android unit. + +- By default, ALL speak and play events will be pushed to ALL android's + regardless of the value in the speak/play "rooms" parameter. If you + want the android's to honor the rooms parameter, then you must define + the android_use_rooms parameter in my.private.ini. Each android declares + a room name when the android registers with the server. + + android_use_rooms=1 + +=cut + +use Voice_Text; + +my (%androidClients); + +#Tell MH to call our routine each time something is spoken +if ($Startup or $Reload) { + &Speak_parms_add_hook(\&pre_speak_to_android); +} + +$android_server = new Socket_Item(undef, undef, 'server_android'); +if ($state = said $android_server) { + my ($pass, $android_device, $port, $room) = split /,/, $state; + &print_log ("android_server pass: $pass android_device: $android_device, port: $port, room: $room") if $Debug{android}; + if (my $user = password_check $pass, 'server_android') { + &print_log ("Android Connect accepted for: room: $room at device: $android_device") if $Debug{android}; + my $client = $Socket_Ports{'server_proxy'}{socka}; + $room = $client unless defined $room; + &print_log("android_register: $client $room") if $Debug{android}; + $androidClients{$client}{room} = $room; + } + else { + &print_log ("Android Connect denied for: $room at $android_device") if $Debug{android}; + } +} + +sub file_ready_for_android { + my (%parms) = @_; + my $speakFile = $parms{web_file}; + &print_log("file ready for android $speakFile") if $Debug{android}; + my @rooms = $parms{androidSpeakRooms}; + foreach my $android (keys %androidClients) { + my $room = lc $androidClients{$android}{room}; + &print_log("file_ready_for_android client: $android room: $room") if $Debug{android}; + if ( grep(/$room/, @{$parms{androidSpeakRooms}}) ) { + my $function = "speak"; +#if ($android->active( )) { + $android_server->set(join '?', $function, $speakFile), $android; +#} + } + } +} + +#MH just said something. Generate the same thing to our file (which is monitored above) +sub pre_speak_to_android { + my ($parms_ref) = @_; + &print_log("pre_speak_to_android $parms_ref->{web_file}") if $Debug{android}; + return if $parms_ref->{mode} and ($parms_ref->{mode} eq 'mute' or $parms_ref->{mode} eq 'offline'); + return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $parms_ref->{mode} !~ /unmute/i; + my @rooms = split ',', lc $parms_ref->{rooms}; + + # determine which if any androids to speak to; we honor the rooms paramter + # whenever android_use_rooms is defined, otherwise, we send to all androids + if (!exists $config_parms{android_use_rooms} || !exists $parms_ref->{rooms} || grep(/all/, @rooms) ) { + @rooms = (); + foreach my $android (keys %androidClients) { + my $room = lc $androidClients{$android}{room}; + &print_log("pre_speak_to_android client: $android room: $room") if $Debug{android}; + push @rooms, $room; + } + } else { + my @androidRooms = (); + foreach my $android (keys %androidClients) { + my $room = lc $androidClients{$android}{room}; + if ( grep(/$room/, @rooms) ) { + push @androidRooms, $room; + } + } + @rooms = @androidRooms; + } + &print_log("pre_speak_to_android rooms: @rooms") if $Debug{android}; + return if (!@rooms); + + # okay, process the speech and add to the process array + $parms_ref->{web_file} = "web_file"; + push(@{$parms_ref->{androidSpeakRooms}},@rooms); + push @{$parms_ref->{web_hook}},\&file_ready_for_android; + $parms_ref->{async} = 1; + $parms_ref->{async} = 0 if $config_parms{Android_speak_sync}; +} + +#Tell MH to call our routine each time a wav file is played +&Play_parms_add_hook(\&pre_play_to_android) if $Reload; + +#MH just played a wav file. Copy it to our file (which is monitored above) +sub pre_play_to_android { + my ($parms_ref) = @_; + &print_log("pre play to android") if $Debug{android}; + return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $parms_ref->{mode} !~ /unmute/i; + + # determine which if any androids to speak to; we honor the rooms parameter + # whenever android_use_rooms is defined, otherwise, we send to all androids + my @rooms = split ',', lc $parms_ref->{rooms}; + if (!exists $config_parms{android_use_rooms} || !exists $parms_ref->{rooms} || grep(/all/, @rooms) ) { + @rooms = (); + foreach my $android (keys %androidClients) { + my $room = lc $androidClients{$android}{room}; + push @rooms, $room; + } + } else { + my @androidRooms = (); + foreach my $android (keys %androidClients) { + my $room = lc $androidClients{$android}{room}; + if ( grep(/$room/, @rooms) ) { + push @androidRooms, $room; + } + } + @rooms = @androidRooms; + } + return if (!@rooms); + + $parms_ref->{web_file} = "web_file"; + push(@{$parms_ref->{androidSpeakRooms}},@rooms); + push(@{$parms_ref->{web_hook}},\&file_ready_for_android); +} diff --git a/code/common/audreyspeak.pl b/code/common/audreyspeak.pl index 863530226..f35145bb3 100644 --- a/code/common/audreyspeak.pl +++ b/code/common/audreyspeak.pl @@ -89,144 +89,101 @@ =cut #Tell MH to call our routine each time something is spoken -&Speak_pre_add_hook(\&speak_to_Audrey) if $Reload; - -my ($audreyIndex, $audreyMaxIndex, @speakRooms); if ($Startup or $Reload) { - $audreyIndex = 0; - $audreyMaxIndex = 10; + &Speak_parms_add_hook(\&pre_speak_to_audrey); } sub file_ready_for_audrey { - my ($audreyIndex)=@_; - - &print_log("audrey file $audreyIndex is ready"); - + my (%parms) = @_; + my $speakFile = $parms{web_file}; + my @rooms, $parms{audreySpeakRooms}; my $MHWeb = $Info{IPAddress_local} . ":" . $config_parms{http_port}; - my $speakFile = "/speakToAudrey${audreyIndex}.wav"; - my $rooms = $speakRooms[$audreyIndex]; + &print_log("file ready for audrey $speakFile @rooms") if $Debug{voice}; for my $audrey (split ',', $config_parms{Audrey_IPs}) { - $audrey =~ /(\S+)\-(\S+)/; - my $room = lc $1; - my $ip = $2; - if ( grep(/$room/, @$rooms) ) { - run "get_url -quiet http://$ip/mhspeak.shtml?http://$MHWeb$speakFile /dev/null"; + my ($room, $ip) = $audrey =~ /(\S+)\-(\S+)/; + $room = lc $room; + if ( grep(/$room/, @{$parms{audreySpeakRooms}}) ) { + run "get_url -quiet http://$ip/mhspeak.shtml?http://$MHWeb/$speakFile /dev/null"; } } } #MH just said something. Generate the same thing to our file (which is monitored above) -sub speak_to_Audrey { - my %parms = @_; - return if $parms{mode} and ($parms{mode} eq 'mute' or $parms{mode} eq 'offline'); - return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $parms{mode} !~ /unmute/i; - my @rooms = split ',', lc $parms{rooms}; - - # determine which if any audreys to speak to; we honor the rooms paramter +sub pre_speak_to_audrey { + my ($parms_ref) = @_; + return if $parms_ref->{mode} and ($parms_ref->{mode} eq 'mute' or $parms_ref->{mode} eq 'offline'); + return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $parms_ref->{mode} !~ /unmute/i; + my @rooms = split ',', lc $parms_ref->{rooms}; + &print_log("pre_speak_to_audrey $parms_ref->{web_file} rooms: @rooms") if $Debug{voice}; + + # determine which if any audreys to speak to; we honor the rooms paramter # whenever audrey_use_rooms is defined, otherwise, we send to all audreys - if (!exists $config_parms{audrey_use_rooms} || grep(/all/, @rooms) ) { - @rooms = (); - for my $audrey (split ',', $config_parms{Audrey_IPs}) { - $audrey =~ /(\S+)\-(\S+)/; - my $room = lc $1; - my $ip = $2; - push @rooms, $room; - } + if (!exists $config_parms{audrey_use_rooms} || !exists $parms_ref->{rooms} || grep(/all/, @rooms)) { + @rooms = (); + for my $audrey (split ',', $config_parms{Audrey_IPs}) { + my ($room,$ip) = $audrey =~ /(\S+)\-(\S+)/; + $room = lc $room; + push @rooms, $room; + } } else { - my @audreyRooms = (); - for my $audrey (split ',', $config_parms{Audrey_IPs}) { - $audrey =~ /(\S+)\-(\S+)/; - my $room = lc $1; - my $ip = $2; - if ( grep(/$room/, @rooms) ) { - push @audreyRooms, $room; - } - } - @rooms = @audreyRooms; + my @audreyRooms = (); + for my $audrey (split ',', $config_parms{Audrey_IPs}) { + my ($room,$ip) = $audrey =~ /(\S+)\-(\S+)/; + $room = lc $room; + if ( grep(/$room/, @rooms) ) { + push @audreyRooms, $room; + } + } + @rooms = @audreyRooms; } + &print_log("pre_speak_to_audrey rooms: @rooms") if $Debug{voice}; return if (!@rooms); # okay, process the speech and add to the process array - $parms{"to_file"} = $config_parms{html_dir} . "/speakToAudrey" . $audreyIndex . ".wav"; - $parms{rooms} = @rooms; - $parms{audreyIndex}=$audreyIndex; - $parms{async}=1; - $parms{async}=0 if $config_parms{Audrey_speak_sync}; - $speakRooms[$audreyIndex] = \@rooms; - &print_log("generating audrey file $audreyIndex (via TTS)"); - &Voice_Text::speak_text(%parms); - $audreyIndex = ($audreyIndex + 1) % $audreyMaxIndex; + $parms_ref->{web_file} = "web_file"; + push(@{$parms_ref->{audreySpeakRooms}},@rooms); + push @{$parms_ref->{web_hook}},\&file_ready_for_audrey; + $parms_ref->{async} = 1; + $parms_ref->{async} = 0 if $config_parms{Audrey_speak_sync}; } #Tell MH to call our routine each time a wav file is played -&Play_pre_add_hook(\&play_to_audrey) if $Reload; +&Play_parms_add_hook(\&pre_play_to_audrey) if $Reload; #MH just played a wav file. Copy it to our file (which is monitored above) -sub play_to_audrey { - my %parms = @_; - return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $parms{mode} !~ /unmute/i; +sub pre_play_to_audrey { + my ($parms_ref) = @_; + return if $Save{mode} and ($Save{mode} eq 'mute' or $Save{mode} eq 'offline') and $parms_ref->{mode} !~ /unmute/i; # determine which if any audreys to speak to; we honor the rooms paramter # whenever audrey_use_rooms is defined, otherwise, we send to all audreys - my @rooms = split ',', lc $parms{rooms}; - if (!exists $config_parms{audrey_use_rooms} || grep(/all/, @rooms) ) { + my @rooms = split ',', lc $parms_ref->{rooms}; + &print_log("pre play to audrey rooms: @rooms") if $Debug{voice}; + if (!exists $config_parms{audrey_use_rooms} || !exists $parms_ref->{rooms} || grep(/all/, @rooms) ) { @rooms = (); for my $audrey (split ',', $config_parms{Audrey_IPs}) { - $audrey =~ /(\S+)\-(\S+)/; - my $room = lc $1; - my $ip = $2; + my ($room,$ip) = $audrey =~ /(\S+)\-(\S+)/; + $room = lc $room; push @rooms, $room; } } else { my @audreyRooms = (); for my $audrey (split ',', $config_parms{Audrey_IPs}) { - $audrey =~ /(\S+)\-(\S+)/; - my $room = lc $1; - my $ip = $2; + my ($room,$ip) = $audrey =~ /(\S+)\-(\S+)/; + $room = lc $room; if ( grep(/$room/, @rooms) ) { push @audreyRooms, $room; } } @rooms = @audreyRooms; } + my @testArray = ('a','b','c'); + &print_log("pre_play_to_audrey rooms: @rooms") if $Debug{voice}; return if (!@rooms); - # okay, process each file and add to the process array - my @files = split(/[, ]/, $parms{file}); - for my $file (@files) { - 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]; - } - } - next if (! -e $file); - - my $speakFile = $config_parms{html_dir} . "/speakToAudrey" . $audreyIndex . ".wav"; - $speakRooms[$audreyIndex] = \@rooms; - - &print_log("generating audrey file $audreyIndex (from .wav file)"); - copy $file, $speakFile; - &file_ready_for_audrey($audreyIndex); - $audreyIndex = ($audreyIndex + 1) % $audreyMaxIndex; - } + $parms_ref->{web_file} = "web_file"; + push(@{$parms_ref->{audreySpeakRooms}},@rooms); + push(@{$parms_ref->{web_hook}},\&file_ready_for_audrey); } + diff --git a/lib/Voice_Text.pm b/lib/Voice_Text.pm index d5e393476..52adf5acc 100644 --- a/lib/Voice_Text.pm +++ b/lib/Voice_Text.pm @@ -8,7 +8,7 @@ use strict; use vars '$VTxt_version'; my (@VTxt, $VTxt_stream1, $VTxt_stream2, %VTxt_cards, $VTxt_festival, $VTxt_mac); my ($save_mute_esd, $save_change_volume, %pronouncable); -my (%voice_names, @voice_names, $voice_names_index, $VTxt_pid); +my (%voice_names, @voice_names, $voice_names_index, $VTxt_pid, $web_index); my $is_speaking_timer = new Timer; @@ -16,6 +16,8 @@ my $is_speaking_timer = new Timer; sub init { my ($engine) = @_; + $web_index = 0; + # The darwin hook is currently done in the main bin/mh code # if ($main::Info{OS_name}=~ /darwin/i) { # &main::my_use("Mac::Sound"); @@ -70,7 +72,7 @@ sub init { } $VTxt[0] = $VTxt[1] unless $VTxt[0]; # Default to the first card if specified one not found - # Create an object for to_file calls + # Create an object for to_file calls $VTxt_stream1 = Win32::OLE->new('Sapi.SpVoice'); $VTxt_stream1 = undef unless defined $VTxt_stream1->GetVoices; # undef it if now voices exist if (defined $VTxt_stream1) { @@ -103,17 +105,30 @@ sub init { } +# Execute callback for web based clients +sub web_hook_callback { + my (%parms) = @_; + &main::print_log("web_hook_callback: $parms{web_file}"); + return if ($parms{web_file} eq "web_file"); + if (defined $parms{web_hook}) { + foreach my $web_hook (@{$parms{web_hook}}) { + &$web_hook(%parms); + } + } +} + sub speak_text { my(%parms) = @_; if ($::Debug{voice}) { - print 'speak_text: parms are'; + my $parmsdisplay; foreach (sort(keys(%parms))) { - print " '$_'='$parms{$_}'"; + $parmsdisplay .= " '$_'='$parms{$_}'"; } - print "\n"; + &main::print_log ("speak_text: parms are $parmsdisplay"); } - # set a default voice, if configured + + # set a default voice, if configured $parms{voice}=$::config_parms{voice_text_default_voice} unless $parms{voice}; return if lc $parms{voice} eq 'none'; return if !$parms{to_file} and $::config_parms{disable_local_sound}; @@ -135,7 +150,22 @@ sub speak_text { } return; } - # Pick the correct card (default, if not specified). Currently only engine=MS + + # Support for audrey, android, and other web based clients which + # synthesized text to voice is provided for. Make a recursive call + # to create the static file pushed to web devices. + if ($parms{web_file} eq "web_file") { + $parms{web_file} = "speakToWeb" . $web_index . ".wav"; + my $to_file = $parms{to_file}; + $parms{to_file} = $::config_parms{html_dir} . "/" . $parms{web_file}; + $web_index++; + $web_index = $web_index % 10; + &speak_text(%parms); + $parms{to_file} = $to_file; + $parms{web_file} = "web_file"; + } + + # Pick the correct card (default, if not specified). Currently only engine=MS my $vtxt_card = $VTxt[0]; if ($parms{card}) { my $card = $parms{card}; @@ -235,6 +265,8 @@ sub speak_text { print "Voice_Text $speak_engine eval error: $@" if $@; } elsif ($speak_engine =~ /festival/i) { + + # Initialize the festival server if necessary &init('festival') unless $VTxt_festival; if ($VTxt_festival and not active $VTxt_festival) { if (start $VTxt_festival) { @@ -245,81 +277,93 @@ sub speak_text { } } - - # Clear out buffer, so is_speaking works + # Clear out buffer, so is_speaking works $main::Socket_Ports{festival}{data_record} = ''; $main::Socket_Ports{festival}{data} = ''; + # Send Voice Text to a file if ($parms{to_file}) { - # Change from relative to absolute path + # Change from relative to absolute path $parms{to_file} = "$main::Pgm_Path/$1" if $parms{to_file} =~ /^\.\/(.+)/; $parms{text} = qq[(utt.save.wave (utt.synth (Utterance Text "$parms{text}")) "$parms{to_file}" "riff")]; + + # Use the festival server if ($VTxt_festival and active $VTxt_festival) { $parms{text} =~ s/<\/?speaker.*?>//ig; # Server does not do sable - print "Voice_text TTS: Festival saving to file via server: $parms{to_file}\n" if $main::Debug{voice}; + &main::print_log ("Voice_text TTS: Festival saving to file via server: $parms{to_file}\n") if $main::Debug{voice}; set $VTxt_festival $parms{text}; my $fork=1 if $parms{async}; if ($fork) { my $pid = fork; - - # we are the parent + # we are the parent if ($fork and $pid) { return; # nothing else to do, the child is looking after the rest of the work - } + } } + # Wait for server to respond that it is done my $sock = $main::Socket_Ports{festival}{sock}; my $i; while ($i++ < 100) { - print '-'; + print '-' if $main::Debug{voice}; select undef, undef, undef, .1; my $nfound = &main::socket_has_data($sock); if ($nfound > 0) { last; } } - if (defined $parms{audreyIndex}) { - &::file_ready_for_audrey($parms{audreyIndex}); - } - if ($fork) { - if ($main::OS_win) { - exec 'true'; - } else { - &POSIX::_exit(0); - } -# exit; # nothing left for the child to do - } - } + + # Send voice text to waiting web clients + &web_hook_callback(%parms); + + # End the child if necessary + if ($fork) { + if ($main::OS_win) { + exec 'true'; + } else { + &POSIX::_exit(0); + } + # exit; # nothing left for the child to do + } + } + + # Call festival directly else { my $file = "$main::config_parms{data_dir}/mh_temp.festival.txt"; &main::file_write($file, $parms{text}); - print "Voice_text TTS: Festival saving to file: $file\n" if $main::Debug{voice}; + &main::print_log("Voice_text TTS: Festival saving to file: $file\n") if $main::Debug{voice}; my $fork = $parms{async}; if ($fork) { - my $pid = fork; - # we are the parnet - if ($fork and $pid) { - return; # the child will look after the real work - } - } + my $pid = fork; + # we are the parent + if ($fork and $pid) { + return; # the child will look after the real work + } + } + + # Call festival system("$main::config_parms{voice_text_festival} -b $file"); - if (defined $parms{audreyIndex}) { - &::file_ready_for_audrey($parms{audreyIndex}); - } - if ($fork) { - if ($main::OS_win) { - exec 'true'; - } else { - &POSIX::_exit(0); - } -# exit; # nothing left for the child to do - } + + # Send voice text to waiting web clients + &web_hook_callback(%parms); + + # Clean up the child if necessary + if ($fork) { + if ($main::OS_win) { + exec 'true'; + } else { + &POSIX::_exit(0); + } + # exit; # nothing left for the child to do + } } select undef, undef, undef, .2; # Need this ? } - # Check for sable requests. Server does not do sable + + # Speak Voice directly, not to a file + # Check for sable requests. Server does not do sable elsif (!$VTxt_festival or $parms{voice} or $parms{volume} or $parms{rate} or $parms{text} =~ /i/) { @@ -346,21 +390,22 @@ sub speak_text { my $pid = fork; # we are the parnet if ($fork and $pid) { - return; # the child will look after the real work - } - } + return; # the child will look after the real work + } + } system("($main::config_parms{voice_text_festival} --tts $file ; rm $file) &"); - if (defined $parms{audreyIndex}) { - &::file_ready_for_audrey($parms{audreyIndex}); - } - if ($fork) { - if ($main::OS_win) { - exec 'true'; - } else { - &POSIX::_exit(0); - } -# exit; # nothing left for the child to do - } + + # Send voice text to waiting web clients + &web_hook_callback(%parms); + + if ($fork) { + if ($main::OS_win) { + exec 'true'; + } else { + &POSIX::_exit(0); + } + # exit; # nothing left for the child to do + } } else { my $text = $parms{text}; @@ -374,18 +419,18 @@ sub speak_text { my $pid = fork; # we are the parnet if ($fork and $pid) { - return; # the child will look after the real work - } - } + return; # the child will look after the real work + } + } set $VTxt_festival qq[(SayText "$text")]; - if ($fork) { - if ($main::OS_win) { - exec 'true'; - } else { - &POSIX::_exit(0); - } -# exit; # nothing left for the child to do - } + if ($fork) { + if ($main::OS_win) { + exec 'true'; + } else { + &POSIX::_exit(0); + } + # exit; # nothing left for the child to do + } } } elsif ($speak_pgm) { @@ -517,7 +562,7 @@ sub speak_text { $speak_pgm_arg .= " -to_file $parms{to_file}" if $parms{to_file}; } - print "Voice_text TTS: f=$fork stdin=$speak_pgm_use_stdin p=$speak_pgm a=$speak_pgm_arg ai=$parms{audreyIndex}\n" if $main::Debug{voice}; + print "Voice_text TTS: f=$fork stdin=$speak_pgm_use_stdin p=$speak_pgm a=$speak_pgm_arg to_file=$parms{to_file}\n" if $main::Debug{voice}; if ($speak_pgm_use_stdin) { open VOICE, "| $speak_pgm $speak_pgm_arg"; @@ -538,9 +583,9 @@ sub speak_text { # print "can't execute $speak_pgm $speak_pgm_arg: rc is $? and $!\n"; # exit; # } - if (defined $parms{audreyIndex}) { - &::file_ready_for_audrey($parms{audreyIndex}); - } + # Send voice text to waiting web clients + &web_hook_callback(%parms); + if ($main::OS_win) { exec 'true'; } else { @@ -554,9 +599,9 @@ sub speak_text { } else { system qq[$speak_pgm $speak_pgm_arg]; - if (defined $parms{audreyIndex}) { - &::file_ready_for_audrey($parms{audreyIndex}); - } + + # Send voice text to waiting web clients + &web_hook_callback(%parms); } } } @@ -565,18 +610,18 @@ sub speak_text { if ($VTxt_version eq 'msv5') { # Allow option to save speech to a wav file if ($parms{to_file}) { - my $audreyFork=0; + my $webFork=0; # we only fork if we are asynchronously generating a file for Audrey. # otherwise, we can just use the native async capability - $audreyFork=1 if ($parms{async} and defined $parms{audreyIndex}); + $webFork=1 if ($parms{async} and defined $parms{to_file}); # this currently doesn't work - causes a strange "Bizarre SvType [92]" error at the fork line below # This is due to Win32::OLE not supporting forks! Known problem, not yet fixed. # For now, force async=0 for Audrey on windows # Hopefully this will work sometime in the future. :-( - if ($audreyFork) { - $audreyFork=0; + if ($webFork) { + $webFork=0; $parms{async}=0; } @@ -600,7 +645,7 @@ sub speak_text { # so that we can wait around for the file to get created. Once created, we notify # Audrey that the file is ready through &::file_ready_for_audrey - if ($audreyFork) { + if ($webFork) { my $pid=fork; # if we are the child if (!defined($pid)) { @@ -619,7 +664,9 @@ sub speak_text { $VTxt_stream2->Close; # at this point, the file _should_ be ready for Audrey undef $VTxt_stream2; - &::file_ready_for_audrey($parms{audreyIndex}); + + # Send voice text to waiting web clients + &web_hook_callback(%parms); # child is done all its work exec 'true'; } else { @@ -642,9 +689,8 @@ sub speak_text { $VTxt_stream1->Speak($parms{text}, 8); # Flags: 8=XML (no async, so we can close) $VTxt_stream2->Close; undef $VTxt_stream2; - &::file_ready_for_audrey($parms{audreyIndex}) if (defined $parms{audreyIndex}); -# &main::print_log("Text->wav file: $parms{to_file}"); -# &main::play($parms{to_file}); + # Send voice text to waiting web clients + &web_hook_callback(%parms); } } else { &main::print_log("WARN: no file could be produced for audrey."); From ea6b08adf17453833b2dedf97605e8eba8a2219b Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 3 Feb 2012 17:12:11 +0000 Subject: [PATCH 104/150] Add minor comments. --- lib/Insteon/AllLinkDatabase.pm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 4576ec4ba..a0e13f392 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -833,7 +833,9 @@ sub delete_orphan_links { if ($is_controller) { + # reference_object is the controller that is referenced by this ALDB's deviceid and the group my $reference_object = &Insteon::get_object($$self{device}->device_id, $group); + # reverse_object is the responder referenced by the ALDB link and it's data3 content my $reverse_object = &Insteon::get_object($device->device_id, ($data3 eq '00') ? '01' : $data3); if (ref $reference_object and ref $reverse_object and $reference_object->isa("Insteon::BaseController") and $reference_object->has_member($reverse_object)) { @@ -856,7 +858,11 @@ sub delete_orphan_links } else # is a responder { - my $reference_object = &Insteon::get_object($$self{device}->device_id, ($data3 eq '00') ? '01' : $data3); + # reference_object is the responder that is referenced by this ALDB's deviceid + # and the ALDB link's data3 + my $reference_object = &Insteon::get_object($$self{device}->device_id, + ($data3 eq '00') ? '01' : $data3); + # reverse_object is the controller referenced by the ALDB link and the group my $reverse_object = &Insteon::get_object($device->device_id, $group ); if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) { From f4f400b7c26f39cc3c11652fd50a9253e70145e9 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 3 Feb 2012 17:13:02 +0000 Subject: [PATCH 105/150] Replace hash flag representing ongoing transmission ("xmit_in_progress") with member function. --- lib/Insteon/BaseInterface.pm | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index de1fea563..618caf37a 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -47,6 +47,7 @@ sub new @{$$self{command_stack2}} = (); @{$$self{command_history}} = (); bless $self, $class; + $self->transmit_in_progress(0); # $self->debug(0) unless $self->debug; return $self; } @@ -141,14 +142,24 @@ sub clear_active_message my ($self) = @_; $$self{active_message} = undef; # $self->_clear_timeout('command'); - $$self{xmit_in_progress} = 0; + $self->transmit_in_progress(0); } sub retry_active_message { my ($self) = @_; # $self->_clear_timeout('command'); - $$self{xmit_in_progress} = 0; + $self->transmit_in_progress(0); +} + +sub transmit_in_progress +{ + my ($self, $xmit_flag) = @_; + if (defined $xmit_flag) + { + $$self{xmit_in_progress} = $xmit_flag; + } + return $$self{xmit_in_progress}; } sub queue_message @@ -186,7 +197,7 @@ sub process_queue my ($self) = @_; my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size unless !($$self{xmit_in_progress}); + return $command_queue_size if $self->transmit_in_progress; # get pending command record my $pending_message = $self->active_message; @@ -198,7 +209,7 @@ sub process_queue } #we dont transmit on top of another xmit - if (!($$self{xmit_in_progress})) + if (!($self->transmit_in_progress)) { # no transmission is progress that has not already been acked or nacked by the PLM if ($pending_message) { # a message exists to be sent (whether previously sent or queued) From 9826a372a69031cce4aada8923ec78e71f532d82 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 3 Feb 2012 17:14:30 +0000 Subject: [PATCH 106/150] Replace use of hash flag (xmit_in_progress) with member function. Ensure that received x10 message doesn't clear active message unless the active message is an x10 message. --- lib/Insteon_PLM.pm | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index a4cbfe1ee..adda9bfa6 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -102,7 +102,6 @@ sub new { $$self{port_name} = $port_name; $$self{port} = $port; $$self{last_command} = ''; - $$self{xmit_in_progress} = 0; $$self{_prior_data_fragment} = ''; bless $self, $class; $self->restore_data('debug'); @@ -167,10 +166,9 @@ sub check_for_data { if ($self->_check_timeout('command') == 1) { $self->_clear_timeout('command'); - if ($$self{xmit_in_progress}) { + if ($self->transmit_in_progress) { # &::print_log("[Insteon_PLM] WARN: No acknowledgement from PLM to last command requires forced abort of current command." # . " This may reflect a problem with your environment."); - $$self{xmit_in_progress} = 0; # pop(@{$$self{command_stack2}}); # pop the active command off the queue $self->retry_active_message(); $self->process_queue(); @@ -185,7 +183,7 @@ sub check_for_data { elsif ($self->_check_timeout('xmit') == 1) { $self->_clear_timeout('xmit'); - if (!($$self{xmit_in_progress})) + if (!($self->transmit_in_progress)) { $self->process_queue(); } @@ -284,7 +282,7 @@ sub _send_cmd { return; } unshift(@{$$self{command_history}},$::Time); - $$self{xmit_in_progress} = 1; + $self->transmit_in_progress(1); my $command = $message->interface_data; my $delay = $$self{xmit_delay}; @@ -401,7 +399,9 @@ sub _parse_data { . $pending_message->to_string) if $main::Debug{insteon} >= 3; } - if ($parsed_data =~ /$prefix{x10_send}\w{4}06/) + # X10 messages don't ACK back on the powerline, so clear them if the PLM acknowledges + # AND if the current, pending message is the X10 message + if (($parsed_data =~ /$prefix{x10_send}\w{4}06/) && ($pending_message->isa('Insteon::X10Message'))) { $self->clear_active_message(); } @@ -509,7 +509,6 @@ sub _parse_data { # We have a problem (Usually we stepped on another X10 command) &::print_log("[Insteon_PLM] ERROR: encountered $parsed_data. " . $pending_message->to_string()); -# $$self{xmit_in_progress} = 0; $self->retry_active_message(); #move it off the top of the stack and re-transmit later! #TODO: We should keep track of an errored command and kill it if it fails twice. prevent an infinite loop here @@ -580,7 +579,7 @@ sub _parse_data { my $failure_group = substr($message_data,2,2); my $failure_device = substr($message_data,4,6); - &::print_log("[Insteon_PLM] DEBUG2: Recieved all-link cleanup failure from device: " + &::print_log("[Insteon_PLM] DEBUG2: Received all-link cleanup failure from device: " . "$failure_device and group: failure_group") if $main::Debug{insteon} >= 2; } elsif ($parsed_prefix eq $prefix{all_link_record} and ($message_length == 20)) @@ -643,7 +642,6 @@ sub _parse_data { . " after delaying for $nack_delay second") if $main::Debug{insteon} >= 3; $self->_set_timeout('xmit',$nack_delay * 1000); $self->retry_active_message(); -# $$self{xmit_in_progress} = 0; $process_next_command = 0; $nack_count++; } From 406563c627b21ab4187ec77039261aa16cd06ded Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 7 Feb 2012 18:58:42 +0000 Subject: [PATCH 107/150] Discard frequent reports only if the state is the same. --- lib/Insteon/Controller.pm | 4 ++-- lib/Insteon/Security.pm | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/Controller.pm b/lib/Insteon/Controller.pm index 3d11e6786..0958759f7 100755 --- a/lib/Insteon/Controller.pm +++ b/lib/Insteon/Controller.pm @@ -35,7 +35,7 @@ sub set # if it can't be controlled (i.e., a responder), then don't send out any signals # motion sensors seem to get multiple fast reports; don't trigger on both - if (not defined($self->get_idle_time) or $self->get_idle_time > 1) { + if (not defined($self->get_idle_time) or $self->get_idle_time > 1 or $self->state ne $p_state) { &::print_log("[Insteon::RemoteLinc] " . $self->get_object_name() . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; $self->set_receive($p_state,$p_setby); @@ -52,4 +52,4 @@ sub is_responder return 0; } -1 \ No newline at end of file +1 diff --git a/lib/Insteon/Security.pm b/lib/Insteon/Security.pm index 9616b4fcb..374fe55a9 100755 --- a/lib/Insteon/Security.pm +++ b/lib/Insteon/Security.pm @@ -28,7 +28,7 @@ sub set # if it can't be controlled (i.e., a responder), then don't send out any signals # motion sensors seem to get multiple fast reports; don't trigger on both - if (not defined($self->get_idle_time) or $self->get_idle_time > 1) { + if (not defined($self->get_idle_time) or $self->get_idle_time > 1 or $self->state ne $p_state) { &::print_log("[Insteon::MotionSensor] " . $self->get_object_name() . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; $self->set_receive($p_state,$p_setby); From bc0f8ab38b7f7c23d458123246f005bcb97b9703 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 13 Feb 2012 18:32:23 +0000 Subject: [PATCH 108/150] Improve log statement utility during audit mode delete orphan links. --- lib/Insteon/AllLinkDatabase.pm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index a0e13f392..3d5c94c13 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -711,20 +711,22 @@ sub delete_orphan_links { # ignore since this is just a link back to the PLM } - elsif ($device->isa("Insteon::BaseInterface")) + elsif ($device->isa("Insteon::BaseInterface")) # and is a RESPONDER!! { - # does the PLM have a link point back? If not, the delete this one + # does the PLM have a link point back to it? If not, the delete this one # These are all responder links if (!($device->has_link($$self{device},$group,1))) { if ($audit_mode) { + my $plm_scene = &Insteon::get_object('000000',$group); &::print_log("[Insteon::ALDB_i1] (AUDIT) Now deleting orphaned responder link in " . $$self{device}->get_object_name . (($data3 eq '00' or $data3 eq '01') ? "" : " [button:" . $data3 . "]") . " because PLM does not have a corresponding controller record " - . "with group ($group). Try resyncing the scene corresponding to PLM:$group " - . "if the mht scene entry exists."); + . "with group ($group)." . (($plm_scene && ref $plm_scene) ? " Please resync " + . $plm_scene->get_object_name . " before re-running in non-audit mode to restore PLM side" + : "")); } else { From a8c41c13d6a59b47589bb26780096d96d18a146c Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 13 Feb 2012 18:33:12 +0000 Subject: [PATCH 109/150] Minor indenting cleanup. --- lib/Insteon/BaseInterface.pm | 64 ++++++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 25 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 618caf37a..a7f1346a0 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -11,30 +11,35 @@ sub check_for_data $interface->check_for_data(); } -sub poll_all { +sub poll_all +{ my $scan_at_startup = $main::config_parms{Insteon_PLM_scan_at_startup}; $scan_at_startup = 1 unless defined $scan_at_startup; $scan_at_startup = 0 unless $main::Save{mh_exit} eq 'normal'; my $plm = &Insteon::active_interface(); - if (defined $plm) { - if (!($plm->device_id) and !($$plm{_id_check})) { + if (defined $plm) + { + if (!($plm->device_id) and !($$plm{_id_check})) + { $$plm{_id_check} = 1; $plm->queue_message(new Insteon::InsteonMessage('plm_info', $plm)); } - if ($scan_at_startup) { - - for my $insteon_device (&Insteon::find_members('Insteon::BaseDevice')) { - if ($insteon_device and $insteon_device->is_root and $insteon_device->is_responder) - { - # don't request status for objects associated w/ other than the primary group - # as they are psuedo links - $insteon_device->request_status(); - } - if ($insteon_device->devcat) { - # reset devcat so as to trigger any device specific properties - $insteon_device->devcat($insteon_device->devcat); - } - } + if ($scan_at_startup) + { + + for my $insteon_device (&Insteon::find_members('Insteon::BaseDevice')) + { + if ($insteon_device and $insteon_device->is_root and $insteon_device->is_responder) + { + # don't request status for objects associated w/ other than the primary group + # as they are psuedo links + $insteon_device->request_status(); + } + if ($insteon_device->devcat) { + # reset devcat so as to trigger any device specific properties + $insteon_device->devcat($insteon_device->devcat); + } + } } } } @@ -76,8 +81,10 @@ sub _is_duplicate return 1 if ($self->active_message && $self->active_message->interface_data eq $cmd); my $duplicate_detected = 0; # check for duplicates of $cmd already in command_stack and ignore if they exist - foreach my $message (@{$$self{command_stack2}}) { - if ($message->interface_data eq $cmd) { + foreach my $message (@{$$self{command_stack2}}) + { + if ($message->interface_data eq $cmd) + { $duplicate_detected = 1; last; } @@ -101,10 +108,13 @@ sub add_link if ($self->_aldb) { my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } $self->_aldb->add_link(%link_parms); @@ -117,10 +127,13 @@ sub delete_link if ($self->_aldb) { my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } $self->_aldb->delete_link(%link_parms); @@ -173,8 +186,9 @@ sub queue_message if (defined $message) { my $setby = $message->setby; - if ($self->_is_duplicate($message->interface_data) && !($message->isa('Insteon::X10Message'))) { - &main::print_log("[Insteon_PLM] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; + if ($self->_is_duplicate($message->interface_data) && !($message->isa('Insteon::X10Message'))) + { + &main::print_log("[Insteon::BaseInterface] Attempt to queue command already in queue; skipping ...") if $main::Debug{insteon}; } else { From 03d4f5175fd33de90c35d3e4a22481747506edd5 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 14 Feb 2012 21:32:54 +0000 Subject: [PATCH 110/150] Improve diagnostic logging statements. --- lib/Insteon/AllLinkDatabase.pm | 259 +++++++++++++++++++++++---------- 1 file changed, 179 insertions(+), 80 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 3d5c94c13..6ebd9072c 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -696,7 +696,7 @@ sub delete_orphan_links # no device is known by mh with the ADLB record's deviceid if ($audit_mode) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " + &::print_log("[Insteon::ALDB_i1] (AUDIT) " . $selfname . " now deleting orphaned link w/ details: " . (($is_controller) ? "controller" : "responder") . ", deviceid=$deviceid, group=$group"); } @@ -770,12 +770,18 @@ sub delete_orphan_links } } } - if ($is_invalid) { + if ($is_invalid) + { if ($audit_mode) { + my $button_msg = ""; + if ($data3 ne '00' and $data3 ne '01') + { + ## to-do - validate that $data3 is <= 8 for all 8 key devices + $button_msg = " [button:" . $data3 . "]"; + } &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan responder link from " - . $$self{device}->get_object_name - . (($data3 eq '00' or $data3 eq '01') ? "" : " [button:" . $data3 . "]") + . $selfname . $button_msg . " to PLM because no SCENE_MEMBER entry could be found " . "in items.mht for INSTEON_ICONTROLLER: " . $plm_link->get_object_name); @@ -789,12 +795,19 @@ sub delete_orphan_links $num_deleted++; } } - } else { + } + else + { # no corresponding PLM link found if ($audit_mode) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no PLM link defined to: " - . (($is_controller) ? "controller" : "responder") - . "=$selfname" . "($group), data=$data3"); + my $button_msg = ""; + if ($data3 ne '00' and $data3 ne '01') + { + ## to-do - validate that $data3 is <= 8 for all 8 key devices + $button_msg = " [button:" . $data3 . "]"; + } + &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan responder link from " + . $selfname . $button_msg . " to PLM because to PLM contoller exists for group:$group"); } else { @@ -1046,10 +1059,13 @@ sub _process_delete_queue { { my $delete_req_ptr = shift(@{$$self{delete_queue}}); my %delete_req = %$delete_req_ptr; - if ($delete_req{address}) { + if ($delete_req{address}) + { &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " now deleting duplicate record at address " . $delete_req{address}); - } else { + } + else + { &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " . (($delete_req{is_controller}) ? "controller" : "responder") . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name @@ -1068,19 +1084,25 @@ sub add_link { my ($self, $parms_text) = @_; my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } my $device_id; my $insteon_object = $link_parms{object}; my $group = $link_parms{group}; - if (!(defined($insteon_object))) { + if (!(defined($insteon_object))) + { $device_id = lc $link_parms{deviceid}; $insteon_object = &Insteon::get_object($device_id, $group); - } else { + } + else + { $device_id = lc $insteon_object->device_id; } my $is_controller = ($link_parms{is_controller}) ? 1 : 0; @@ -1089,20 +1111,25 @@ sub add_link # get the address via lookup into the hash my $key = lc $device_id . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if (!($subaddress eq '00' or $subaddress eq '01')) { + if (!($subaddress eq '00' or $subaddress eq '01')) + { $key .= $subaddress; } - if (defined $$self{aldb}{$key}{inuse}) { + if (defined $$self{aldb}{$key}{inuse}) + { &::print_log("[Insteon::ALDB_i1] WARN: attempt to add link to " . $$self{device}->get_object_name . " that already exists! " . "object=" . $insteon_object->get_object_name . ", group=$group, is_controller=$is_controller"); - if ($link_parms{callback}) { + if ($link_parms{callback}) + { package main; eval($link_parms{callback}); &::print_log("[Insteon::ALDB_i1] failure occurred in callback eval for " . $$self{device}->get_object_name . ":" . $@) if $@ and $main::Debug{insteon}; package Insteon::ALDB_i1; } - } else { + } + else + { # strip optional % sign to append on_level my $on_level = $link_parms{on_level}; $on_level =~ s/(\d)%?/$1/; @@ -1111,18 +1138,30 @@ sub add_link my $ramp_rate = $link_parms{ramp_rate}; $ramp_rate =~ s/(\d)s?/$1/; $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default - &::print_log("[Insteon::ALDB_i1] adding link record " . $$self{device}->get_object_name - . " light level controlled by " . $insteon_object->get_object_name - . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") if $main::Debug{insteon}; - my $data1 = &Insteon::DimmableLight::convert_level($on_level); - my $data2 = ($$self{device}->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; - my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; # get the first available memory location my $address = pop @{$$self{aldb}{empty}}; - # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails - $$self{_mem_activity} = 'add'; - $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); + if ($address) + { + &::print_log("[Insteon::ALDB_i1] DEBUG2: adding link record " . $$self{device}->get_object_name + . " light level controlled by " . $insteon_object->get_object_name + . " and group: $group with on level: $on_level and ramp rate: $ramp_rate") + if $main::Debug{insteon} >= 2; + my $data1 = &Insteon::DimmableLight::convert_level($on_level); + my $data2 = ($$self{device}->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; + my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; + $$self{_mem_activity} = 'add'; + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); + # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails + } + else + { + &::print_log("[Insteon::ALDB_i1] ERROR: adding link record failed because " + . $$self{device}->get_object_name + . " does not have a record of the first empty ALDB record." + . " Please rescan this device's link table") + if $main::Debug{insteon}; + } } } @@ -1150,7 +1189,8 @@ sub update_link # get the address via lookup into the hash my $key = lc $deviceid . $group . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if (!($subaddress eq '00' or $subaddress eq '01')) { + if (!($subaddress eq '00' or $subaddress eq '01')) + { $key .= $subaddress; } my $address = $$self{aldb}{$key}{address}; @@ -1181,16 +1221,24 @@ sub log_alllink_table # corresponding address is a duplicate), or a hash key (which # indicates that the ALDB at corresponding address contains # a link). - foreach my $aldbkey (keys %{$$self{aldb}}) { - if ($aldbkey eq "empty") { - foreach my $address (@{$$self{aldb}{empty}}) { + foreach my $aldbkey (keys %{$$self{aldb}}) + { + if ($aldbkey eq "empty") + { + foreach my $address (@{$$self{aldb}{empty}}) + { $aldb{$address}{empty} = undef; # Any value will do } - } elsif ($aldbkey eq "duplicates") { - foreach my $address (@{$$self{aldb}{duplicates}}) { + } + elsif ($aldbkey eq "duplicates") + { + foreach my $address (@{$$self{aldb}{duplicates}}) + { $aldb{$address}{duplicate} = undef; # Any value will do } - } else { + } + else + { $aldb{$$self{aldb}{$aldbkey}{address} }{$aldbkey} = $$self{aldb}{$aldbkey}; } } @@ -1310,14 +1358,18 @@ sub has_link { my ($self, $insteon_object, $group, $is_controller, $subaddress) = @_; my $key = ""; - if ($insteon_object->isa('Insteon::BaseObject') || $insteon_object->isa('Insteon::BaseInterface')) { + if ($insteon_object->isa('Insteon::BaseObject') || $insteon_object->isa('Insteon::BaseInterface')) + { $key = lc $insteon_object->device_id . $group . $is_controller; - } elsif ($insteon_object->isa('Insteon::AllLinkDatabase')) { + } + elsif ($insteon_object->isa('Insteon::AllLinkDatabase')) + { $key = lc $$insteon_object{device}->device_id . $group . $is_controller; } $subaddress = '00' unless $subaddress; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if (!($subaddress eq '00' or $subaddress eq '01')) { + if (!($subaddress eq '00' or $subaddress eq '01')) + { $key .= $subaddress; } return (defined $$self{aldb}{$key}) ? 1 : 0; @@ -1326,10 +1378,12 @@ sub has_link sub _write_link { my ($self, $address, $deviceid, $group, $is_controller, $data1, $data2, $data3) = @_; - if ($address) { + if ($address) + { &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " address: $address found for device: $deviceid and group: $group"); # change address for start of change to be address + offset - if ($$self{_mem_activity} eq 'update') { + if ($$self{_mem_activity} eq 'update') + { $address = sprintf('%04X',hex($address) + 5); } $$self{pending_aldb}{address} = $address; @@ -1339,14 +1393,17 @@ sub _write_link $$self{pending_aldb}{data1} = (defined $data1) ? lc $data1 : '00'; $$self{pending_aldb}{data2} = (defined $data2) ? lc $data2 : '00'; # Note: if device is a KeypadLinc, then $data3 must be assigned the value of the applicable button (01) - if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) { + if (($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) and ($data3 eq '00')) + { &::print_log("[Insteon::ALDB_i1] setting data3 to " . $$self{device}->group . " for this keypadlinc") if $main::Debug{insteon}; $data3 = $$self{device}->group; } $$self{pending_aldb}{data3} = (defined $data3) ? lc $data3 : '00'; $self->_peek($address); - } else { + } + else + { &::print_log("[Insteon::ALDB_i1] WARN: " . $$self{device}->get_object_name . " write_link failure: no address available for record to device: $deviceid and group: $group" . " and is_controller: $is_controller");; @@ -1358,12 +1415,15 @@ sub _peek my ($self, $address, $extended) = @_; my $msb = substr($address,0,2); my $lsb = substr($address,2,2); - if ($extended) { + if ($extended) + { my $message = $self->device->derive_message('peek','insteon_ext_send', $lsb . "0000000000000000000000000000"); $self->interface->queue_message($message); - } else { + } + else + { $$self{_mem_lsb} = $lsb; $$self{_mem_msb} = $msb; $$self{_mem_action} = 'aldb_peek'; @@ -1420,13 +1480,16 @@ sub restore_string { my ($self) = @_; my $restore_string = ''; - if ($$self{aldb}) { + if ($$self{aldb}) + { my $link = ''; - foreach my $link_key (keys %{$$self{aldb}}) { + foreach my $link_key (keys %{$$self{aldb}}) + { $link .= '|' if $link; # separate sections my %link_record = %{$$self{aldb}{$link_key}}; my $record = ''; - foreach my $record_key (keys %link_record) { + foreach my $record_key (keys %link_record) + { next unless $link_record{$record_key}; $record .= ',' if $record; $record .= $record_key . '=' . $link_record{$record_key}; @@ -1448,13 +1511,16 @@ sub restore_string sub restore_linktable { my ($self, $links) = @_; - if ($links) { - foreach my $link_section (split(/\|/,$links)) { + if ($links) + { + foreach my $link_section (split(/\|/,$links)) + { my %link_record = (); my $deviceid = ''; my $groupid = '01'; my $is_controller = 0; - foreach my $link_record (split(/,/,$link_section)) { + foreach my $link_record (split(/,/,$link_section)) + { my ($key,$value) = split(/=/,$link_record); $deviceid = $value if ($key eq 'deviceid'); $groupid = $value if ($key eq 'group'); @@ -1502,8 +1568,8 @@ sub log_alllink_table sub parse_alllink { my ($self, $data) = @_; -# &::print_log("[DEBUG] $data"); - if (substr($data,0,6)) { + if (substr($data,0,6)) + { my %link = (); my $flag = substr($data,0,1); $link{is_controller} = (hex($flag) & 0x04) ? 1 : 0; @@ -1538,19 +1604,21 @@ sub delete_orphan_links @{$$self{delete_queue}} = (); # reset the work queue my $selfname = $$self{device}->get_object_name; my $num_deleted = 0; - foreach my $linkkey (keys %{$$self{aldb}}) { + foreach my $linkkey (keys %{$$self{aldb}}) + { my $deviceid = lc $$self{aldb}{$linkkey}{deviceid}; my $group = $$self{aldb}{$linkkey}{group}; my $is_controller = $$self{aldb}{$linkkey}{is_controller}; my $data3 = $$self{aldb}{$linkkey}{data3}; my $device = &Insteon::get_object($deviceid,'01'); # if a PLM link (regardless of responder or controller) exists to a device that is not known, then delete - if (!($device)) { + if (!($device)) + { if ($audit_mode) { - &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete Orphan Link to non-existant device " . - " device: " . - $deviceid . "; group: $group; is_controller: $is_controller, data: $data3") + &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete Orphan Link to non-existant deviceid: " . + $deviceid . "; group:$group; " + . (($is_controller) ? "controller; data:$data3" : "responder")) if $main::Debug{insteon}; } else @@ -1560,14 +1628,18 @@ sub delete_orphan_links linkdevice => $self, data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; } - } else { + } + else + { my $is_invalid = 1; my $link = undef; - if ($is_controller) { + if ($is_controller) + { # then, this is a PLM defined link; and, we won't care about responder links as we assume # they're ok given that they reference known devices $link = &Insteon::get_object('000000',$group); - if (!($link)) { + if (!($link)) + { # a reference in the PLM's linktable does not match a scene member target if ($audit_mode) { @@ -1632,12 +1704,14 @@ sub delete_orphan_links $is_invalid = 0; } } # foreach $$link{members} - if ($is_invalid) { + if ($is_invalid) + { # then, there is a good chance that a reciprocal link exists; if so, delet it too - if ($device->has_link($self,$group,0, $data3)) { + if ($device->has_link($self,$group,0, $data3)) + { if ($audit_mode) { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan controller link from PLM to " + &::print_log("[Insteon::ALDB_PLM] (AUDIT) Delete orphan controller link from PLM to " . $device->get_object_name() . " because no SCENE_MEMBER entry could be found " . "in items.mht for INSTEON_ICONTROLLER: " @@ -1678,25 +1752,33 @@ sub _process_delete_queue { my ($self, $p_num_deleted) = @_; $$self{delete_queue_processed} += $p_num_deleted if $p_num_deleted; my $num_in_queue = @{$$self{delete_queue}}; - if ($num_in_queue) { + if ($num_in_queue) + { my $delete_req_ptr = shift(@{$$self{delete_queue}}); my %delete_req = %$delete_req_ptr; # distinguish between deleting PLM links and processing delete orphans for a root item if ($delete_req{'root_object'}) { $delete_req{'root_object'}->delete_orphan_links(); - } else { - if ($delete_req{linkdevice} eq $self) { + } + else + { + if ($delete_req{linkdevice} eq $self) + { &::print_log("[Insteon::ALDB_PLM] now deleting orphaned link w/ details: " . (($delete_req{is_controller}) ? "controller" : "responder") . ", " . (($delete_req{object}) ? "object=" . $delete_req{object}->get_object_name : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}") if $main::Debug{insteon}; $self->delete_link(%delete_req); - } elsif ($delete_req{linkdevice}) { + } + elsif ($delete_req{linkdevice}) + { $delete_req{linkdevice}->delete_link(%delete_req); } } - } else { + } + else + { &::print_log("[Insteon::ALDB_PLM] A total of $$self{delete_queue_processed} orphaned link records were deleted."); } @@ -1707,10 +1789,13 @@ sub delete_link # linkkey is concat of: deviceid, group, is_controller my ($self, $parms_text) = @_; my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } my $num_deleted = 0; @@ -1719,7 +1804,8 @@ sub delete_link my $group = $link_parms{group}; my $is_controller = ($link_parms{is_controller}) ? 1 : 0; my $linkkey = lc $deviceid . $group . (($is_controller) ? '1' : '0'); - if (defined $$self{aldb}{$linkkey}) { + if (defined $$self{aldb}{$linkkey}) + { my $cmd = '80' . $$self{aldb}{$linkkey}{flags} . $$self{aldb}{$linkkey}{group} @@ -1737,9 +1823,12 @@ sub delete_link } $message->interface_data($cmd); $$self{device}->queue_message($message); - } else { + } + else + { &::print_log("[Insteon::ALDB_PLM] no entry in linktable could be found for linkkey: $linkkey"); - if ($link_parms{callback}) { + if ($link_parms{callback}) + { package main; eval ($link_parms{callback}); &::print_log("[Insteon_PLM] error in add link callback: " . $@) @@ -1754,35 +1843,45 @@ sub add_link { my ($self, $parms_text) = @_; my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } my $device_id; my $group = ($link_parms{group}) ? $link_parms{group} : '01'; my $insteon_object = $link_parms{object}; - if (!(defined($insteon_object))) { + if (!(defined($insteon_object))) + { $device_id = lc $link_parms{deviceid}; $insteon_object = &Insteon::get_object($device_id, $group); - } else { + } + else + { $device_id = lc $insteon_object->device_id; } my $is_controller = ($link_parms{is_controller}) ? 1 : 0; # first, confirm that the link does not already exist my $linkkey = lc $device_id . $group . $is_controller; - if (defined $$self{aldb}{$linkkey}) { + if (defined $$self{aldb}{$linkkey}) + { &::print_log("[Insteon::ALDB_PLM] WARN: attempt to add link to PLM that already exists! " . "deviceid=" . $device_id . ", group=$group, is_controller=$is_controller"); - if ($link_parms{callback}) { + if ($link_parms{callback}) + { package main; eval ($link_parms{callback}); &::print_log("[Insteon::ALDB_PLM] error in add link callback: " . $@) if $@ and $main::Debug{insteon}; package Insteon_PLM; } - } else { + } + else + { my $control_code = ($is_controller) ? '40' : '41'; # flags should be 'a2' for responder and 'e2' for controller my $flags = ($is_controller) ? 'E2' : 'A2'; From aed572ed84485cd532d4c5426d3ac29685fd2819 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 20:14:40 +0000 Subject: [PATCH 111/150] Report setby object name rather than allow object ref to be logged. --- lib/Insteon/Controller.pm | 8 +++++--- lib/Insteon/Security.pm | 8 +++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/Controller.pm b/lib/Insteon/Controller.pm index 0958759f7..45b77b9ad 100755 --- a/lib/Insteon/Controller.pm +++ b/lib/Insteon/Controller.pm @@ -35,13 +35,15 @@ sub set # if it can't be controlled (i.e., a responder), then don't send out any signals # motion sensors seem to get multiple fast reports; don't trigger on both + my $setby_name = $p_setby; + $setby_name = $p_setby->get_object_name() if (ref $p_setby and $p_setby->can('get_object_name')); if (not defined($self->get_idle_time) or $self->get_idle_time > 1 or $self->state ne $p_state) { &::print_log("[Insteon::RemoteLinc] " . $self->get_object_name() - . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; + . "::set_receive($p_state, $setby_name)") if $main::Debug{insteon}; $self->set_receive($p_state,$p_setby); } else { &::print_log("[Insteon::RemoteLinc] " . $self->get_object_name() - . "::set_receive($p_state, $p_setby) deferred due to repeat within 1 second") + . "::set_receive($p_state, $setby_name) deferred due to repeat within 1 second") if $main::Debug{insteon}; } return; @@ -52,4 +54,4 @@ sub is_responder return 0; } -1 +1 \ No newline at end of file diff --git a/lib/Insteon/Security.pm b/lib/Insteon/Security.pm index 374fe55a9..0672dde3c 100755 --- a/lib/Insteon/Security.pm +++ b/lib/Insteon/Security.pm @@ -28,13 +28,15 @@ sub set # if it can't be controlled (i.e., a responder), then don't send out any signals # motion sensors seem to get multiple fast reports; don't trigger on both + my $setby_name = $p_setby; + $setby_name = $p_setby->get_object_name() if (ref $p_setby and $p_setby->can('get_object_name')); if (not defined($self->get_idle_time) or $self->get_idle_time > 1 or $self->state ne $p_state) { &::print_log("[Insteon::MotionSensor] " . $self->get_object_name() - . "::set_receive($p_state, $p_setby)") if $main::Debug{insteon}; + . "::set_receive($p_state, $setby_name)") if $main::Debug{insteon}; $self->set_receive($p_state,$p_setby); } else { &::print_log("[Insteon::MotionSensor] " . $self->get_object_name() - . "::set_receive($p_state, $p_setby) deferred due to repeat within 1 second") + . "::set_receive($p_state, $setby_name) deferred due to repeat within 1 second") if $main::Debug{insteon}; } return; @@ -45,4 +47,4 @@ sub is_responder return 0; } -1 +1 \ No newline at end of file From 7a540c913db498176d6a51b8a06b2b9bda47b584 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 20:15:44 +0000 Subject: [PATCH 112/150] Alter delete orphans logic so that missing links does not also force other checks. --- lib/Insteon/AllLinkDatabase.pm | 73 ++++++++++++++++------------------ 1 file changed, 35 insertions(+), 38 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 6ebd9072c..be3ca8ddc 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -689,9 +689,9 @@ sub delete_orphan_links my $is_controller = $$self{aldb}{$linkkey}{is_controller}; my $data3 = $$self{aldb}{$linkkey}{data3}; # $device is the object that is referenced by the ALDB record's deviceid - my $device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface + my $linked_device = ($deviceid eq lc $$self{device}->interface->device_id) ? $$self{device}->interface : &Insteon::get_object($deviceid,'01'); - if (!($device)) + if (!($linked_device)) { # no device is known by mh with the ADLB record's deviceid if ($audit_mode) @@ -707,15 +707,14 @@ sub delete_orphan_links push @{$$self{delete_queue}}, \%delete_req; } } - elsif ($device->isa("Insteon::BaseInterface") and $is_controller) + elsif ($linked_device->isa("Insteon::BaseInterface") and $is_controller) { # ignore since this is just a link back to the PLM } - elsif ($device->isa("Insteon::BaseInterface")) # and is a RESPONDER!! + elsif ($linked_device->isa("Insteon::BaseInterface")) # and is a RESPONDER!! { - # does the PLM have a link point back to it? If not, the delete this one - # These are all responder links - if (!($device->has_link($$self{device},$group,1))) + # does the PLM have a corresponding controlled link to $self? If not, the delete this responder link + if (!($linked_device->has_link($$self{device},$group,1))) { if ($audit_mode) { @@ -731,19 +730,15 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", object => $device, data3 => $data3, + callback => "$selfname->_aldb->_process_delete_queue()", object => $linked_device, data3 => $data3, cause => 'PLM does not have a link pointing back to device'); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } } - # is there an entry in the items.mht that corresponds to this link? - if ($is_controller) - { - # TO-DO: handle this case - } else { + # is there an entry in the items.mht that corresponds to this link? # find the corresponding PLM scene that has this group my $plm_link = &Insteon::get_object('000000', $group); if ($plm_link) @@ -789,7 +784,7 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", object => $device, + callback => "$selfname->_aldb->_process_delete_queue()", object => $linked_device, cause => "no link is defined for the plm controlled scene", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -813,32 +808,32 @@ sub delete_orphan_links { # delete the link since it doesn't exist my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", object => $device, + callback => "$selfname->_aldb->_process_delete_queue()", object => $linked_device, cause => "no plm link could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } } - } # is not a controller + } } else # is a non-PLM device { - if ($device->isa('Insteon::RemoteLinc') or $device->isa('Insteon::MotionSensor')) + if ($linked_device->isa('Insteon::RemoteLinc') or $linked_device->isa('Insteon::MotionSensor')) { - &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from 'deaf' device: " . $device->get_object_name); + &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from 'deaf' device: " . $linked_device->get_object_name); } # make sure that the health of the device's ALDB is ok - elsif ($device->_aldb->health ne 'good') + elsif ($linked_device->_aldb->health ne 'good') { &::print_log("[Insteon::ALDB_i1] Delete orphan links: skipping check for reciprocal links from " - . $device->get_object_name . " because health: " - . $device->_aldb->health . ". Please rescan this device!!") - if ($device->_aldb->health ne 'empty'); + . $linked_device->get_object_name . " because health: " + . $linked_device->_aldb->health . ". Please rescan this device!!") + if ($linked_device->_aldb->health ne 'empty'); } else { # does the device fail to have a reciprocal link? - if (!($device->has_link($self,$group,($is_controller) ? 0:1, $data3))) + if (!($linked_device->has_link($self,$group,($is_controller) ? 0:1, $data3))) { # this may be a case of an impartial link (not yet bidirectional) # BUT... if is_controller and $device is not a member of $$self{device} @@ -851,8 +846,10 @@ sub delete_orphan_links # reference_object is the controller that is referenced by this ALDB's deviceid and the group my $reference_object = &Insteon::get_object($$self{device}->device_id, $group); # reverse_object is the responder referenced by the ALDB link and it's data3 content - my $reverse_object = &Insteon::get_object($device->device_id, ($data3 eq '00') ? '01' : $data3); - if (ref $reference_object and ref $reverse_object and $reference_object->isa("Insteon::BaseController") and $reference_object->has_member($reverse_object)) + my $reverse_object = &Insteon::get_object($linked_device->device_id, ($data3 eq '00') ? '01' : $data3); + if (ref $reference_object and ref $reverse_object and + $reference_object->isa("Insteon::BaseController") and + $reference_object->has_member($reverse_object)) { &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reciprocal link defined for: " . $reference_object->get_object_name @@ -866,7 +863,7 @@ sub delete_orphan_links &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " . $$self{device}->get_object_name . "($group) as controller and " - . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + . $linked_device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" . " because no reciprocal link exists!" ); } @@ -878,7 +875,7 @@ sub delete_orphan_links my $reference_object = &Insteon::get_object($$self{device}->device_id, ($data3 eq '00') ? '01' : $data3); # reverse_object is the controller referenced by the ALDB link and the group - my $reverse_object = &Insteon::get_object($device->device_id, $group ); + my $reverse_object = &Insteon::get_object($linked_device->device_id, $group ); if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) { &::print_log("[Insteon::ALDB_i1] (AUDIT) WARNING: no reverse link defined for: " @@ -893,7 +890,7 @@ sub delete_orphan_links &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " . $$self{device}->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " - . $device->get_object_name . "($group)" + . $linked_device->get_object_name . "($group)" . " because no reverse links exists!" ); } @@ -904,7 +901,7 @@ sub delete_orphan_links if ($is_controller) { my $reference_object = &Insteon::get_object($$self{device}->device_id, $group); - my $reverse_object = &Insteon::get_object($device->device_id, ($data3 eq '00') ? '01' : $data3); + my $reverse_object = &Insteon::get_object($linked_device->device_id, ($data3 eq '00') ? '01' : $data3); if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) { &::print_log("[Insteon::ALDB_i1] WARNING: no reciprocal link defined for: " @@ -919,11 +916,11 @@ sub delete_orphan_links &::print_log("[Insteon::ALDB_i1] Deleting link defined for: " . $$self{device}->get_object_name . "($group) as controller and " - . $device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" + . $linked_device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" . " because no reciprocal link exists!" ); my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, + callback => "$selfname->_process_delete_queue()", object => $linked_device, cause => "no link to the device could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -932,7 +929,7 @@ sub delete_orphan_links else # is a responder { my $reference_object = &Insteon::get_object($$self{device}->device_id, ($data3 eq '00') ? '01' : $data3); - my $reverse_object = &Insteon::get_object($device->device_id, $group ); + my $reverse_object = &Insteon::get_object($linked_device->device_id, $group ); if (ref $reference_object and ref $reverse_object and $reverse_object->isa("Insteon::BaseController") and $reverse_object->has_member($reference_object)) { &::print_log("[Insteon::ALDB_i1] WARNING: no reverse link defined for: " @@ -947,11 +944,11 @@ sub delete_orphan_links &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " . $$self{device}->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " - . $device->get_object_name . "($group)" + . $linked_device->get_object_name . "($group)" . " because no reverse links exists!" ); my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $device, + callback => "$selfname->_process_delete_queue()", object => $linked_device, cause => "no link to the device could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; @@ -963,7 +960,7 @@ sub delete_orphan_links { my $is_invalid = 1; my $link = ($is_controller) ? &Insteon::get_object($$self{device}->device_id,$group) - : &Insteon::get_object($device->device_id,$group); + : &Insteon::get_object($linked_device->device_id,$group); if ($link) { foreach my $member_ref (keys %{$$link{members}}) @@ -994,7 +991,7 @@ sub delete_orphan_links last; } elsif ($member->isa('Insteon::BaseDevice') && $is_controller - && ($member->device_id eq $device->device_id)) + && ($member->device_id eq $linked_device->device_id)) { $is_invalid = 0; last; @@ -1006,7 +1003,7 @@ sub delete_orphan_links if ($audit_mode) { &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because no reverse link could be found " - . $device->get_object_name . + . $linked_device->get_object_name . " details: " . (($is_controller) ? "controller" : "responder") . ", deviceid=$deviceid, group=$group, data=$data3"); @@ -1014,7 +1011,7 @@ sub delete_orphan_links else { my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", object => $device, + callback => "$selfname->_aldb->_process_delete_queue()", object => $linked_device, cause => "no reverse link could be found", data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; From c5aa672e1b673133e57e06d8560eab272fbfac53 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 20:16:59 +0000 Subject: [PATCH 113/150] Improve sync_links logic to support audit mode. Don't allow link updates if the data is functionally equivalent. --- lib/Insteon/BaseInsteon.pm | 121 +++++++++++++++++++++++++------------ 1 file changed, 84 insertions(+), 37 deletions(-) diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 38e7283ec..0f144ba2f 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -1234,7 +1234,7 @@ sub add sub sync_links { - my ($self, $callback) = @_; + my ($self, $audit_mode, $callback, $failure_callback) = @_; @{$$self{sync_queue}} = (); # reset the work queue $$self{sync_queue_callback} = ($callback) ? $callback : undef; my $insteon_object = $self->interface; @@ -1309,7 +1309,7 @@ sub sync_links my $link_on_level = hex($$member_aldb{aldb}{$aldbkey}{data1})/2.55; my $raw_ramp_rate = $$member_aldb{aldb}{$aldbkey}{data2}; my $raw_tgt_ramp_rate = &Insteon::DimmableLight::convert_ramp($tgt_ramp_rate); - if ($raw_ramp_rate != $raw_tgt_ramp_rate) + if (($raw_ramp_rate != $raw_tgt_ramp_rate) && ($raw_ramp_rate ne '00' and $raw_tgt_ramp_rate ne '1f')) { $requires_update = 1; &::print_log("[Insteon::BaseController] DEBUG: flagging " . $self->get_object_name @@ -1327,42 +1327,71 @@ sub sync_links } if ($requires_update) { - my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, - group => $self->group, is_controller => 0, - on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + if ($audit_mode) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; + &::print_log("[Insteon::BaseController] (AUDIT) - updating responder record to " + . $member->get_object_name . " for " + . $insteon_object->get_object_name . " with group:" . $self->group + . "; on_level:$tgt_on_level; ramp_rate:$tgt_ramp_rate"); + } + else + { + my %link_req = ( member => $member, cmd => 'update', object => $insteon_object, + group => $self->group, is_controller => 0, + on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } } } else { - my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, - group => $self->group, is_controller => 0, - on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + if ($audit_mode) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; + &::print_log("[Insteon::BaseController] (AUDIT) - adding responder record to " + . $member->get_object_name . " for " + . $insteon_object->get_object_name . " with group:" . $self->group + . "; on_level:$tgt_on_level; ramp_rate:$tgt_ramp_rate"); + } + else + { + my %link_req = ( member => $member, cmd => 'add', object => $insteon_object, + group => $self->group, is_controller => 0, + on_level => $tgt_on_level, ramp_rate => $tgt_ramp_rate, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } } if (!($insteon_object->has_link($member, $self->group, 1, $linkmember->group))) { - my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, - group => $self->group, is_controller => 1, - callback => "$self_link_name->_process_sync_queue()" ); - # set data3 is device is a KeypadLinc - if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + if ($audit_mode) { - $link_req{data3} = $linkmember->group; - } - push @{$$self{sync_queue}}, \%link_req; + &::print_log("[Insteon::BaseController] (AUDIT) - adding controller record to " + . $insteon_object->get_object_name . " for " . $member->get_object_name + . " with group:" . $self->group); + } + else + { + my %link_req = ( member => $insteon_object, cmd => 'add', object => $member, + group => $self->group, is_controller => 1, + callback => "$self_link_name->_process_sync_queue()" ); + # set data3 is device is a KeypadLinc + if ($member->isa('Insteon::KeyPadLincRelay') or $member->isa('Insteon::KeyPadLinc')) + { + $link_req{data3} = $linkmember->group; + } + push @{$$self{sync_queue}}, \%link_req; + } } } } @@ -1372,18 +1401,36 @@ sub sync_links my $subaddress = ($self->isa('Insteon::KeyPadLincRelay') or $self->isa('Insteon::KeyPadLinc')) ? $self->group : '00'; if (!($insteon_object->has_link($self->interface,$self->group,1,$subaddress))) { - my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, - group => $self->group, is_controller => 1, - callback => "$self_link_name->_process_sync_queue()" ); - $link_req{data3} = $self->group if $insteon_object->isa('Insteon::KeyPadLincRelay') or $insteon_object->isa('Insteon::KeyPadLinc'); - push @{$$self{sync_queue}}, \%link_req; + if ($audit_mode) + { + &::print_log("[Insteon::BaseController] (AUDIT) - adding controller record to " + . $insteon_object->get_object_name . " for " + . $self->interface->get_object_name . " with group:" . $self->group); + } + else + { + my %link_req = ( member => $insteon_object, cmd => 'add', object => $self->interface, + group => $self->group, is_controller => 1, + callback => "$self_link_name->_process_sync_queue()" ); + $link_req{data3} = $self->group if $insteon_object->isa('Insteon::KeyPadLincRelay') or $insteon_object->isa('Insteon::KeyPadLinc'); + push @{$$self{sync_queue}}, \%link_req; + } } if (!($self->interface->has_link($insteon_object,$self->group,0,$subaddress))) { - my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, - group => $self->group, is_controller => 0, - callback => "$self_link_name->_process_sync_queue()" ); - push @{$$self{sync_queue}}, \%link_req; + if ($audit_mode) + { + &::print_log("[Insteon::BaseController] (AUDIT) - adding responder record to " + . $self->interface->get_object_name . " for " + . $insteon_object->get_object_name . " with group:" . $self->group); + } + else + { + my %link_req = ( member => $self->interface, cmd => 'add', object => $insteon_object, + group => $self->group, is_controller => 0, + callback => "$self_link_name->_process_sync_queue()" ); + push @{$$self{sync_queue}}, \%link_req; + } } } my $num_sync_queue = @{$$self{sync_queue}}; From d8918374b854ffb28a8c1b2701c4333cc136d75e Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 20:17:25 +0000 Subject: [PATCH 114/150] Add support for sync links audit mode. --- lib/Insteon.pm | 139 ++++++++++++++++++++++++------------------------- 1 file changed, 69 insertions(+), 70 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 6b53cab12..6a735d394 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -9,6 +9,7 @@ use strict; my (@_insteon_plm,@_insteon_device,@_insteon_link,@_scannable_link,$_scan_cnt,$_sync_cnt,$_sync_failure_cnt); my $init_complete; my (@_scan_devices,@_scan_device_failures,$current_scan_device); +my (@_sync_devices,@_sync_device_failures,$current_sync_device); sub scan_all_linktables { @@ -17,7 +18,6 @@ sub scan_all_linktables &main::print_log("[Scan all linktables] WARN: link already underway. Ignoring request for new scan ..."); return; } - print "######### GOT HERE #############\n"; my @candidate_devices = (); # clear @_scan_devices @_scan_devices = (); @@ -99,78 +99,76 @@ sub _get_next_linkscan } -sub _process_sync_links +sub sync_all_links { - my ($current_name, $prior_failure) = @_; - if ($prior_failure) { - $_sync_failure_cnt++; - } else { - $_sync_failure_cnt = 0; - } - my @devices = (); - push @devices,@_insteon_link; - my $dev_cnt = @devices; - my $return_next = ($current_name) ? 0 : 1; - my $next_name = undef; - - if ($current_name) { - for (my $i=0; $i<$dev_cnt; $i++) { - if ($devices[$i] eq $current_name) { - if ($_sync_failure_cnt ==0) { - # get the next - $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - $_sync_cnt = $i + 2; - # remove the queue_timer_callback - my $current_obj = &main::get_object_by_name($current_name); - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); - } - # don't try to scan devices that are not responders - my $next_obj = &main::get_object_by_name($next_name); - if (ref $next_obj and $next_obj->isa('Insteon::BaseDevice') - and !($next_obj->is_responder) and !($next_obj->isa('Insteon::InterfaceController'))) { - &main::print_log("[Sync all links] $next_name is not a candidate for syncing. Moving to next"); - $current_name = $next_name; - # move on - next; - } - } elsif ($_sync_cnt == 1) { - #try again - $next_name = $current_name; - &main::print_log("[Sync all links] WARN: failure occurred when syncing $current_name. Trying again..."); - $_sync_cnt = $i + 1; - } else { - # skip because this is a repeat failure - $next_name = $devices[$i+1] if $i+1 < $dev_cnt; - &main::print_log("[Sync all links] WARN: failure occurred when syncing $current_name. Moving on..."); - $_sync_failure_cnt = 0; # reset failure counter - $_sync_cnt = $i + 2; - # remove the queue_timer_callback - my $current_obj = &main::get_object_by_name($current_name); - if (!($current_obj->isa('Insteon_PLM'))) { -# $current_obj->queue_timer_callback(''); + my ($audit_mode) = @_; + &main::print_log("[Sync all links] Starting now!"); + @_sync_devices = (); + # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links + for my $obj (&Insteon::find_members('Insteon::BaseController')) + { + my %sync_req = ('sync_object' => $obj, 'audit_mode' => ($audit_mode) ? 1 : 0); + &main::print_log("[Sync all links] Adding " . $obj->get_object_name . " to sync queue"); + push @_sync_devices, \%sync_req; + } + + $_sync_cnt = scalar @_sync_devices; + + &_get_next_linksync(); +} + +sub _get_next_linksync +{ + $current_scan_device = shift @_scan_devices; + my $sync_req_ptr = shift(@_sync_devices); + my %sync_req = ($sync_req_ptr) ? %$sync_req_ptr : undef; + if (%sync_req) + { + + $current_sync_device = $sync_req{'sync_object'}; + } + else + { + $current_sync_device = undef; + } + + if ($current_sync_device) + { + &main::print_log("[Sync all links] Now syncing: " + . $current_sync_device->get_object_name . " (" + . ($_sync_cnt - scalar @_sync_devices) + . " of $_sync_cnt)"); + # pass first the success callback followed by the failure callback + $current_sync_device->sync_links($sync_req{'audit_mode'}, '&Insteon::_get_next_linksync()','&Insteon::_get_next_linksync_failure()'); + } + else + { + &main::print_log("[Sync all links] All links have completed syncing"); + my $_sync_failure_cnt = scalar @_sync_device_failures; + if ($_sync_failure_cnt) + { + &main::print_log("[Sync all links] However, some failures were noted:"); + for my $failed_obj (@_sync_device_failures) + { + &main::print_log("[Sync all links] WARN: failure occurred when syncing " + . $failed_obj->get_object_name); + } } - } - } - } - } elsif ($dev_cnt) { - $next_name = $devices[0]; - $_sync_cnt = 1; - } - if ($next_name) { - my $obj = &main::get_object_by_name($next_name); - if ($obj) { - &main::print_log("[Sync all links] Now syncing links: " . $obj->get_object_name . " ($_sync_cnt of $dev_cnt)"); -# $obj->queue_timer_callback('&main::_process_sync_links(\'' . $next_name . '\',1)') unless $obj->isa('Insteon_PLM'); - $obj->sync_links('&Insteon::_process_sync_links(\'' . $next_name . '\')'); - } - } else { - $_sync_cnt = 0; - return undef; - } + } + +} + +sub _get_next_linksync_failure +{ + push @_sync_device_failures, $current_sync_device; + &main::print_log("[Sync all links] WARN: failure occurred when scanning " + . $current_sync_device->get_object_name . ". Moving on..."); + &_get_next_linksync(); + } + sub init { # only run once @@ -253,7 +251,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; } - $object_string .= "$object_name_v -> tie_event('$object_name->sync_links()','sync links');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->sync_links(0)','sync links');\n\n"; $object_string .= "$object_name_v -> tie_items($object_name, 'on');\n\n"; $object_string .= "$object_name_v -> tie_items($object_name, 'off');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_link_commands'); @@ -281,7 +279,7 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,delete orphan links,AUDIT - delete orphan links,scan all device link tables"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,delete orphan links,AUDIT - delete orphan links,scan all device link tables,AUDIT - sync all links"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -291,6 +289,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all device link tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::sync_all_links(1)','AUDIT - sync all links');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; } From daa83de1f08bfd6f1cd3b08a49cd2380160d1aa5 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 21:36:02 +0000 Subject: [PATCH 115/150] Add support to filter out deaf devices during queueing of sync all links. --- lib/Insteon.pm | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 6a735d394..847585bbe 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -107,9 +107,22 @@ sub sync_all_links # iterate over all registered objects and compare whether the link tables match defined scene linkages in known Insteon_Links for my $obj (&Insteon::find_members('Insteon::BaseController')) { - my %sync_req = ('sync_object' => $obj, 'audit_mode' => ($audit_mode) ? 1 : 0); - &main::print_log("[Sync all links] Adding " . $obj->get_object_name . " to sync queue"); - push @_sync_devices, \%sync_req; + if ($obj->isa('Insteon::RemoteLinc') or $obj->isa('Insteon::MotionSensor')) + { + &main::print_log("[Sync all links] Ignoring links from 'deaf' device: " . $obj->get_object_name); + } + elsif(!($obj->isa('Insteon::InterfaceController')) && ($obj->_aldb->health eq 'unknown')) + { + &main::print_log("[Sync all links] Skipping links from 'unreachable' device: " + . $obj->get_object_name . ". Consider rescanning the link table of this device"); + } + else + { + my %sync_req = ('sync_object' => $obj, 'audit_mode' => ($audit_mode) ? 1 : 0); + &main::print_log("[Sync all links] Adding " . $obj->get_object_name + . " to sync queue"); + push @_sync_devices, \%sync_req + }; } $_sync_cnt = scalar @_sync_devices; From 1e2d5324840f43f1bfe6afef2c5d19096d6be186 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 21:36:29 +0000 Subject: [PATCH 116/150] Support failure callback handling. --- lib/Insteon/AllLinkDatabase.pm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index be3ca8ddc..452048058 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -617,8 +617,9 @@ sub delete_link } else { %link_parms = &main::parse_func_parms($parms_text); } + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; if ($link_parms{address}) { - $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $$self{_mem_activity} = 'delete'; $$self{pending_aldb}{address} = $link_parms{address}; $self->_peek($link_parms{address},0); @@ -641,7 +642,6 @@ sub delete_link &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$address] with the following data" . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); # now, alter the flags byte such that the in_use flag is set to 0 - $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $$self{_mem_activity} = 'delete'; $$self{pending_aldb}{deviceid} = lc $deviceid; $$self{pending_aldb}{group} = $groupid; @@ -1148,6 +1148,7 @@ sub add_link my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; $$self{_mem_activity} = 'add'; $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails } @@ -1193,6 +1194,7 @@ sub update_link my $address = $$self{aldb}{$key}{address}; $$self{_mem_activity} = 'update'; $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; $self->_write_link($address, $deviceid, $group, $is_controller, $data1, $data2, $data3); } From 3c369b32af90b8bda69963faca114489a999d13f Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 22:50:15 +0000 Subject: [PATCH 117/150] Incorporate callback to memory functions so that failures will allow continuation. --- lib/Insteon/AllLinkDatabase.pm | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 452048058..b2f3f2ade 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -1137,6 +1137,8 @@ sub add_link $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default # get the first available memory location my $address = pop @{$$self{aldb}{empty}}; + $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; + $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; if ($address) { &::print_log("[Insteon::ALDB_i1] DEBUG2: adding link record " . $$self{device}->get_object_name @@ -1147,8 +1149,6 @@ sub add_link my $data2 = ($$self{device}->isa('Insteon::DimmableLight')) ? &Insteon::DimmableLight::convert_ramp($ramp_rate) : '00'; my $data3 = ($link_parms{data3}) ? $link_parms{data3} : '00'; $$self{_mem_activity} = 'add'; - $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; - $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; $self->_write_link($address, $device_id, $group, $is_controller, $data1, $data2, $data3); # TO-DO: ensure that pop'd address is restored back to queue if the transaction fails } @@ -1159,6 +1159,16 @@ sub add_link . " does not have a record of the first empty ALDB record." . " Please rescan this device's link table") if $main::Debug{insteon}; + + if ($$self{_success_callback}) + { + package main; + eval ($$self{_success_callback}); + &::print_log("[Insteon::ALDB_i1] WARN1: Error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon} >= 1; + package Insteon::AllLinkDatabase; + } + } } } @@ -1406,6 +1416,14 @@ sub _write_link &::print_log("[Insteon::ALDB_i1] WARN: " . $$self{device}->get_object_name . " write_link failure: no address available for record to device: $deviceid and group: $group" . " and is_controller: $is_controller");; + if ($$self{_success_callback}) + { + package main; + eval ($$self{_success_callback}); + &::print_log("[Insteon::ALDB_i1] WARN1: Error encountered during ack callback: " . $@) + if $@ and $main::Debug{insteon} >= 1; + package Insteon::AllLinkDatabase; + } } } @@ -1897,7 +1915,6 @@ sub add_link . $data1 . $data2 . $data3; - $$self{_success_callback} = $link_parms{callback} if $link_parms{callback}; $$self{aldb}{$linkkey}{flags} = lc $flags; $$self{aldb}{$linkkey}{group} = lc $group; $$self{aldb}{$linkkey}{is_controller} = $is_controller; @@ -1907,6 +1924,12 @@ sub add_link $$self{aldb}{$linkkey}{data3} = lc $data3; my $message = new Insteon::InsteonMessage('all_link_manage_rec', $$self{device}); $message->interface_data($cmd); + if ($link_parms{callback}) + { + $$self{_success_callback} = $link_parms{callback}; + $message->callback($link_parms{callback}); + } + $message->interface_data($cmd); $$self{device}->queue_message($message); } } From 73ae09e3241d995396f4615a39c9862de576b0ac Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 16 Feb 2012 22:51:42 +0000 Subject: [PATCH 118/150] Added sync all links (non-audit). --- lib/Insteon.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index 847585bbe..d882a0a97 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -292,7 +292,7 @@ sub generate_voice_commands $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_item_commands'); push @_insteon_device, $object_name if $group eq '01'; # don't allow non-base items to participate } elsif ($object->isa('Insteon_PLM')) { - my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,delete orphan links,AUDIT - delete orphan links,scan all device link tables,AUDIT - sync all links"; + my $cmd_states = "complete linking as responder,cancel linking,delete link with PLM,scan link table,show link table to log,delete orphan links,AUDIT - delete orphan links,scan all device link tables,sync all links,AUDIT - sync all links"; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; $object_string .= "$object_name_v -> tie_event('$object_name->complete_linking_as_responder','complete linking as responder');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->initiate_unlinking_as_controller','initiate unlinking');\n\n"; @@ -302,6 +302,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links','delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->delete_orphan_links(1)','AUDIT - delete orphan links');\n\n"; $object_string .= "$object_name_v -> tie_event('&Insteon::scan_all_linktables','scan all device link tables');\n\n"; + $object_string .= "$object_name_v -> tie_event('&Insteon::sync_all_links(0)','sync all links');\n\n"; $object_string .= "$object_name_v -> tie_event('&Insteon::sync_all_links(1)','AUDIT - sync all links');\n\n"; $object_string .= &main::store_object_data($object_name_v, 'Voice_Cmd', 'Insteon', 'Insteon_PLM_commands'); push @_insteon_plm, $object_name; From e2183a5129266fb66a4ad81139d0534dbd0fecc3 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 1 Mar 2012 00:10:56 +0000 Subject: [PATCH 119/150] Properly queue up each individual candidate device's delete_orphan_link method rather than run them all concurrently. --- lib/Insteon/AllLinkDatabase.pm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index b2f3f2ade..bf2190cc0 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -1071,10 +1071,10 @@ sub _process_delete_queue { $self->delete_link(%delete_req); $$self{delete_queue_processed}++; } -# else -# { -# $$self{device}->interface->_aldb->_process_delete_queue($$self{delete_queue_processed}); -# } + else + { + $$self{device}->interface->_aldb->_process_delete_queue($$self{delete_queue_processed}); + } } sub add_link @@ -1757,8 +1757,7 @@ sub delete_orphan_links #Match on real objects only if (($obj->is_root)) { - $num_deleted += $obj->delete_orphan_links($audit_mode); - my %delete_req = ('root_object' => $obj, callback => "$selfname->_aldb->_process_delete_queue()"); + my %delete_req = ('root_object' => $obj, 'audit_mode' => $audit_mode); push @{$$self{delete_queue}}, \%delete_req; } } @@ -1774,8 +1773,9 @@ sub _process_delete_queue { my $delete_req_ptr = shift(@{$$self{delete_queue}}); my %delete_req = %$delete_req_ptr; # distinguish between deleting PLM links and processing delete orphans for a root item - if ($delete_req{'root_object'}) { - $delete_req{'root_object'}->delete_orphan_links(); + if ($delete_req{'root_object'}) + { + $delete_req{'root_object'}->delete_orphan_links($del_req{'audit_mode'}); } else { From 3b60d4a1a0e9e4b548b577bf5ff1176425498a12 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 1 Mar 2012 00:11:36 +0000 Subject: [PATCH 120/150] Minor cleanup. --- lib/Insteon/Lighting.pm | 8 -------- 1 file changed, 8 deletions(-) diff --git a/lib/Insteon/Lighting.pm b/lib/Insteon/Lighting.pm index 6dbd15f74..931530349 100755 --- a/lib/Insteon/Lighting.pm +++ b/lib/Insteon/Lighting.pm @@ -5,10 +5,6 @@ use Insteon::BaseInsteon; @Insteon::BaseLight::ISA = ('Insteon::BaseDevice'); -#my %message_types = ( -# %SUPER::message_types -#); - sub new { my ($class,$p_deviceid,$p_interface) = @_; @@ -167,10 +163,6 @@ use Insteon::BaseInsteon; @Insteon::ApplianceLinc::ISA = ('Insteon::BaseLight'); -#my %message_types = ( -# %SUPER::message_types -#); - sub new { my ($class,$p_deviceid,$p_interface) = @_; From a95401cf8b8e4de5217ab741c0f92d8cbf3279b9 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 1 Mar 2012 00:13:08 +0000 Subject: [PATCH 121/150] Fix typo. --- lib/Insteon/AllLinkDatabase.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index bf2190cc0..3fb146024 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -1775,7 +1775,7 @@ sub _process_delete_queue { # distinguish between deleting PLM links and processing delete orphans for a root item if ($delete_req{'root_object'}) { - $delete_req{'root_object'}->delete_orphan_links($del_req{'audit_mode'}); + $delete_req{'root_object'}->delete_orphan_links($delete_req{'audit_mode'}); } else { From a29a1ba145b9f4784e0219088899a552e07e1d05 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 1 Mar 2012 00:13:59 +0000 Subject: [PATCH 122/150] Guard against duplicate messages when parsing. --- lib/Insteon_PLM.pm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index adda9bfa6..f5cd50a67 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -360,15 +360,19 @@ sub _parse_data { my $process_next_command = 1; my $nack_count = 0; my $entered_ack_loop; + my $previous_parsed_data; if (defined $prev_cmd and $prev_cmd ne '') { my $ackcmd = $prev_cmd . '06'; my $nackcmd = $prev_cmd . '15'; my $badcmd = $prev_cmd . '0f'; + $previous_parsed_data = ''; foreach my $parsed_data (split(/($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($badcmd)/,$data)) { #ignore blanks.. the split does odd things next if $parsed_data eq ''; + next if $previous_parsed_data eq $parsed_data; # guard against repeats + $previous_parsed_data = $parsed_data; # and, now reinitialize $entered_ack_loop = 1; if ($parsed_data =~ /^($ackcmd)|($nackcmd)|($prefix{plm_info}\w{12}06)|($prefix{plm_info}\w{12}15)|($prefix{all_link_first_rec}15)|($prefix{all_link_next_rec}15)|($badcmd)$/) { @@ -538,10 +542,14 @@ sub _parse_data { my $entered_rcv_loop = 0; + $previous_parsed_data = ''; + foreach my $parsed_data (split(/($prefix{x10_received}\w{4})|($prefix{insteon_received}\w{18})|($prefix{insteon_ext_received}\w{46})|($prefix{all_link_complete}\w{16})|($prefix{all_link_clean_failed}\w{8})|($prefix{all_link_record}\w{16})|($prefix{all_link_clean_status}\w{2})|($prefix{plm_button_event}\w{2})/,$residue_data)) { #ignore blanks.. the split does odd things next if $parsed_data eq ''; + next if $previous_parsed_data eq $parsed_data; # guard against repeats + $previous_parsed_data = $parsed_data; # and, now reinitialize $entered_rcv_loop = 1; From 67f7e13acb4b1f37a17be48b08ca001b2c6e337e Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 1 Mar 2012 00:27:30 +0000 Subject: [PATCH 123/150] Don't warn about skipping unhealthy device if it is "deaf" anyway. --- lib/Insteon/AllLinkDatabase.pm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 3fb146024..cfba0ebaa 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -672,10 +672,17 @@ sub delete_orphan_links # first, make sure that the health of ALDB is ok if ($self->health ne 'good') { - &::print_log("[Insteon::ALDB_i1] Delete orphan links: skipping $selfname because health: " - . $self->health . ". Please rescan this device!!") - if ($self->health ne 'empty'); + if ($$self{device}->isa('Insteon::RemoteLinc') or $$self{device}->isa('Insteon::MotionSensor')) + { + &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from deaf device: $selfname"); + } + else + { + &::print_log("[Insteon::ALDB_i1] Delete orphan links: skipping $selfname because health: " + . $self->health . ". Please rescan this device!!") + if ($self->health ne 'empty'); + } return $num_deleted; # no links deleted } From bf1a1b74661f0eba4291dd6a552cdf3933a2b488 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 2 Mar 2012 23:30:25 +0000 Subject: [PATCH 124/150] Exit properly for deaf devices. --- lib/Insteon/AllLinkDatabase.pm | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index cfba0ebaa..f95816679 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -666,6 +666,7 @@ sub delete_orphan_links { my ($self, $audit_mode) = @_; @{$$self{delete_queue}} = (); # reset the work queue + $$self{delete_queue_processed} = 0; my $selfname = $$self{device}->get_object_name; my $num_deleted = 0; @@ -683,7 +684,8 @@ sub delete_orphan_links . $self->health . ". Please rescan this device!!") if ($self->health ne 'empty'); } - return $num_deleted; # no links deleted + $self->_process_delete_queue(); + return; } for my $linkkey (keys %{$$self{aldb}}) @@ -827,7 +829,7 @@ sub delete_orphan_links { if ($linked_device->isa('Insteon::RemoteLinc') or $linked_device->isa('Insteon::MotionSensor')) { - &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from 'deaf' device: " . $linked_device->get_object_name); + &::print_log("[Insteon::ALDB_i1] Delete orphan links: ignoring link from $selfname to 'deaf' device: " . $linked_device->get_object_name); } # make sure that the health of the device's ALDB is ok elsif ($linked_device->_aldb->health ne 'good') @@ -1051,9 +1053,8 @@ sub delete_orphan_links } } } - $$self{delete_queue_processed} = 0; $self->_process_delete_queue(); - return $num_deleted; +# return $num_deleted; } sub _process_delete_queue { @@ -1080,6 +1081,8 @@ sub _process_delete_queue { } else { + &::print_log("[Insteon::ALDB_i1] Nothing else to do for " . $$self{device}->get_object_name . " after deleting " + . $$self{delete_queue_processed} . " links") if $main::Debug{insteon}; $$self{device}->interface->_aldb->_process_delete_queue($$self{delete_queue_processed}); } } @@ -1625,6 +1628,9 @@ sub get_next_alllink sub delete_orphan_links { my ($self, $audit_mode) = @_; + + &::print_log("[Insteon::ALDB_PLM] #### NOW BEGINNING DELETE ORPHAN LINKS ####"); + @{$$self{delete_queue}} = (); # reset the work queue my $selfname = $$self{device}->get_object_name; my $num_deleted = 0; @@ -1768,6 +1774,7 @@ sub delete_orphan_links push @{$$self{delete_queue}}, \%delete_req; } } + $self->_process_delete_queue(); } @@ -1804,6 +1811,7 @@ sub _process_delete_queue { else { &::print_log("[Insteon::ALDB_PLM] A total of $$self{delete_queue_processed} orphaned link records were deleted."); + &::print_log("[Insteon::ALDB_PLM] #### END DELETE ORPHAN LINKS ####"); } } From d2bd34e48a0c6167d4819e093e1ea1751ea159a1 Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 5 Mar 2012 20:41:47 +0000 Subject: [PATCH 125/150] Keep duplicate addresses array from being clobbered during delete_orphan_links. Pass the "data3" record always when creating a delete request (needed for KPL lookups). Various logging improvements. --- lib/Insteon/AllLinkDatabase.pm | 69 ++++++++++++++++++++++------------ 1 file changed, 45 insertions(+), 24 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index f95816679..04aa6026a 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -711,8 +711,12 @@ sub delete_orphan_links } else { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", cause => "no device could be found"); + my %delete_req = (deviceid => $deviceid, + group => $group, + is_controller => $is_controller, + callback => "$selfname->_aldb->_process_delete_queue()", + data3 => $data3, + cause => "no device could be found"); push @{$$self{delete_queue}}, \%delete_req; } } @@ -738,9 +742,13 @@ sub delete_orphan_links } else { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", object => $linked_device, data3 => $data3, - cause => 'PLM does not have a link pointing back to device'); + my %delete_req = (deviceid => $deviceid, + group => $group, + is_controller => $is_controller, + callback => "$selfname->_aldb->_process_delete_queue()", + object => $linked_device, + data3 => $data3, + cause => 'PLM does not have a link pointing back to device'); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } @@ -928,9 +936,13 @@ sub delete_orphan_links . $linked_device->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ")" . " because no reciprocal link exists!" ); - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $linked_device, - cause => "no link to the device could be found", data3 => $data3); + my %delete_req = (deviceid => $deviceid, + group => $group, + is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", + object => $linked_device, + cause => "no link to the device could be found", + data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } @@ -950,15 +962,19 @@ sub delete_orphan_links } else { - &::print_log("[Insteon::ALDB_i1] (AUDIT) Deleting link defined for: " + &::print_log("[Insteon::ALDB_i1] Deleting link defined for: " . $$self{device}->get_object_name . "(" . (($data3 eq '00') ? '01' : $data3) . ") as responder and " . $linked_device->get_object_name . "($group)" . " because no reverse links exists!" ); - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_process_delete_queue()", object => $linked_device, - cause => "no link to the device could be found", data3 => $data3); + my %delete_req = (deviceid => $deviceid, + group => $group, + is_controller => $is_controller, + callback => "$selfname->_process_delete_queue()", + object => $linked_device, + cause => "no link to the device could be found", + data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } @@ -1019,9 +1035,13 @@ sub delete_orphan_links } else { - my %delete_req = (deviceid => $deviceid, group => $group, is_controller => $is_controller, - callback => "$selfname->_aldb->_process_delete_queue()", object => $linked_device, - cause => "no reverse link could be found", data3 => $data3); + my %delete_req = (deviceid => $deviceid, + group => $group, + is_controller => $is_controller, + callback => "$selfname->_aldb->_process_delete_queue()", + object => $linked_device, + cause => "no reverse link could be found", + data3 => $data3); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } @@ -1032,29 +1052,30 @@ sub delete_orphan_links } elsif ($linkkey eq 'duplicates') { - my $address = pop @{$$self{aldb}{duplicates}}; + my @duplicate_addresses = (); + push @duplicate_addresses, @{$$self{aldb}{duplicates}}; + my $address = pop @duplicate_addresses; while ($address) { if ($audit_mode) { &::print_log("[Insteon::ALDB_i1] (AUDIT) Delete orphan because duplicate found " - . $$self{device}->get_object_name - . " address=$address"); + . "$selfname, address=$address"); } else { my %delete_req = (address => $address, - callback => "$selfname->_aldb->_process_delete_queue()", - cause => "duplicate record found"); + callback => "$selfname->_aldb->_process_delete_queue()", + cause => "duplicate record found"); push @{$$self{delete_queue}}, \%delete_req; $num_deleted++; } - $address = pop @{$$self{aldb}{duplicates}}; + $address = pop @duplicate_addresses; } } } $self->_process_delete_queue(); -# return $num_deleted; + &::print_log("[Insteon::ALDB_i1] ## Begin processing delete queue for: $selfname"); } sub _process_delete_queue { @@ -1066,12 +1087,12 @@ sub _process_delete_queue { my %delete_req = %$delete_req_ptr; if ($delete_req{address}) { - &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " now deleting duplicate record at address " + &::print_log("[Insteon::ALDB_i1] (#$num_in_queue) " . $$self{device}->get_object_name . " now deleting duplicate record at address " . $delete_req{address}); } else { - &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " + &::print_log("[Insteon::ALDB_i1] (#$num_in_queue) " . $$self{device}->get_object_name . " now deleting orphaned link w/ details: " . (($delete_req{is_controller}) ? "controller" : "responder") . ", " . (($delete_req{object}) ? "device=" . $delete_req{object}->get_object_name : "deviceid=$delete_req{deviceid}") . ", group=$delete_req{group}, cause=$delete_req{cause}"); From ba1fc5ed40ac55ec2bce31b9b83026aed1a78291 Mon Sep 17 00:00:00 2001 From: gliming Date: Tue, 6 Mar 2012 22:05:25 +0000 Subject: [PATCH 126/150] Don't clobber the callback after processing the pending one. Ensure that it is cleared in advance. --- lib/Insteon/AllLinkDatabase.pm | 342 +++++++++++++++++++++------------ 1 file changed, 219 insertions(+), 123 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 04aa6026a..3b931f7b3 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -177,69 +177,82 @@ sub _on_poke { my ($self,%msg) = @_; my $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'peek'); - if (($$self{_mem_activity} eq 'update') or ($$self{_mem_activity} eq 'add')) { - if ($$self{_mem_action} eq 'aldb_flag') { + if (($$self{_mem_activity} eq 'update') or ($$self{_mem_activity} eq 'add')) + { + if ($$self{_mem_action} eq 'aldb_flag') + { $$self{_mem_action} = 'aldb_group'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_group') { + } + elsif ($$self{_mem_action} eq 'aldb_group') + { $$self{_mem_action} = 'aldb_devhi'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_devhi') { + } + elsif ($$self{_mem_action} eq 'aldb_devhi') + { $$self{_mem_action} = 'aldb_devmid'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_devmid') { + } + elsif ($$self{_mem_action} eq 'aldb_devmid') + { $$self{_mem_action} = 'aldb_devlo'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_devlo') { + } + elsif ($$self{_mem_action} eq 'aldb_devlo') + { $$self{_mem_action} = 'aldb_data1'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_data1') { + } + elsif ($$self{_mem_action} eq 'aldb_data1') + { $$self{_mem_action} = 'aldb_data2'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_data2') { + } + elsif ($$self{_mem_action} eq 'aldb_data2') + { $$self{_mem_action} = 'aldb_data3'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_data3') { + } + elsif ($$self{_mem_action} eq 'aldb_data3') + { ## update the aldb records w/ the changes that were made - my $aldbkey = $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; + my $aldbkey = $$self{pending_aldb}{deviceid} + . $$self{pending_aldb}{group} + . $$self{pending_aldb}{is_controller}; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists my $subaddress = $$self{pending_aldb}{data3}; - if (($subaddress ne '00') and ($subaddress ne '01')) { + if (($subaddress ne '00') and ($subaddress ne '01')) + { $aldbkey .= $subaddress; } $$self{aldb}{$aldbkey}{data1} = $$self{pending_aldb}{data1}; $$self{aldb}{$aldbkey}{data2} = $$self{pending_aldb}{data2}; $$self{aldb}{$aldbkey}{data3} = $$self{pending_aldb}{data3}; $$self{aldb}{$aldbkey}{inuse} = 1; # needed so that restore string will preserve record - if ($$self{_mem_activity} eq 'add') { + if ($$self{_mem_activity} eq 'add') + { $$self{aldb}{$aldbkey}{is_controller} = $$self{pending_aldb}{is_controller}; $$self{aldb}{$aldbkey}{deviceid} = lc $$self{pending_aldb}{deviceid}; $$self{aldb}{$aldbkey}{group} = lc $$self{pending_aldb}{group}; @@ -247,15 +260,20 @@ sub _on_poke # on completion, check to see if the empty links list is now empty; if so, # then decrement the current address and add it to the list my $num_empty = @{$$self{aldb}{empty}}; - if (!($num_empty)) { + if (!($num_empty)) + { my $low_address = 0; - for my $key (keys %{$$self{aldb}}) { + for my $key (keys %{$$self{aldb}}) + { next if $key eq 'empty' or $key eq 'duplicates'; my $new_address = hex($$self{aldb}{$key}{address}); - if (!($low_address)) { + if (!($low_address)) + { $low_address = $new_address; next; - } else { + } + else + { $low_address = $new_address if $new_address < $low_address; } } @@ -265,7 +283,8 @@ sub _on_poke } # clear out mem_activity flag $$self{_mem_activity} = undef; - if (defined $$self{_success_callback}) { + if (defined $$self{_success_callback}) + { my $callback = $$self{_success_callback}; # clear it out *before* the eval $$self{_success_callback} = undef; @@ -276,44 +295,56 @@ sub _on_poke if $@ and $main::Debug{insteon}; } } - } elsif ($$self{_mem_activity} eq 'update_local') { - if ($$self{_mem_action} eq 'local_onlevel') { + } + elsif ($$self{_mem_activity} eq 'update_local') + { + if ($$self{_mem_action} eq 'local_onlevel') + { $$self{_mem_lsb} = '21'; $$self{_mem_action} = 'local_ramprate'; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'local_ramprate') { - if ($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) { + } + elsif ($$self{_mem_action} eq 'local_ramprate') + { + if ($$self{device}->isa('Insteon::KeyPadLincRelay') or $$self{device}->isa('Insteon::KeyPadLinc')) + { # update from eeprom--only a kpl issue $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); } } - } elsif ($$self{_mem_activity} eq 'update_flags') { + } + elsif ($$self{_mem_activity} eq 'update_flags') + { # update from eeprom--only a kpl issue $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'do_read_ee'); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'do_read_ee','is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'delete') { + } + elsif ($$self{_mem_activity} eq 'delete') + { # clear out mem_activity flag $$self{_mem_activity} = undef; # add the address of the deleted link to the empty list push @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; - if (exists $$self{pending_aldb}{deviceid}) { - my $key = lc $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; + if (exists $$self{pending_aldb}{deviceid}) + { + my $key = lc $$self{pending_aldb}{deviceid} + . $$self{pending_aldb}{group} + . $$self{pending_aldb}{is_controller}; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists my $subaddress = $$self{pending_aldb}{data3}; - if ($subaddress ne '00' and $subaddress ne '01') { + if ($subaddress ne '00' and $subaddress ne '01') + { $key .= $subaddress; } delete $$self{aldb}{$key}; } - if (defined $$self{_success_callback}) { + if (defined $$self{_success_callback}) + { my $callback = $$self{_success_callback}; # clear it out *before* the eval $$self{_success_callback} = undef; @@ -322,10 +353,8 @@ sub _on_poke &::print_log("[Insteon::ALDB_i1] error in link callback: " . $@) if $@ and $main::Debug{insteon}; package Insteon::ALDB_i1; - $$self{_success_callback} = undef; } } -# } sub _on_peek @@ -335,13 +364,18 @@ sub _on_peek if ($msg{is_extended}) { &::print_log("[Insteon::ALDB_i1]: extended peek for " . $$self{device}->{object_name} . " is " . $msg{extra}) if $main::Debug{insteon}; - } else { - if ($$self{_mem_action} eq 'aldb_peek') { - if ($$self{_mem_activity} eq 'scan') { + } + else + { + if ($$self{_mem_action} eq 'aldb_peek') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{_mem_action} = 'aldb_flag'; # if the device is responding to the peek, then init the link table # if at the very start of a scan - if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { + if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') + { # reinit the aldb hash as there will be a new one $$self{aldb} = undef; # reinit the empty address list @@ -349,34 +383,48 @@ sub _on_peek # and, also the duplicates list @{$$self{aldb}{duplicates}} = (); } - } elsif ($$self{_mem_activity} eq 'update') { + } + elsif ($$self{_mem_activity} eq 'update') + { $$self{_mem_action} = 'aldb_data1'; - } elsif ($$self{_mem_activity} eq 'update_local') { + } + elsif ($$self{_mem_activity} eq 'update_local') + { $$self{_mem_action} = 'local_onlevel'; - } elsif ($$self{_mem_activity} eq 'update_flags') { + } + elsif ($$self{_mem_activity} eq 'update_flags') + { $$self{_mem_action} = 'update_flags'; - } elsif ($$self{_mem_activity} eq 'delete') { + } + elsif ($$self{_mem_activity} eq 'delete') + { $$self{_mem_action} = 'aldb_flag'; - } elsif ($$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'add') + { $$self{_mem_action} = 'aldb_flag'; } $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'aldb_flag') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_flag') + { + if ($$self{_mem_activity} eq 'scan') + { my $flag = hex($msg{extra}); $$self{pending_aldb}{inuse} = ($flag & 0x80) ? 1 : 0; $$self{pending_aldb}{is_controller} = ($flag & 0x40) ? 1 : 0; $$self{pending_aldb}{highwater} = ($flag & 0x02) ? 1 : 0; - if (!($$self{pending_aldb}{highwater})) { + if (!($$self{pending_aldb}{highwater})) + { # since this is the last unused memory location, then add it to the empty list unshift @{$$self{aldb}{empty}}, $$self{_mem_msb} . $$self{_mem_lsb}; $$self{_mem_action} = undef; # clear out mem_activity flag $$self{_mem_activity} = undef; - if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') { + if (lc $$self{_mem_msb} eq '0f' and lc $$self{_mem_lsb} eq 'f8') + { # set health as empty for now $self->health("empty"); } @@ -387,19 +435,20 @@ sub _on_peek &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . " completed link memory scan") if $main::Debug{insteon}; - if (defined $$self{_success_callback}) { + if (defined $$self{_success_callback}) + { + my $callback = $$self{_success_callback}; + # clear it out *before* the eval + $$self{_success_callback} = undef; package main; - eval ($$self{_success_callback}); + eval ($callback); &::print_log("[Insteon::ALDB_i1] " . $$self{device}->get_object_name . ": error during scan callback $@") if $@ and $main::Debug{insteon}; package Insteon::ALDB_i1; - $$self{_success_callback} = undef; } - # ping the device as part of the scan if we don't already have a devcat - # if (!($self->{devcat})) { - # $self->ping(); - # } - } else { + } + else + { $$self{pending_aldb}{flag} = $msg{extra}; ## confirm that we have a high-water mark; otherwise stop $$self{pending_aldb}{address} = $$self{_mem_msb} . $$self{_mem_lsb}; @@ -408,148 +457,176 @@ sub _on_peek $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); } - } elsif ($$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'add') + { my $flag = ($$self{pending_aldb}{is_controller}) ? 'E2' : 'A2'; $$self{pending_aldb}{flag} = $flag; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($flag); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $flag, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'delete') { + } + elsif ($$self{_mem_activity} eq 'delete') + { $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra('02'); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => '02', 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_group') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_group') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{pending_aldb}{group} = lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devhi'; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, -# 'is_synchronous' => 1); - } else { + } + else + { $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{group}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{group}, -# 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_devhi') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_devhi') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{pending_aldb}{deviceid} = lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devmid'; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'add') + { my $devid = substr($$self{pending_aldb}{deviceid},0,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_devmid') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_devmid') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{pending_aldb}{deviceid} .= lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devlo'; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'add') + { my $devid = substr($$self{pending_aldb}{deviceid},2,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_devlo') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_devlo') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{pending_aldb}{deviceid} .= lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_data1'; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'add') + { my $devid = substr($$self{pending_aldb}{deviceid},4,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $devid, 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_data1') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_data1') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{_mem_action} = 'aldb_data2'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{pending_aldb}{data1} = $msg{extra}; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') + { # poke the new value $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{data1}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data1}, 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_data2') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_data2') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{pending_aldb}{data2} = $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_data3'; $message->extra($$self{_mem_lsb}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'peek', 'extra' => $$self{_mem_lsb}, 'is_synchronous' => 1); - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') + { # poke the new value $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{data2}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data2}, 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'aldb_data3') { - if ($$self{_mem_activity} eq 'scan') { + } + elsif ($$self{_mem_action} eq 'aldb_data3') + { + if ($$self{_mem_activity} eq 'scan') + { $$self{pending_aldb}{data3} = $msg{extra}; # check the previous record if highwater is set - if ($$self{pending_aldb}{highwater}) { - if ($$self{pending_aldb}{inuse}) { + if ($$self{pending_aldb}{highwater}) + { + if ($$self{pending_aldb}{inuse}) + { # save pending_aldb and then clear it out my $aldbkey = lc $$self{pending_aldb}{deviceid} . $$self{pending_aldb}{group} . $$self{pending_aldb}{is_controller}; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists my $subaddress = $$self{pending_aldb}{data3}; - if ($subaddress ne '00' and $subaddress ne '01') { + if ($subaddress ne '00' and $subaddress ne '01') + { $aldbkey .= $subaddress; } # check for duplicates - if (exists $$self{aldb}{$aldbkey} && $$self{aldb}{$aldbkey}{inuse}) { + if (exists $$self{aldb}{$aldbkey} && $$self{aldb}{$aldbkey}{inuse}) + { unshift @{$$self{aldb}{duplicates}}, $$self{pending_aldb}{address}; - } else { + } + else + { %{$$self{aldb}{$aldbkey}} = %{$$self{pending_aldb}}; } - } else { + } + else + { # TO-DO: record the locations of deleted aldb records for subsequent reuse unshift @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; } @@ -557,37 +634,41 @@ sub _on_peek $$self{pending_aldb} = undef; $self->_peek($newaddress); } - } elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') { + } + elsif ($$self{_mem_activity} eq 'update' or $$self{_mem_activity} eq 'add') + { # poke the new value $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{data3}); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $$self{pending_aldb}{data3}, 'is_synchronous' => 1); } - } elsif ($$self{_mem_action} eq 'local_onlevel') { + } + elsif ($$self{_mem_action} eq 'local_onlevel') + { my $on_level = $self->local_onlevel; $on_level = &Insteon::DimmableLight::convert_level($on_level); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($on_level); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $on_level, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'local_ramprate') { + } + elsif ($$self{_mem_action} eq 'local_ramprate') + { my $ramp_rate = $$self{_ramprate}; $ramp_rate = '1f' unless $ramp_rate; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($ramp_rate); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $ramp_rate, 'is_synchronous' => 1); - } elsif ($$self{_mem_action} eq 'update_flags') { + } + elsif ($$self{_mem_action} eq 'update_flags') + { my $flags = $$self{_operating_flags}; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($flags); $message->failure_callback($$self{_failure_callback}); $self->_send_cmd($message); -# $self->_send_cmd('command' => 'poke', 'extra' => $flags, 'is_synchronous' => 1); } # # &::print_log("AllLinkDataBase: peek for " . $self->{object_name} @@ -611,20 +692,27 @@ sub delete_link { my ($self, $parms_text) = @_; my %link_parms; - if (@_ > 2) { + if (@_ > 2) + { shift @_; %link_parms = @_; - } else { + } + else + { %link_parms = &main::parse_func_parms($parms_text); } $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; - if ($link_parms{address}) { + if ($link_parms{address}) + { + &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$link_parms{address}]"); $$self{_mem_activity} = 'delete'; $$self{pending_aldb}{address} = $link_parms{address}; $self->_peek($link_parms{address},0); - } else { + } + else + { my $insteon_object = $link_parms{object}; my $deviceid = ($insteon_object) ? $insteon_object->device_id : $link_parms{deviceid}; my $groupid = $link_parms{group}; @@ -634,11 +722,13 @@ sub delete_link # get the address via lookup into the hash my $key = lc $deviceid . $groupid . $is_controller; # append the device "sub-address" (e.g., a non-root button on a keypadlinc) if it exists - if ($subaddress ne '00' and $subaddress ne '01') { + if ($subaddress ne '00' and $subaddress ne '01') + { $key .= $subaddress; } my $address = $$self{aldb}{$key}{address}; - if ($address) { + if ($address) + { &main::print_log("[Insteon::ALDB_i1] Now deleting link [0x$address] with the following data" . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); # now, alter the flags byte such that the in_use flag is set to 0 @@ -648,10 +738,13 @@ sub delete_link $$self{pending_aldb}{is_controller} = $is_controller; $$self{pending_aldb}{address} = $address; $self->_peek($address,0); - } else { + } + else + { &main::print_log('[Insteon::ALDB_i1] WARN: (' . $$self{device}->get_object_name . ') attempt to delete link that does not exist!' . " deviceid=$deviceid, groupid=$groupid, is_controller=$is_controller"); - if ($link_parms{callback}) { + if ($link_parms{callback}) + { package main; eval($link_parms{callback}); &::print_log("[Insteon::ALDB_i1] error encountered during delete_link callback: " . $@) @@ -1074,8 +1167,11 @@ sub delete_orphan_links } } } + if (!($audit_mode)) + { + &::print_log("[Insteon::ALDB_i1] ## Begin processing delete queue for: $selfname"); + } $self->_process_delete_queue(); - &::print_log("[Insteon::ALDB_i1] ## Begin processing delete queue for: $selfname"); } sub _process_delete_queue { From 60095814f83e751a000b99689f4a1fa89a406645 Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 8 Mar 2012 22:47:37 +0000 Subject: [PATCH 127/150] Fix keeping duplicate_link_addresses state on delete operations. Fix available next empty address on "add" operations. Add extra debug statements for scan logging. --- lib/Insteon/AllLinkDatabase.pm | 177 +++++++++++++++++++++++++-------- 1 file changed, 136 insertions(+), 41 deletions(-) diff --git a/lib/Insteon/AllLinkDatabase.pm b/lib/Insteon/AllLinkDatabase.pm index 3b931f7b3..63d436edc 100755 --- a/lib/Insteon/AllLinkDatabase.pm +++ b/lib/Insteon/AllLinkDatabase.pm @@ -257,29 +257,6 @@ sub _on_poke $$self{aldb}{$aldbkey}{deviceid} = lc $$self{pending_aldb}{deviceid}; $$self{aldb}{$aldbkey}{group} = lc $$self{pending_aldb}{group}; $$self{aldb}{$aldbkey}{address} = $$self{pending_aldb}{address}; - # on completion, check to see if the empty links list is now empty; if so, - # then decrement the current address and add it to the list - my $num_empty = @{$$self{aldb}{empty}}; - if (!($num_empty)) - { - my $low_address = 0; - for my $key (keys %{$$self{aldb}}) - { - next if $key eq 'empty' or $key eq 'duplicates'; - my $new_address = hex($$self{aldb}{$key}{address}); - if (!($low_address)) - { - $low_address = $new_address; - next; - } - else - { - $low_address = $new_address if $new_address < $low_address; - } - } - $low_address = sprintf('%04X', $low_address - 8); - unshift @{$$self{aldb}{empty}}, $low_address; - } } # clear out mem_activity flag $$self{_mem_activity} = undef; @@ -328,7 +305,9 @@ sub _on_poke # clear out mem_activity flag $$self{_mem_activity} = undef; # add the address of the deleted link to the empty list - push @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; + $self->add_empty_address($$self{pending_aldb}{address}); + # and, remove from the duplicates list (if it is a member) + $self->delete_duplicate_link_address($$self{pending_aldb}{address}); if (exists $$self{pending_aldb}{deviceid}) { my $key = lc $$self{pending_aldb}{deviceid} @@ -412,6 +391,9 @@ sub _on_peek { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; my $flag = hex($msg{extra}); $$self{pending_aldb}{inuse} = ($flag & 0x80) ? 1 : 0; $$self{pending_aldb}{is_controller} = ($flag & 0x40) ? 1 : 0; @@ -419,7 +401,7 @@ sub _on_peek if (!($$self{pending_aldb}{highwater})) { # since this is the last unused memory location, then add it to the empty list - unshift @{$$self{aldb}{empty}}, $$self{_mem_msb} . $$self{_mem_lsb}; + $self->add_empty_address($$self{_mem_msb} . $$self{_mem_lsb}); $$self{_mem_action} = undef; # clear out mem_activity flag $$self{_mem_activity} = undef; @@ -461,6 +443,9 @@ sub _on_peek } elsif ($$self{_mem_activity} eq 'add') { + # TO-DO!!! Eventually add the ability to set the highwater mark + # the below flags never reset the highwater mark so that + # the scanner will continue scanning extra empty records my $flag = ($$self{pending_aldb}{is_controller}) ? 'E2' : 'A2'; $$self{pending_aldb}{flag} = $flag; $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); @@ -480,65 +465,71 @@ sub _on_peek { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{pending_aldb}{group} = lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devhi'; $message->extra($$self{_mem_lsb}); - $message->failure_callback($$self{_failure_callback}); - $self->_send_cmd($message); } else { $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($$self{pending_aldb}{group}); - $message->failure_callback($$self{_failure_callback}); - $self->_send_cmd($message); } + $message->failure_callback($$self{_failure_callback}); + $self->_send_cmd($message); } elsif ($$self{_mem_action} eq 'aldb_devhi') { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{pending_aldb}{deviceid} = lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devmid'; $message->extra($$self{_mem_lsb}); - $message->failure_callback($$self{_failure_callback}); - $self->_send_cmd($message); } elsif ($$self{_mem_activity} eq 'add') { my $devid = substr($$self{pending_aldb}{deviceid},0,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); - $message->failure_callback($$self{_failure_callback}); - $self->_send_cmd($message); } + $message->failure_callback($$self{_failure_callback}); + $self->_send_cmd($message); } elsif ($$self{_mem_action} eq 'aldb_devmid') { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{pending_aldb}{deviceid} .= lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_devlo'; $message->extra($$self{_mem_lsb}); - $message->failure_callback($$self{_failure_callback}); - $self->_send_cmd($message); } elsif ($$self{_mem_activity} eq 'add') { my $devid = substr($$self{pending_aldb}{deviceid},2,2); $message = new Insteon::InsteonMessage('insteon_send', $$self{device}, 'poke'); $message->extra($devid); - $message->failure_callback($$self{_failure_callback}); - $self->_send_cmd($message); } + $message->failure_callback($$self{_failure_callback}); + $self->_send_cmd($message); } elsif ($$self{_mem_action} eq 'aldb_devlo') { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{pending_aldb}{deviceid} .= lc $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_data1'; @@ -559,6 +550,9 @@ sub _on_peek { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{_mem_action} = 'aldb_data2'; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{pending_aldb}{data1} = $msg{extra}; @@ -579,6 +573,9 @@ sub _on_peek { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{pending_aldb}{data2} = $msg{extra}; $$self{_mem_lsb} = sprintf("%02X", hex($$self{_mem_lsb}) + 1); $$self{_mem_action} = 'aldb_data3'; @@ -599,6 +596,9 @@ sub _on_peek { if ($$self{_mem_activity} eq 'scan') { + &::print_log("[Insteon::ALDB_i1] DEBUG3: " . $$self{device}->get_object_name + . " [0x" . $$self{_mem_msb} . $$self{_mem_lsb} . "] received: " + . lc $msg{extra} . " for " . $$self{_mem_action}) if $main::Debug{insteon} >= 3; $$self{pending_aldb}{data3} = $msg{extra}; # check the previous record if highwater is set if ($$self{pending_aldb}{highwater}) @@ -618,7 +618,7 @@ sub _on_peek # check for duplicates if (exists $$self{aldb}{$aldbkey} && $$self{aldb}{$aldbkey}{inuse}) { - unshift @{$$self{aldb}{duplicates}}, $$self{pending_aldb}{address}; + $self->add_duplicate_link_address($$self{pending_aldb}{address}); } else { @@ -627,8 +627,7 @@ sub _on_peek } else { - # TO-DO: record the locations of deleted aldb records for subsequent reuse - unshift @{$$self{aldb}{empty}}, $$self{pending_aldb}{address}; + $self->add_empty_address($$self{pending_aldb}{address}); } my $newaddress = sprintf("%04X", hex($$self{pending_aldb}{address}) - 8); $$self{pending_aldb} = undef; @@ -1204,6 +1203,102 @@ sub _process_delete_queue { } } +sub add_duplicate_link_address +{ + my ($self, $address) = @_; + + unshift @{$$self{aldb}{duplicates}}, $address; + + # now, keep the list sorted! + @{$$self{adlb}{duplicates}} = sort(@{$$self{aldb}{duplicates}}); + +} + +sub delete_duplicate_link_address +{ + my ($self, $address) = @_; + my $num_duplicate_link_addresses = @{$$self{aldb}{duplicates}}; + if ($num_duplicate_link_addresses) + { + my @temp_duplicates = (); + foreach my $temp_address (@{$$self{aldb}{duplicates}}) + { + if ($temp_address ne $address) + { + push @temp_duplicates, $temp_address; + } + } + # keep it sorted + @{$$self{aldb}{duplicates}} = sort(@temp_duplicates); + } +} + +sub add_empty_address +{ + my ($self, $address) = @_; + # before adding it, make sure that it isn't already in the list!! + my $num_addresses = @{$$self{aldb}{empty}}; + my $exists = 0; + if ($num_addresses and $address) + { + foreach my $temp_address (@{$$self{aldb}{empty}}) + { + if ($temp_address eq $address) + { + $exists = 1; + last; + } + } + } + # add it to the list if it doesn't exist + if (!($exists) and $address) + { + unshift @{$$self{aldb}{empty}}, $address; + } + + # now, keep the list sorted! + @{$$self{adlb}{empty}} = sort(@{$$self{aldb}{empty}}); + +} + +sub get_first_empty_address +{ + my ($self) = @_; + + # NOTE: The issue here is that we give up an address from the list + # with the assumption that it will be made non-empty; + # So, if there is a problem during update/add, then will have + # a non-empty, but non-functional entry + my $first_address = pop @{$$self{aldb}{empty}}; + + if (!($first_address)) + { + # then, cycle through all of the existing non-empty addresses + # to find the lowest one and then decrement by 8 + # + # TO-DO: factor in appropriate use of the "highwater" flag + # + my $low_address = 0; + for my $key (keys %{$$self{aldb}}) + { + next if $key eq 'empty' or $key eq 'duplicates'; + my $new_address = hex($$self{aldb}{$key}{address}); + if (!($low_address)) + { + $low_address = $new_address; + next; + } + else + { + $low_address = $new_address if $new_address < $low_address; + } + } + $first_address = sprintf('%04X', $low_address - 8); + } + + return $first_address; +} + sub add_link { my ($self, $parms_text) = @_; @@ -1263,7 +1358,7 @@ sub add_link $ramp_rate =~ s/(\d)s?/$1/; $ramp_rate = '0.1' unless $ramp_rate; # 0.1s is the default # get the first available memory location - my $address = pop @{$$self{aldb}{empty}}; + my $address = $self->get_first_empty_address(); $$self{_success_callback} = ($link_parms{callback}) ? $link_parms{callback} : undef; $$self{_failure_callback} = ($link_parms{failure_callback}) ? $link_parms{failure_callback} : undef; if ($address) From 79daceb98216e1069b2fb8a095e15a71cf856abc Mon Sep 17 00:00:00 2001 From: gliming Date: Thu, 8 Mar 2012 22:49:16 +0000 Subject: [PATCH 128/150] Ensure that xmit timer is checked as part of transmit_in_progress return value to guarantee that the queue does not get processed until the timer expires. --- lib/Insteon/BaseInterface.pm | 114 ++++++++++++++++------------------- 1 file changed, 52 insertions(+), 62 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index a7f1346a0..c4109fa73 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -172,7 +172,9 @@ sub transmit_in_progress { $$self{xmit_in_progress} = $xmit_flag; } - return $$self{xmit_in_progress}; + # also factor in xmit timer since this must be honored to allow + # adequate time to elapse + return $$self{xmit_in_progress} || ($self->_check_timeout('xmit')==0); } sub queue_message @@ -211,67 +213,61 @@ sub process_queue my ($self) = @_; my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size if $self->transmit_in_progress; - - # get pending command record - my $pending_message = $self->active_message; - - if (!($pending_message)) - { # no prior message remains; so, get one from the queue - $pending_message = pop(@{$$self{command_stack2}}); - $self->active_message($pending_message) if $pending_message; - } + if ($self->transmit_in_progress) + { + return $command_queue_size; + } + else #we dont transmit on top of another xmit - if (!($self->transmit_in_progress)) { # no transmission is progress that has not already been acked or nacked by the PLM + # get pending command record + my $pending_message = $self->active_message; + + if (!($pending_message)) + { # no prior message remains; so, get one from the queue + $pending_message = pop(@{$$self{command_stack2}}); + $self->active_message($pending_message) if $pending_message; + } + if ($pending_message) { # a message exists to be sent (whether previously sent or queued) - if (!($self->_check_timeout('xmit')==0)) - { # only send a message if the xmit timer has timed out - - if ($self->active_message->send($self) == 0) - { # this only occurs if the retry count has been exceeded - # which also means that there wasn't a message actually sent - &::print_log("[Insteon::BaseInterface] WARN: number of retries (" - . $self->active_message->send_attempts - . ") for " . $self->active_message->to_string() - . " exceeds limit. Now moving on...") if $main::Debug{insteon}; - # !!!!!!!!! TO-DO - handle failure timeout ??? - my $failed_message = $self->active_message; - # make sure to let the sending object know!!! - if (defined($failed_message->setby) and $failed_message->setby->can('is_acknowledged')) - { - $failed_message->setby->is_acknowledged(0); - } - else - { - &main::print_log("[Insteon::BaseInterface] WARN! Unable to clear acknowledge for " - . ((defined($failed_message->setby)) ? $failed_message->setby->get_object_name : "undefined")); - } - # clear active message - $self->clear_active_message(); - - # may instead want a "failure" callback separate from success callback - if ($failed_message->failure_callback) - { - &::print_log("[Insteon::BaseInterface] WARN: Now calling callback: " . - $failed_message->failure_callback) if $main::Debug{insteon}; - package main; - eval $failed_message->failure_callback; - &::print_log("[Insteon::BaseInterface] problem w/ retry callback: $@") if $@; - package Insteon::BaseInterface; - } - - $self->process_queue(); - } - else + + if ($self->active_message->send($self) == 0) + { # this only occurs if the retry count has been exceeded + # which also means that there wasn't a message actually sent + &::print_log("[Insteon::BaseInterface] WARN: number of retries (" + . $self->active_message->send_attempts + . ") for " . $self->active_message->to_string() + . " exceeds limit. Now moving on...") if $main::Debug{insteon}; + # !!!!!!!!! TO-DO - handle failure timeout ??? + my $failed_message = $self->active_message; + # make sure to let the sending object know!!! + if (defined($failed_message->setby) and $failed_message->setby->can('is_acknowledged')) + { + $failed_message->setby->is_acknowledged(0); + } + else + { + &main::print_log("[Insteon::BaseInterface] WARN! Unable to clear acknowledge for " + . ((defined($failed_message->setby)) ? $failed_message->setby->get_object_name : "undefined")); + } + # clear active message + $self->clear_active_message(); + + # may instead want a "failure" callback separate from success callback + if ($failed_message->failure_callback) { - # may want to move "success" callback handling from message to here - } - } # if xmit timer has expired - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; + &::print_log("[Insteon::BaseInterface] WARN: Now calling callback: " . + $failed_message->failure_callback) if $main::Debug{insteon}; + package main; + eval $failed_message->failure_callback; + &::print_log("[Insteon::BaseInterface] problem w/ retry callback: $@") if $@; + package Insteon::BaseInterface; + } + + $self->process_queue(); + } } else # no pending message { @@ -280,12 +276,6 @@ sub process_queue return 0; } } - else # transmit in progress - { -# &::print_log("[Insteon_PLM] active transmission; moving on...") if $main::Debug{insteon}; - my $command_queue_size = @{$$self{command_stack2}}; - return $command_queue_size; - } my $command_queue_size = @{$$self{command_stack2}}; return $command_queue_size; } From 8cb1582acb83d915eeb4de95af3ae1b7de7fbcd1 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 9 Mar 2012 16:32:47 +0000 Subject: [PATCH 129/150] Actively match against deviceid and other factors before processing message to an object. Avoid the possibility of accidental processing for an unsent message. --- lib/Insteon/BaseInterface.pm | 45 +++++++++++++++++++++++++++--------- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index c4109fa73..cf16d0629 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -154,14 +154,12 @@ sub clear_active_message { my ($self) = @_; $$self{active_message} = undef; -# $self->_clear_timeout('command'); $self->transmit_in_progress(0); } sub retry_active_message { my ($self) = @_; -# $self->_clear_timeout('command'); $self->transmit_in_progress(0); } @@ -345,26 +343,51 @@ sub on_standard_insteon_received &::print_log("[Insteon::BaseInterface] command:$msg{command}; type:$msg{type}; group: $msg{group}") if (!($msg{is_ack} or $msg{is_nack})) and $main::Debug{insteon}; } -# &::print_log("[Insteon_PLM] Processing message for " . $object->get_object_name) if $main::Debug{insteon}; - $object->_process_message($self, %msg); if ($msg{is_ack} or $msg{is_nack}) { # need to confirm that this message corresponds to the current active one before clearing it # TO-DO!!! This is a brute force and poor compare technique; needs to be replaced by full compare if ($self->active_message && ref $self->active_message->setby) { - if ((lc $self->active_message->setby->device_id eq lc $msg{source}) and ($msg{type} eq 'direct')) - { - $self->clear_active_message(); - } + if ($self->active_message->send_attempts == 0) + { + &main::print_log("[Insteon::BaseInterface] WARN: received ACK/NACK message for " + . $object->get_object_name . " but cannot correlate to sent message " + . "(active but send attempts = 0). IGNORING received message!!"); + } + elsif ($msg{type} eq 'direct') + { + if (lc $self->active_message->setby->device_id eq lc $msg{source}) + { + # ask the object to process the received message and update its state + $object->_process_message($self, %msg); + $self->clear_active_message(); + } + else + { + &main::print_log("[Insteon::BaseInterface] WARN: deviceid of " + . "active message != received message source (" + . $object->get_object_name() . "). IGNORING received message!!"); + } + } else { - &main::print_log("[Insteon::BaseInterface] WARN: deviceid of " - . "active message != received message source") - if $msg{type} eq 'direct' and $main::Debug{insteon}; + &main::print_log("[Insteon::BaseInterface] ERROR: received ACK/NACK message from " + . $object->get_object_name . " but unable to process $msg{type} message type." + . " IGNORING received message!!"); } } + else + { + &main::print_log("[Insteon::BaseInterface] WARN: received insteon ACK/NACK message from " + . $object->get_object_name . " but cannot correlate to sent message! IGNORING received message!!"); + } } + else + { + # ask the object to process the received message and update its state + $object->_process_message($self, %msg); + } } else { From ebf483802cd61f433a17e4cc426e471006a530a0 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 9 Mar 2012 16:33:03 +0000 Subject: [PATCH 130/150] Minor code cleanup. --- lib/Insteon/Message.pm | 42 ++++++++++++++++++++++++++++++------------ 1 file changed, 30 insertions(+), 12 deletions(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 7fe5ba284..3876fe824 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -112,7 +112,6 @@ sub send } # need to set timeout as a function of retries; also need to alter hop count - $self->send_attempts($self->send_attempts + 1); $interface->_send_cmd($self, $self->send_timeout); if ($self->callback) @@ -187,41 +186,60 @@ sub command_to_hash $msg{hopsleft} = $hopflag >> 2; my $msgflag = hex(uc substr($p_state,12,1)); $msg{is_extended} = (0x01 & $msgflag) ? 1 : 0; - if ($msg{is_extended}) { + if ($msg{is_extended}) + { $msg{source} = substr($p_state,0,6); $msg{destination} = substr($p_state,6,6); $msg{extra} = substr($p_state,16,16); - } else { + } + else + { $msg{source} = substr($p_state,0,6); $msgflag = $msgflag >> 1; - if ($msgflag == 4) { + if ($msgflag == 4) + { $msg{type} = 'broadcast'; $msg{devcat} = substr($p_state,6,4); $msg{firmware} = substr($p_state,10,2); $msg{is_master} = substr($p_state,16,2); $msg{dev_attribs} = substr($p_state,18,2); - } elsif ($msgflag ==6) { + } + elsif ($msgflag ==6) + { $msg{type} = 'alllink'; $msg{group} = substr($p_state,10,2); - } else { + } + else + { $msg{destination} = substr($p_state,6,6); - if ($msgflag == 2) { + if ($msgflag == 2) + { $msg{type} = 'cleanup'; $msg{group} = substr($p_state,16,2); - } elsif ($msgflag == 3) { + } + elsif ($msgflag == 3) + { $msg{type} = 'cleanup'; $msg{is_ack} = 1; - } elsif ($msgflag == 7) { + } + elsif ($msgflag == 7) + { $msg{type} = 'cleanup'; $msg{is_nack} = 1; - } elsif ($msgflag == 0) { + } + elsif ($msgflag == 0) + { $msg{type} = 'direct'; $msg{extra} = substr($p_state,16,2); - } elsif ($msgflag == 1) { + } + elsif ($msgflag == 1) + { $msg{type} = 'direct'; $msg{is_ack} = 1; $msg{extra} = substr($p_state,16,2); - } elsif ($msgflag == 5) { + } + elsif ($msgflag == 5) + { $msg{type} = 'direct'; $msg{is_nack} = 1; } From 68b251b783f9801b0df3d423ea575906ad31877c Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 9 Mar 2012 16:34:11 +0000 Subject: [PATCH 131/150] Detect ack messages that have a bogus deviceid. --- lib/Insteon_PLM.pm | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index f5cd50a67..49a3f7717 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -523,8 +523,26 @@ sub _parse_data { # is $parsed_data an accidental anomoly? (there are other cases; but, this is a good start) if ($parsed_data =~ /^($prefix{insteon_send}\w{12}06)|($prefix{insteon_send}\w{12}15)$/) { - &::print_log("[Insteon_PLM] ERROR: encountered '$parsed_data' but expected '$ackcmd'."); - $residue_data .= $parsed_data; + # first, parse the content to confirm that it could be a legitimate ACK + my $unknown_deviceid = substr($parsed_data,4,6); + my $unknown_msg_flags = substr($parsed_data,10,2); + my $unknown_command = substr($parsed_data,12,2); + my $unknown_data = substr($parsed_data,14,2); + my $unknown_obj = &Insteon::get_object($unknown_deviceid, '01'); + if ($unknown_obj) + { + &::print_log("[Insteon_PLM] WARN: encountered '$parsed_data' " + . "from " . $unknown_obj->get_object_name() + . " with command: $unknown_command, but expected '$ackcmd'."); + $residue_data .= $parsed_data; + } + else + { + &::print_log("[Insteon_PLM] ERROR: encountered '$parsed_data' " + . "that does not match any known device ID (expected '$ackcmd')." + . " Discarding received data."); + #$residue_data .= $parsed_data; + } } else { From 8aa6be82d329c3e7c67f946f95730b7bcff7d239 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 9 Mar 2012 22:32:37 +0000 Subject: [PATCH 132/150] Parse group record for cleanup message. --- lib/Insteon/Message.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 3876fe824..93655c44a 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -221,6 +221,8 @@ sub command_to_hash { $msg{type} = 'cleanup'; $msg{is_ack} = 1; + # the "extra" value will contain the controller's group ID + $msg{extra} = substr($p_state,16,2); } elsif ($msgflag == 7) { From 5a0d6bf32d7cc06ee6407eada09cc04f8576dec5 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 9 Mar 2012 22:33:24 +0000 Subject: [PATCH 133/150] Properly handly more corner case ACK/NACK messages. --- lib/Insteon/BaseInterface.pm | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index cf16d0629..143ee042b 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -379,8 +379,26 @@ sub on_standard_insteon_received } else { - &main::print_log("[Insteon::BaseInterface] WARN: received insteon ACK/NACK message from " - . $object->get_object_name . " but cannot correlate to sent message! IGNORING received message!!"); + if ($msg{type} eq 'direct') + { + &main::print_log("[Insteon::BaseInterface] WARN: received insteon ACK/NACK message from " + . $object->get_object_name . " but cannot correlate to sent message! IGNORING received message!!"); + } + elsif ($msg{type} eq 'cleanup') + { + # for now, this is just going to be ignore since there is a virtual processing done + # in the Insteon_PLM handler for cleanup messages. + # but, this probably should be dealt with differently and explicitly + # attempt to treat the message + &main::print_log("[Insteon::BaseInterface] DEBUG2: received cleanup message responding to " + . "PLM controller group: $msg{extra}. Ignoring as this has already been processed (we hope)") + if $main::Debug{insteon} >= 2; + } + else + { + # ask the object to process the received message and update its state + $object->_process_message($self, %msg); + } } } else From 510110be90516d73903bb4ed4584af6fa9de3a01 Mon Sep 17 00:00:00 2001 From: gliming Date: Fri, 9 Mar 2012 23:17:10 +0000 Subject: [PATCH 134/150] Add explicit handlers for cleanup direct messages. --- lib/Insteon/BaseInterface.pm | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 143ee042b..1b89e4714 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -370,6 +370,17 @@ sub on_standard_insteon_received . $object->get_object_name() . "). IGNORING received message!!"); } } + elsif ($msg{type} eq 'cleanup') + { + $object = &Insteon::get_object('000000', $msg{extra}); + my %cleanup_msg = ('type' => 'cleanup', + 'group' => $msg{extra}, + 'is_ack' => 1, + 'command' => 'cleanup' + ); + $object->_process_message($self, %cleanup_msg); + $self->clear_active_message(); + } else { &main::print_log("[Insteon::BaseInterface] ERROR: received ACK/NACK message from " @@ -386,13 +397,13 @@ sub on_standard_insteon_received } elsif ($msg{type} eq 'cleanup') { - # for now, this is just going to be ignore since there is a virtual processing done + # this is just going to be ignored since there is a virtual processing done # in the Insteon_PLM handler for cleanup messages. - # but, this probably should be dealt with differently and explicitly - # attempt to treat the message - &main::print_log("[Insteon::BaseInterface] DEBUG2: received cleanup message responding to " - . "PLM controller group: $msg{extra}. Ignoring as this has already been processed (we hope)") - if $main::Debug{insteon} >= 2; + # however, if the virtual handler was not invoked due to receipt of the broadcast message + # then, the above cleanup handler would be run + &main::print_log("[Insteon::BaseInterface] DEBUG3: received cleanup message responding to " + . "PLM controller group: $msg{extra}. Ignoring as this has already been processed") + if $main::Debug{insteon} >= 3; } else { From efb84f3e6b9f919e702c8a38ea33049a4c18e593 Mon Sep 17 00:00:00 2001 From: gliming Date: Sun, 11 Mar 2012 17:47:48 +0000 Subject: [PATCH 135/150] Prevent processing pending transmit queue until after clearing occurs. --- lib/Insteon/BaseInterface.pm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 1b89e4714..948384bf2 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -359,6 +359,8 @@ sub on_standard_insteon_received { if (lc $self->active_message->setby->device_id eq lc $msg{source}) { + # prevent re-processing transmit queue until after clearing occurs + $self->transmit_in_progress(1); # ask the object to process the received message and update its state $object->_process_message($self, %msg); $self->clear_active_message(); @@ -378,6 +380,9 @@ sub on_standard_insteon_received 'is_ack' => 1, 'command' => 'cleanup' ); + # prevent re-processing transmit queue until after clearing occurs + $self->transmit_in_progress(1); + # ask the object to process the received message and update its state $object->_process_message($self, %cleanup_msg); $self->clear_active_message(); } From 5e7d18843f39437d5202ba973fe68ea55772b265 Mon Sep 17 00:00:00 2001 From: jduda Date: Mon, 12 Mar 2012 00:49:35 +0000 Subject: [PATCH 136/150] Update pocketsphinx to support the latest 0.7 release and utilize the CMU Language Toolkit for buiding the language files. This new version is much better with the binary language file support. --- bin/mh.ini | 1 - bin/pocketsphinx | 46 ++- code/common/pocketsphinx_control.pl | 39 +-- lib/PocketSphinx.pm | 498 ++++++++-------------------- 4 files changed, 168 insertions(+), 416 deletions(-) diff --git a/bin/mh.ini b/bin/mh.ini index 447621401..27346f968 100644 --- a/bin/mh.ini +++ b/bin/mh.ini @@ -1197,7 +1197,6 @@ viavoice_voice = male @ sleep mode @ - pocketsphinx_timeout_response: This is what is said (or played) when the awake @ timer expires. -@ - pocketsphinx_cmudict Pocketsphinx full english dictionary file location. @ - pocketsphinx_hmm Pocketsphinx Human Markov Model directory location. @ - pocketsphinx_rate Audio Sample rate @ - pocketsphinx_continuous Program location for pocketsphinx_continuous diff --git a/bin/pocketsphinx b/bin/pocketsphinx index afe394cd6..e1f46ccdb 100755 --- a/bin/pocketsphinx +++ b/bin/pocketsphinx @@ -75,8 +75,8 @@ $SIG{KILL} = \&signal_handler; #====================================================================== # Check invocation options, and print usage message if necessary #====================================================================== -if (!&GetOptions(\%parms, "h", "help", "host=s", "port", "log_file=s", - "sent_file=s", "lm_file=s", "dict_file=s", "hmm_file=s", "program=s", +if (!&GetOptions(\%parms, "h", "help", "host=s", "port=i", "log_file=s", + "sent_file=s", "lm_file=s", "hmm_file=s", "program=s", "device=s", "sample=i") or ($parms{h} or $parms{help})) { print< This help text -help => This help text -host xyz => xyz is the host name of the computer running misterhouse - -port xyz => xyz is the port which misterhouse is listening on (3245) + -port xyz => xyz is the port which misterhouse is listening on (3235) -log_file xyz => log information is directed to this file -sent_file xyz => xyz is the pocketsphinx sentence file -lm_file xyz => xyz is the pocketsphinx language model file - -dict_file xyx => xyz is the pocketsphinx dictionary file -hmm_file xyz => xyz is the pocketsphinx hidden markov model file -program xyz => xyz is the path to pocketsphinx_continuous program -device xyz => xyz is the alsa/oss listening device @@ -103,11 +102,10 @@ audio device and sample rate are configurable on the command line. Example: - $Pgm_Name -host localhost -port 3245 \ + $Pgm_Name -host localhost -port 3235 \ -log_file /misterhouse/data/pocketsphinx/pocketsphinx.log \ -sent_file /misterhouse/data/pocketsphinx/current.sent \ - -lm_file /misterhouse/data/pocketsphinx/current.lm \ - -dict_file /misterhouse/data/pocketsphinx/current.dic \ + -lm_file /misterhouse/data/pocketsphinx/current.lm.DMP \ -hmm_file /usr/local/share/pocketsphinx/model/hmm/wsj1 \ -program /usr/local/bin/pocketsphinx_continuous \ -device default \ @@ -138,8 +136,8 @@ if (@devices > 1) { } sub setup { - $parms{localhost} = "localhost" unless $parms{localhost}; - $parms{localport} = 3235 unless $parms{localport}; + $parms{host} = "localhost" unless $parms{host}; + $parms{port} = 3235 unless $parms{port}; $parms{program} = "/usr/local/bin/pocketsphinx_continuous" unless $parms{program}; $parms{device} = "default" unless $parms{device}; $parms{sample} = 16000 unless $parms{sample}; @@ -157,11 +155,10 @@ sub run { $device =~ s/^\s+//; $device =~ s/\s+$//; - my $localhost = $parms{localhost}; - my $localport = $parms{localport}; + my $host = $parms{host}; + my $port = $parms{port}; my $sent = $parms{sent_file}; - my $lm = $parms{lm_file}; - my $dict = $parms{dict_file}; + my $lm_file = $parms{lm_file}; my $hmm = $parms{hmm_file}; my $program = $parms{program}; my $rate = $parms{sample}; @@ -174,11 +171,8 @@ sub run { if (!-e $sent) { die "Missing sent_file $sent !!"; } - if (!-e $lm) { - die "missing lm_file $lm !!"; - } - if (!-e $dict) { - die "missing dict_file $dict !!"; + if (!-e $lm_file) { + die "missing lm_file $lm_file !!"; } if (!-e $hmm) { die "missing hmm_file $hmm !!"; @@ -187,17 +181,16 @@ sub run { die "missing program $program !!"; } - print LOGFILE "localhost: $localhost\n"; - print LOGFILE "localport: $localport\n"; + print LOGFILE "host: $host\n"; + print LOGFILE "port: $port\n"; print LOGFILE "sent: $sent\n"; - print LOGFILE "lm: $lm\n"; - print LOGFILE "dict: $dict\n"; + print LOGFILE "lm: $lm_file\n"; print LOGFILE "hmm: $hmm\n"; print LOGFILE "program: $program\n"; print LOGFILE "device: $device\n"; print LOGFILE "rate: $rate\n"; - my $socket = IO::Socket::INET->new(PeerAddr=>$localhost, PeerPort=>$localport, Proto=>'tcp', Type=> SOCK_STREAM) or die "\nCould not create socket: $!\n"; + my $socket = IO::Socket::INET->new(PeerAddr=>$host, PeerPort=>$port, Proto=>'tcp', Type=> SOCK_STREAM) or die "\nCould not create socket: $!\n"; print LOGFILE "starting listener ...\n"; my $sphinx_command = join " ", @@ -212,8 +205,7 @@ sub run { # "-nfft 256", # "-cmn none", # "-agc emax", - "-lm $lm", - "-dict $dict", + "-lm $lm_file", "-hmm $hmm", "-samprate $rate", # "-dsratio 2", @@ -235,11 +227,11 @@ sub run { while(my $msg = ){ chomp $msg; print LOGFILE "sphinx:: msg: $msg\n"; - if ( $msg =~ /^\d+\: (.*) \(.*\)$/ ) { + if ( $msg =~ /^\d+\: (.*)$/ ) { $msg = $1; print LOGFILE "sphinx:: found: $msg\n"; if (`grep \'$msg\' $sent`) { - $msg = uc $msg; + $msg = lc $msg; $msg =~ s/_/ /g; if ($msg) { print $socket "$msg\n"; diff --git a/code/common/pocketsphinx_control.pl b/code/common/pocketsphinx_control.pl index b56968366..6985788aa 100644 --- a/code/common/pocketsphinx_control.pl +++ b/code/common/pocketsphinx_control.pl @@ -8,35 +8,28 @@ pocketsphinx_control.pl -01/21/2007 Created by Jim Duda (jim@duda.tzo.com) +03/11/2012 Created by Jim Duda (jim@duda.tzo.com) Use this module to control the PocketSphinx VR engine (currently Linux only) -Requirements: +RRequirements: - Download and install PocketSphinx - http://cmusphinx.sourceforge.net + Download and install Sphinxbase, PocketSphinx, and CMU Language Toolkit + http://cmusphinx.sourceforge.net/wiki/download/ -These versions of pocketsphinx are supported: + Current Version Supported: + PocketSphinx: 0.7 + SphinxBase: 0.7 + Cmuclmtk: 0.7 - Sphinxbase: 0.4.1 - Pocketsphinx: 0.5.1 - - You need to install both SphinxBase and PocketSphinx. When building SphinxBase, it will - default to OSS, if you want ALSA (recommended) then you need to add --with-alsa to the - configure command. - - Download the CMU Sphinx dictionary file from here: - https://cmusphinx.svn.sourceforge.net/svnroot/cmusphinx/trunk/SphinxTrain/test/res/cmudict.0.6d - - Install the dictionary file in some useful place - example: /usr/local/share/pocketsphinx/model/lm/cmudict/cmudict.0.6d - pocketsphinx_cmudict must match the location where the file is installed. + When building SphinxBase, it will default to OSS, if you want ALSA (recommended) then you + need to add --with-alsa to the configure command. Setup: Install and configure all the above software. Set these values in your mh.private.ini file Note that all those marked as default are in mh.ini and need not be loaded unless truly different. +Enable the pocket_sphinx_control module in misterhouse setup (code/common). voice_cmd = pocketsphinx # REQUIRED server_pocketsphinx_port = 3235 # REQUIRED @@ -44,11 +37,10 @@ pocketsphinx_awake_response = "yes master?" # optional pocketsphinx_awake_time=300 # optional pocketsphinx_asleep_phrase={go to sleep,change to sleep mode} # optional - pocketsphinx_asleep_response=Ok, later. # optional - pocketsphinx_timeout_response=Later. # optional + pocketsphinx_asleep_response=Ok, later. + pocketsphinx_timeout_response=Later. - pocketsphinx_cmudict = /usr/local/share/pocketsphinx/model/lm/cmudict/cmudict.0.6d # default - pocketsphinx_hmm = /usr/local/share/pocketsphinx/model/hmm/wsj1 # default + pocketsphinx_hmm = /usr/local/share/pocketsphinx/model/hmm/en_US/hub4wsj_sc_8k # default pocketsphinx_rate = 16000 # default pocketsphinx_continuous = /usr/local/bin/pocketsphinx_continuous # default pocketsphinx_dev = default # default @@ -68,10 +60,9 @@ @ sleep mode @ - pocketsphinx_timeout_response: This is what is said (or played) when the awake @ timer expires. -@ - pocketsphinx_cmudict Pocketsphinx full english dictionary file location. @ - pocketsphinx_hmm Pocketsphinx Human Markov Model directory location. @ - pocketsphinx_rate Audio Sample rate -@ - pocketsphinx_continuouts Program location for pocketsphinx_continuous +@ - pocketsphinx_continuous Program location for pocketsphinx_continuous @ - pocketsphinx_dev Audio device (multiple devices can be separated by "|") =cut diff --git a/lib/PocketSphinx.pm b/lib/PocketSphinx.pm index a70d703ef..481b13a57 100644 --- a/lib/PocketSphinx.pm +++ b/lib/PocketSphinx.pm @@ -8,19 +8,16 @@ Use this module to control the PocketSphinx VR engine (currently Linux only) Requirements: - Download and install PocketSphinx - http://cmusphinx.sourceforge.net + Download and install Sphinxbase, PocketSphinx, and CMU Language Toolkit + http://cmusphinx.sourceforge.net/wiki/download/ - You need to install both SphinxBase and PocketSphinx. When building SphinxBase, it will - default to OSS, if you want ALSA (recommended) then you need to add --with-alsa to the - configure command. + Current Version Supported: + PocketSphinx: 0.7 + SphinxBase: 0.7 + Cmuclmtk: 0.7 - Download the CMU Sphinx dictionary file from here: - https://cmusphinx.svn.sourceforge.net/svnroot/cmusphinx/trunk/SphinxTrain/test/res/cmudict.0.6d - - Install the dictionary file in some useful place - example: /usr/local/share/pocketsphinx/model/lm/cmudict/cmudict.0.6d - pocketsphinx_cmudict must match the location where the file is installed. + When building SphinxBase, it will default to OSS, if you want ALSA (recommended) then you + need to add --with-alsa to the configure command. Setup: @@ -37,11 +34,10 @@ Enable the pocket_sphinx_control module in misterhouse setup (code/common). pocketsphinx_asleep_response=Ok, later. pocketsphinx_timeout_response=Later. - pocketsphinx_cmudict = "/usr/local/share/pocketsphinx/model/lm/cmudict/cmudict.0.6d" # default - pocketsphinx_hmm = "/usr/local/share/pocketsphinx/model/hmm/wsj1" # default - pocketsphinx_rate = 16000 # default - pocketsphinx_continuous = "/usr/local/bin/pocketsphinx_continuous" # default - pocketsphinx_dev = "default" # default + pocketsphinx_hmm = /usr/local/share/pocketsphinx/model/hmm/en_US/hub4wsj_sc_8k # default + pocketsphinx_rate = 16000 # default + pocketsphinx_continuous = /usr/local/bin/pocketsphinx_continuous # default + pocketsphinx_dev = default # default Note: If using OSS instead of ALSA, pocketsphinx_device needs to be "/dev/dsp" or similiar. @@ -58,10 +54,9 @@ Enable the pocket_sphinx_control module in misterhouse setup (code/common). @ sleep mode @ - pocketsphinx_timeout_response: This is what is said (or played) when the awake @ timer expires. -@ - pocketsphinx_cmudict Pocketsphinx full english dictionary file location. @ - pocketsphinx_hmm Pocketsphinx Human Markov Model directory location. @ - pocketsphinx_rate Audio Sample rate -@ - pocketsphinx_continues Program location for pocketsphinx_continuous +@ - pocketsphinx_continuous Program location for pocketsphinx_continuous @ - pocketsphinx_dev Audio device (multiple devices can be separated by "|") =cut @@ -82,11 +77,9 @@ my $p_sphinx = undef; my $s_pocketsphinx = undef; my $sentence_file = "$main::config_parms{data_dir}/pocketsphinx/current.sent"; -my $lm_file = "$main::config_parms{data_dir}/pocketsphinx/current.lm"; -my $dictionary_file = "$main::config_parms{data_dir}/pocketsphinx/current.dic"; +my $lm_file = "$main::config_parms{data_dir}/pocketsphinx/current.lm.DMP"; my $lm_log_file = "$main::config_parms{data_dir}/pocketsphinx/build_lm.log"; -my $cmu_dict = "/usr/local/share/pocketsphinx/model/lm/cmudict/cmudict.0.6d"; -my $hmm_file = "/usr/local/share/pocketsphinx/model/hmm/wsj1"; +my $hmm_file = "/usr/local/share/pocketsphinx/model/hmm/en_US/hub4wsj_sc_8k"; my $awake_time = 300; sub startup { @@ -120,11 +113,8 @@ sub startup { mkdir ("$main::config_parms{data_dir}/pocketsphinx", 0777) unless -d "$main::config_parms{data_dir}/pocketsphinx"; # Insure we have all the files we need, if so, start the process - $cmu_dict = "$main::config_parms{pocketsphinx_cmudict}" if exists $main::config_parms{pocketsphinx_cmudict}; $hmm_file = "$main::config_parms{pocketsphinx_hmm}" if exists $main::config_parms{pocketsphinx_hmm}; - if (!-e $cmu_dict) { - &main::print_log ("PocketSphinx_Control:: ERROR: file: $cmu_dict MISSING!!"); - } elsif (!-e $hmm_file) { + if (!-e $hmm_file) { &main::print_log ("PocketSphinx_Control:: ERROR: file: $hmm_file MISSING!!"); } else { &::MainLoop_pre_add_hook(\&PocketSphinx_Control::state_machine, 'persistent'); @@ -159,7 +149,7 @@ sub said { $token =~ s/^\s+//; $token =~ s/\s+$//; $token =~ s/[\{\}]//; - $token = uc($token); + $token = lc($token); if ($tmp eq $token) { $text = $tmp; } @@ -173,42 +163,29 @@ sub said { } sub state_machine { - if ($main::Startup or $main::Reload) { - # save old sentence file, compare with new to avoid reloading - rename ($sentence_file, "$sentence_file.bak"); + my ($self) = @_; + if ($main::Startup or $main::Reload or ($PocketSphinx_state eq "reset")) { &build_sentence_file($sentence_file); - if ( (compare( $sentence_file, "$sentence_file.bak") == 0) && - -e $lm_file && -e $dictionary_file) { - &main::print_log ("PocketSphinx_Control:: reusing language files") if $main::Debug{pocketsphinx}; - - $PocketSphinx_state = "run_sphinx"; - } else { - $PocketSphinx_state = "build_lm"; - &main::print_log ("PocketSphinx_Control:: build_lm") if $main::Debug{pocketsphinx}; - set_errlog $p_sphinx ""; - set_output $p_sphinx ""; - set $p_sphinx "&PocketSphinx_Control::build_lm ('$sentence_file','$lm_file','$lm_log_file')"; - start $p_sphinx; + $PocketSphinx_state = "build_lm"; + &main::print_log ("PocketSphinx_Control:: build_lm") if $main::Debug{pocketsphinx}; + set_errlog $p_sphinx "$main::config_parms{data_dir}/pocketsphinx/build_lm.stderr"; + set_output $p_sphinx "$main::config_parms{data_dir}/pocketsphinx/build_lm.stdout"; + my $pgm_root = "/usr/local/bin"; + if ($self->{continuous} =~ /(\S+)\/pocketsphinx/) { + $pgm_root = $1; } + my $data_root = "$main::config_parms{data_dir}/pocketsphinx/current"; + set $p_sphinx "&PocketSphinx_Control::build_lm ('$pgm_root','$data_root','$lm_log_file')"; + start $p_sphinx; } # wait for build_lm to complete if ($PocketSphinx_state eq "build_lm") { - if (done $p_sphinx) { - &main::print_log ("PocketSphinx_Control:: build_dictionary") if $main::Debug{pocketsphinx}; - $PocketSphinx_state = "build_dictionary"; - set_errlog $p_sphinx ""; - set_output $p_sphinx ""; - set $p_sphinx "&PocketSphinx_Control::build_dictionary('$sentence_file','$cmu_dict','$dictionary_file')"; - start $p_sphinx; - } - } - - # wait for build dictionary to be complete - if ($PocketSphinx_state eq "build_dictionary") { if (done $p_sphinx) { &main::print_log ("PocketSphinx_Control:: run_sphinx") if $main::Debug{pocketsphinx}; $PocketSphinx_state = "run_sphinx"; + set_errlog $p_sphinx ""; + set_output $p_sphinx ""; } } } @@ -218,8 +195,9 @@ sub get_state { } sub reset_language_files { - unlink $sentence_file; - unlink "$sentence_file.bak"; + my ($self) = @_; + $PocketSphinx_state = "reset"; + $self->{disabled} = 0; } #============================================================================================ @@ -229,333 +207,82 @@ sub build_sentence_file { my ($sentence_file) = @_; #first write the sentence file open(OUTPUT,">$sentence_file"); - my @phrase_array = &Voice_Cmd::voice_items('mh','no_category'); + my @phrase_array = &Voice_Cmd::voice_items('mh','no_category'); + @phrase_array = sort(@phrase_array); foreach my $cmd (@phrase_array) { chomp $cmd; - $cmd = uc($cmd); + $cmd = lc($cmd); print OUTPUT " $cmd \n"; } close OUTPUT; } -#============================================================================================ -# BUILD DICTIONARY FILE -#============================================================================================ -sub build_dictionary { - my ($sentence_file,$cmu_dict,$dictionary_file) = @_; - - #read the big dictionary into memory - open (DICT,"$cmu_dict"); - my @dict; - while(){ - push(@dict,$_); - } - close (DICT); - - my @already_added; - #now look for prounciations in the big dictionary - open (DOUT,">$dictionary_file"); - open (DIN,"$sentence_file"); - while () { - chomp $_; - next unless $_ =~ /^ (.*) $/; - my $text=uc($1); - #added Nov 15 2003: Shane C. Masony - #if there are multiple words in the text(like a phrase), we need to add them - #so first, split by space, then make sure that these words have not been added - #because identicle entries cause a hash error when sphinx loads them - my @elements=split(" ",$text); - foreach my $thisword (@elements){ - my $exists_flag=0; - foreach my $existing_word (@already_added){ - if($thisword eq $existing_word){ - $exists_flag=1; - } - } - if(!$exists_flag){ - push(@already_added,$thisword); - foreach my $input (@dict){ - if($input =~ /^$thisword[\s|\(]/){ #match $text\s and $text( - $input =~ /^(\S*)\s*(.*)$/; - my $a = $1; - my $b = $2; - print DOUT "$a\t$b\n"; - } - } - } - } - } - close (DIN); - close (DOUT); -} - #============================================================================================ # BUILD LANGUAGE MODEL FILE #============================================================================================ - - -#/* ==================================================================== -# * Copyright (c) 1996-2002 Alexander I. Rudnicky and Carnegie Mellon University. -# * All rights reserved. -# * -# * Redistribution and use in source and binary forms, with or without -# * modification, are permitted provided that the following conditions -# * are met: -# * -# * 1. Redistributions of source code must retain the above copyright -# * notice, this list of conditions and the following disclaimer. -# * -# * 2. Redistributions in binary form must reproduce the above copyright -# * notice, this list of conditions and the following disclaimer in -# * the documentation and/or other materials provided with the -# * distribution. -# * -# * 3. All copies, used or distributed, must preserve the original wording of -# * the copyright notice included in the output file. -# * -# * This work was supported in part by funding from the Defense Advanced -# * Research Projects Agency and the CMU Sphinx Speech Consortium. -# * -# * THIS SOFTWARE IS PROVIDED BY CARNEGIE MELLON UNIVERSITY ``AS IS'' AND -# * ANY EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, -# * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -# * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY -# * NOR ITS EMPLOYEES BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -# * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -# * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -# * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -# * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -# * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -# * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -# * -# * ==================================================================== -# * -# */ - - -#Pretty Good Language Modeler, now with unigram vector augmentation! - -#The Pretty Good Language Modeler is intended for quick construction of small -#language models, typically as might be needed in application development. Depending -#on the version of Perl that you are running, a practical limitation is a -#maximum vocabulary size on the order of 1000-2000 words. The limiting factor -#is the number of n-grams observed, since each n-gram is stored as a hash key. -#(So smaller vocabularies may turn out to be a problem as well.) - -#This package computes a stadard back-off language model. It differs in one significant -#respect, which is the computation of the discount. We adopt a "proportional" (or ratio) -#discount in which a certain percentage of probability mass is removed (typically 50%) -#from observed n-grams and redistributed over unobserved n-grams. - -#Conventionally, an absolute discount would be used, however we have found that the -#proportional discount appears to be robust for extremely small languages, as might be -#prototyped by a developer, as opposed to based on a collected corpus. We have found that -#absolute and proportional discounts produce comparable recognition results with perhaps -#a slight advantage for proportional discounting. A more systematic investigation of -#this technique would be desirable. In any case it also has the virtue of using a very -#simple computation. - - - -# NOTE: this is by no means an efficient implementation and performance will -# deteriorate rapidly as a function of the corpus size. Larger corpora should be -# processed using the toolkit available at http://www.speech.cs.cmu.edu/SLM_info.html - -# [2feb96] (air) -# cobbles together a language model from a set of exemplar sentences. -# features: 1) uniform discounting, 2) no cutoffs -# the "+" version allows insertion of extra words into the 1gram vector - -# [27nov97] (air) -# bulletproof a bit for use in conjunction with a cgi script - -# [20000711] (air) -# made visible the discount parmeter - -# [20011123] (air) -# cleaned-up version for distribution - - -#[20021130] Shane C. Mason (me@perlbox.org) -#added structure for -o output filename switch +# 1) Prepare a reference text that will be used to generate the language model. +# The language model toolkit expects its input to be in the form of normalized text files, +# with utterances delimited by and tags. A number of input filters are available +# for specific corpora such as Switchboard, ISL and NIST meetings, and HUB5 transcripts. +# The result should be the set of sentences that are bounded by the start and end sentence +# markers: and . + +# Here's an example: +# generally cloudy today with scattered outbreaks of rain and drizzle persistent and heavy at times +# some dry intervals also with hazy sunshine especially in eastern parts in the morning +# highest temperatures nine to thirteen Celsius in a light or moderate mainly east south east breeze +# cloudy damp and misty today with spells of rain and drizzle in most places much of this rain will be +# light and patchy but heavier rain may develop in the west later +# +# 2) Generate the vocabulary file. This is a list of all the words in the file: +# text2wfreq < weather.txt | wfreq2vocab > weather.tmp.vocab +# +# 3) You may want to edit the vocabulary file to remove words (numbers, misspellings, names). +# If you find misspellings, it is a good idea to fix them in the input transcript. +# +# 4) If you want a closed vocabulary language model (a language model that has no provisions +# for unknown words), then you should remove sentences from your input transcript that contain +# words that are not in your vocabulary file. + +# 5) Generate the arpa format language model with the commands: +# % text2idngram -vocab weather.vocab -idngram weather.idngram < weather.closed.txt +# % idngram2lm -vocab_type 0 -idngram weather.idngram -vocab \ +# weather.vocab -arpa weather.arpa +# +# 6) Generate the CMU binary form (DMP) +# % sphinx_lm_convert -i weather.arpa -o weather.lm + +# /usr/local/bin/text2wfreq < current.sent | /usr/local/bin/wfreq2vocab > current.vocab +# text2idngram -vocab current.vocab -idngram current.idngram < current.sent +# /usr/local/bin/idngram2lm -vocab_type 0 -idngram current.idngram -vocab current.vocab -arpa current.arpa +# /usr/local/bin/sphinx_lm_convert -i current.arpa -o current.lm sub build_lm { # input parameters # quick_lm -s [-w ] [-d discount]\n"); } - my ($sentfile,$lm_file,$logfile,$wordfile,$discount) = @_; - - my $wflag; - my $discount_mass; - my $deflator; - my $sent_cnt; - my @word; - my %unigram; - my %alpha; - my %bialpha; - my %trigram; - my %bigram; - my $new; - my %uniprob; - my %biprob; - - $| = 1; # always flush buffers + my ($pgm_root,$data_root,$logfile) = @_; open(LOG,">$logfile"); - open(IN,"$sentfile") or die("can't open $sentfile!\n"); - if (defined $wordfile) { - open(WORDS,"$wordfile"); - $wflag = 1; - } else { - $wflag = 0; - } - - my $log10 = log(10.0); - - if (defined $discount) { - if (($discount<=0.0) or ($discount>=1.0)) { - print LOG "\discount value out of range: must be 0.0 < x < 1.0! ...using 0.5\n"; - $discount_mass = 0.5; # just use default - } else { - $discount_mass = $discount; - } - } else { - # Ben and Greg's experiments show that 0.5 is a way better default choice. - $discount_mass = 0.5; # Set a nominal discount... - } - $deflator = 1.0 - $discount_mass; - - # create count tables - $sent_cnt = 0; - while () { - s/^\s*//; s/\s*$//; - if ( $_ eq "" ) { next; } else { $sent_cnt++; } # skip empty lines - @word = split(/\s/); - my $j; - for ($j=0;$j<($#word-1);$j++) { - $trigram{join(" ",$word[$j],$word[$j+1],$word[$j+2])}++; - $bigram{ join(" ",$word[$j],$word[$j+1])}++; - $unigram{$word[$j]}++; - } - # finish up the bi and uni's at the end of the sentence... - $bigram{join(" ",$word[$j],$word[$j+1])}++; - $unigram{$word[$j]}++; - - $unigram{$word[$j+1]}++; - } - close(IN); - print LOG "$sent_cnt sentences found.\n"; - - # add in any words - if ($wflag) { - $new = 0; - my $read_in = 0; - while () { - s/^\s*//; s/\s*$//; - if ( $_ eq "" ) { next; } else { $read_in++; } # skip empty lines - if (! $unigram{$_}) { $unigram{$_} = 1; $new++; } - } - print LOG "tried to add $read_in word; $new were new words\n"; - close (WORDS); - } - if ( ($sent_cnt==0) && ($new==0) ) { - print LOG "no input?\n"; - exit; - } - open(LM,">$lm_file") or die("can't open $lm_file for output!\n"); #scm -changed to lm_file - - my $preface = ""; - $preface .= "Language model created by QuickLM for perlbox-voice on ".`date`; - $preface .= "Copyright (c) 1996-2002\nCarnegie Mellon University and Alexander I. Rudnicky\n\n"; - $preface .= "This model based on a corpus of $sent_cnt sentences and ".scalar (keys %unigram). " words\n"; - $preface .= "The (fixed) discount mass is $discount_mass\n\n"; - - # compute counts - my $unisum = 0; - my $uni_count = 0; - my $bi_count = 0; - my $tri_count = 0; - foreach my $x (keys(%unigram)) { $uni_count++; $unisum += $unigram{$x}; } - foreach my $x (keys(%bigram)) { $bi_count++; } - foreach my $x (keys(%trigram)) { $tri_count++; } - - print LM $preface; - print LM "\\data\\\n"; - print LM "ngram 1=$uni_count\n"; - if ( $bi_count > 0 ) { print LM "ngram 2=$bi_count\n"; } - if ( $tri_count > 0 ) { print LM "ngram 3=$tri_count\n"; } - print LM "\n"; - - # compute uni probs - foreach my $x (keys(%unigram)) { - $uniprob{$x} = ($unigram{$x}/$unisum) * $deflator; - } + my $cmd = "$pgm_root/text2wfreq < $data_root.sent | $pgm_root/wfreq2vocab > $data_root.vocab"; + print LOG "$cmd\n"; + system $cmd; - # compute alphas - foreach my $y (keys(%unigram)) { - my $w1 = $y; - my $sum_denom = 0.0; - foreach my $x (keys(%bigram)) { - if ( substr($x,0,rindex($x," ")) eq $w1 ) { - my $w2 = substr($x,index($x," ")+1); - $sum_denom += $uniprob{$w2}; - } - } - $alpha{$w1} = $discount_mass / (1.0 - $sum_denom); - } + $cmd = "$pgm_root/text2idngram -vocab $data_root.vocab -idngram $data_root.idngram < $data_root.sent"; + print LOG "$cmd\n"; + system $cmd; - print LM "\\1-grams:\n"; - foreach my $x (sort keys(%unigram)) { - printf LM "%6.4f %s %6.4f\n", log($uniprob{$x})/$log10, $x, log($alpha{$x})/$log10; - } - print LM "\n"; - - #compute bi probs - foreach my $x (keys(%bigram)) { - my $w1 = substr($x,0,rindex($x," ")); - $biprob{$x} = ($bigram{$x}*$deflator)/$unigram{$w1}; - } + $cmd = "$pgm_root/idngram2lm -vocab_type 0 -idngram $data_root.idngram -vocab $data_root.vocab -arpa $data_root.arpa"; + print LOG "$cmd\n"; + system $cmd; - #compute bialphas - foreach my $x (keys(%bigram)) { - my $w1w2 = $x; - my $sum_denom = 0.0; - foreach my $y (keys(%trigram)) { - if (substr($y,0,rindex($y," ")) eq $w1w2 ) { - my $w2w3 = substr($y,index($y," ")+1); - $sum_denom += $biprob{$w2w3}; - } - } - $bialpha{$w1w2} = $discount_mass / (1.0 - $sum_denom); - } - - # output the bigrams and trigrams (now that we have the alphas computed). - if ( $bi_count > 0 ) { - print LM "\\2-grams:\n"; - foreach my $x (sort keys(%bigram)) { - printf LM "%6.4f %s %6.4f\n", - log($biprob{$x})/$log10, $x, log($bialpha{$x})/$log10; - } - print LM "\n"; - } - - if ($tri_count > 0 ) { - print LM "\\3-grams:\n"; - foreach my $x (sort keys(%trigram)) { - my $w1w2 = substr($x,0,rindex($x," ")); - printf LM "%6.4f %s\n", - log(($trigram{$x}*$deflator)/$bigram{$w1w2})/$log10, $x; - } - print LM "\n"; - } + $cmd = "$pgm_root/sphinx_lm_convert -i $data_root.arpa -o $data_root.lm.DMP"; + print LOG "$cmd\n"; + system $cmd; - print LM "\\end\\\n"; - close(LM); + close (LOG); - print LOG "Language model completed at ",scalar localtime(),"\n"; - - return "build_lm:: complete"; } package PocketSphinx_Listener; @@ -606,15 +333,15 @@ sub new my $friendly_name = "PocketSphinx_Listener_p_sphinx_$device"; &main::store_object_data($self->{p_sphinx}, 'Process_Item', $friendly_name, $friendly_name); $self->{t_crash_timer} = new Timer; + $self->{t_speak_timer} = new Timer; # file names from the Control portion $self->{log_file} = "$main::config_parms{data_dir}/pocketsphinx/pocketsphinx"; $self->{sentence_file} = "$main::config_parms{data_dir}/pocketsphinx/current.sent"; - $self->{lm_file} = "$main::config_parms{data_dir}/pocketsphinx/current.lm"; - $self->{dictionary_file} = "$main::config_parms{data_dir}/pocketsphinx/current.dic"; + $self->{lm_file} = "$main::config_parms{data_dir}/pocketsphinx/current.lm.DMP"; # run parameters - $self->{hmm_file} = "/usr/local/share/pocketsphinx/model/hmm/wsj1"; + $self->{hmm_file} = "/usr/local/share/pocketsphinx/model/hmm/en_US/hub4wsj_sc_8k"; $self->{continuous} = "/usr/local/bin/pocketsphinx_continuous"; $self->{host} = "localhost"; $self->{port} = 3235; @@ -627,10 +354,22 @@ sub new $self->{crash_cnt} = 0; &::MainLoop_pre_add_hook(\&PocketSphinx_Listener::state_machine,undef,$self); &::Reload_pre_add_hook(\&PocketSphinx_Listener::restart,undef,$self); + &::Speak_parms_add_hook(\&PocketSphinx_Listener::speak, 0); return $self; } +# Set functions +sub set_hmm_file { + my ($self,$file) = @_; + $self->{hmm_file} = $file if -e $file; +} + +sub set_sample_rate { + my ($self,$sample_rate) = @_; + $self->{sample_rate} = $sample_rate; +} + # Trim leading and trailing spaces sub _trim { my $string = shift; @@ -672,6 +411,38 @@ sub restart { $self->{p_sphinx}->stop( ); } +# Update speak parameters based upon context +sub speak { + my ($self,$parms_ref) = @_; + &main::print_log ("PocketSphinx_Listener::speak called!!") if $main::Debug{pocketsphinx}; + my @rooms = split ',', lc $parms_ref->{rooms}; + foreach my $room (@rooms) { + &main::print_log ("PocketSphinx_Listener::speak room: $room\n"); + } + if (exists $self->{speak_room} ) { + if ( !$self->{t_crash_timer}->active( ) ) { + delete $self->{speak_room}; + } else { + push @rooms, $self->{speak_room}; + $parms_ref->{rooms} = join ",",@rooms; + my @rooms = split ',', lc $parms_ref->{rooms}; + foreach my $room (@rooms) { + &main::print_log ("PocketSphinx_Listener::speak room: $room\n") if $main::Debug{pocketsphinx}; + } + $self->{t_speak_timer}->set(60); + } + } +} + +# Define the speaking room +sub set_speak_room { + my ($self,$room) = @_; + $self->{speak_room} = $room; + &main::print_log ("PocketSphinx_Listener::set_speak_room room: $room\n") if $main::Debug{pocketsphinx}; + $self->{t_speak_timer}->set(60); +} + + # Allow the listener to startup on the next pass of the state_machine maintenance thread. sub start_listener { my ($self) = @_; @@ -724,7 +495,6 @@ sub state_machine { "-log_file $self->{log_file}", "-sent_file $self->{sentence_file}", "-lm_file $self->{lm_file}", - "-dict_file $self->{dictionary_file}", "-hmm_file $self->{hmm_file}", "-program $self->{continuous}", "-device $self->{device}", From 72f5da6085cd1e0a18f184edd658742ebf9b9adf Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 12 Mar 2012 11:20:49 +0000 Subject: [PATCH 137/150] Catch the possibility of a corrupted message in the cleanup message handler of on_standard_insteon_received. --- lib/Insteon/BaseInterface.pm | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/lib/Insteon/BaseInterface.pm b/lib/Insteon/BaseInterface.pm index 948384bf2..01b324a6d 100755 --- a/lib/Insteon/BaseInterface.pm +++ b/lib/Insteon/BaseInterface.pm @@ -375,16 +375,25 @@ sub on_standard_insteon_received elsif ($msg{type} eq 'cleanup') { $object = &Insteon::get_object('000000', $msg{extra}); - my %cleanup_msg = ('type' => 'cleanup', + if ($object) + { + my %cleanup_msg = ('type' => 'cleanup', 'group' => $msg{extra}, 'is_ack' => 1, 'command' => 'cleanup' ); - # prevent re-processing transmit queue until after clearing occurs - $self->transmit_in_progress(1); - # ask the object to process the received message and update its state - $object->_process_message($self, %cleanup_msg); - $self->clear_active_message(); + # prevent re-processing transmit queue until after clearing occurs + $self->transmit_in_progress(1); + # ask the object to process the received message and update its state + $object->_process_message($self, %cleanup_msg); + $self->clear_active_message(); + } + else + { + &main::print_log("[Insteon::BaseInterface] ERROR: received cleanup message " + . "that does not correspond to a valid PLM group. Corrupted message is assumed " + . "and will be skipped!"); + } } else { From 21b9d4ad338a71f9c6f614d140a7613012cb2bbe Mon Sep 17 00:00:00 2001 From: gliming Date: Mon, 12 Mar 2012 18:32:27 +0000 Subject: [PATCH 138/150] Ensure that check on active_message->command_type only occurs if it is an InsteonMessage. --- lib/Insteon_PLM.pm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Insteon_PLM.pm b/lib/Insteon_PLM.pm index 49a3f7717..52c2e097b 100644 --- a/lib/Insteon_PLM.pm +++ b/lib/Insteon_PLM.pm @@ -640,7 +640,8 @@ sub _parse_data { # attempt to process the message by the link object; this acknowledgement will reset # the auto-retry timer - if ($self->active_message && ($self->active_message->command_type == 'all_link_send')) + if ($self->active_message && $self->active_message->isa('Insteon::InsteonMessage') + &&($self->active_message->command_type == 'all_link_send')) { my $group = substr($self->active_message->interface_data,0,2); my $link = &Insteon::get_object('000000',$group); @@ -651,7 +652,7 @@ sub _parse_data { 'is_ack' => 1, 'command' => 'cleanup' ); - $link->_process_message($self, %msg); + $link->_process_message($self, %msg); } # only clear the active message if this all_link_clean_status corresponds to a all_link_send message $self->clear_active_message(); From 3b02fb1c9df8264603212b8d69807697309b37b1 Mon Sep 17 00:00:00 2001 From: jduda Date: Sat, 17 Mar 2012 14:45:38 +0000 Subject: [PATCH 139/150] Repair various bugs which can caused lights to remain stuck on at times. --- lib/Door_Item.pm | 2 +- lib/Light_Item.pm | 279 ++++++++++++++++++++-------------------- lib/Motion_Item.pm | 4 +- lib/Presence_Monitor.pm | 54 +++++--- 4 files changed, 177 insertions(+), 162 deletions(-) diff --git a/lib/Door_Item.pm b/lib/Door_Item.pm index 145a3028a..21e643c89 100644 --- a/lib/Door_Item.pm +++ b/lib/Door_Item.pm @@ -152,7 +152,7 @@ sub set } $p_state = 'check'; } elsif ($p_state eq 'closed') { - $$self{m_timerAlarm}->stop(); + $$self{m_timerAlarm}->unset(); $$self{last_closed} = $::Time; } } diff --git a/lib/Light_Item.pm b/lib/Light_Item.pm index e01093fef..5f9e8479c 100644 --- a/lib/Light_Item.pm +++ b/lib/Light_Item.pm @@ -172,74 +172,76 @@ sub initialize $$self{m_always_set_state} = 1; # the default is to set state regardless of change $$self{m_restrict_off} = 0; # disable light restrictions items from preventing off states $$self{m_save_state} = 0; # allow states to be restored across restarts + $$self{debug} = $main::Debug{light_item}; # defined possible states @{$$self{states}} = ('on','off'); } +sub set_debug { + my ($self, $debug) = @_; + $self->{debug} = $debug; +} -sub set -{ - my ($self,$p_state,$p_setby,$p_respond) = @_; +sub set { + my ($self,$p_state,$p_setby,$p_respond) = @_; ############################################################################ ## NEW Redesign ############################################################################ - my $l_event_state=undef; - my $l_handler_state=undef; - my $l_final_state=undef; - my $l_temp_state=undef; - - $p_state=lc($p_state); - - ### prevent reciprocal sets ### - return if (ref $p_setby and $p_setby->can('get_set_by') and $p_setby->{set_by} eq $self); - - ### allow "automatic resume from manual" if a timer has been set - if ((ref $p_setby) && ($p_setby eq $$self{m_manualTimer})) { - # reset the current state to what is in $$self{_automation_state} ??? - if ((($self->state eq 'off') and $$self{m_manual_auto_off}) or - (($self->state ne 'off') and $$self{m_manual_auto_on})) { - if ($self->allow_set_state($$self{_automation_state}, $p_setby)) { - &::print_log("Light_Item($$self{object_name}):: manual state reverting to tracked state: " - . "$$self{_automation_state}") if $main::Debug{light_item}; - - $self->SUPER::set($$self{_automation_state},$p_setby,$p_respond); - } else { - &::print_log("Light_Item($$self{object_name}):: resuming from manual to automatic mode") if $main::Debug{light_item}; - } - } else { - &::print_log("Light_Item($$self{object_name}):: resuming from manual to automatic mode") if $main::Debug{light_item}; - } - - $self->manual(0); - $$self{m_manualTimer}->unset(); + my $l_event_state=undef; + my $l_handler_state=undef; + my $l_final_state=undef; + my $l_temp_state=undef; + + $p_state=lc($p_state); + + ### prevent reciprocal sets ### + return if (ref $p_setby and $p_setby->can('get_set_by') and $p_setby->{set_by} eq $self); + + ### allow "automatic resume from manual" if a timer has been set + if ((ref $p_setby) && ($p_setby eq $$self{m_manualTimer})) { + # reset the current state to what is in $$self{_automation_state} ??? + if ((($self->state eq 'off') and $$self{m_manual_auto_off}) or + (($self->state ne 'off') and $$self{m_manual_auto_on})) { + if ($self->allow_set_state($$self{_automation_state}, $p_setby)) { + &::print_log("Light_Item($$self{object_name}):: manual state reverting to tracked state: " + . "$$self{_automation_state}") if $self->{debug}; + $self->SUPER::set($$self{_automation_state},$p_setby,$p_respond); + } else { + &::print_log("Light_Item($$self{object_name}):: resuming from manual to automatic mode") if $self->{debug}; + } + } else { + &::print_log("Light_Item($$self{object_name}):: resuming from manual to automatic mode") if $self->{debug}; + } - return; - } + $self->manual(0); + $$self{m_manualTimer}->unset(); + return; + } - ### Manual shutoff (unless set by the manually controlled light) ### + ### Manual shutoff (unless set by the manually controlled light) ### # return if ($self->manual() && !((ref $p_setby) && (ref $self->manual) && ($self->manual eq $p_setby))); ######### EVENTS - #Determine what type of event this is ON/OFF - if ($self->is_on_event($p_state,$p_setby)) { - $l_event_state='on'; - } elsif ($self->is_off_event($p_state,$p_setby)) { - $l_event_state='off'; - } + #Determine what type of event this is ON/OFF + if ($self->is_on_event($p_state,$p_setby)) { + $l_event_state='on'; + } elsif ($self->is_off_event($p_state,$p_setby)) { + $l_event_state='off'; + } if ($self->manual && ((ref $p_setby) && (ref $self->manual) && ($self->manual eq $p_setby))) { - if ($l_event_state eq 'on') { - if ($p_state=~/^[+-]?\d?\d\%?/ or $p_state=~/^[+]?100\%?/) { - #Someone wants a pre-set dim or dimmed state - $l_final_state = $p_state; - } else { - $l_final_state = 'on'; - } - } elsif ($l_event_state eq 'off') { - $l_final_state = 'off'; - } + if ($l_event_state eq 'on') { + if ($p_state=~/^[+-]?\d?\d\%?/ or $p_state=~/^[+]?100\%?/) { + #Someone wants a pre-set dim or dimmed state + $l_final_state = $p_state; + } else { + $l_final_state = 'on'; + } + } elsif ($l_event_state eq 'off') { + $l_final_state = 'off'; + } } else { ######### HANDLERS #IDLE Handler @@ -253,7 +255,7 @@ sub set $l_temp_state = $self->do_on_delay($p_state,$p_setby,$l_event_state); $l_handler_state = $self->get_handler_state($l_temp_state,$l_event_state,$l_handler_state); - #Delay OFF handler + #Delay OFF handler $l_temp_state = $self->do_off_delay($p_state,$p_setby,$l_event_state); $l_handler_state = $self->get_handler_state($l_temp_state,$l_event_state,$l_handler_state); @@ -262,48 +264,48 @@ sub set $l_handler_state = $self->get_handler_state($l_temp_state,$l_event_state,$l_handler_state); -######### RESTRICTIONS + ######### RESTRICTIONS # Apply restrictions # ON if (defined($l_handler_state) and $l_handler_state ne 'off') { #If we are on - if ($self->is_on_restriction($p_state,$p_setby) and !($self->manual)) { #if there is a restriction in place, dont do it - $l_final_state = undef; + if ($self->is_on_restriction($p_state,$p_setby) and !($self->manual)) { #if there is a restriction in place, dont do it + $l_final_state = undef; + } else { + if ($l_event_state ne $l_handler_state) { #If a handler modified the state, then use it instead + $l_final_state = $l_handler_state; + } elsif ($p_state=~/^[+-]?\d?\d\%?/ or $p_state=~/^[+]?100\%?/) { + #Someone wants a pre-set dim or dimmed state + $l_final_state = $p_state; } else { - if ($l_event_state ne $l_handler_state) { #If a handler modified the state, then use it instead - $l_final_state = $l_handler_state; - } elsif ($p_state=~/^[+-]?\d?\d\%?/ or $p_state=~/^[+]?100\%?/) { - #Someone wants a pre-set dim or dimmed state - $l_final_state = $p_state; - } else { - $l_final_state = $self->set_on_state(); - } + $l_final_state = $self->set_on_state(); } + } } # OFF if (defined($l_handler_state) and $l_handler_state eq 'off') { #If we are off - if ($self->is_off_restriction($p_state,$p_setby) ) { #if there is a restriction in place, dont do it - $l_final_state = undef; - } else { - $l_final_state = $l_handler_state; - } + if ($self->is_off_restriction($p_state,$p_setby) ) { #if there is a restriction in place, dont do it + $l_final_state = undef; + } else { + $l_final_state = $l_handler_state; + } } ######## MAINTAIN STATE ### - if (defined($l_final_state)) { - $$self{_automation_state} = $l_final_state; - if ($self->manual) { - $l_final_state = undef; # don't set state if manual - } - } + if (defined($l_final_state)) { + $$self{_automation_state} = $l_final_state; + if ($self->manual) { + $l_final_state = undef; # don't set state if manual + } + } } if (defined($l_final_state)) { if ($self->allow_set_state($l_final_state, $p_setby)) { ######### LOG ############## - &::print_log("Light_Item($$self{object_name}):: State->$p_state Event->$l_event_state Handler->$l_handler_state Final->$l_final_state DelayOff->" . $$self{m_timerOff}->active() . " Setby->$p_setby (" . ( ref($p_setby) ? $$p_setby{object_name} :'') . ")") if $main::Debug{light_item}; + &::print_log("Light_Item($$self{object_name}):: State->$p_state Event->$l_event_state Handler->$l_handler_state Final->$l_final_state DelayOff->" . $$self{m_timerOff}->active() . " Setby->$p_setby (" . ( ref($p_setby) ? $$p_setby{object_name} :'') . ")") if $self->{debug}; ######### SET LIGHT STATE ############## - $self->SUPER::set($l_final_state,$p_setby,$p_respond); + $self->SUPER::set($l_final_state,$p_setby,$p_respond); } } } @@ -387,7 +389,7 @@ sub do_X10_sync if ($self->x10_sync() and $p_event_state eq 'off') { #if we have a qualified attempt to turn off if ( ! $$self{m_timerOff}->active() ) { #if the off timer isnt already running $$self{m_timerSync}->set($$self{m_timerSyncTime} + (rand() * $$self{m_timerSyncTime}), $self); #sync non-status reporting light status -# &::print_log("$$self{object_name}:X10Sync Start"); + &::print_log("$$self{object_name}:X10Sync Start") if $self->{debug}; } elsif ($p_setby eq $$self{m_timerSync}) { #If delay_off timer is running and this is a Sync Event $p_event_state=undef; } @@ -419,55 +421,55 @@ sub do_on_delay sub do_off_delay { - my ($self,$p_state,$p_setby,$p_event_state) = @_; - my $l_delay; - - $l_delay = $self->get_off_delay_effective($p_state,$p_setby); -# &::print_log("Delay$$self{object_name}:$l_delay"); - if ($l_delay >0 ) { #Delay off is enabled - #ON EVENT - if ($p_event_state eq 'on') { - #These are considered "Temporary" ON state sets - if (defined($p_setby) and ( $p_setby->isa('Motion_Item') or - ($p_setby->isa('Presence_Monitor') and $p_state eq 'predict') )) { #These are subject to a delay off timer upon turning on (temporary state) - if (! $self->is_somebody_present($p_setby,$p_state)) { #only start the timer if no one is here -# &::print_log("$$self{object_name}:Delay Start:$l_delay"); - $$self{m_timerOff}->set($l_delay, $self); - } else { #stop the timer if this is true - $$self{m_timerOff}->stop(); -# &::print_log("$$self{object_name}:Delay Stop:$l_delay"); - } - } elsif (defined($p_setby) and $p_setby eq $$self{m_idleTimer} ) { - #Ignore the Idle timer, it never causes a delay - } else { - # All other device states can turn on and stay on - #stop a delay off timer on any other device set -# &::print_log("$$self{object_name}:Delay Stop:$l_delay"); - $$self{m_timerOff}->stop(); - } - ### OFF EVENT - } elsif ($p_event_state eq 'off') { - if (defined($p_setby) and - ($p_setby->isa('Motion_Item') or - $p_setby->isa('Presence_Monitor') or - $p_setby->isa('Photocell_Item') or - $p_setby->isa('Door_Item') ) ) { # Do not immediately turn off for these devices. Qualify for delay override - if (! $self->is_somebody_present($p_setby,$p_state) ) { - if (!$$self{m_timerOn}->active()) { #only reset if we arent previously running -# &::print_log("$$self{object_name}:Delay Start:$l_delay"); - $$self{m_timerOff}->set($l_delay, $self); - } - } else { #stop the timer if someone is here -# &::print_log("$$self{object_name}:Delay Stop:$l_delay"); - $$self{m_timerOff}->stop(); - } - $p_event_state=undef; - } + my ($self,$p_state,$p_setby,$p_event_state) = @_; + my $l_delay; + + $l_delay = $self->get_off_delay_effective($p_state,$p_setby); + &::print_log("do_off_delay:$$self{object_name}:$l_delay") if $self->{debug}; + if ($l_delay >0 ) { #Delay off is enabled + #ON EVENT + if ($p_event_state eq 'on') { + #These are considered "Temporary" ON state sets + if (defined($p_setby) and ( $p_setby->isa('Motion_Item') or + ($p_setby->isa('Presence_Monitor') and $p_state eq 'predict') )) { #These are subject to a delay off timer upon turning on (temporary state) + if (! $self->is_somebody_present($p_setby,$p_state)) { #only start the timer if no one is here + &::print_log("$$self{object_name}:Delay Start:$l_delay") if $self->{debug}; + $$self{m_timerOff}->set($l_delay, $self); + } else { #stop the timer if this is true + $$self{m_timerOff}->unset(); + &::print_log("$$self{object_name}:Delay Stop:$l_delay") if $self->{debug}; } - + } elsif (defined($p_setby) and $p_setby eq $$self{m_idleTimer} ) { + #Ignore the Idle timer, it never causes a delay + } else { + # All other device states can turn on and stay on + #stop a delay off timer on any other device set + &::print_log("$$self{object_name}:Delay Stop:$l_delay") if $self->{debug}; + $$self{m_timerOff}->unset(); + } + ### OFF EVENT + } elsif ($p_event_state eq 'off') { + if (defined($p_setby) and + ($p_setby->isa('Motion_Item') or + $p_setby->isa('Presence_Monitor') or + $p_setby->isa('Photocell_Item') or + $p_setby->isa('Door_Item') ) ) { # Do not immediately turn off for these devices. Qualify for delay override + if (! $self->is_somebody_present($p_setby,$p_state) ) { + if (!$$self{m_timerOn}->active()) { #only reset if we arent previously running + &::print_log("$$self{object_name}:Delay Start:$l_delay") if $self->{debug}; + $$self{m_timerOff}->set($l_delay, $self); + } + } else { #stop the timer if someone is here + &::print_log("$$self{object_name}:Delay Stop:$l_delay") if $self->{debug}; + $$self{m_timerOff}->unset(); + } + $p_event_state=undef; + } } -# &::print_log("Delayout:$p_event_state"); - return $p_event_state; + + } + &::print_log("$$self{object_name}:Delayout:$p_event_state") if $self->{debug}; + return $p_event_state; } sub do_idle @@ -505,7 +507,7 @@ sub is_on_event if ($p_state eq 'occupied' ) { $l_qualified=1; } if ($p_state eq 'predict' and $self->predict() ) { $l_qualified=1; } } elsif ($p_setby->isa('Light_Restriction_Item') ) { - if ($p_state eq 'light_ok' ) { $l_qualified=1; } + if (($p_state eq 'light_ok' ) && ($self->is_somebody_present($p_setby, $p_state))) { $l_qualified=1; } } elsif ($p_setby->isa('Photocell_Item') ) { #Photocell only triggers an ON event if there are no other devices attached if ($p_state eq 'dark' ) { if ( !(defined $self->find_members('Motion_Item') or @@ -540,7 +542,7 @@ sub is_on_restriction my ($self,$p_state,$p_setby) = @_; my $setby_conduit = &main::set_by_to_target($p_setby); if ( ( $setby_conduit =~ /^serial|xpl|xap|web|telnet/i ) or ($main::Reload and ( $p_setby eq 'init' ) ) ) { - print "No on restrictions permitted when set by non-automation device\n" if $main::Debug{occupancy}; + &::print_log ("$$self{object_name}:No on restrictions permitted when set by non-automation device\n") if $self->{debug}; return 0; } my $l_qualified=0; @@ -552,8 +554,8 @@ sub is_on_restriction if ( defined($p_setby) ) { #Automatic on events are no allowed to shutoff lights if someone is here if ( $p_setby->isa('Light_Restriction_Item') ) { - if ( ! ($self->is_somebody_present($p_setby, $p_state) ) ) { #If someone is in the room, allow the light on! - $l_qualified=1; + if ( ($self->is_somebody_present($p_setby, $p_state) ) ) { #If someone is in the room, allow the light on! + $l_qualified=1; } } } @@ -609,7 +611,7 @@ sub is_off_event $p_state eq 'off' and !$$self{m_timerSync}->active()) { $l_qualified = 1; -# &::print_log("$$self{object_name}:X10syncEnd:Off"); + &::print_log("$$self{object_name}:X10syncEnd:Off") if $self->{debug}; } } elsif ($p_setby eq $$self{m_timerOn} ) { #Does not apply $l_qualified=0; @@ -632,7 +634,7 @@ sub is_off_restriction my ($self,$p_state,$p_setby) = @_; my $setby_conduit = &main::set_by_to_target($p_setby); if ( ( $setby_conduit =~ /^serial|xpl|xap|web|telnet/i ) or ($main::Reload and ( $p_setby eq 'init' ) ) ) { - &::print_log("No off restrictions permitted when set by non-automation device ($setby_conduit)") if $main::Debug{light_item}; + &::print_log("$$self{object_name}:No off restrictions permitted when set by non-automation device ($setby_conduit)") if $self->{debug}; return 0; } my $l_qualified=0; @@ -667,14 +669,14 @@ sub is_change_allowed { my @l_objects; @l_objects = $self->find_members('Light_Restriction_Item'); for my $obj (@l_objects) { - &::print_log("Light_Item($$self{object_name}): Light_Restriction_Item $$obj{object_name}: " . $obj->state()) if $main::Debug{occupancy}; + &::print_log("Light_Item($$self{object_name}): Light_Restriction_Item $$obj{object_name}: " . $obj->state()) if $self->{debug}; if ($obj->state() eq 'no_light') { return 0; } } # Only return 1 if no restrictions are active *and* no lock is pending if ($$self{m_pending_lock}) { - &::print_log("Light_Item($$self{object_name}): not allowing on because of pending lock") if $main::Debug{occupancy}; + &::print_log("Light_Item($$self{object_name}): not allowing on because of pending lock") if $self->{debug}; return 0; } else { return 1; @@ -732,14 +734,14 @@ sub predict { my ($self,$p_blnPredict) = @_; $$self{m_predict} = $p_blnPredict if defined $p_blnPredict; -# &::print_log("InPredict:" . $$self{object_name} . ":" . $p_blnPredict . ":" . $$self{m_predict}); + &::print_log("InPredict:" . $$self{object_name} . ":" . $p_blnPredict . ":" . $$self{m_predict}) if $self->{debug}; return $$self{m_predict}; } sub set_on_state { my ($self,$p_strOnState) = @_; -# &::print_log("set_on_state($self, $p_strOnState)"); + &::print_log("$$self{object_name}:set_on_state($self, $p_strOnState)") if $self->{debug}; $$self{m_on_state} = $p_strOnState if defined $p_strOnState; return $$self{m_on_state}; } @@ -791,11 +793,11 @@ sub manual { $$self{m_manualTimer}->unset(); if (($self->state eq 'off') or ($self->state eq '') or ($self->state eq '0%')) { &::print_log("Light_Item($$self{object_name}):: setting mode to manual (off)" - . (($$self{m_manual_auto_off}) ? "[auto]" : "") . "; reverting in $offTime seconds") if $main::Debug{light_item}; + . (($$self{m_manual_auto_off}) ? "[auto]" : "") . "; reverting in $offTime seconds") if $self->{debug}; $$self{m_manualTimer}->set($offTime, $self); } else { &::print_log("Light_Item($$self{object_name}):: setting mode to manual (on)" - . (($$self{m_manual_auto_on}) ? "[auto]" : "") . "; reverting in $onTime seconds") if $main::Debug{light_item}; + . (($$self{m_manual_auto_on}) ? "[auto]" : "") . "; reverting in $onTime seconds") if $self->{debug}; $$self{m_manualTimer}->set($onTime, $self); } } @@ -825,7 +827,7 @@ sub x10_sync my ($self,$p_blnSync) = @_; $$self{m_sync} = $p_blnSync if defined $p_blnSync; if (! $$self{m_sync}) { - $$self{m_timerSync}->stop(); + $$self{m_timerSync}->unset(); } return $$self{m_sync}; } @@ -851,6 +853,7 @@ sub start_delay_off { return; } } + sub restore_string { my ($self) = @_; @@ -860,7 +863,7 @@ sub restore_string if ($$self{m_save_state}) { $l_restore_string = $self->SUPER::restore_string; $l_restore_string =~ s/-\>{state}=(.*);/-\>{state}='off'/ig; - #&::print_log("Restore:::$l_restore_string:"); + #&::print_log("Restore:::$l_restore_string:") if $self->{debug}; } return $l_restore_string; diff --git a/lib/Motion_Item.pm b/lib/Motion_Item.pm index a09716bc0..eb2cc81f5 100644 --- a/lib/Motion_Item.pm +++ b/lib/Motion_Item.pm @@ -121,7 +121,7 @@ sub set } elsif ($p_setby eq $$self{m_timeout}) { # Timer expired $p_state='still'; } elsif ($p_state eq 'still') { # Motion OFF - $$self{m_timeout}->stop() if defined $$self{m_timeout} + $$self{m_timeout}->unset() if defined $$self{m_timeout} } $self->SUPER::set($p_state, $p_setby); } @@ -142,4 +142,4 @@ sub set_inactivity_alarm($$$) { $$self{m_timerCheck}->set($time*3600, $self); } -1; \ No newline at end of file +1; diff --git a/lib/Presence_Monitor.pm b/lib/Presence_Monitor.pm index 018d2bff6..967067715 100644 --- a/lib/Presence_Monitor.pm +++ b/lib/Presence_Monitor.pm @@ -101,10 +101,16 @@ sub new $$self{m_timerCancelPredict} = new Timer(); $$self{m_timerOccupancyExpire} = new Timer(); $$self{state}=0; - $$self{m_occupancy_expire} = 0; + $$self{m_occupancy_expire} = 0; + $$self{debug} = $main::Debug{presence}; return $self; } +sub set_debug { + my ($self, $debug) = @_; + $self->{debug} = $debug; +} + sub handle_presence { my ($self) = @_; # Return if already occupied @@ -112,7 +118,7 @@ sub handle_presence { foreach my $action (keys %{$$self{'vacancy_timers'}}) { foreach my $time (keys %{$$self{'vacancy_timers'}{$action}}) { if ($$self{'vacancy_timers'}{$action}{$time}{'timer'}->active()) { - $$self{'vacancy_timers'}{$action}{$time}{'timer'}->stop(); + $$self{'vacancy_timers'}{$action}{$time}{'timer'}->unset(); } } } @@ -132,7 +138,7 @@ sub handle_vacancy { foreach my $action (keys %{$$self{'presence_timers'}}) { foreach my $time (keys %{$$self{'presence_timers'}{$action}}) { if ($$self{'presence_timers'}{$action}{$time}{'timer'}->active()) { - $$self{'presence_timers'}{$action}{$time}{'timer'}->stop(); + $$self{'presence_timers'}{$action}{$time}{'timer'}->unset(); } } } @@ -151,18 +157,24 @@ sub process_count { if ($l_count < 0 and ($self->state() eq 'occupied' or $self->state() eq 'vacant')) { #start the timer for prediction $$self{m_timerCancelPredict}->set(60, $self); + # $$self{m_timerOccupancyExpire}->unset( ); + &::print_log("$$self{object_name}: predict timer set 60, marking room as predict") if $self->{debug}; $p_state = 'predict'; } elsif ($l_count >= 1) { $p_state = 'occupied'; - $$self{m_timerCancelPredict}->stop(); - if (defined $$self{m_occupancy_expire} && ref $p_setby && ref $p_setby->get_set_by - && $p_setby->get_set_by eq $$self{m_obj} && $$self{m_obj}->state eq 'motion') { + $$self{m_timerCancelPredict}->unset(); + if (defined $$self{m_occupancy_expire} and $$self{m_obj}->state =~ /(motion|open)/i) { +# and ref $p_setby and ref $p_setby->get_set_by and $p_setby->get_set_by eq $$self{m_obj} $$self{m_timerOccupancyExpire}->set($$self{m_occupancy_expire}, $self); + &::print_log("$$self{object_name}: occupancy timer set $$self{m_occupancy_expire}, marking room as occupied") if $self->{debug}; } elsif (!(defined $$self{m_occupancy_expire})) { - $$self{m_timerOccupancyExpire}->stop(); + $$self{m_timerOccupancyExpire}->unset(); } $self->handle_presence(); - } elsif ($l_count == 0 or $l_count eq '' or (($l_count > 0) and ($l_count < 1))) { + } elsif ( ($l_count == 0 or $l_count eq '' or (($l_count > 0) and ($l_count < 1))) and + !$$self{m_timerCancelPredict}->active and + !$$self{m_timerOccupancyExpire}->active) { + &::print_log("$$self{object_name}: room count ($l_count) zero, marking room as vacant") if $self->{debug}; $p_state = 'vacant'; $self->handle_vacancy(); } elsif ($l_count == -1) { @@ -181,7 +193,7 @@ sub add_presence_timer { sub remove_presence_timer { my ($self, $time, $action) = @_; if ($$self{'presence_timers'} and $$self{'presence_timers'}{$action} and $$self{'presence_timers'}{$action}{$time}) { - $$self{'presence_timers'}{$action}{$time}{'timer'}->stop(); + $$self{'presence_timers'}{$action}{$time}{'timer'}->unset(); delete $$self{'presence_timers'}{$action}{$time}; unless (keys %{$$self{'presence_timers'}{$action}}) { delete $$self{'presence_timers'}{$action}; @@ -200,7 +212,7 @@ sub add_vacancy_timer { sub remove_vacancy_timer { my ($self, $time, $action) = @_; if ($$self{'vacancy_timers'} and $$self{'vacancy_timers'}{$action} and $$self{'vacancy_timers'}{$action}{$time}) { - $$self{'vacancy_timers'}{$action}{$time}{'timer'}->stop(); + $$self{'vacancy_timers'}{$action}{$time}{'timer'}->unset(); delete $$self{'vacancy_timers'}{$action}{$time}; unless (keys %{$$self{'vacancy_timers'}{$action}}) { delete $$self{'vacancy_timers'}{$action}; @@ -219,26 +231,26 @@ sub set #Timer expired. Reset predict state if ($p_setby eq $$self{m_timerCancelPredict} and $self->state() eq 'predict') { #timer up reset if ($$self{m_OM}->sensor_count($$self{m_obj}) eq -1) { - #&::print_log("$$self{object_name}: prediction timer expired, marking room as vacant"); + &::print_log("$$self{object_name}: prediction timer expired, marking room as vacant") if $self->{debug}; $$self{m_OM}->sensor_count($$self{m_obj}, 0); $p_state = 'vacant'; - $self->handle_vacancy(); + $self->handle_vacancy(); } else { $p_state = undef; } } elsif ($p_setby eq $$self{m_timerOccupancyExpire} and $self->state() eq 'occupied') { #timer up $p_state = 'vacant'; - $$self{m_OM}->sensor_count($$self{m_obj}, 0); - #&::print_log("$$self{object_name}: occupancy timer expired, marking room as vacant"); - $self->handle_vacancy(); + $$self{m_OM}->sensor_count($$self{m_obj}, 0); + &::print_log("$$self{object_name}: occupancy timer expired, marking room as vacant") if $self->{debug}; + $self->handle_vacancy(); } else { - my $l_count = $$self{m_OM}->sensor_count($$self{m_obj}); - $p_state = $self->process_count($l_count,$p_setby); - } + my $l_count = $$self{m_OM}->sensor_count($$self{m_obj}); + $p_state = $self->process_count($l_count,$p_setby); + } - if (defined $p_state and $p_state ne $self->state()) { - $self->SUPER::set($p_state, $p_setby, $p_response); - } + if (defined $p_state and $p_state ne $self->state()) { + $self->SUPER::set($p_state, $p_setby, $p_response); + } } sub occupancy_expire From 2d223d8fff652f475c72835c8a79267fda81ed95 Mon Sep 17 00:00:00 2001 From: marcmerlin Date: Thu, 18 Oct 2012 15:41:33 +0000 Subject: [PATCH 140/150] Modified to support rfxcom lan in xpl mode, patch from famille --- lib/xPL_Items.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/xPL_Items.pm b/lib/xPL_Items.pm index 3507c978b..6db1a4f59 100644 --- a/lib/xPL_Items.pm +++ b/lib/xPL_Items.pm @@ -1017,7 +1017,7 @@ sub tie_value_convertor { sub device_monitor { my ( $self, $monitor_info ) = @_; if ($monitor_info) { - my ( $key, $value ) = $monitor_info =~ /(\S+)\s*=\s*(\S+)/; + my ($key,$value) = $monitor_info =~ /(\S+)\s*[:=]\s*(.+)/; if ( !( $value or $value =~ /^0/ ) ) { $value = ($key) ? $key : $monitor_info; $key = 'device'; From ed9c929903fec7fd153875278e36b4d458990337 Mon Sep 17 00:00:00 2001 From: jduda Date: Sun, 28 Oct 2012 17:06:58 +0000 Subject: [PATCH 141/150] Update android_server to allow speak and play events to go to multiple android devices. Previously, only the last android device register would get these events. Update the android_server module to support the new android_xml subroutine which provides more advanced xml feature for android application support. --- code/common/android_server.pl | 351 ++++++++++++++++++++++++++++++---- 1 file changed, 317 insertions(+), 34 deletions(-) diff --git a/code/common/android_server.pl b/code/common/android_server.pl index c7738c896..287499646 100644 --- a/code/common/android_server.pl +++ b/code/common/android_server.pl @@ -9,18 +9,28 @@ =begin comment -androidspeak.pl +android_server.pl This script allows MisterHouse to capture and send speech and played wav files to an Android unit. -- By default, ALL speak and play events will be pushed to ALL android's - regardless of the value in the speak/play "rooms" parameter. If you - want the android's to honor the rooms parameter, then you must define - the android_use_rooms parameter in my.private.ini. Each android declares - a room name when the android registers with the server. +- mh.private.ini requirements - android_use_rooms=1 +Add "server_android_port" to your ini file. The default port is 4444. +The port number assigned to server_android_port must match the port +configured in the android client. The ports must match in order for +the android device to receive speech events and notifications. + +server_android_port=4444 + + +By default, ALL speak and play events will be pushed to ALL android's +regardless of the value in the speak/play "rooms" parameter. If you +want the android's to honor the rooms parameter, then you must define +the android_use_rooms parameter in my.private.ini. Each android declares +a room name when the android registers with the server. + +android_use_rooms=1 =cut @@ -37,16 +47,19 @@ if ($state = said $android_server) { my ($pass, $android_device, $port, $room) = split /,/, $state; &print_log ("android_server pass: $pass android_device: $android_device, port: $port, room: $room") if $Debug{android}; - if (my $user = password_check $pass, 'server_android') { - &print_log ("Android Connect accepted for: room: $room at device: $android_device") if $Debug{android}; - my $client = $Socket_Ports{'server_proxy'}{socka}; - $room = $client unless defined $room; - &print_log("android_register: $client $room") if $Debug{android}; - $androidClients{$client}{room} = $room; - } - else { - &print_log ("Android Connect denied for: $room at $android_device") if $Debug{android}; - } +# if (my $user = password_check $pass, 'server_android') { + my $user = ""; + &print_log ("Android Connect accepted user: $user room: $room device: $android_device") if $Debug{android}; + my $client_ip = $main::Socket_Ports{server_android}{client_ip_address}; + my $client = $main::Socket_Ports{server_android}{socka}; + $room = $client_ip unless defined $room; + &print_log("android_register: ip: $client_ip client: $client room: $room") if $Debug{android}; + $androidClients{$client_ip}{room} = $room; + $androidClients{$client_ip}{client} = $client; +# } +# else { +# &print_log ("Android Connect denied for: $room at $android_device") if $Debug{android}; +# } } sub file_ready_for_android { @@ -54,14 +67,30 @@ sub file_ready_for_android { my $speakFile = $parms{web_file}; &print_log("file ready for android $speakFile") if $Debug{android}; my @rooms = $parms{androidSpeakRooms}; - foreach my $android (keys %androidClients) { - my $room = lc $androidClients{$android}{room}; - &print_log("file_ready_for_android client: $android room: $room") if $Debug{android}; - if ( grep(/$room/, @{$parms{androidSpeakRooms}}) ) { - my $function = "speak"; -#if ($android->active( )) { - $android_server->set(join '?', $function, $speakFile), $android; -#} + foreach my $client_ip (keys %androidClients) { + my $room = lc $androidClients{$client_ip}{room}; + my $client = $androidClients{$client_ip}{client}; + &print_log("file_ready_for_android ip: $client_ip room: $room client: $client") if $Debug{android}; + if ( grep(/$room/, @{$parms{androidSpeakRooms}}) ) { + # Check to see if the client/server is still active + my $active = 0; + for my $ptr (@{$main::Socket_Ports{server_android}{clients}}) { + my ($socka, $client_ip_address, $client_port, $data) = @{$ptr}; + #&print_log("Testing socket client ip address: $client_ip_address:$client_port\n") if $main::Debug{android}; + if ($socka and ($client_ip_address =~ /$client_ip/)) { + $active = 1; + last; + } + } + # If active, send, otherwise, delete from list + if ($active) { + my $function = "speak"; + &print_log("file_ready_for_android:: ip: $client_ip client: $client room: $room") if $Debug{android}; + $android_server->set( (join '?', $function, $speakFile), $client_ip); + } else { + &print_log("client_ip: $client_ip inactive"); + delete $androidClients{$client_ip}; + } } } } @@ -78,15 +107,15 @@ sub pre_speak_to_android { # whenever android_use_rooms is defined, otherwise, we send to all androids if (!exists $config_parms{android_use_rooms} || !exists $parms_ref->{rooms} || grep(/all/, @rooms) ) { @rooms = (); - foreach my $android (keys %androidClients) { - my $room = lc $androidClients{$android}{room}; - &print_log("pre_speak_to_android client: $android room: $room") if $Debug{android}; + foreach my $client_ip (keys %androidClients) { + my $room = lc $androidClients{$client_ip}{room}; + &print_log("pre_speak_to_android client_ip: $client_ip room: $room") if $Debug{android}; push @rooms, $room; } } else { my @androidRooms = (); - foreach my $android (keys %androidClients) { - my $room = lc $androidClients{$android}{room}; + foreach my $client_ip (keys %androidClients) { + my $room = lc $androidClients{$client_ip}{room}; if ( grep(/$room/, @rooms) ) { push @androidRooms, $room; } @@ -118,14 +147,15 @@ sub pre_play_to_android { my @rooms = split ',', lc $parms_ref->{rooms}; if (!exists $config_parms{android_use_rooms} || !exists $parms_ref->{rooms} || grep(/all/, @rooms) ) { @rooms = (); - foreach my $android (keys %androidClients) { - my $room = lc $androidClients{$android}{room}; + foreach my $client_ip (keys %androidClients) { + my $room = lc $androidClients{$client_ip}{room}; + &print_log("pre play to android client_ip: $client_ip room: $room") if $Debug{android}; push @rooms, $room; } } else { my @androidRooms = (); - foreach my $android (keys %androidClients) { - my $room = lc $androidClients{$android}{room}; + foreach my $client_ip (keys %androidClients) { + my $room = lc $androidClients{$client_ip}{room}; if ( grep(/$room/, @rooms) ) { push @androidRooms, $room; } @@ -138,3 +168,256 @@ sub pre_play_to_android { push(@{$parms_ref->{androidSpeakRooms}},@rooms); push(@{$parms_ref->{web_hook}},\&file_ready_for_android); } + +sub android_xml { + + my ( $request, $options ) = @_; + my ( $xml, $xml_types, $xml_groups, $xml_categories, $xml_vars, + $xml_objects ); + + return &android_usage unless $request; + + my %request; + foreach ( split ',', $request ) { + my ( $k, undef, $v ) = /(\w+)(=(.+))?/; + $request{$k}{active} = 1; + $request{$k}{members} = [ split /\|/, $v ] if $k and $v; + } + + my %options; + foreach ( split ',', $options ) { + my ( $k, undef, $v ) = /(\w+)(=(.+))?/; + $options{$k}{active} = 1; + $options{$k}{members} = [ split /\|/, $v ] if $k and $v; + } + + my %fields; + foreach ( @{ $options{fields}{members} } ) { + $fields{$_} = 1; + } + $fields{all} = 1 unless %fields; + + print_log "xml: request=$request options=$options" if $Debug{xml}; + + # List objects by type + if ( $request{types} ) { + $xml .= " \n"; + my @types; + if ( $request{types}{members} and @{ $request{types}{members} } ) { + @types = @{ $request{types}{members} }; + } + else { + @types = @Object_Types; + } + foreach my $type ( sort @types ) { + print_log "xml: type $type" if $Debug{xml}; + $xml .= " \n"; + if ($fields{all} || $fields{name}) { + $xml .= " $type\n"; + } + unless ( $options{truncate} ) { + $xml .= " \n"; + foreach my $o ( sort &list_objects_by_type($type) ) { + $o = &get_object_by_name($o); + $xml .= &android_object_detail( $o, 4, %fields ); + } + $xml .= " \n"; + } + $xml .= " \n"; + } + $xml .= " \n"; + } + + # List objects by groups + if ( $request{groups} ) { + $xml .= " \n"; + my @groups; + if ( $request{groups}{members} and @{ $request{groups}{members} } ) { + @groups = @{ $request{groups}{members} }; + } + else { + @groups = &list_objects_by_type('Group'); + } + foreach my $group ( sort @groups ) { + print_log "xml: group $group" if $Debug{xml}; + my $group_object = &get_object_by_name($group); + next unless $group_object; + $xml .= " \n"; + if ($fields{all} || $fields{name}) { + $xml .= " $group\n"; + } + unless ( $options{truncate} ) { + $xml .= " \n"; + foreach my $object ( list $group_object) { + $xml .= &android_object_detail( $object, 4, %fields ); + } + $xml .= " \n"; + } + $xml .= " \n"; + } + $xml .= " \n"; + } + + # List voice commands by category + if ( $request{categories} ) { + $xml .= " \n"; + my @categories; + if ( $request{categories}{members} + and @{ $request{categories}{members} } ) + { + @categories = @{ $request{categories}{members} }; + } + else { + @categories = &list_code_webnames('Voice_Cmd'); + } + for my $category ( sort @categories ) { + print_log "xml: cat $category" if $Debug{xml}; + next if $category =~ /^none$/; + $xml .= " \n"; + if ($fields{all} || $fields{name}) { + $xml .= " $category\n"; + } + unless ( $options{truncate} ) { + $xml .= " \n"; + foreach my $name ( sort &list_objects_by_webname($category) ) { + my ( $object, $type ); + $object = &get_object_by_name($name); + $type = ref $object; + print_log "xml: o $name t $type" if $Debug{xml}; + next unless $type eq 'Voice_Cmd'; + $xml .= &android_object_detail( $object, 4, %fields ); + } + $xml .= " \n"; + } + $xml .= " \n"; + } + $xml .= " \n"; + } + + # List objects by name + if ( $request{objects} ) { + $xml .= " \n"; + my @objects; + if ( $request{objects}{members} and @{ $request{objects}{members} } ) { + @objects = @{ $request{objects}{members} }; + } + else { + foreach my $object_type (@Object_Types) { + push @objects, &list_objects_by_type($object_type); + } + } + foreach my $o ( map { &get_object_by_name($_) } sort @objects ) { + next unless $o; + my $name = $o; + $name = $o->get_object_name if $o->can("get_object_name"); + print_log "xml: object name=$name ref=" . ref $o if $Debug{xml}; + $xml .= &android_object_detail( $o, 2, %fields ); + } + $xml .= " \n"; + } + + # Translate special characters + $xml = encode_entities( $xml, "\200-\377&" ); + $options{xsl}{members}[0] = '' + if exists $options{xsl} + and not defined $options{xsl}{members}[0]; + return &android_page( $xml, $options{xsl}{members}[0] ); +} + +sub android_object_detail { + my ( $object, $depth, %fields ) = @_; + return if exists $fields{none} and $fields{none}; + my $ref = ref \$object; + return unless $ref eq 'REF'; + #return if $object->can('hidden') and $object->hidden; + $fields{all} = 1 unless %fields; + my $num_elements = 0; + if ($object->can('android_query')) { + $num_elements += $object->android_query( ); + } + my $prefix = ' ' x $depth; + my $type = ref $object; + my $more = $num_elements > 2 ? " more=\"true\"" : ""; + my $xml_objects = $prefix . "\n"; + if ($object->can('android_xml')) { + $xml_objects .= $object->android_xml($depth+1, %fields); + } + $xml_objects .= $prefix . "\n"; + return $xml_objects; +} + +sub android_page { + my ( $xml, $xsl ) = @_; + + $xsl = '/lib/android.xsl' unless defined $xsl; + + # handle blank xsl name + my $style; + $style = qq|| if $xsl; + return < +$style + +$xml + +eof + +} + +sub android_usage { + my $html = < + + + + +eof + my @requests = qw( types groups objects categories ); + + my %options = ( + xsl => { + applyto => 'all', + example => '|/lib/xml2js.xslt', + }, + fields => { + applyto => 'types|groups|objects|categories', + example => 'state|set_by', + }, + truncate => { applyto => 'types|groups|categories', }, + ); + foreach my $r (@requests) { + my $url = "/sub?android_xml($r)"; + $html .= "

    $r

    \n

    $url

    \n
      \n"; + foreach my $opt ( sort keys %options ) { + if ( $options{$opt}{applyto} eq 'all' or grep /^$r$/, + split /\|/, $options{$opt}{applyto} ) + { + $url = "/sub?android_xml($r,$opt"; + if ( defined $options{$opt}{example} ) { + foreach ( split /\|/, $options{$opt}{example} ) { + print_log "xml: r $r opt $opt ex $_" if $Debug{xml}; + $html .= "
    • $url=$_)
      • \n"; + } + } + else { + $html .= "
    • $url)
      • \n"; + } + } + } + $html .= "
    \n"; + } + $html .= < + +eof + + return $html; +} From 746df35c11dca782c67a940e376fa16fda8645d2 Mon Sep 17 00:00:00 2001 From: jduda Date: Sun, 28 Oct 2012 17:07:03 +0000 Subject: [PATCH 142/150] Update Generic_Item and Voice_Cmd to provide android_xml subroutines which provide additional xml capabilities for android application support. --- lib/Generic_Item.pm | 83 +++++++++++++++++++++++++++++++++++++++++++++ lib/Voice_Cmd.pm | 40 +++++++++++++++++++++- 2 files changed, 122 insertions(+), 1 deletion(-) diff --git a/lib/Generic_Item.pm b/lib/Generic_Item.pm index 68bbcdeb7..42ce3e77b 100644 --- a/lib/Generic_Item.pm +++ b/lib/Generic_Item.pm @@ -14,6 +14,8 @@ sub STORE { package Generic_Item; +use HTML::Entities; # So we can encode characters like <>& etc + =head1 NAME B - This is the parent object for all state-based mh objects, @@ -1473,6 +1475,87 @@ sub reset_states { @states_from_previous_pass = @items_with_more_states; } +# Return the number of tags which will be returned via android_xml +sub android_query { + my ($self) = @_; + my $num_tags = 2; # name + state + my $log_size = 0; + $log_size = @{$$self{state_log}} if $$self{state_log} ; + if ($log_size > 0) { + $num_tags++; + } + return $num_tags; +} + +sub android_xml { + my ($self, $depth, %fields) = @_; + my $xml_objects; + my $prefix = ' ' x $depth; + + my @f = qw( name state state_log ); + + foreach my $f ( @f ) { + next unless $fields{all} or $fields{$f}; + + my $method = $f; + my $value; + if ($self->can($method) + or ( ( $method = 'get_' . $method ) + and $self->can($method) ) + ) { + if ( $f eq 'states' or $f eq 'state_log' ) { + my @a = $self->$method; + $value = \@a; + } else { + $value = $self->$method; + $value = encode_entities( $value, "\200-\377&<>" ); + } + } elsif (exists $self->{$f}) { + $value = $self->{$f}; + $value = encode_entities( $value, "\200-\377&<>" ); + } + + if ($f eq "state") { + my @states = $self->get_states( ); + my $numStates = @states; + my $attribute = ' type="text"'; + if ($numStates eq 2) { + $attribute = ' type="toggle"'; + } + if ($numStates > 2) { + $attribute = ' type="spinner"'; + } + $attribute .= " value=\"$value\""; + $xml_objects .= $prefix . "\n"; + foreach (@states) { + $_ = 'undef' unless defined $_; + $value = $_; + $value = encode_entities( $value, "\200-\377&<>" ); + my $selected = ""; + #if ($_ eq $self->{state}) { + # $selected = " selected=\"true\""; + #} + $xml_objects .= $prefix . " $value\n"; + } + $xml_objects .= $prefix . "\n"; + } elsif ($f eq "state_log") { + $xml_objects .= $prefix . "\n"; + my @state_log = @{$value}; + foreach (@state_log) { + $_ = 'undef' unless defined $_; + $value = $_; + $value = encode_entities( $value, "\200-\377&<>" ); + $xml_objects .= $prefix . " $value\n"; + } + $xml_objects .= $prefix . "\n"; + } elsif ($f eq "name") { + $xml_objects .= $prefix . "$self->{object_name}\n"; + } else { + $xml_objects .= $prefix . "<$f>$value\n"; + } + } + return $xml_objects; +} =head1 INI PARAMETERS diff --git a/lib/Voice_Cmd.pm b/lib/Voice_Cmd.pm index 4210386a8..14b55696f 100644 --- a/lib/Voice_Cmd.pm +++ b/lib/Voice_Cmd.pm @@ -3,6 +3,9 @@ package Voice_Cmd; @Voice_Cmd::ISA = ('Generic_Item'); use strict; + +use HTML::Entities; # So we can encode characters like <>& etc + my ($cmd_num); my (%cmd_by_num, %cmd_state_by_num, %cmd_num_by_text, %cmd_text_by_num, %cmd_text_by_vocab); my (%cmd_word_list, %cmd_vocabs); @@ -709,7 +712,42 @@ sub disablevocab { $Vcmd_viavoice->set(''); } - +# Return the number of tags which will be returned via android_xml +sub android_query { + my ($self) = @_; + my $num_tags = $self->SUPER::android_query(); + $num_tags += 1; + return $num_tags; +} + +sub android_xml { + my ($self, $depth, %fields) = @_; + my $xml_objects = $self->SUPER::android_xml($depth, %fields); + my $prefix = ' ' x $depth; + + my @f = qw( text ); + + foreach my $f ( @f ) { + next unless $fields{all} or $fields{$f}; + + my $method = $f; + my $value; + if ($self->can($method) + or ( ( $method = 'get_' . $method ) + and $self->can($method) ) + ) { + $value = $self->$method; + $value = encode_entities( $value, "\200-\377&<>" ); + } elsif (exists $self->{$f}) { + $value = $self->{$f}; + $value = encode_entities( $value, "\200-\377&<>" ); + } + + $xml_objects .= $prefix . "<$f>$value\n"; + } + return $xml_objects; +} + 1; # From 4aa6efa43024c9529231a1fcb750bf09572ad5ed Mon Sep 17 00:00:00 2001 From: jduda Date: Sun, 28 Oct 2012 17:07:06 +0000 Subject: [PATCH 143/150] Prevent Caller ID announcments when receiving MSG_OFF and MSG_WAITING indicators for TELCO. --- lib/CID_Log.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/CID_Log.pm b/lib/CID_Log.pm index fd1519130..da5a702e3 100644 --- a/lib/CID_Log.pm +++ b/lib/CID_Log.pm @@ -77,6 +77,8 @@ sub set { my ($self,$p_state,$p_setby) = @_; # &::print_log("CIDLOG $p_state, $p_setby"); + return if ($p_setby->cid_name() =~ /MSG OFF/); + return if ($p_setby->cid_name() =~ /MSG WAITING/); if ($p_state =~ /^CID/i) { $self->cid_name($p_setby->cid_name()); From 7e24c76953cb6c58c3f9ab86f5192c0275fa4bc0 Mon Sep 17 00:00:00 2001 From: jduda Date: Sun, 28 Oct 2012 17:07:10 +0000 Subject: [PATCH 144/150] Add a watch-dog timer to Presence_Monitor to avoid lights remaining on too long. This prevents a rouge problems with occupancy which I havn't been able to resolve in any better wway. --- lib/Presence_Monitor.pm | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/lib/Presence_Monitor.pm b/lib/Presence_Monitor.pm index 967067715..ed294cb6e 100644 --- a/lib/Presence_Monitor.pm +++ b/lib/Presence_Monitor.pm @@ -102,6 +102,9 @@ sub new $$self{m_timerOccupancyExpire} = new Timer(); $$self{state}=0; $$self{m_occupancy_expire} = 0; + $$self{wdog_interval} = 60; + $$self{m_timer_wdog} = new Timer; + $$self{m_timer_wdog}-> set($self->{wdog_interval}, sub {&Presence_Monitor::watch_dog($self)}); $$self{debug} = $main::Debug{presence}; return $self; } @@ -111,6 +114,24 @@ sub set_debug { $self->{debug} = $debug; } +# This watch_dog timer method will look for conditions where the room is occupied but no +# occupancy expiration timer is in play. +sub watch_dog { + my ($self) = @_; + if ($self->state eq 'occupied') { + if (!$self->{m_timerOccupancyExpire}->active( )) { + &::print_log("$$self{object_name}: watch_dog, occupied without timer!") if $self->{debug}; + if (defined $self->{m_occupancy_expire}) { + &::print_log("$$self{object_name}: occupancy timer set $$self{m_occupancy_expire}, watchdog condition!") if $self->{debug}; + $self->{m_timerOccupancyExpire}->set($self->{m_occupancy_expire}, $self); + $self->{wdog_interval} = $self->{m_occupancy_expire}+2; + } + } + } + # reload the timer + $self->{m_timer_wdog}-> set($self->{wdog_interval}, sub {&Presence_Monitor::watch_dog($self)}); +} + sub handle_presence { my ($self) = @_; # Return if already occupied @@ -163,6 +184,9 @@ sub process_count { } elsif ($l_count >= 1) { $p_state = 'occupied'; $$self{m_timerCancelPredict}->unset(); + my $m_state = $$self{m_obj}->state; + my $m_name = $$self{m_obj}->{object_name}; + &::print_log("$$self{object_name}: room occupied $m_state $m_name") if $self->{debug}; if (defined $$self{m_occupancy_expire} and $$self{m_obj}->state =~ /(motion|open)/i) { # and ref $p_setby and ref $p_setby->get_set_by and $p_setby->get_set_by eq $$self{m_obj} $$self{m_timerOccupancyExpire}->set($$self{m_occupancy_expire}, $self); From cc7053d0d900c8d519a3bc74c5e3ec1ced9068ce Mon Sep 17 00:00:00 2001 From: Brian Warren Date: Sat, 3 Nov 2012 13:54:52 -0400 Subject: [PATCH 145/150] Provide human readable NACK messages. Implement Insteon get_engine_version command. --- lib/Insteon.pm | 8 ++++-- lib/Insteon/BaseInsteon.pm | 57 ++++++++++++++++++++++++++++++++------ 2 files changed, 53 insertions(+), 12 deletions(-) diff --git a/lib/Insteon.pm b/lib/Insteon.pm index d882a0a97..e65106b9a 100755 --- a/lib/Insteon.pm +++ b/lib/Insteon.pm @@ -253,7 +253,7 @@ sub generate_voice_commands $cmd_states .= ",link to interface,unlink with interface"; } if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { - $cmd_states .= ",status,scan link table,log links"; + $cmd_states .= ",status,get engine version,scan link table,log links"; push @_scannable_link, $object_name; } $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; @@ -261,6 +261,7 @@ sub generate_voice_commands $object_string .= "$object_name_v -> tie_event('$object_name->interface()->cancel_linking','cancel linking');\n\n"; if ($object->is_root and !($object->isa('Insteon::InterfaceController'))) { $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->get_engine_version','get engine version');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; } @@ -272,7 +273,7 @@ sub generate_voice_commands } elsif ($object->isa('Insteon::BaseDevice')) { $states = $insteon_menu_states if $insteon_menu_states && ($object->can('is_dimmable') && $object->is_dimmable); - my $cmd_states = "$states,status,scan link table,log links,update onlevel/ramprate"; #,on level,ramp rate"; + my $cmd_states = "$states,status,get engine version,scan link table,log links,update onlevel/ramprate"; #,on level,ramp rate"; $cmd_states .= ",link to interface,unlink with interface" if $object->isa("Insteon::BaseController") || $object->is_controller; $object_string .= "$object_name_v = new Voice_Cmd '$command [$cmd_states]';\n"; foreach my $state (split(/,/,$states)) { @@ -280,6 +281,7 @@ sub generate_voice_commands } $object_string .= "$object_name_v -> tie_event('$object_name->log_alllink_table()','log links');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->request_status','status');\n\n"; + $object_string .= "$object_name_v -> tie_event('$object_name->get_engine_version','get engine version');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->update_local_properties','update onlevel/ramprate');\n\n"; $object_string .= "$object_name_v -> tie_event('$object_name->scan_link_table(\"" . '\$self->log_alllink_table' . "\")','scan link table');\n\n"; if ($object->isa("Insteon::BaseController") || $object->is_controller) { @@ -504,4 +506,4 @@ sub find_members { return @l_found; } -1 \ No newline at end of file +1 diff --git a/lib/Insteon/BaseInsteon.pm b/lib/Insteon/BaseInsteon.pm index 0f144ba2f..ae2db4270 100755 --- a/lib/Insteon/BaseInsteon.pm +++ b/lib/Insteon/BaseInsteon.pm @@ -40,6 +40,14 @@ our %message_types = ( off => 0x13 ); +our %nack_messages = ( + fb => 'illegal_value_in_cmd', + fc => 'pre_nak_long_db_search', + fd => 'bad_checksum_or_unknown_cmd', + fe => 'load_sense_detects_no_load', + ff => 'sender_id_not_in_responder_aldb', +); + sub derive_link_state { my ($p_state) = @_; @@ -435,6 +443,19 @@ sub _is_info_request } # if this were a scene controller, then also propogate the result to all members } + elsif ( $cmd eq 'get_engine_version' ) { + my $version = $msg{extra}; + $version++; # version retuned in cmd2 is 0 indexed + if ( $version == 3 ) { + $version = 'I2CS'; + } + else { + $version = 'I'. sprintf( "%1d",$version); + } + &::print_log("[Insteon::BaseObject] received engine version for " + . $self->{object_name} . " of $version."); + } + return $is_info_request; } @@ -503,16 +524,21 @@ sub _process_message # } # else # { - if ($self->isa('Insteon::BaseLight')) - { - &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + if ($self->isa('Insteon::BaseLight')) { + + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message (" + . $self->get_nack_msg_for( $msg{extra} ) + .") for " + . $self->{object_name} . ". It may be unplugged or have a burned out bulb") if $main::Debug{insteon}; - } - else - { - &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message for " . $self->{object_name} + } + else { + &::print_log("[Insteon::BaseObject] WARN!! encountered a nack message (" + . $self->get_nack_msg_for( $msg{extra} ) + .") for " + . $self->{object_name} . " ... skipping"); - } + } $self->is_acknowledged(0); $self->_process_command_stack(%msg); # } @@ -635,6 +661,11 @@ sub _is_valid_state } } +# Provide human readable nack message. +sub get_nack_msg_for { + my ($self,$msg) = @_; + return $nack_messages{ $msg }; +} #################################### ### ##################### @@ -656,6 +687,7 @@ our %message_types = ( delete_from_group => 0x02, linking_mode => 0x09, unlinking_mode => 0x0A, + get_engine_version => 0x0D, ping => 0x10, on_fast => 0x12, off_fast => 0x14, @@ -1020,6 +1052,13 @@ sub request_status # $self->_send_cmd('command' => 'status_request', 'is_synchronous' => 1); } +sub get_engine_version { + my ($self, $requestor) = @_; + + my $message = new Insteon::InsteonMessage('insteon_send', $self, 'get_engine_version'); + $self->_send_cmd($message); +} + sub ping { my ($self) = @_; @@ -1815,4 +1854,4 @@ sub is_root return 0; } -1; \ No newline at end of file +1; From 51c761709f0e140c4887de2a0c6f83740d22bf3f Mon Sep 17 00:00:00 2001 From: Brian Warren Date: Sat, 3 Nov 2012 20:36:45 -0400 Subject: [PATCH 146/150] Need to carry over cmd2 data for nacks. --- lib/Insteon/Message.pm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/Insteon/Message.pm b/lib/Insteon/Message.pm index 93655c44a..3dedaa8df 100755 --- a/lib/Insteon/Message.pm +++ b/lib/Insteon/Message.pm @@ -228,6 +228,7 @@ sub command_to_hash { $msg{type} = 'cleanup'; $msg{is_nack} = 1; + $msg{extra} = substr($p_state,16,2); } elsif ($msgflag == 0) { @@ -244,6 +245,7 @@ sub command_to_hash { $msg{type} = 'direct'; $msg{is_nack} = 1; + $msg{extra} = substr($p_state,16,2); } } } @@ -685,4 +687,4 @@ sub generate_commands return @data; } -1 \ No newline at end of file +1 From ba265d553bf131e7b06f9d98b403de277d0c1159 Mon Sep 17 00:00:00 2001 From: Jim Duda Date: Tue, 6 Nov 2012 14:08:23 -0500 Subject: [PATCH 147/150] Add support for callerid pop up message and notification. This change adds the android_callerid method. Call this message with a callerid Name and Number. This will result in a callerid popup message and notification to be sent to the android. The android application can be configured to act on the message or ignore. --- code/common/android_server.pl | 68 +++++++++++++++++++++++++---------- 1 file changed, 49 insertions(+), 19 deletions(-) diff --git a/code/common/android_server.pl b/code/common/android_server.pl index 287499646..1480aa143 100644 --- a/code/common/android_server.pl +++ b/code/common/android_server.pl @@ -72,25 +72,7 @@ sub file_ready_for_android { my $client = $androidClients{$client_ip}{client}; &print_log("file_ready_for_android ip: $client_ip room: $room client: $client") if $Debug{android}; if ( grep(/$room/, @{$parms{androidSpeakRooms}}) ) { - # Check to see if the client/server is still active - my $active = 0; - for my $ptr (@{$main::Socket_Ports{server_android}{clients}}) { - my ($socka, $client_ip_address, $client_port, $data) = @{$ptr}; - #&print_log("Testing socket client ip address: $client_ip_address:$client_port\n") if $main::Debug{android}; - if ($socka and ($client_ip_address =~ /$client_ip/)) { - $active = 1; - last; - } - } - # If active, send, otherwise, delete from list - if ($active) { - my $function = "speak"; - &print_log("file_ready_for_android:: ip: $client_ip client: $client room: $room") if $Debug{android}; - $android_server->set( (join '?', $function, $speakFile), $client_ip); - } else { - &print_log("client_ip: $client_ip inactive"); - delete $androidClients{$client_ip}; - } + &android_send_message ( $client_ip, "speak", $speakFile ); } } } @@ -169,6 +151,54 @@ sub pre_play_to_android { push(@{$parms_ref->{web_hook}},\&file_ready_for_android); } +# This method provides the lowest level interface to send a message to +# a specific android device identified by a $client_ip address. +sub android_send_message ( ) { + my ($client_ip, $function, $data) = @_; + # Check to see if the client/server is still active + my $active = 0; + for my $ptr (@{$main::Socket_Ports{server_android}{clients}}) { + my ($socka, $client_ip_address, $client_port, $data) = @{$ptr}; + #&print_log("Testing socket client ip address: $client_ip_address:$client_port\n") if $main::Debug{android}; + if ($socka and ($client_ip_address =~ /$client_ip/)) { + $active = 1; + last; + } + } + # If active, send, otherwise, delete from list + if ($active) { + &print_log("android_send_data:: ip: $client_ip") if $Debug{android}; + $android_server->set( (join '?', $function, $data), $client_ip); + } else { + &print_log("client_ip: $client_ip inactive"); + delete $androidClients{$client_ip}; + } +} + +$v_test_android_speak = new Voice_Cmd("test android speak"); +if (my $state = said $v_test_android_speak) { + &speak ( "hello from jim duda"); +} + +$v_test_android_play = new Voice_Cmd("test android play"); +if (my $state = said $v_test_android_play) { + &play ( "../sounds/sound_trek1.wav"); +} + +$v_test_android_callerid = new Voice_Cmd("test android caller id"); +if (my $state = said $v_test_android_callerid) { + &android_callerid ( "Jim Duda", "7813545048"); +} + +sub android_callerid { + my ($name, $number) = @_; + print_log "android_callerid: $name $number"; + my $data = "{\"name\"" . ":" . "\"$name\"" . "," . "\"number\"" . ":" . "\"$number\"}"; + foreach my $client_ip (keys %androidClients) { + &android_send_message ( $client_ip, "callerid", $data ); + } +} + sub android_xml { my ( $request, $options ) = @_; From 870989a34fcaf21683eb483ff2124ad80760b794 Mon Sep 17 00:00:00 2001 From: Lieven Hollevoet Date: Wed, 21 Nov 2012 21:06:26 +0100 Subject: [PATCH 148/150] Updated xPL_Items.pl to the version of the master branch. The merging operation until now did not bring the xPL_Items.pl file up to the most recent version. Fixed it. --- lib/xPL_Items.pm | 2732 +++++++++++++++++++++++----------------------- 1 file changed, 1366 insertions(+), 1366 deletions(-) diff --git a/lib/xPL_Items.pm b/lib/xPL_Items.pm index c578738a2..88d1cda8e 100644 --- a/lib/xPL_Items.pm +++ b/lib/xPL_Items.pm @@ -1,1366 +1,1366 @@ - -=begin comment - -xPL_Items.pm - Misterhouse interface for the xPL protocol - -Info: - - xPL websites: - http://www.xplproject.org.uk - http://www.xaphal.com - -Authors: - 10/26/2002 Created by Bruce Winter bruce@misterhouse.net - - -xPL works by using the xPL Hub built in misterhouse and listening for -xPL connections. See: -http://misterhouse.wikispaces.com/xAP+and+xPL+-+Getting+Started - -Relevant variables for mh.private.ini are: -#ipaddress_xpl_broadcast = 192.168.205.255 -#ipaddress_xpl = 192.168.205.3 -#xpl_disable = 1 -#xpl_nohub = 1 -#xpl_enable_items = 1 - -You can disable the mh internal xPL hub if you are running a more capable one. -To get data input, you can use something like - -xpl-rfxcom-rx --verbose --rfxcom-rx-verbose --rfxcom-rx-tty /dev/rfxcom --interface eth1 - -from xPL-Perl. Then watch for sensor updates passing by and paste their info -in your device table, like so: -XPL_SENSOR, bnz-rfxcomrx.gargamel:bthr918n.e6, oregon_intemp, XPL_temp, temp - -Another option to figure out the name to use in XPL_SENSOR is to use -xpl-logger -head -body -i ethx 2>&1 | grep "xpl-trig\/" -(or without the grep for more details on which field is called what). - -A few samples: -XPL_SENSOR, iranger-rfx.*:WGR918, oregon_winddir, , direction -XPL_SENSOR, iranger-rfx.*:BHTR968, oregon_intemp, , temp -XPL_SENSOR, bnz-owfs.*:10.2223EF010800, owfs_temp, , temp -XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000, owfs_humidity, , humidity -XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000.1, owfs_humidity1, , humidity -XPL_X10SECURITY, iranger-rfx.*:F8, x10sec_garage1, , ds10 - -Note that XPL_SENSOR should just be used for XPL messages of the x10.basic -type. XPL_X10SECURITY is for x10.security schema, while there is no way to -currently read x10.basic messages (see this file for more supported schemas). - -Once it is running, objects get variables including these: -'state' => '17.9', -'states_nosubstate' => 1, -'states_substate' ? -'address' => 'bnz-rfxcomrx.gargamel', -'states_nomultistate' => 1, -'states_multistate' ? -'target_address' => '*', -'_device_id' => 'bthr918n.e6' -'set_time' => 1285555578, -'m_timerHeartBeat' => bless( {}, 'Timer' ), -'m_timeoutHeartBeat' => 0, - - -So, you would write this to print temperature: -print_log $oregon_intemp->state -=cut - -use strict; - -package xPL; - -#@xPL::ISA = ('Generic_Item'); - -my ( - @xpl_item_names, $started, %hub_ports, - $xpl_listen, $xpl_hub_listen, $xpl_send, - %xpl_hub_ports, $xpl_hbeat_interval, $xpl_hbeat_counter -); - -# Create sockets and add hook to check incoming data -sub startup { - return - if $started++ - ; # Allows us to call with $Reload or with xpl_module mh.ini parm - - # In case you don't want xpl for some reason - return if $::config_parms{xpl_disable}; - - # determine our local ipaddress(es) - @xpl_item_names = (); - my ($port); - - # init the hbeat intervals and counters - $xpl_hbeat_interval = $::config_parms{xpl_hbeat_interval}; - $xpl_hbeat_interval = 5 unless $xpl_hbeat_interval; - $xpl_hbeat_counter = $xpl_hbeat_interval; - - if ( !( $::config_parms{xpl_disable} ) ) { - undef $port; - $port = $::config_parms{xpl_port}; - $port = 3865 unless $port; - - # open the sending port - &open_port( $port, 'send', 'xpl_send', 0, 1 ); - $xpl_send = new Socket_Item( undef, undef, 'xpl_send' ); - - # Find and use the first open port - my $port_listen; - for my $p (49352 .. 65535) { - $port_listen = $p; - last if &open_port( $port_listen, 'listen', 'xpl_listen', 1, 1); - } - # The socket code will select a free local port if given 0 - # not working on ubuntu 12.04 - #&open_port( 0, 'listen', 'xpl_listen', 1, 1 ); - #$port_listen = $::Socket_Ports{'xpl_listen'}{port}; - $xpl_listen = new Socket_Item( undef, undef, 'xpl_listen' ); - - # initialize the hub (listen) port - if ( $::config_parms{xpl_nohub} ) { - $xpl_hub_listen = undef; - } - else { - if ( &open_port( $port, 'listen', 'xpl_hub_listen', 0, 1 ) ) { - $xpl_hub_listen = - new Socket_Item( undef, undef, 'xpl_hub_listen' ); - print " - mh in xPL Hub mode\n"; - - # now set up the hub port that will send to mh - $xpl_hub_ports{$port_listen} = &xPL::get_xpl_mh_source_info(); - my $port_name = "xpl_send_$port_listen"; - &open_port( $port_listen, 'send', $port_name, 1, 1 ); - } - else { - print " - mh automatically switching out of xPL Hub mode. " . - "Another application is binding to the hub port ($port)\n"; - $xpl_hub_listen = undef; - } - } - - # now that a listen port exists, advertise it w/ the first hbeat msg - &xPL::send_xpl_heartbeat() if $xpl_send; - - } - - &::MainLoop_pre_add_hook( \&xPL::check_for_data, 1 ); - - # add reload hook so that xpl_item_names list is reset - &::Reload_pre_add_hook( \&xPL::reload_hook, 1 ); -} - -sub reload_hook { - @xpl_item_names = (); -} - -sub main::display_xpl { - my (%args) = @_; - my $schema = lc ${args}{schema}; - $schema = 'osd.basic' unless $schema; - if ( $schema eq 'osd.basic' ) { - &main::display_xpl_osd_basic(%args); - } - else { - &main::print_log( - "Display support for the schema, $schema, does not yet exist"); - } -} - -sub main::display_xpl_osd_basic { - my (%args) = @_; - my ( $text, $duration, $address ); - $text = $args{raw_text}; - $text = $args{text} unless $text; - $text =~ s/[\n\r ]+/ /gm; # strip out new lines and extra space - $text =~ s/\n/\\n/gm; # escape new lines - $duration = $args{duration}; - $duration = $args{display} - unless $duration; # this apparently is the original param? - $duration = 10 unless $duration; # default to 10 sec display - $address = $args{to}; - $address = $args{address} unless $address; - $address = '*' unless $address; - - # auto pre-pend text w/ a newline if the target is a squeezebox and - # doesn't already have one - if ( $address =~ /^slimdev-slimserv/i ) { - $text = "\\n$text" unless $text =~ /\\n\S+/i; - } - &xPL::send( 'xPL', $address, - 'osd.basic' => { command => 'write', delay => $duration, text => $text } - ); -} - -sub open_port { - my ( $port, $send_listen, $port_name, $local, $verbose ) = @_; - - # Need to re-open the port, if client app has been re-started?? - close $::Socket_Ports{$port_name}{sock} - if $::Socket_Ports{$port_name}{sock}; - - my $sock; - if ( $send_listen eq 'send' ) { - my $dest_address; - if ($local) { - if ($main::OS_win || $::Info{'OS_name'} eq 'cygwin') { - $dest_address = $::Info{IPAddress_local} unless $dest_address; - } - else { - $dest_address = '0.0.0.0'; - } - } - else { - $dest_address = $::config_parms{'ipaddress_xpl_broadcast'}; - $dest_address = '255.255.255.255' unless $dest_address; - } - $sock = new IO::Socket::INET->new( - PeerPort => $port, - Proto => 'udp', - PeerAddr => $dest_address, - Broadcast => 1 - ); - - print "db xPL_Items open_port: pn=$port_name l=$local PeerPort=$port " . - "PeerAddr=$dest_address" if $main::Debug{xpl}; - } - else { - my $listen_address; - if ( !($local) ) { - $listen_address = $::config_parms{'ipaddress_xpl'}; - $listen_address = $::config_parms{'xpl_address'} - unless $listen_address; - } - if ($main::OS_win || $::Info{'OS_name'} eq 'cygwin') { - $listen_address = $::Info{IPAddress_local} unless $listen_address; - } - else { - # can't get *nix to bind to a specific address; defaults to - # kernel assigned default IP - $listen_address = '0.0.0.0'; - } - $sock = new IO::Socket::INET->new( - LocalPort => $port, - Proto => 'udp', - LocalAddr => $listen_address, - Broadcast => 1 - ); - $port = $sock->sockport() if ($port == 0); - - print "db xPL_Items open_port: pn=$port_name l=$local LocalPort=$port " . - "LocalAddr=$listen_address" if $main::Debug{xpl}; - } - unless ($sock) { - print " -- FAILED\n" if $main::Debug{xpl}; - print "\nError: Could not start a udp xPL send server on $port: $@\n\n" - if $send_listen eq 'send'; - return 0; - } - print "\n" if $main::Debug{xpl}; - - printf " - creating %-15s on %3s %5s %s\n", $port_name, 'udp', $port, - $send_listen - if $verbose; - - $::Socket_Ports{$port_name}{protocol} = 'udp'; - $::Socket_Ports{$port_name}{datatype} = 'raw'; - $::Socket_Ports{$port_name}{port} = $port; - $::Socket_Ports{$port_name}{sock} = $sock; - $::Socket_Ports{$port_name}{socka} = $sock; # UDP ports are always "active" - - return $sock; -} - -sub check_for_data { - - if ( $xpl_hub_listen && ( my $xpl_hub_data = said $xpl_hub_listen) ) { - &_process_incoming_xpl_hub_data($xpl_hub_data); - } - if ( $xpl_listen && ( my $xpl_data = said $xpl_listen) ) { - &_process_incoming_xpl_data($xpl_data); - } - - # check to see if hbeats need to be sent - if ( &::new_minute($xpl_hbeat_interval) ) { - if ($xpl_send) { - if ( $xpl_hbeat_counter == 5 ) { - &xPL::send_xpl_heartbeat(); - $xpl_hbeat_counter = $xpl_hbeat_interval; - } - else { - $xpl_hbeat_counter = $xpl_hbeat_counter - 1; - } - } - } -} - -# Parse incoming xPL records -sub parse_data { - my ($data) = @_; - my ( $source, $class, $target, $msg_type, $section, %d ); - print "db4 xPL data:\n$data\n" - if $main::Debug{xpl} and $main::Debug{xpl} == 4; - for my $r ( split /[\r\n]/, $data ) { - next if $r =~ /^[\{\} ]*$/; - - # Store xpl-header, xpl-heartbeat, and other data - if ( my ( $key, $value ) = $r =~ /(.+?)=(.*)/ ) { - $key = lc $key; - $value = lc $value - if ( $section =~ /^xpl/ ); # Do not lc real data; - $source = $value if $section =~ /^xpl/ and $key =~ /^source$/i; - $target = $value if $section =~ /^xpl/ and $key =~ /^target$/i; - if ( exists( $d{$section}{$key} ) ) { - $d{$section}{$key} .= "," - . $value; # xpl allows "continuation lines" - } - else { - $d{$section}{$key} = $value; - } - print "db4 xpl parsed c=$section k=$key v=$value\n" - if ( $main::Debug{xpl} and $main::Debug{xpl} == 4 ); - } - - # section (e.g. xpl-header, xpl-heartbeat, source.instance - else { - $section = lc $r; - $msg_type ? $class = $section : $msg_type = $section; - } - } - # define target as '*' if undefined - $target = '*' if !($target); - - return(\%d, $source, $class, $target, $msg_type); -} - -sub _process_incoming_xpl_hub_data { - my ($data) = @_; - my $ip_address = $::config_parms{'ipaddress_xpl'}; - $ip_address = $::Info{IPAddress_local} unless $ip_address; - - my ($xpl_data, $source, $class, $target, $msg_type) = &parse_data($data); - - return unless $source; - - my ($port); - - # Log hearbeats of other apps; ignore hbeat.basic messages as these - # should not be handled by the hub - if ( $$xpl_data{'hbeat.app'} ) { - # rely on the xPL-message's remote-ip attribute in the hbeat.app - # as the basis for performing IP comparisons - my $sender_ip_address = $$xpl_data{'hbeat.app'}{'remote-ip'}; - - # Open/re-open the port on every hbeat if it posts a listening port. - # Skip if it is our own hbeat (port = listen port) - if ( ( $sender_ip_address eq $ip_address ) ) { - $port = $$xpl_data{'hbeat.app'}{port}; - if ($port) { - $xpl_hub_ports{$port} = $source; - my $port_name = "xpl_send_$port"; - my $msg = - ( $::Socket_Ports{$port_name}{sock} ) - ? 'renewing' - : 'registering'; - print "db xpl $msg port=$port to xPL client $source\n" - if $main::Debug{xpl}; - - # xPL apps want local - &open_port( $port, 'send', $port_name, 1, - $msg eq 'registering' ); - } - } - } - - # As a hub, echo data to other xpl listeners unless it's our transmission - for $port ( keys %xpl_hub_ports ) { - my $sock = $::Socket_Ports{"xpl_send_$port"}{sock}; - print "db2 xpl hub: sending xpl data to p=$port destination=" . - "$xpl_hub_ports{$port} s=$sock d=\n$data.\n" - if $main::Debug{xpl} and $main::Debug{xpl} == 2; - print $sock $data if defined($sock); - } -} - -sub _process_incoming_xpl_data { - my ($data) = @_; - - my ($xpl_data, $source, $class, $target, $msg_type) = &parse_data($data); - - print "db1 xpl check: s=$source c=$class t=$target d=\n$data\n" - if $main::Debug{xpl} and $main::Debug{xpl} == 1; - - # the first time that this sub is called, the xpl_item_names array - # needs to be filled - if ( !(@xpl_item_names) ) { - foreach my $object_type (&::list_object_types) { - foreach my $object_name ( &::list_objects_by_type($object_type) ) { - my $object = &::get_object_by_name("$object_name"); - if ( $object and $object->isa('xPL_Item') ) { - push @xpl_item_names, $object_name; - } - } - } - } - - return unless $source; - - # continue processing unless we are the source (e.g., heart-beat) - if ( !( $source eq &xPL::get_xpl_mh_source_info() ) ) { - # Set states in matching xPL objects - for my $name (@xpl_item_names) - { #(&::list_objects_by_type('xPL_Item')) { - my $o = &main::get_object_by_name($name); - $o = $name unless $o; # In case we stored object directly - print "db3 xpl test o=$name s=$source oa=$$o{source}\n" - if $main::Debug{xpl} and $main::Debug{xpl} == 3; - - # skip this object unless the source matches if a stat or trig - # otherwise, we check the target for a cmnd - # NOTE: the object's hash reference for "source" is "address" - my $regex_address = &wildcard_2_regex( $$o{address} ); - if ( $$o{set_state_on_cmnd} and $msg_type eq 'xpl-cmnd' ) { - my $regex_target = &wildcard_2_regex($target); - next - unless ( $target =~ /^$regex_address$/i ) - or ( $$o{address} =~ /^$regex_target$/i ); - } - else { - if ( $source =~ /^$regex_address$/i ) { - - # handle hbeat data - for my $section ( keys %{$xpl_data} ) { - if ( $section =~ /^hbeat./i ) { - if ( lc $section eq 'hbeat.app' ) { - $o->_handle_alive_app(); - } - else { - $o->_handle_dead_app(); - } - } - } - } - else { - next; - } - } - - # skip this object unless the class matches - if ( $class && $$o{class} ) { - my $regex_class = &wildcard_2_regex( $$o{class} ); - next unless $class =~ /^$regex_class$/i; - } - - # check if device monitoring is enabled - if ( !( $class =~ /hbeat./i ) ) { - next if $o->ignore_message($xpl_data); - } - - # Find and set the state variable - my $state_value; - $$o{changed} = ''; - for my $section ( keys %{$xpl_data} ) { - $$o{sections}{$section} = 'received' - unless $$o{sections}{$section}; - for my $key ( keys %{ $$xpl_data{$section} } ) { - my $value = $$xpl_data{$section}{$key}; - - # does a tied value convertor exist for this key and object? - my $value_convertor = $$o{_value_convertors}{$key} - if defined( $$o{_value_convertors} ); - if ($value_convertor) { - print - "db xpl: located value convertor: $value_convertor\n" - if $main::Debug{xpl}; - my $converted_value = eval $value_convertor; - if ($@) { - print $@; - } - else { - print - "db xpl: converted value is: $converted_value\n" - if $main::Debug{xpl}; - } - $value = $converted_value if $converted_value; - } - $$o{$section}{$key} = $value; - - # Monitor what changed (real data, and include hbeat as - # it may include useful info, e.g., slimserver). - $$o{changed} .= "$section : $key = $value | " - unless $section eq 'xpl-stat' - or $section eq 'xpl-trig' - or $section eq 'xpl-cmnd' - or ( $section eq 'hbeat.app' and $key ne 'status' ); - print "db3 xpl state check m=$$o{state_monitor} key=" . - "$section : $key value=$value\n" - if $main::Debug{xpl}; # and $main::Debug{xpl} == 3; - if ( $$o{state_monitor} ) { - foreach my $state_monitor ( - split( /\|/, $$o{state_monitor} ) ) - { - if ( $state_monitor =~ /$section\s*[:=]\s*$key/i - and defined $value ) - { - print "db3 xpl setting state to $value\n" - if $main::Debug{xpl} - and $main::Debug{xpl} == 3; - $state_value = $value; - } - } - } - } - } - - # assign the "summary" of the message to state_value unless - # state_monitor is being used - $state_value = $$o{changed} unless $$o{state_monitor}; - print "db3 xpl set: n=$name to state=$state_value\n\n" - if $main::Debug{xpl}; # and $main::Debug{xpl} == 3; - - # Can not use Generic_Item set method, as state_next_pass - # only carries state, not all other $section data, to the next pass -# $o -> SUPER::set($state_value, 'xPL') if defined $state_value; - - $o->received( $data ); - if ( defined $state_value and $state_value ne '' ) { - my $set_by_name = 'xPL'; - $set_by_name .= " [$source]"; - $o->set_now( $state_value, $set_by_name ); - #$o->SUPER::set_now( $state_value, $set_by_name ); - $o->state_now_msg_type("$msg_type"); - } - } - } -} - -sub get_mh_vendor_info { - return 'mhouse'; -} - -sub get_mh_device_info { - return 'mh'; -} - -sub get_xpl_mh_source_info { - my $instance = $::config_parms{xpl_title}; - $instance = $::config_parms{title} unless $instance; - $instance = - ( $instance =~ /misterhouse(.*)pid/i ) ? 'misterhouse' : $instance; - $instance = &xPL::get_ok_name_part($instance); - return - &get_mh_vendor_info() . '-' - . &get_mh_device_info() . '.' - . $instance; -} - -sub get_ok_name_part { - my ($in_name) = @_; - my $out_name = lc $in_name; - $out_name =~ tr/ /_/; - $out_name =~ s/[^a-z0-9\-_]//g; - return $out_name; -} - -sub wildcard_2_regex { - my ($expr) = @_; - return unless $expr; - - # convert all periods - $expr =~ s/\./(\\\.)/g; - - # convert all asterisks - $expr =~ s/\*/(\.\*)/g; - - # treat all :> as asterisks - $expr =~ s/:>/(\.\*)/g; - - # convert all greater than symbols - $expr =~ s/>/(\.\*)/g; - - return $expr; -} - -sub send { - my ( $protocol, $class_address, @data ) = @_; - - print "db5 xPL send: ca=$class_address d=@data xpl_send=$xpl_send\n" - if ($main::Debug{xpl} and $main::Debug{xpl} == 5); - - my $target = $class_address; - &sendXpl( $target, 'cmnd', @data ); -} - -sub sendXpl { - if ( defined($xpl_send) ) { - my ( $target, $msg_type, @data ) = @_; - my ( $parms, $msg ); - $msg = "xpl-$msg_type\n{\nhop=1\nsource=" - . &xPL::get_xpl_mh_source_info() . "\n"; - if ( defined($target) ) { - $msg .= "target=$target\n"; - } - $msg .= "}\n"; - while (@data) { - my $section = shift @data; - $msg .= "$section\n{\n"; - my $ptr = shift @data; - if ($ptr) { - my %parms = %$ptr; - for my $key ( sort keys %parms ) { - - # order is important for many xPL clients - # allow a sort key delimitted by ## to drive the order - my ( $subkey1, $subkey2 ) = $key =~ /^(\S+)##(.*)/; - if ( defined $subkey1 and defined $subkey2 ) { - $msg .= "$subkey2=$parms{$key}\n"; - } - else { - $msg .= "$key=$parms{$key}\n"; - } - } - } - $msg .= "}\n"; - } - print "db5 xpl msg: $msg" - if $main::Debug{xpl}; # and $main::Debug{xpl} == 5; - if ($xpl_send) { - - # check to see if the socket is still valid - if ( !( $::Socket_Ports{'xpl_send'}{socka} ) ) { - &xPL::_handleStaleXplSockets(); - } - $xpl_send->set($msg) if $::Socket_Ports{'xpl_send'}{socka}; - } - } - else { - print "WARNING! xPL is disabled and you are trying to send xPL " . - "data!! (xPL::sendXpl())\n"; - } -} - -sub send_xpl_heartbeat { - my ($protocol) = @_; - my $port = $::Socket_Ports{xpl_listen}{port}; - my $ip_address = $::config_parms{'xpl_address'}; - $ip_address = $::config_parms{'ipaddress_xpl'} unless $ip_address; - $ip_address = $::Info{IPAddress_local} - unless $ip_address and $ip_address ne '0.0.0.0'; - - my $msg; - if ($xpl_send) { - $msg = "xpl-stat\n{\nhop=1\nsource=" . &xPL::get_xpl_mh_source_info() - . "\ntarget=*\n}\nhbeat.app\n{\ninterval=$xpl_hbeat_interval\nport=" - . "$port\nremote-ip=$ip_address\n}\n"; - - # check to see if all of the sockets are still valid - &xPL::_handleStaleXplSockets(); - if ($::Socket_Ports{'xpl_send'}{socka}) { - $xpl_send->set($msg); - print "db6 xPL heartbeat: $msg.\n" - if $main::Debug{xpl} and $main::Debug{xpl} == 6; - } else { - print "Error in xPL_Item::send_heartbeat. send socket not active\n"; - } - } - else { - print "Error in xPL_Item::send_heartbeat. " - . "xPL send socket not available.\n" - . "Either disable xPL (xpl_disable = 1) or resolve " - . "system network problem (UDP port 3865).\n"; - } -} - -sub _handleStaleXplSockets { - - # check main sending socket - my $port_name = 'xpl_send'; - if ( !( $::Socket_Ports{$port_name}{socka} ) ) { - if ( - &xPL::open_port( - $::Socket_Ports{$port_name}{port}, - 'send', $port_name, 0, 1 - ) - ) - { - print "Notice. xPL socket ($port_name) had been closed and " - . "has been reopened\n"; - } - else { - print "WARNING! xPL socket ($port_name) had been closed and " - . "can not be reopened\n"; - } - } - - # check main listening socket - $port_name = 'xpl_listen'; - if ( !( $::Socket_Ports{$port_name}{socka} ) ) { - if ( - &xPL::open_port( - $::Socket_Ports{$port_name}{port}, - 'listen', $port_name, 0, 1 - ) - ) - { - print "Notice. xPL socket ($port_name) had been closed and " - . "has been reopened\n"; - } - else { - print "WARNING! xPL socket ($port_name) had been closed and " - . "can not be reopened\n"; - } - } - - # check the hub listening socket if hub mode is enabled - if ( !( $::config_parms{xpl_nohub} ) and defined($xpl_hub_listen) ) { - $port_name = 'xpl_hub_listen'; - if ( !( $::Socket_Ports{$port_name}{socka} ) ) { - if ( - &xPL::open_port( - $::Socket_Ports{$port_name}{port}, - 'listen', $port_name, 0, 1 - ) - ) - { - print "Notice. xPL socket ($port_name) had been closed and " - . "has been reopened\n"; - } - else { - print "WARNING! xPL socket ($port_name) had been closed and " - . "can not be reopened\n"; - } - } - - # no need to check each hub "responder" socket as it is automatically - # reopened on receipt of client's heartbeat - } -} - -package xPL_Item; - -=head1 NAME - -xPL_Item - Misterhouse base xPL Item - -=head1 SYNOPSIS - - IMPORTANT: Mark uses of following methods if for init purposes w/ # noloop. Sample use follows: - - $mySqueezebox = new xPL_Item('slimdev-slimserv.squeezebox'); - $mySqueezebox->manage_heartbeat_timeout(360, "speak 'Squeezebox is not reporting'",1); # noloop - -=head1 DESCRIPTION -=begin comment - - - If # noloop is not used on manage_heartbeat_timeout, you will see many attempts to start the timer - - state_now(): returns all current section data using the following form (unless otherwise - set via state monitor): - : = | : = - - state_now(section_name): returns undef if not defined; otherwise, returns current data for - section name using the following form (unless otherwise set via state_monitor): - = | = - - current_section_names: returns the list of current section names delimitted by the pipe character - - tie_value_convertor(keyname, expr): ties the code reference in expr to keyname. The returned - value from expr is substituted into the key value. The reference in expr may use the variables - $section and $value for processing (where $section is the section name and $value is the - original value. - - e.g., $xpl_obj->tie_value_convertor('temp','$main::convert_c_to_f_degrees($value'); - note: the reference to '$main::' allows access to the user code sub - convert_c_to_f_degrees - - class_name(class_name): Sets/Gets the classname. Classname is actually the . - for xPL. It is also often referred to as the schema name. Used to filter - inbound messages. Except for generic "monitors", this shoudl be set. - - source(source): Sets/Gets the source (name). This is normally ... - It is used to filter inbound messages. Except for generic "monitors", this should be set. - - target_address(target_address): Sets/Gets the target (name). Syntax is similar to source. Used to direct (target) - the message to a specific device. Use "*" (default) for broadcast messages. - - manage_heartbeat_timeout(timeout, action, repeat). Sets the timeout interval (in secs) and action to be performed - on expiration of a timer w/ no corresponding heart-beat messages. Used to enable warnings/notices - of absent heart-beats. See comments on using # noloop above. Timeout should be set to a value - greater than the actual device heartbeat interval. Action/timer is not repeated unless - repeat is 1 or true. - - dead_action(action). Sets/gets the action to be applied on receipt of a "dead" heartbeat (the app - indicates that it is stopping/dying). Not all devices supply a "dead" heartbeat message; - therefore, use manage_heartbeat_timeout as the primary safeguard. - - app_status(). Gets the app status. Initially, set to "unknown" until receipt of first "alive" - heartbeat (then, set to "alive"). Set to "dead" on first dead heart-beat. - - send_cmnd(data). Sends xPL message to target device using data hash. - - device_monitor(deviceinfo): constrains state updates to only messages w/ a devicekey=devicevalue - pair. A common example is where deviceinfo is set to 'someid'. In this case, state updates - are constrained to occur only when a message constains "device=someid". deviceinfo can also - take the literal 'somekey = someid' for messages that use a key other than the literal: 'device'. - - -=cut - -@xPL_Item::ISA = ('Generic_Item'); - -=item $h = xPL_Item->new('tag', 'attrname' => 'value',...) - -The object constructor. Takes a tag name as argument. Optionally, -allows you to specify initial attributes at object creation time. - -=cut - -# Support both send and receive objects -sub new { - my ( $object_class, $xpl_source, @data, $xpl_class ) = @_; - my $self = {}; - bless $self, $object_class; - - $xpl_source = '*' if !$xpl_source or $xpl_source eq '*'; - - $$self{state} = ''; - $$self{address} = $xpl_source; # left in place for legacy - $$self{address} = '*' if !$xpl_source; - $$self{target_address} = '*'; - $$self{class} = $xpl_class unless !$xpl_class; - $$self{m_timeoutHeartBeat} = 0; - $$self{m_appStatus} = 'unknown'; - $$self{m_timerHeartBeat} = new Timer(); - $$self{m_state_now_msg_type} = 'unknown'; - $$self{m_allow_empty_state} = 0; - - &xPL_Item::store_data( $self, @data ); - - $self->state_overload('off') - ; # By default, do not process ~;: strings as substate/multistate - - return $self; -} - -sub source { - my ( $self, $p_strSource ) = @_; - $$self{address} = $p_strSource if defined $p_strSource; - return $$self{address}; -} - -sub class_name { - - my ( $self, $p_strClassName ) = @_; - $$self{class} = $p_strClassName if defined $p_strClassName; - return $$self{class}; -} - -sub target_address { - my ( $self, $p_strTarget ) = @_; - $$self{target_address} = $p_strTarget if defined $p_strTarget; - return $$self{target_address}; -} - -sub received { - my ( $self, $received ) = @_; - $$self{received} = $received if defined $received; - return $$self{received}; -} - -sub device_name { - my ( $self, $p_strDeviceName ) = @_; - $$self{m_device_name} = $p_strDeviceName if $p_strDeviceName; - return $$self{m_device_name}; -} - -sub on_set_message { - my ( $self, @data ) = @_; - while (@data) { - my $section = shift @data; - my $ptr = shift @data; - my %parms = %$ptr; - for my $key ( sort keys %parms ) { - my $value = $parms{$key}; - $$self{_on_set_message}{$section}{$key} = $value; - } - } - return $$self{_on_set_message}; -} - -sub allow_empty_state { - my ( $self, $p_allowEmptyState ) = @_; - $$self{m_allow_empty_state} = $p_allowEmptyState - if defined($p_allowEmptyState); - return $$self{m_allow_empty_state}; -} - -sub manage_heartbeat_timeout { - my ( $self, $p_timeoutHeartBeat, $p_actionHeartBeat, $p_repeatAction ) = @_; - if ( defined($p_timeoutHeartBeat) and defined($p_actionHeartBeat) ) { - my $m_repeatAction = 0; - $m_repeatAction = $p_repeatAction if $p_repeatAction; - $$self{m_actionHeartBeat} = $p_actionHeartBeat; - $$self{m_timeoutHeartBeat} = $p_timeoutHeartBeat; - $$self{m_timerHeartBeat}->set( - $$self{m_timeoutHeartBeat}, - $$self{m_actionHeartBeat}, - $m_repeatAction - ); - $$self{m_timerHeartBeat}->start(); - } -} - -sub dead_action { - my ( $self, $p_actionDeadApp ) = @_; - $$self{m_app_Status} = 'dead'; - if ( defined $p_actionDeadApp ) { - $$self{m_actionDeadApp} = $p_actionDeadApp; - } - return $$self{m_actionDeadApp}; -} - -sub _handle_dead_app { - my ($self) = @_; - return eval $$self{m_actionDeadApp} if defined( $$self{m_actionDeadApp} ); -} - -sub _handle_alive_app { - my ($self) = @_; - $$self{m_appStatus} = 'alive'; - if ( $$self{m_timeoutHeartBeat} != 0 ) { - $$self{m_timerHeartBeat}->restart() - unless $$self{m_timerHeartBeat}->inactive(); - return 1; - } - else { - $$self{m_timerHeartBeat}->stop() - unless $$self{m_timerHeartBeat}->inactive(); - return 0; - } -} - -sub app_status { - my ($self) = @_; - return $$self{m_appStatus}; -} - -sub store_data { - my ( $self, @data ) = @_; - while (@data) { - my $section = shift @data; - $$self{class} = $section; - $$self{sections}{$section} = 'send'; - my $ptr = shift @data; - my %parms = %$ptr; - for my $key ( sort keys %parms ) { - my $value = $parms{$key}; - $$self{$section}{$key} = $value; - $$self{state_monitor} = "$section : $key" if $value eq '$state'; - } - } -} - -sub state_now { - my ( $self, $section_name ) = @_; - my $state_now = $self->SUPER::state_now(); - if ($section_name) { - - # default section_state_now to undef unless it actually exists - my $section_state_now = undef; - for my $section ( split( /\s+\|\s+/, $state_now ) ) { - my @section_data = split( /\s+:\s+/, $section ); - my $section_ref = $section_data[0]; - next if $section_ref eq ''; - if ( $section_ref eq $section_name ) { - if ( defined($section_state_now) ) { - $section_state_now .= " | $section_data[1]"; - } - else { - $section_state_now = $section_data[1]; - } - } - } - print "db xPL_Item:state_now: section data for $section_name is: " - . "$section_state_now\n" - if $main::Debug{xpl} and $section_state_now; - $state_now = $section_state_now; - } - return $state_now; -} - -sub current_section_names { - my ($self) = @_; - my $changed = $$self{changed}; - my $current_section_names = undef; - if ($changed) { - for my $section ( split( /\s+\|\s+/, $changed ) ) { - my @section_data = split( /\s+:\s+/, $section ); - if ( defined($current_section_names) ) { - $current_section_names .= " | $section_data[0]"; - } - else { - $current_section_names = $section_data[0]; - } - } - - } - print "db xPL_Item:current_section_names : $current_section_names\n" - if $main::Debug{xpl}; - return $current_section_names; -} - -sub tie_value_convertor { - my ( $self, $key_name, $convertor ) = @_; - $$self{_value_convertors}{$key_name} = $convertor - if ( defined($key_name) && defined($convertor) ); - -} - -sub device_monitor { - my ( $self, $monitor_info ) = @_; - if ($monitor_info) { - my ($key,$value) = $monitor_info =~ /(\S+)\s*[:=]\s*(.+)/; - if ( !( $value or $value =~ /^0/ ) ) { - $value = ($key) ? $key : $monitor_info; - $key = 'device'; - } - $$self{_device_id} = lc $value; - $$self{_device_id_key} = lc $key; - } - if ( defined $$self{_device_id} ) { - return ( - ( $$self{_device_id_key} ) ? $$self{_device_id_key} : 'device' ) - . $$self{_device_id}; - } - else { - return; - } -} - -sub default_setstate { - my ( $self, $state, $substate, $set_by ) = @_; - # Send data, unless we are processing incoming data - return if !(ref $set_by) and $set_by =~ /^xpl/i; - my @parms; - - if ( $$self{_on_set_message} ) { - for my $class_name ( sort keys %{ $$self{_on_set_message} } ) { - my $block; - for my $msg_key ( - sort keys %{ $$self{_on_set_message}{$class_name} } ) - { - my $field_value = - eval( $$self{_on_set_message}{$class_name}{$msg_key} ); - $block->{$msg_key} = $field_value; - } - push @parms, $class_name, $block; - } - } - else { - if ( $$self{state_monitor} ) { - foreach my $state_monitor ( split( /\|/, $$self{state_monitor} ) ) { - my ( $section, $key ) = - $$self{state_monitor} =~ /(\S+)\s*[:=]\s*(\S+)/; - $$self{$section}{$key} = $state; - } - } - for my $section ( sort keys %{ $$self{sections} } ) { - next - unless $$self{sections}{$section} eq - 'send'; # Do not echo received data - push @parms, $section, $$self{$section}; - } - } - - if (@parms) { - - # sending stat info about ourselves? - if ( lc $$self{source} eq &xPL::get_xpl_mh_source_info() ) { - $self->send_trig(@parms); - } - else { - - # must be cmnd info to another device addressed by address - $self->send_cmnd(@parms); - } - } -} - -sub state_now_msg_type { - my ( $self, $p_msgType ) = @_; - $$self{m_state_now_msg_type} = $p_msgType if defined($p_msgType); - return $$self{m_state_now_msg_type}; -} - -# DO NOT use the following sub -# Instead, DO use either send_cmnd, send_trig or send_stat -sub send_message { - my ( $self, $p_strTarget, @p_data ) = @_; - $self->send_cmnd(@p_data); -} - -sub send_cmnd { - my ( $self, @p_data ) = @_; - if ( defined $$self{_device_id} ) { - my $classname = shift @p_data; - my $ptr = shift @p_data; - my @new_data = (); - $ptr->{ $$self{_device_id_key} } = $$self{_device_id}; - push @new_data, $classname, $ptr; - &xPL::sendXpl( $self->source, 'cmnd', @new_data ); - } - else { - &xPL::sendXpl( $self->source, 'cmnd', @p_data ); - } -} - -sub send_stat { - my ( $self, @p_data ) = @_; - if ( defined $$self{_device_id} ) { - my $classname = shift @p_data; - my $ptr = shift @p_data; - my @new_data = (); - $ptr->{ $$self{_device_id_key} } = $$self{_device_id}; - push @new_data, $classname, $ptr; - &xPL::sendXpl( '*', 'stat', @new_data ); - } - else { - &xPL::sendXpl( '*', 'stat', @p_data ); - } -} - -sub send_trig { - my ( $self, @p_data ) = @_; - if ( defined $$self{_device_id} ) { - my $classname = shift @p_data; - my $ptr = shift @p_data; - my @new_data = (); - $ptr->{ $$self{_device_id_key} } = $$self{_device_id}; - push @new_data, $classname, $ptr; - &xPL::sendXpl( '*', 'trig', @new_data ); - } - else { - &xPL::sendXpl( '*', 'trig', @p_data ); - } -} - -sub ignore_message { - my ( $self, $p_data ) = @_; - my $ignore_message = 0; - if ( $$self{_device_id_key} and $self->class_name ) { - print -"Device monitoring enabled: key=$$self{_device_id_key}, id=$$self{_device_id}, tested value=" - . $$p_data{ $self->class_name }{ $$self{_device_id_key} } . "\n" - if $main::Debug{xpl}; - $ignore_message = - ( $$self{_device_id} ne - lc $$p_data{ $self->class_name }{ $$self{_device_id_key} } ) - ? 1 - : 0; - } - return $ignore_message; -} - -package xPL_Sensor; - -@xPL_Sensor::ISA = ('xPL_Item'); - -sub new { - my ( $class, $p_source, $p_type, $p_statekey ) = @_; - my ( $source, $deviceid ) = $p_source =~ /(\S+)?:([\S ]+)/; - $source = $p_source unless $source; - my $self = $class->SUPER::new($source); - if ($p_type) - { - $$self{sensor_type} = $p_type; - if ($p_type eq 'output') # define a default message to be sent out on a call to the "set" method - { - # the following can always be overwritten - $self->on_set_message('control.basic' => { 'z##current' => '$state' }); - } - } - else - { - $$self{sensor_type} = 'input'; # set a default - } - my $statekey = 'current'; - $statekey = $p_statekey if $p_statekey; - $self->SUPER::class_name('sensor.basic'); - $$self{state_monitor} = "sensor.basic : $statekey"; - $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; - return $self; -} - -sub type { - my ( $self, $p_type ) = @_; - $$self{sensor_type} = $p_type if $p_type; - return $$self{sensor_type}; -} - -sub current { - my ($self) = @_; - return $$self{'sensor.basic'}{current}; -} - -sub units { - my ($self) = @_; - return $$self{'sensor.basic'}{units}; -} - -sub lowest { - my ($self) = @_; - return $$self{'sensor.basic'}{lowest}; -} - -sub highest { - my ($self) = @_; - return $$self{'sensor.basic'}{highest}; -} - -sub ignore_message { - my ( $self, $p_data ) = @_; - return 1 - if $self->SUPER::ignore_message($p_data) - ; # user xPL_Item's filter against deviceid - return ( $$p_data{'sensor.basic'}{type} ne $$self{sensor_type} ) ? 1 : 0; -} - -sub request_stat { - my ($self) = @_; - $self->SUPER::send_cmnd( 'sensor.request' => - { 'request' => 'current', 'type' => "'$$self{sensor_type}'" } ); -} - -package xPL_UPS; - -@xPL_UPS::ISA = ('xPL_Item'); - -sub new { - my ( $class, $p_source, $p_statekey ) = @_; - my ( $source, $deviceid ) = $p_source =~ /(\S+):(\S+)/; - $source = $p_source unless $source; - my $self = $class->SUPER::new($source); - my $statekey = $p_statekey; - $statekey = 'status'; - - # $self->SUPER::class_name('ups.basic'); - $$self{state_monitor} = "ups.basic : $statekey|hbeat.app : $statekey"; - $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; - return $self; -} - -sub status { - my ( $self, $p_status ) = @_; - return ( $$self{'ups.basic'}{status} ) - ? $$self{'ups.basic'}{status} - : $$self{'hbeat.app'}{status}; -} - -sub event { - my ($self) = @_; - return $$self{'ups.basic'}{event}; -} - -sub ignore_message { - my ( $self, $p_data ) = @_; - return 1 - if $self->SUPER::ignore_message($p_data) - ; # user xPL_Item's filter against deviceid - return ( $$p_data{'ups.basic'} or $$p_data{'hbeat.app'} ) ? 0 : 1; -} - -package xPL_X10Security; - -@xPL_X10Security::ISA = ('xPL_Item'); - -sub new { - my ( $class, $p_source, $p_type, $p_statekey ) = @_; - my ( $source, $deviceid ) = $p_source =~ /(\S+):(\S+)/; - $source = $p_source unless $source; - my $self = $class->SUPER::new($source); - $$self{type} = $p_type if $p_type; - my $statekey = $p_statekey; - $statekey = 'command'; - $self->SUPER::class_name('x10.security'); - $$self{state_monitor} = "x10.security : $statekey"; - $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; - return $self; -} - -sub type { - my ( $self, $p_type ) = @_; - $$self{type} = $p_type if $p_type; - return $$self{type}; -} - -sub command { - my ($self) = @_; - return $$self{'x10.security'}{command}; -} - -sub tamper { - my ($self) = @_; - return $$self{'x10.security'}{tamper}; -} - -sub low_battery { - my ($self) = @_; - return $$self{'x10.security'}{'low-battery'}; -} - -sub delay { - my ($self) = @_; - return $$self{'x10.security'}{delay}; -} - -sub ignore_message { - my ( $self, $p_data ) = @_; - return 1 - if $self->SUPER::ignore_message($p_data) - ; # user xPL_Item's filter against deviceid - if ( $$self{type} ) { - return ( $$p_data{'x10.security'}{type} ne $$self{type} ) ? 1 : 0; - } - else { - return 0; - } -} - -package xPL_Rio; - -@xPL_Rio::ISA = ('xPL_Item'); - -# Support both send and receive objects -sub new { - my ( $object_class, $xpl_source, $xpl_target ) = @_; - my $self = {}; - bless $self, $object_class; - - $$self{state} = ''; - $$self{source} = $xpl_source; - $$self{target_address} = $xpl_target unless !$xpl_target; - - &xPL_Item::store_data( $self, 'rio.basic' => { sel => '$state' } ); - - @{ $$self{states} } = ( - 'play', - 'stop', - 'mute', - 'volume +20', - 'volume -20', - 'volume 100', - 'skip', - 'back', - 'random', - 'power on', - 'power off', - 'light on', - 'light off' - ); - - return $self; - -} - -1; + +=begin comment + +xPL_Items.pm - Misterhouse interface for the xPL protocol + +Info: + + xPL websites: + http://www.xplproject.org.uk + http://www.xaphal.com + +Authors: + 10/26/2002 Created by Bruce Winter bruce@misterhouse.net + + +xPL works by using the xPL Hub built in misterhouse and listening for +xPL connections. See: +http://misterhouse.wikispaces.com/xAP+and+xPL+-+Getting+Started + +Relevant variables for mh.private.ini are: +#ipaddress_xpl_broadcast = 192.168.205.255 +#ipaddress_xpl = 192.168.205.3 +#xpl_disable = 1 +#xpl_nohub = 1 +#xpl_enable_items = 1 + +You can disable the mh internal xPL hub if you are running a more capable one. +To get data input, you can use something like + +xpl-rfxcom-rx --verbose --rfxcom-rx-verbose --rfxcom-rx-tty /dev/rfxcom --interface eth1 + +from xPL-Perl. Then watch for sensor updates passing by and paste their info +in your device table, like so: +XPL_SENSOR, bnz-rfxcomrx.gargamel:bthr918n.e6, oregon_intemp, XPL_temp, temp + +Another option to figure out the name to use in XPL_SENSOR is to use +xpl-logger -head -body -i ethx 2>&1 | grep "xpl-trig\/" +(or without the grep for more details on which field is called what). + +A few samples: +XPL_SENSOR, iranger-rfx.*:WGR918, oregon_winddir, , direction +XPL_SENSOR, iranger-rfx.*:BHTR968, oregon_intemp, , temp +XPL_SENSOR, bnz-owfs.*:10.2223EF010800, owfs_temp, , temp +XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000, owfs_humidity, , humidity +XPL_SENSOR, bnz-owfs.*:26.2E4DF5000000.1, owfs_humidity1, , humidity +XPL_X10SECURITY, iranger-rfx.*:F8, x10sec_garage1, , ds10 + +Note that XPL_SENSOR should just be used for XPL messages of the x10.basic +type. XPL_X10SECURITY is for x10.security schema, while there is no way to +currently read x10.basic messages (see this file for more supported schemas). + +Once it is running, objects get variables including these: +'state' => '17.9', +'states_nosubstate' => 1, +'states_substate' ? +'address' => 'bnz-rfxcomrx.gargamel', +'states_nomultistate' => 1, +'states_multistate' ? +'target_address' => '*', +'_device_id' => 'bthr918n.e6' +'set_time' => 1285555578, +'m_timerHeartBeat' => bless( {}, 'Timer' ), +'m_timeoutHeartBeat' => 0, + + +So, you would write this to print temperature: +print_log $oregon_intemp->state +=cut + +use strict; + +package xPL; + +#@xPL::ISA = ('Generic_Item'); + +my ( + @xpl_item_names, $started, %hub_ports, + $xpl_listen, $xpl_hub_listen, $xpl_send, + %xpl_hub_ports, $xpl_hbeat_interval, $xpl_hbeat_counter +); + +# Create sockets and add hook to check incoming data +sub startup { + return + if $started++ + ; # Allows us to call with $Reload or with xpl_module mh.ini parm + + # In case you don't want xpl for some reason + return if $::config_parms{xpl_disable}; + + # determine our local ipaddress(es) + @xpl_item_names = (); + my ($port); + + # init the hbeat intervals and counters + $xpl_hbeat_interval = $::config_parms{xpl_hbeat_interval}; + $xpl_hbeat_interval = 5 unless $xpl_hbeat_interval; + $xpl_hbeat_counter = $xpl_hbeat_interval; + + if ( !( $::config_parms{xpl_disable} ) ) { + undef $port; + $port = $::config_parms{xpl_port}; + $port = 3865 unless $port; + + # open the sending port + &open_port( $port, 'send', 'xpl_send', 0, 1 ); + $xpl_send = new Socket_Item( undef, undef, 'xpl_send' ); + + # Find and use the first open port + my $port_listen; + for my $p (49352 .. 65535) { + $port_listen = $p; + last if &open_port( $port_listen, 'listen', 'xpl_listen', 1, 1); + } + # The socket code will select a free local port if given 0 + # not working on ubuntu 12.04 + #&open_port( 0, 'listen', 'xpl_listen', 1, 1 ); + #$port_listen = $::Socket_Ports{'xpl_listen'}{port}; + $xpl_listen = new Socket_Item( undef, undef, 'xpl_listen' ); + + # initialize the hub (listen) port + if ( $::config_parms{xpl_nohub} ) { + $xpl_hub_listen = undef; + } + else { + if ( &open_port( $port, 'listen', 'xpl_hub_listen', 0, 1 ) ) { + $xpl_hub_listen = + new Socket_Item( undef, undef, 'xpl_hub_listen' ); + print " - mh in xPL Hub mode\n"; + + # now set up the hub port that will send to mh + $xpl_hub_ports{$port_listen} = &xPL::get_xpl_mh_source_info(); + my $port_name = "xpl_send_$port_listen"; + &open_port( $port_listen, 'send', $port_name, 1, 1 ); + } + else { + print " - mh automatically switching out of xPL Hub mode. " . + "Another application is binding to the hub port ($port)\n"; + $xpl_hub_listen = undef; + } + } + + # now that a listen port exists, advertise it w/ the first hbeat msg + &xPL::send_xpl_heartbeat() if $xpl_send; + + } + + &::MainLoop_pre_add_hook( \&xPL::check_for_data, 1 ); + + # add reload hook so that xpl_item_names list is reset + &::Reload_pre_add_hook( \&xPL::reload_hook, 1 ); +} + +sub reload_hook { + @xpl_item_names = (); +} + +sub main::display_xpl { + my (%args) = @_; + my $schema = lc ${args}{schema}; + $schema = 'osd.basic' unless $schema; + if ( $schema eq 'osd.basic' ) { + &main::display_xpl_osd_basic(%args); + } + else { + &main::print_log( + "Display support for the schema, $schema, does not yet exist"); + } +} + +sub main::display_xpl_osd_basic { + my (%args) = @_; + my ( $text, $duration, $address ); + $text = $args{raw_text}; + $text = $args{text} unless $text; + $text =~ s/[\n\r ]+/ /gm; # strip out new lines and extra space + $text =~ s/\n/\\n/gm; # escape new lines + $duration = $args{duration}; + $duration = $args{display} + unless $duration; # this apparently is the original param? + $duration = 10 unless $duration; # default to 10 sec display + $address = $args{to}; + $address = $args{address} unless $address; + $address = '*' unless $address; + + # auto pre-pend text w/ a newline if the target is a squeezebox and + # doesn't already have one + if ( $address =~ /^slimdev-slimserv/i ) { + $text = "\\n$text" unless $text =~ /\\n\S+/i; + } + &xPL::send( 'xPL', $address, + 'osd.basic' => { command => 'write', delay => $duration, text => $text } + ); +} + +sub open_port { + my ( $port, $send_listen, $port_name, $local, $verbose ) = @_; + + # Need to re-open the port, if client app has been re-started?? + close $::Socket_Ports{$port_name}{sock} + if $::Socket_Ports{$port_name}{sock}; + + my $sock; + if ( $send_listen eq 'send' ) { + my $dest_address; + if ($local) { + if ($main::OS_win || $::Info{'OS_name'} eq 'cygwin') { + $dest_address = $::Info{IPAddress_local} unless $dest_address; + } + else { + $dest_address = '0.0.0.0'; + } + } + else { + $dest_address = $::config_parms{'ipaddress_xpl_broadcast'}; + $dest_address = '255.255.255.255' unless $dest_address; + } + $sock = new IO::Socket::INET->new( + PeerPort => $port, + Proto => 'udp', + PeerAddr => $dest_address, + Broadcast => 1 + ); + + print "db xPL_Items open_port: pn=$port_name l=$local PeerPort=$port " . + "PeerAddr=$dest_address" if $main::Debug{xpl}; + } + else { + my $listen_address; + if ( !($local) ) { + $listen_address = $::config_parms{'ipaddress_xpl'}; + $listen_address = $::config_parms{'xpl_address'} + unless $listen_address; + } + if ($main::OS_win || $::Info{'OS_name'} eq 'cygwin') { + $listen_address = $::Info{IPAddress_local} unless $listen_address; + } + else { + # can't get *nix to bind to a specific address; defaults to + # kernel assigned default IP + $listen_address = '0.0.0.0'; + } + $sock = new IO::Socket::INET->new( + LocalPort => $port, + Proto => 'udp', + LocalAddr => $listen_address, + Broadcast => 1 + ); + $port = $sock->sockport() if ($port == 0); + + print "db xPL_Items open_port: pn=$port_name l=$local LocalPort=$port " . + "LocalAddr=$listen_address" if $main::Debug{xpl}; + } + unless ($sock) { + print " -- FAILED\n" if $main::Debug{xpl}; + print "\nError: Could not start a udp xPL send server on $port: $@\n\n" + if $send_listen eq 'send'; + return 0; + } + print "\n" if $main::Debug{xpl}; + + printf " - creating %-15s on %3s %5s %s\n", $port_name, 'udp', $port, + $send_listen + if $verbose; + + $::Socket_Ports{$port_name}{protocol} = 'udp'; + $::Socket_Ports{$port_name}{datatype} = 'raw'; + $::Socket_Ports{$port_name}{port} = $port; + $::Socket_Ports{$port_name}{sock} = $sock; + $::Socket_Ports{$port_name}{socka} = $sock; # UDP ports are always "active" + + return $sock; +} + +sub check_for_data { + + if ( $xpl_hub_listen && ( my $xpl_hub_data = said $xpl_hub_listen) ) { + &_process_incoming_xpl_hub_data($xpl_hub_data); + } + if ( $xpl_listen && ( my $xpl_data = said $xpl_listen) ) { + &_process_incoming_xpl_data($xpl_data); + } + + # check to see if hbeats need to be sent + if ( &::new_minute($xpl_hbeat_interval) ) { + if ($xpl_send) { + if ( $xpl_hbeat_counter == 5 ) { + &xPL::send_xpl_heartbeat(); + $xpl_hbeat_counter = $xpl_hbeat_interval; + } + else { + $xpl_hbeat_counter = $xpl_hbeat_counter - 1; + } + } + } +} + +# Parse incoming xPL records +sub parse_data { + my ($data) = @_; + my ( $source, $class, $target, $msg_type, $section, %d ); + print "db4 xPL data:\n$data\n" + if $main::Debug{xpl} and $main::Debug{xpl} == 4; + for my $r ( split /[\r\n]/, $data ) { + next if $r =~ /^[\{\} ]*$/; + + # Store xpl-header, xpl-heartbeat, and other data + if ( my ( $key, $value ) = $r =~ /(.+?)=(.*)/ ) { + $key = lc $key; + $value = lc $value + if ( $section =~ /^xpl/ ); # Do not lc real data; + $source = $value if $section =~ /^xpl/ and $key =~ /^source$/i; + $target = $value if $section =~ /^xpl/ and $key =~ /^target$/i; + if ( exists( $d{$section}{$key} ) ) { + $d{$section}{$key} .= "," + . $value; # xpl allows "continuation lines" + } + else { + $d{$section}{$key} = $value; + } + print "db4 xpl parsed c=$section k=$key v=$value\n" + if ( $main::Debug{xpl} and $main::Debug{xpl} == 4 ); + } + + # section (e.g. xpl-header, xpl-heartbeat, source.instance + else { + $section = lc $r; + $msg_type ? $class = $section : $msg_type = $section; + } + } + # define target as '*' if undefined + $target = '*' if !($target); + + return(\%d, $source, $class, $target, $msg_type); +} + +sub _process_incoming_xpl_hub_data { + my ($data) = @_; + my $ip_address = $::config_parms{'ipaddress_xpl'}; + $ip_address = $::Info{IPAddress_local} unless $ip_address; + + my ($xpl_data, $source, $class, $target, $msg_type) = &parse_data($data); + + return unless $source; + + my ($port); + + # Log hearbeats of other apps; ignore hbeat.basic messages as these + # should not be handled by the hub + if ( $$xpl_data{'hbeat.app'} ) { + # rely on the xPL-message's remote-ip attribute in the hbeat.app + # as the basis for performing IP comparisons + my $sender_ip_address = $$xpl_data{'hbeat.app'}{'remote-ip'}; + + # Open/re-open the port on every hbeat if it posts a listening port. + # Skip if it is our own hbeat (port = listen port) + if ( ( $sender_ip_address eq $ip_address ) ) { + $port = $$xpl_data{'hbeat.app'}{port}; + if ($port) { + $xpl_hub_ports{$port} = $source; + my $port_name = "xpl_send_$port"; + my $msg = + ( $::Socket_Ports{$port_name}{sock} ) + ? 'renewing' + : 'registering'; + print "db xpl $msg port=$port to xPL client $source\n" + if $main::Debug{xpl}; + + # xPL apps want local + &open_port( $port, 'send', $port_name, 1, + $msg eq 'registering' ); + } + } + } + + # As a hub, echo data to other xpl listeners unless it's our transmission + for $port ( keys %xpl_hub_ports ) { + my $sock = $::Socket_Ports{"xpl_send_$port"}{sock}; + print "db2 xpl hub: sending xpl data to p=$port destination=" . + "$xpl_hub_ports{$port} s=$sock d=\n$data.\n" + if $main::Debug{xpl} and $main::Debug{xpl} == 2; + print $sock $data if defined($sock); + } +} + +sub _process_incoming_xpl_data { + my ($data) = @_; + + my ($xpl_data, $source, $class, $target, $msg_type) = &parse_data($data); + + print "db1 xpl check: s=$source c=$class t=$target d=\n$data\n" + if $main::Debug{xpl} and $main::Debug{xpl} == 1; + + # the first time that this sub is called, the xpl_item_names array + # needs to be filled + if ( !(@xpl_item_names) ) { + foreach my $object_type (&::list_object_types) { + foreach my $object_name ( &::list_objects_by_type($object_type) ) { + my $object = &::get_object_by_name("$object_name"); + if ( $object and $object->isa('xPL_Item') ) { + push @xpl_item_names, $object_name; + } + } + } + } + + return unless $source; + + # continue processing unless we are the source (e.g., heart-beat) + if ( !( $source eq &xPL::get_xpl_mh_source_info() ) ) { + # Set states in matching xPL objects + for my $name (@xpl_item_names) + { #(&::list_objects_by_type('xPL_Item')) { + my $o = &main::get_object_by_name($name); + $o = $name unless $o; # In case we stored object directly + print "db3 xpl test o=$name s=$source oa=$$o{source}\n" + if $main::Debug{xpl} and $main::Debug{xpl} == 3; + + # skip this object unless the source matches if a stat or trig + # otherwise, we check the target for a cmnd + # NOTE: the object's hash reference for "source" is "address" + my $regex_address = &wildcard_2_regex( $$o{address} ); + if ( $$o{set_state_on_cmnd} and $msg_type eq 'xpl-cmnd' ) { + my $regex_target = &wildcard_2_regex($target); + next + unless ( $target =~ /^$regex_address$/i ) + or ( $$o{address} =~ /^$regex_target$/i ); + } + else { + if ( $source =~ /^$regex_address$/i ) { + + # handle hbeat data + for my $section ( keys %{$xpl_data} ) { + if ( $section =~ /^hbeat./i ) { + if ( lc $section eq 'hbeat.app' ) { + $o->_handle_alive_app(); + } + else { + $o->_handle_dead_app(); + } + } + } + } + else { + next; + } + } + + # skip this object unless the class matches + if ( $class && $$o{class} ) { + my $regex_class = &wildcard_2_regex( $$o{class} ); + next unless $class =~ /^$regex_class$/i; + } + + # check if device monitoring is enabled + if ( !( $class =~ /hbeat./i ) ) { + next if $o->ignore_message($xpl_data); + } + + # Find and set the state variable + my $state_value; + $$o{changed} = ''; + for my $section ( keys %{$xpl_data} ) { + $$o{sections}{$section} = 'received' + unless $$o{sections}{$section}; + for my $key ( keys %{ $$xpl_data{$section} } ) { + my $value = $$xpl_data{$section}{$key}; + + # does a tied value convertor exist for this key and object? + my $value_convertor = $$o{_value_convertors}{$key} + if defined( $$o{_value_convertors} ); + if ($value_convertor) { + print + "db xpl: located value convertor: $value_convertor\n" + if $main::Debug{xpl}; + my $converted_value = eval $value_convertor; + if ($@) { + print $@; + } + else { + print + "db xpl: converted value is: $converted_value\n" + if $main::Debug{xpl}; + } + $value = $converted_value if $converted_value; + } + $$o{$section}{$key} = $value; + + # Monitor what changed (real data, and include hbeat as + # it may include useful info, e.g., slimserver). + $$o{changed} .= "$section : $key = $value | " + unless $section eq 'xpl-stat' + or $section eq 'xpl-trig' + or $section eq 'xpl-cmnd' + or ( $section eq 'hbeat.app' and $key ne 'status' ); + print "db3 xpl state check m=$$o{state_monitor} key=" . + "$section : $key value=$value\n" + if $main::Debug{xpl}; # and $main::Debug{xpl} == 3; + if ( $$o{state_monitor} ) { + foreach my $state_monitor ( + split( /\|/, $$o{state_monitor} ) ) + { + if ( $state_monitor =~ /$section\s*[:=]\s*$key/i + and defined $value ) + { + print "db3 xpl setting state to $value\n" + if $main::Debug{xpl} + and $main::Debug{xpl} == 3; + $state_value = $value; + } + } + } + } + } + + # assign the "summary" of the message to state_value unless + # state_monitor is being used + $state_value = $$o{changed} unless $$o{state_monitor}; + print "db3 xpl set: n=$name to state=$state_value\n\n" + if $main::Debug{xpl}; # and $main::Debug{xpl} == 3; + + # Can not use Generic_Item set method, as state_next_pass + # only carries state, not all other $section data, to the next pass +# $o -> SUPER::set($state_value, 'xPL') if defined $state_value; + + $o->received( $data ); + if ( defined $state_value and $state_value ne '' ) { + my $set_by_name = 'xPL'; + $set_by_name .= " [$source]"; + $o->set_now( $state_value, $set_by_name ); + #$o->SUPER::set_now( $state_value, $set_by_name ); + $o->state_now_msg_type("$msg_type"); + } + } + } +} + +sub get_mh_vendor_info { + return 'mhouse'; +} + +sub get_mh_device_info { + return 'mh'; +} + +sub get_xpl_mh_source_info { + my $instance = $::config_parms{xpl_title}; + $instance = $::config_parms{title} unless $instance; + $instance = + ( $instance =~ /misterhouse(.*)pid/i ) ? 'misterhouse' : $instance; + $instance = &xPL::get_ok_name_part($instance); + return + &get_mh_vendor_info() . '-' + . &get_mh_device_info() . '.' + . $instance; +} + +sub get_ok_name_part { + my ($in_name) = @_; + my $out_name = lc $in_name; + $out_name =~ tr/ /_/; + $out_name =~ s/[^a-z0-9\-_]//g; + return $out_name; +} + +sub wildcard_2_regex { + my ($expr) = @_; + return unless $expr; + + # convert all periods + $expr =~ s/\./(\\\.)/g; + + # convert all asterisks + $expr =~ s/\*/(\.\*)/g; + + # treat all :> as asterisks + $expr =~ s/:>/(\.\*)/g; + + # convert all greater than symbols + $expr =~ s/>/(\.\*)/g; + + return $expr; +} + +sub send { + my ( $protocol, $class_address, @data ) = @_; + + print "db5 xPL send: ca=$class_address d=@data xpl_send=$xpl_send\n" + if ($main::Debug{xpl} and $main::Debug{xpl} == 5); + + my $target = $class_address; + &sendXpl( $target, 'cmnd', @data ); +} + +sub sendXpl { + if ( defined($xpl_send) ) { + my ( $target, $msg_type, @data ) = @_; + my ( $parms, $msg ); + $msg = "xpl-$msg_type\n{\nhop=1\nsource=" + . &xPL::get_xpl_mh_source_info() . "\n"; + if ( defined($target) ) { + $msg .= "target=$target\n"; + } + $msg .= "}\n"; + while (@data) { + my $section = shift @data; + $msg .= "$section\n{\n"; + my $ptr = shift @data; + if ($ptr) { + my %parms = %$ptr; + for my $key ( sort keys %parms ) { + + # order is important for many xPL clients + # allow a sort key delimitted by ## to drive the order + my ( $subkey1, $subkey2 ) = $key =~ /^(\S+)##(.*)/; + if ( defined $subkey1 and defined $subkey2 ) { + $msg .= "$subkey2=$parms{$key}\n"; + } + else { + $msg .= "$key=$parms{$key}\n"; + } + } + } + $msg .= "}\n"; + } + print "db5 xpl msg: $msg" + if $main::Debug{xpl}; # and $main::Debug{xpl} == 5; + if ($xpl_send) { + + # check to see if the socket is still valid + if ( !( $::Socket_Ports{'xpl_send'}{socka} ) ) { + &xPL::_handleStaleXplSockets(); + } + $xpl_send->set($msg) if $::Socket_Ports{'xpl_send'}{socka}; + } + } + else { + print "WARNING! xPL is disabled and you are trying to send xPL " . + "data!! (xPL::sendXpl())\n"; + } +} + +sub send_xpl_heartbeat { + my ($protocol) = @_; + my $port = $::Socket_Ports{xpl_listen}{port}; + my $ip_address = $::config_parms{'xpl_address'}; + $ip_address = $::config_parms{'ipaddress_xpl'} unless $ip_address; + $ip_address = $::Info{IPAddress_local} + unless $ip_address and $ip_address ne '0.0.0.0'; + + my $msg; + if ($xpl_send) { + $msg = "xpl-stat\n{\nhop=1\nsource=" . &xPL::get_xpl_mh_source_info() + . "\ntarget=*\n}\nhbeat.app\n{\ninterval=$xpl_hbeat_interval\nport=" + . "$port\nremote-ip=$ip_address\n}\n"; + + # check to see if all of the sockets are still valid + &xPL::_handleStaleXplSockets(); + if ($::Socket_Ports{'xpl_send'}{socka}) { + $xpl_send->set($msg); + print "db6 xPL heartbeat: $msg.\n" + if $main::Debug{xpl} and $main::Debug{xpl} == 6; + } else { + print "Error in xPL_Item::send_heartbeat. send socket not active\n"; + } + } + else { + print "Error in xPL_Item::send_heartbeat. " + . "xPL send socket not available.\n" + . "Either disable xPL (xpl_disable = 1) or resolve " + . "system network problem (UDP port 3865).\n"; + } +} + +sub _handleStaleXplSockets { + + # check main sending socket + my $port_name = 'xpl_send'; + if ( !( $::Socket_Ports{$port_name}{socka} ) ) { + if ( + &xPL::open_port( + $::Socket_Ports{$port_name}{port}, + 'send', $port_name, 0, 1 + ) + ) + { + print "Notice. xPL socket ($port_name) had been closed and " + . "has been reopened\n"; + } + else { + print "WARNING! xPL socket ($port_name) had been closed and " + . "can not be reopened\n"; + } + } + + # check main listening socket + $port_name = 'xpl_listen'; + if ( !( $::Socket_Ports{$port_name}{socka} ) ) { + if ( + &xPL::open_port( + $::Socket_Ports{$port_name}{port}, + 'listen', $port_name, 0, 1 + ) + ) + { + print "Notice. xPL socket ($port_name) had been closed and " + . "has been reopened\n"; + } + else { + print "WARNING! xPL socket ($port_name) had been closed and " + . "can not be reopened\n"; + } + } + + # check the hub listening socket if hub mode is enabled + if ( !( $::config_parms{xpl_nohub} ) and defined($xpl_hub_listen) ) { + $port_name = 'xpl_hub_listen'; + if ( !( $::Socket_Ports{$port_name}{socka} ) ) { + if ( + &xPL::open_port( + $::Socket_Ports{$port_name}{port}, + 'listen', $port_name, 0, 1 + ) + ) + { + print "Notice. xPL socket ($port_name) had been closed and " + . "has been reopened\n"; + } + else { + print "WARNING! xPL socket ($port_name) had been closed and " + . "can not be reopened\n"; + } + } + + # no need to check each hub "responder" socket as it is automatically + # reopened on receipt of client's heartbeat + } +} + +package xPL_Item; + +=head1 NAME + +xPL_Item - Misterhouse base xPL Item + +=head1 SYNOPSIS + + IMPORTANT: Mark uses of following methods if for init purposes w/ # noloop. Sample use follows: + + $mySqueezebox = new xPL_Item('slimdev-slimserv.squeezebox'); + $mySqueezebox->manage_heartbeat_timeout(360, "speak 'Squeezebox is not reporting'",1); # noloop + +=head1 DESCRIPTION +=begin comment + + + If # noloop is not used on manage_heartbeat_timeout, you will see many attempts to start the timer + + state_now(): returns all current section data using the following form (unless otherwise + set via state monitor): + : = | : = + + state_now(section_name): returns undef if not defined; otherwise, returns current data for + section name using the following form (unless otherwise set via state_monitor): + = | = + + current_section_names: returns the list of current section names delimitted by the pipe character + + tie_value_convertor(keyname, expr): ties the code reference in expr to keyname. The returned + value from expr is substituted into the key value. The reference in expr may use the variables + $section and $value for processing (where $section is the section name and $value is the + original value. + + e.g., $xpl_obj->tie_value_convertor('temp','$main::convert_c_to_f_degrees($value'); + note: the reference to '$main::' allows access to the user code sub - convert_c_to_f_degrees + + class_name(class_name): Sets/Gets the classname. Classname is actually the . + for xPL. It is also often referred to as the schema name. Used to filter + inbound messages. Except for generic "monitors", this shoudl be set. + + source(source): Sets/Gets the source (name). This is normally ... + It is used to filter inbound messages. Except for generic "monitors", this should be set. + + target_address(target_address): Sets/Gets the target (name). Syntax is similar to source. Used to direct (target) + the message to a specific device. Use "*" (default) for broadcast messages. + + manage_heartbeat_timeout(timeout, action, repeat). Sets the timeout interval (in secs) and action to be performed + on expiration of a timer w/ no corresponding heart-beat messages. Used to enable warnings/notices + of absent heart-beats. See comments on using # noloop above. Timeout should be set to a value + greater than the actual device heartbeat interval. Action/timer is not repeated unless + repeat is 1 or true. + + dead_action(action). Sets/gets the action to be applied on receipt of a "dead" heartbeat (the app + indicates that it is stopping/dying). Not all devices supply a "dead" heartbeat message; + therefore, use manage_heartbeat_timeout as the primary safeguard. + + app_status(). Gets the app status. Initially, set to "unknown" until receipt of first "alive" + heartbeat (then, set to "alive"). Set to "dead" on first dead heart-beat. + + send_cmnd(data). Sends xPL message to target device using data hash. + + device_monitor(deviceinfo): constrains state updates to only messages w/ a devicekey=devicevalue + pair. A common example is where deviceinfo is set to 'someid'. In this case, state updates + are constrained to occur only when a message constains "device=someid". deviceinfo can also + take the literal 'somekey = someid' for messages that use a key other than the literal: 'device'. + + +=cut + +@xPL_Item::ISA = ('Generic_Item'); + +=item $h = xPL_Item->new('tag', 'attrname' => 'value',...) + +The object constructor. Takes a tag name as argument. Optionally, +allows you to specify initial attributes at object creation time. + +=cut + +# Support both send and receive objects +sub new { + my ( $object_class, $xpl_source, @data, $xpl_class ) = @_; + my $self = {}; + bless $self, $object_class; + + $xpl_source = '*' if !$xpl_source or $xpl_source eq '*'; + + $$self{state} = ''; + $$self{address} = $xpl_source; # left in place for legacy + $$self{address} = '*' if !$xpl_source; + $$self{target_address} = '*'; + $$self{class} = $xpl_class unless !$xpl_class; + $$self{m_timeoutHeartBeat} = 0; + $$self{m_appStatus} = 'unknown'; + $$self{m_timerHeartBeat} = new Timer(); + $$self{m_state_now_msg_type} = 'unknown'; + $$self{m_allow_empty_state} = 0; + + &xPL_Item::store_data( $self, @data ); + + $self->state_overload('off') + ; # By default, do not process ~;: strings as substate/multistate + + return $self; +} + +sub source { + my ( $self, $p_strSource ) = @_; + $$self{address} = $p_strSource if defined $p_strSource; + return $$self{address}; +} + +sub class_name { + + my ( $self, $p_strClassName ) = @_; + $$self{class} = $p_strClassName if defined $p_strClassName; + return $$self{class}; +} + +sub target_address { + my ( $self, $p_strTarget ) = @_; + $$self{target_address} = $p_strTarget if defined $p_strTarget; + return $$self{target_address}; +} + +sub received { + my ( $self, $received ) = @_; + $$self{received} = $received if defined $received; + return $$self{received}; +} + +sub device_name { + my ( $self, $p_strDeviceName ) = @_; + $$self{m_device_name} = $p_strDeviceName if $p_strDeviceName; + return $$self{m_device_name}; +} + +sub on_set_message { + my ( $self, @data ) = @_; + while (@data) { + my $section = shift @data; + my $ptr = shift @data; + my %parms = %$ptr; + for my $key ( sort keys %parms ) { + my $value = $parms{$key}; + $$self{_on_set_message}{$section}{$key} = $value; + } + } + return $$self{_on_set_message}; +} + +sub allow_empty_state { + my ( $self, $p_allowEmptyState ) = @_; + $$self{m_allow_empty_state} = $p_allowEmptyState + if defined($p_allowEmptyState); + return $$self{m_allow_empty_state}; +} + +sub manage_heartbeat_timeout { + my ( $self, $p_timeoutHeartBeat, $p_actionHeartBeat, $p_repeatAction ) = @_; + if ( defined($p_timeoutHeartBeat) and defined($p_actionHeartBeat) ) { + my $m_repeatAction = 0; + $m_repeatAction = $p_repeatAction if $p_repeatAction; + $$self{m_actionHeartBeat} = $p_actionHeartBeat; + $$self{m_timeoutHeartBeat} = $p_timeoutHeartBeat; + $$self{m_timerHeartBeat}->set( + $$self{m_timeoutHeartBeat}, + $$self{m_actionHeartBeat}, + $m_repeatAction + ); + $$self{m_timerHeartBeat}->start(); + } +} + +sub dead_action { + my ( $self, $p_actionDeadApp ) = @_; + $$self{m_app_Status} = 'dead'; + if ( defined $p_actionDeadApp ) { + $$self{m_actionDeadApp} = $p_actionDeadApp; + } + return $$self{m_actionDeadApp}; +} + +sub _handle_dead_app { + my ($self) = @_; + return eval $$self{m_actionDeadApp} if defined( $$self{m_actionDeadApp} ); +} + +sub _handle_alive_app { + my ($self) = @_; + $$self{m_appStatus} = 'alive'; + if ( $$self{m_timeoutHeartBeat} != 0 ) { + $$self{m_timerHeartBeat}->restart() + unless $$self{m_timerHeartBeat}->inactive(); + return 1; + } + else { + $$self{m_timerHeartBeat}->stop() + unless $$self{m_timerHeartBeat}->inactive(); + return 0; + } +} + +sub app_status { + my ($self) = @_; + return $$self{m_appStatus}; +} + +sub store_data { + my ( $self, @data ) = @_; + while (@data) { + my $section = shift @data; + $$self{class} = $section; + $$self{sections}{$section} = 'send'; + my $ptr = shift @data; + my %parms = %$ptr; + for my $key ( sort keys %parms ) { + my $value = $parms{$key}; + $$self{$section}{$key} = $value; + $$self{state_monitor} = "$section : $key" if $value eq '$state'; + } + } +} + +sub state_now { + my ( $self, $section_name ) = @_; + my $state_now = $self->SUPER::state_now(); + if ($section_name) { + + # default section_state_now to undef unless it actually exists + my $section_state_now = undef; + for my $section ( split( /\s+\|\s+/, $state_now ) ) { + my @section_data = split( /\s+:\s+/, $section ); + my $section_ref = $section_data[0]; + next if $section_ref eq ''; + if ( $section_ref eq $section_name ) { + if ( defined($section_state_now) ) { + $section_state_now .= " | $section_data[1]"; + } + else { + $section_state_now = $section_data[1]; + } + } + } + print "db xPL_Item:state_now: section data for $section_name is: " + . "$section_state_now\n" + if $main::Debug{xpl} and $section_state_now; + $state_now = $section_state_now; + } + return $state_now; +} + +sub current_section_names { + my ($self) = @_; + my $changed = $$self{changed}; + my $current_section_names = undef; + if ($changed) { + for my $section ( split( /\s+\|\s+/, $changed ) ) { + my @section_data = split( /\s+:\s+/, $section ); + if ( defined($current_section_names) ) { + $current_section_names .= " | $section_data[0]"; + } + else { + $current_section_names = $section_data[0]; + } + } + + } + print "db xPL_Item:current_section_names : $current_section_names\n" + if $main::Debug{xpl}; + return $current_section_names; +} + +sub tie_value_convertor { + my ( $self, $key_name, $convertor ) = @_; + $$self{_value_convertors}{$key_name} = $convertor + if ( defined($key_name) && defined($convertor) ); + +} + +sub device_monitor { + my ( $self, $monitor_info ) = @_; + if ($monitor_info) { + my ($key,$value) = $monitor_info =~ /(\S+)\s*[:=]\s*(\S+)/; + if ( !( $value or $value =~ /^0/ ) ) { + $value = ($key) ? $key : $monitor_info; + $key = 'device'; + } + $$self{_device_id} = lc $value; + $$self{_device_id_key} = lc $key; + } + if ( defined $$self{_device_id} ) { + return ( + ( $$self{_device_id_key} ) ? $$self{_device_id_key} : 'device' ) + . $$self{_device_id}; + } + else { + return; + } +} + +sub default_setstate { + my ( $self, $state, $substate, $set_by ) = @_; + # Send data, unless we are processing incoming data + return if !(ref $set_by) and $set_by =~ /^xpl/i; + my @parms; + + if ( $$self{_on_set_message} ) { + for my $class_name ( sort keys %{ $$self{_on_set_message} } ) { + my $block; + for my $msg_key ( + sort keys %{ $$self{_on_set_message}{$class_name} } ) + { + my $field_value = + eval( $$self{_on_set_message}{$class_name}{$msg_key} ); + $block->{$msg_key} = $field_value; + } + push @parms, $class_name, $block; + } + } + else { + if ( $$self{state_monitor} ) { + foreach my $state_monitor ( split( /\|/, $$self{state_monitor} ) ) { + my ( $section, $key ) = + $$self{state_monitor} =~ /(\S+)\s*[:=]\s*(\S+)/; + $$self{$section}{$key} = $state; + } + } + for my $section ( sort keys %{ $$self{sections} } ) { + next + unless $$self{sections}{$section} eq + 'send'; # Do not echo received data + push @parms, $section, $$self{$section}; + } + } + + if (@parms) { + + # sending stat info about ourselves? + if ( lc $$self{source} eq &xPL::get_xpl_mh_source_info() ) { + $self->send_trig(@parms); + } + else { + + # must be cmnd info to another device addressed by address + $self->send_cmnd(@parms); + } + } +} + +sub state_now_msg_type { + my ( $self, $p_msgType ) = @_; + $$self{m_state_now_msg_type} = $p_msgType if defined($p_msgType); + return $$self{m_state_now_msg_type}; +} + +# DO NOT use the following sub +# Instead, DO use either send_cmnd, send_trig or send_stat +sub send_message { + my ( $self, $p_strTarget, @p_data ) = @_; + $self->send_cmnd(@p_data); +} + +sub send_cmnd { + my ( $self, @p_data ) = @_; + if ( defined $$self{_device_id} ) { + my $classname = shift @p_data; + my $ptr = shift @p_data; + my @new_data = (); + $ptr->{ $$self{_device_id_key} } = $$self{_device_id}; + push @new_data, $classname, $ptr; + &xPL::sendXpl( $self->source, 'cmnd', @new_data ); + } + else { + &xPL::sendXpl( $self->source, 'cmnd', @p_data ); + } +} + +sub send_stat { + my ( $self, @p_data ) = @_; + if ( defined $$self{_device_id} ) { + my $classname = shift @p_data; + my $ptr = shift @p_data; + my @new_data = (); + $ptr->{ $$self{_device_id_key} } = $$self{_device_id}; + push @new_data, $classname, $ptr; + &xPL::sendXpl( '*', 'stat', @new_data ); + } + else { + &xPL::sendXpl( '*', 'stat', @p_data ); + } +} + +sub send_trig { + my ( $self, @p_data ) = @_; + if ( defined $$self{_device_id} ) { + my $classname = shift @p_data; + my $ptr = shift @p_data; + my @new_data = (); + $ptr->{ $$self{_device_id_key} } = $$self{_device_id}; + push @new_data, $classname, $ptr; + &xPL::sendXpl( '*', 'trig', @new_data ); + } + else { + &xPL::sendXpl( '*', 'trig', @p_data ); + } +} + +sub ignore_message { + my ( $self, $p_data ) = @_; + my $ignore_message = 0; + if ( $$self{_device_id_key} and $self->class_name ) { + print +"Device monitoring enabled: key=$$self{_device_id_key}, id=$$self{_device_id}, tested value=" + . $$p_data{ $self->class_name }{ $$self{_device_id_key} } . "\n" + if $main::Debug{xpl}; + $ignore_message = + ( $$self{_device_id} ne + lc $$p_data{ $self->class_name }{ $$self{_device_id_key} } ) + ? 1 + : 0; + } + return $ignore_message; +} + +package xPL_Sensor; + +@xPL_Sensor::ISA = ('xPL_Item'); + +sub new { + my ( $class, $p_source, $p_type, $p_statekey ) = @_; + my ( $source, $deviceid ) = $p_source =~ /(\S+)?:([\S ]+)/; + $source = $p_source unless $source; + my $self = $class->SUPER::new($source); + if ($p_type) + { + $$self{sensor_type} = $p_type; + if ($p_type eq 'output') # define a default message to be sent out on a call to the "set" method + { + # the following can always be overwritten + $self->on_set_message('control.basic' => { 'z##current' => '$state' }); + } + } + else + { + $$self{sensor_type} = 'input'; # set a default + } + my $statekey = 'current'; + $statekey = $p_statekey if $p_statekey; + $self->SUPER::class_name('sensor.basic'); + $$self{state_monitor} = "sensor.basic : $statekey"; + $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; + return $self; +} + +sub type { + my ( $self, $p_type ) = @_; + $$self{sensor_type} = $p_type if $p_type; + return $$self{sensor_type}; +} + +sub current { + my ($self) = @_; + return $$self{'sensor.basic'}{current}; +} + +sub units { + my ($self) = @_; + return $$self{'sensor.basic'}{units}; +} + +sub lowest { + my ($self) = @_; + return $$self{'sensor.basic'}{lowest}; +} + +sub highest { + my ($self) = @_; + return $$self{'sensor.basic'}{highest}; +} + +sub ignore_message { + my ( $self, $p_data ) = @_; + return 1 + if $self->SUPER::ignore_message($p_data) + ; # user xPL_Item's filter against deviceid + return ( $$p_data{'sensor.basic'}{type} ne $$self{sensor_type} ) ? 1 : 0; +} + +sub request_stat { + my ($self) = @_; + $self->SUPER::send_cmnd( 'sensor.request' => + { 'request' => 'current', 'type' => "'$$self{sensor_type}'" } ); +} + +package xPL_UPS; + +@xPL_UPS::ISA = ('xPL_Item'); + +sub new { + my ( $class, $p_source, $p_statekey ) = @_; + my ( $source, $deviceid ) = $p_source =~ /(\S+):(\S+)/; + $source = $p_source unless $source; + my $self = $class->SUPER::new($source); + my $statekey = $p_statekey; + $statekey = 'status'; + + # $self->SUPER::class_name('ups.basic'); + $$self{state_monitor} = "ups.basic : $statekey|hbeat.app : $statekey"; + $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; + return $self; +} + +sub status { + my ( $self, $p_status ) = @_; + return ( $$self{'ups.basic'}{status} ) + ? $$self{'ups.basic'}{status} + : $$self{'hbeat.app'}{status}; +} + +sub event { + my ($self) = @_; + return $$self{'ups.basic'}{event}; +} + +sub ignore_message { + my ( $self, $p_data ) = @_; + return 1 + if $self->SUPER::ignore_message($p_data) + ; # user xPL_Item's filter against deviceid + return ( $$p_data{'ups.basic'} or $$p_data{'hbeat.app'} ) ? 0 : 1; +} + +package xPL_X10Security; + +@xPL_X10Security::ISA = ('xPL_Item'); + +sub new { + my ( $class, $p_source, $p_type, $p_statekey ) = @_; + my ( $source, $deviceid ) = $p_source =~ /(\S+):(\S+)/; + $source = $p_source unless $source; + my $self = $class->SUPER::new($source); + $$self{type} = $p_type if $p_type; + my $statekey = $p_statekey; + $statekey = 'command'; + $self->SUPER::class_name('x10.security'); + $$self{state_monitor} = "x10.security : $statekey"; + $self->SUPER::device_monitor("device=$deviceid") if defined $deviceid; + return $self; +} + +sub type { + my ( $self, $p_type ) = @_; + $$self{type} = $p_type if $p_type; + return $$self{type}; +} + +sub command { + my ($self) = @_; + return $$self{'x10.security'}{command}; +} + +sub tamper { + my ($self) = @_; + return $$self{'x10.security'}{tamper}; +} + +sub low_battery { + my ($self) = @_; + return $$self{'x10.security'}{'low-battery'}; +} + +sub delay { + my ($self) = @_; + return $$self{'x10.security'}{delay}; +} + +sub ignore_message { + my ( $self, $p_data ) = @_; + return 1 + if $self->SUPER::ignore_message($p_data) + ; # user xPL_Item's filter against deviceid + if ( $$self{type} ) { + return ( $$p_data{'x10.security'}{type} ne $$self{type} ) ? 1 : 0; + } + else { + return 0; + } +} + +package xPL_Rio; + +@xPL_Rio::ISA = ('xPL_Item'); + +# Support both send and receive objects +sub new { + my ( $object_class, $xpl_source, $xpl_target ) = @_; + my $self = {}; + bless $self, $object_class; + + $$self{state} = ''; + $$self{source} = $xpl_source; + $$self{target_address} = $xpl_target unless !$xpl_target; + + &xPL_Item::store_data( $self, 'rio.basic' => { sel => '$state' } ); + + @{ $$self{states} } = ( + 'play', + 'stop', + 'mute', + 'volume +20', + 'volume -20', + 'volume 100', + 'skip', + 'back', + 'random', + 'power on', + 'power off', + 'light on', + 'light off' + ); + + return $self; + +} + +1; From b9e299ca8de079b06910776dc3ee7856850ce8a1 Mon Sep 17 00:00:00 2001 From: Marc MERLIN Date: Fri, 23 Nov 2012 22:26:51 -0800 Subject: [PATCH 149/150] Made HAI menu more clear, and added symlink to make web interface work. --- web/hai | 1 + 1 file changed, 1 insertion(+) create mode 120000 web/hai diff --git a/web/hai b/web/hai new file mode 120000 index 000000000..fa175d172 --- /dev/null +++ b/web/hai @@ -0,0 +1 @@ +../code/support/hai-omnistat/hai_web \ No newline at end of file From d971bb565d9f46781aa22302ec13aed10ef0c0cb Mon Sep 17 00:00:00 2001 From: Marc MERLIN Date: Fri, 23 Nov 2012 23:00:02 -0800 Subject: [PATCH 150/150] Made HAI RCxx menu more obvious. --- code/support/hai-omnistat/hai_web/menu.html | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/code/support/hai-omnistat/hai_web/menu.html b/code/support/hai-omnistat/hai_web/menu.html index 94aef6534..609edaad9 100644 --- a/code/support/hai-omnistat/hai_web/menu.html +++ b/code/support/hai-omnistat/hai_web/menu.html @@ -8,8 +8,8 @@
    -
    -
    +
    +