diff --git a/bin/mh b/bin/mh index ef932a031..198760f6b 100755 --- a/bin/mh +++ b/bin/mh @@ -114,7 +114,7 @@ use vars qw(%Run_Members); my ($Pgm_PathU); 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 (@Requested_Files, @Print_Log, @Print_Log_Time, @Display_Log, @Speak_Log, @Speak_Log_Time, @Error_Log, @Error_Log_Time); my ($exit_flag, $xcmd_file, %file_code_times, %file_code_times2, %file_change_times); my (@Loop_Code, @Sub_Code, %Sub_Code, %Run_Members, %Run_Members_Error_Count, %Benchmark_Members, @Item_Code, @Item_Code_Objects); @@ -1150,20 +1150,24 @@ sub open_logs { my $speak_log = "$config_parms{data_dir}/logs/speak.log"; my $error_log = "$config_parms{data_dir}/logs/error.log"; - my (@log); + my (@log,@speaklog,@errorlog); @log = &file_tail($print_log, $config_parms{max_log_entries}); chomp @log; @Print_Log = reverse @log; unshift @Print_Log, "$Time_Date ---------- Restart ---------- "; + @Print_Log_Time = (1)x scalar @Print_Log; + + @speaklog = &file_tail($speak_log, $config_parms{max_log_entries}); + chomp @speaklog; + @Speak_Log = reverse @speaklog; + @Speak_Log_Time = (1)x scalar @Speak_Log; - @log = &file_tail($speak_log, $config_parms{max_log_entries}); - chomp @log; - @Speak_Log = reverse @log; # unshift @Speak_Log, "$Time_Date ---------- Restart ---------- "; - @log = &file_tail($error_log, $config_parms{max_log_entries}); - chomp @log; - @Error_Log = reverse @log; + @errorlog = &file_tail($error_log, $config_parms{max_log_entries}); + chomp @errorlog; + @Error_Log = reverse @errorlog; + @Error_Log_Time = (1)x scalar @Error_Log; unshift @Error_Log, "$Time_Date ---------- Restart ---------- "; @@ -4017,6 +4021,9 @@ sub print_log { unshift (@Print_Log, $data); pop @Print_Log if @Print_Log > $config_parms{max_log_entries}; + unshift (@Print_Log_Time, &get_tickcount); + pop @Print_Log_Time if @Print_Log_Time > @Print_Log; + $Last_Response = 'print_log' unless $Last_Response; @@ -4044,6 +4051,37 @@ sub print_log_last { } } +sub print_log_since { + # Return the print_log phrases since time + my ($time) = @_; + #Search from front to back, we are likely looking for an entry near the front + my $index; + for my $i (0 .. $#Print_Log_Time) { + $index = $i; + if ($time >= $Print_Log_Time[$i]){ + # We have already seen this message, so the prior index is what we need + $index--; + last; + } + } + my $count = @Print_Log; + if ($index < 0) { + return; + } + elsif (($index+1) >= $count) { + return @Print_Log; + } + else { + return (@Print_Log[0 .. $index]); + } +} + +sub print_log_current_time { + # Return the time of most recent print_log phrase + return $Print_Log_Time[0] unless (scalar @Print_Log_Time <= 0); + return 0; +} + sub error_log_last { # Return the last how_many error_log phrases my ($how_many) = @_; @@ -4077,12 +4115,15 @@ sub print_speaklog { # my ($data) = @_; my $data = "@_"; + $data =~ s/<\/?voice.*?>//g; # Drop XML speech tags + $data =~ s/\n *$//; # Drop trailing cr + # unshift (@Speak_Log, "$Time_Now $data"); unshift (@Speak_Log, "$Time_Date $data"); pop @Speak_Log if @Speak_Log > $config_parms{max_log_entries}; + unshift (@Speak_Log_Time, &get_tickcount); + pop @Speak_Log_Time if @Speak_Log_Time > @Speak_Log; - $data =~ s/<\/?voice.*?>//g; # Drop XML speech tags - $data =~ s/\n *$//; # Drop trailing cr if ($Tk_objects{speak_window}) { # Most recent at top ... if we put it on the bottom, we have to constantly @@ -4093,8 +4134,61 @@ sub print_speaklog { print "$data\n" unless $config_parms{no_log} =~ /speak/ or $Startup; # On startup no print needed as it is just the "System Restarted" message (or an error with its own debug info) } print SPEAKLOG "$Time_Date $data\n"; + + return; +} + +sub print_speaklog_last { + # Return the last how_many speak phrases + my ($how_many) = @_; + my $count = @Speak_Log; + if ($how_many == 1) { + return $Speak_Log[0]; + } + elsif ($how_many >= $count) { + return @Speak_Log; + } + else { + return (@Speak_Log[0 .. ($how_many-1)]); + } } +sub print_speaklog_since { + # Return the speak phrases since time + my ($time) = @_; + #Search from front to back, we are likely looking for an entry near the front + my $index; + for my $i (0 .. $#Speak_Log_Time) { + $index = $i; + #print "db/mh/since: i=$i time=$time, plt=$Print_Log_Time[$i] slt=$Speak_Log_Time[$i]\n"; + if ($time >= $Speak_Log_Time[$i]){ #TODO: Problem + # We have already seen this message, so the prior index is what we need + $index--; + last; + } + } + my $count = @Speak_Log; + if ($index < 0) { + return; + } + elsif (($index+1) >= $count) { + return @Speak_Log; + } + else { + print "db/mh/since [ " . @Speak_Log[0 .. $index]. "]\n"; + return (@Speak_Log[0 .. $index]); + } +} + +sub print_speaklog_current_time { + # Return the time of most recent speak phrase + + #print "db/mh/curr: time=" . &get_tickcount . " plt=$Print_Log_Time[0] slt=$Speak_Log_Time[0]\n"; + return $Print_Log_Time[0] unless (scalar @Speak_Log_Time <= 0); #TODO HP should return $Speak_Log_Time + return 0; +} + + sub process_external_command { my ($cmd, $warning_flag, $set_by, $respond_target) = @_; $cmd =~ s/^\s+//; # Deletes leading blanks diff --git a/data/web/collections.json b/data/web/collections.json new file mode 100644 index 000000000..f4461b872 --- /dev/null +++ b/data/web/collections.json @@ -0,0 +1,707 @@ +{ + "82" : { + "external" : "http://www.yellowpages.com/", + "icon" : "fa-building-o", + "name" : "Yellow Pages" + }, + "13" : { + "icon" : "fa-home", + "name" : "About MrHouse", + "link" : "/ia7/house/main.shtml" + }, + "76" : { + "icon" : "fa-building-o", + "name" : "Floorplan View2", + "link" : "/ia5/security/floorplan.shtml" + }, + "4" : { + "icon" : "fa-lightbulb-o", + "name" : "Lights & Appliances", + "children" : [ + 51, + 52, + 53, + 54, + 55, + 56, + 57 + ] + }, + "89" : { + "external" : "http://tvguide.com/Listings/index.asp?I=70620&Zip=91403", + "icon" : "fa-book", + "name" : "TV Guide" + }, + "32" : { + "name" : "Label Widgets", + "icon" : "fa-square-o", + "link" : "/ia7/widgets_label" + }, + "84" : { + "name" : "Reverse Lookup", + "external" : "http://www.whitepages.com/find_person.pl?fid=p", + "icon" : "fa-sort-alpha-desc" + }, + "41" : { + "link" : "/ia5/statistics/housestats.shtml", + "icon" : "fa-home", + "name" : "HouseServer Statistics" + }, + "77" : { + "name" : "Recent Incoming Calls", + "icon" : "fa-arrow-down", + "link" : "/bin/phone_in.pl" + }, + "0" : { + "icon" : "fa-home", + "name" : "Home", + "children" : [ + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12 + ] + }, + "64" : { + "name" : "Earthquakes", + "icon" : "fa-bullseye", + "link" : "/ia5/outside/earthquakes.shtml" + }, + "29" : { + "link" : "/ia7/#path=/vars", + "name" : "List Global Variables", + "icon" : "fa-globe" + }, + "65" : { + "link" : "/ia5/outside/sattelite.shtml", + "icon" : "fa-fire", + "name" : "Iridium Flares" + }, + "87" : { + "link" : "/media/mhmedia.html", + "icon" : "fa-play-circle", + "name" : "Media Center" + }, + "2" : { + "children" : [ + 43, + 44, + 45, + 46, + 47 + ], + "icon" : "fa-envelope", + "name" : "Mail and News" + }, + "42" : { + "link" : "/ia7/widgets_checkbox", + "name" : "Browse This Category", + "icon" : "fa-ellipsis-v" + }, + "12" : { + "icon" : "fa-bar-chart-o", + "name" : "Statistics & Logged Data", + "children" : [ + 36, + 37, + 38, + 39, + 40, + 41, + 42 + ] + }, + "47" : { + "name" : "Browse News", + "icon" : "fa-list-alt", + "link" : "/ia5/news/browse.shtml" + }, + "39" : { + "icon" : "fa-floppy-o", + "name" : "View Backup Log", + "link" : "/ia5/statistics/backuplog.shtml" + }, + "106" : { + "link" : "/organizer/calendar.pl", + "name" : "Calendar", + "icon" : "fa-calendar" + }, + "52" : { + "link" : "/ia7/#path=objects&type=X10_Item", + "name" : "Control X10 Items", + "icon" : "fa-info" + }, + "73" : { + "icon" : "fa-pagelines", + "name" : "Backyard Camera", + "link" : "/ia5/security/backyardcam.shtml" + }, + "51" : { + "icon" : "fa-group", + "name" : "Browse Groups", + "link" : "/ia7/#path=/objects&type=Group" + }, + "69" : { + "link" : "/ia5/security/webcam.shtml", + "icon" : "fa-th-large", + "name" : "Windowed Overview" + }, + "55" : { + "name" : "Browse All Lights", + "icon" : "fa-lightbulb-o", + "link" : "/ia7/#path=/objects&parents=All_Lights" + }, + "8" : { + "children" : [ + 86, + 87, + 88, + 89, + 90, + 91, + 92, + 93, + 94, + 95, + 96 + ], + "name" : "TV/Radio Guide & MP3 Music", + "icon" : "fa-music" + }, + "70" : { + "link" : "/ia5/security/wc_sshow.shtml", + "icon" : "fa-clock-o", + "name" : "Time Lapse Viewer" + }, + "38" : { + "name" : "View Error Log", + "icon" : "fa-warning", + "link" : "/ia5/statistics/errorlog.shtml" + }, + "63" : { + "icon" : "fa-moon-o", + "name" : "Sun & Moon Data", + "link" : "/ia5/outside/sunmoon.shtml" + }, + "108" : { + "link" : "/organizer/tasks.pl", + "name" : "TODO List", + "icon" : "fa-list" + }, + "94" : { + "link" : "/ia5/entertain/internetradio.shtml", + "icon" : "fa-sitemap", + "name" : "Internet Radio" + }, + "17" : { + "icon" : "fa-group", + "name" : "Browse Groups", + "link" : "/ia7/#path=objects&type=Group" + }, + "67" : { + "name" : "Browse Category", + "icon" : "fa-archive", + "link" : "/ia5/outside/browse.shtml" + }, + "7" : { + "children" : [ + 77, + 78, + 79, + 80, + 81, + 82, + 83, + 84, + 85 + ], + "name" : "Phone Calls & VoiceMail Msgs", + "icon" : "fa-phone" + }, + "79" : { + "link" : "/bin/phone_search.pl", + "icon" : "fa-search", + "name" : "Search Calls" + }, + "103" : { + "name" : "Browse Photos", + "icon" : "fa-archive", + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Photos" + }, + "59" : { + "external" : "http://www.weather.com/weather/local/91403", + "icon" : "fa-cloud", + "name" : "Weather.com - Local" + }, + "80" : { + "icon" : "fa-list", + "name" : "Phone List", + "link" : "/bin/phone_list.pl" + }, + "90" : { + "icon" : "fa-desktop", + "external" : "http://tvguide.com/tv", + "name" : "What's On Now" + }, + "53" : { + "icon" : "fa-sitemap", + "name" : "Control X10 Appliances", + "link" : "/ia7/#path=objects&type=X10_Appliance" + }, + "45" : { + "icon" : "fa-group", + "external" : "//groups.google.com/grphp", + "name" : "Newsgroups" + }, + "93" : { + "icon" : "fa-signal", + "external" : "http://realguide.real.com/", + "name" : "Radio Guide" + }, + "24" : { + "name" : "Edit Items", + "icon" : "fa-list", + "link" : "/bin/items.pl" + }, + "81" : { + "link" : "/ia5/phone/voicemail.shtml", + "name" : "VoiceMail Messages", + "icon" : "fa-envelope-o" + }, + "40" : { + "name" : "WebServer Statistics", + "icon" : "fa-link", + "link" : "/ia5/statistics/webstats.shtml" + }, + "9" : { + "children" : [ + 97, + 98, + 99, + 100 + ], + "icon" : "fa-microphone", + "name" : "Speech" + }, + "25" : { + "link" : "/bin/iniedit.pl", + "name" : "INI Editor", + "icon" : "fa-table" + }, + "22" : { + "icon" : "fa-code", + "name" : "User Code Activation", + "link" : "/bin/code_unselect.pl" + }, + "74" : { + "name" : "Desktop Camera", + "icon" : "fa-desktop", + "link" : "/ia5/security/desktopcam.shtml" + }, + "33" : { + "link" : "/ia7/widgets_entry", + "icon" : "fa-pencil-square-o", + "name" : "Entry Widgets" + }, + "62" : { + "icon" : "fa-dashboard", + "name" : "HVAC", + "link" : "/ia7/#path=/objects&parents=HVAC" + }, + "1" : { + "children" : [ + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 29, + 30 + ], + "name" : "Mr. House Home", + "icon" : "fa-home" + }, + "21" : { + "link" : "/bin/code_select.pl", + "name" : "Common Code Activation", + "icon" : "fa-code" + }, + "111" : { + "link" : "/bin/triggers.pl", + "name" : "Alarms", + "icon" : "fa-bell-o" + }, + "99" : { + "name" : "Speech Settings", + "icon" : "fa-cog", + "link" : "/ia5/speak/speechsettings.shtml" + }, + "104" : { + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Entertainment", + "icon" : "fa-gamepad", + "name" : "Browse Entertainment" + }, + "72" : { + "icon" : "fa-home", + "name" : "Frontdoor Camera", + "link" : "/ia5/security/frontdoor.shtml" + }, + "3" : { + "icon" : "fa-tasks", + "name" : "Modes", + "children" : [ + 48, + 49, + 50 + ] + }, + "16" : { + "link" : "/ia7/#path=/objects&type=Category", + "icon" : "fa-archive", + "name" : "Browse Categories" + }, + "110" : { + "link" : "/bin/ListManager.pl", + "name" : "List Manager", + "icon" : "fa-list-alt" + }, + "101" : { + "link" : "/comics/index.html", + "name" : "Daily Comics", + "icon" : "fa-picture-o" + }, + "113" : { + "name" : "LED Clock", + "icon" : "fa-clock-o", + "link" : "/clock" + }, + "71" : { + "name" : "Camera Files", + "icon" : "fa-film", + "link" : "/cameras/" + }, + "28" : { + "link" : "/bin/set_parm_tv_provider.pl", + "name" : "Setup TV Provider", + "icon" : "fa-desktop" + }, + "5" : { + "children" : [ + 58, + 59, + 60, + 61, + 62, + 63, + 64, + 65, + 66, + 67 + ], + "icon" : "fa-umbrella", + "name" : "HVAC & Weather" + }, + "68" : { + "icon" : "fa-video-camera", + "name" : "Basic Overview", + "link" : "/ia5/security/main.shtml" + }, + "88" : { + "link" : "/tv", + "icon" : "fa-calendar-o", + "name" : "TV Today" + }, + "31" : { + "link" : "/ia7/widgets", + "name" : "All Widgets", + "icon" : "fa-cogs" + }, + "98" : { + "icon" : "fa-volume-up", + "name" : "Speak Text", + "link" : "/ia5/speak/speakframe.html" + }, + "96" : { + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Music", + "name" : "Browse Music", + "icon" : "fa-headphones" + }, + "44" : { + "name" : "Read CNN", + "external" : "//www.cnn.com", + "icon" : "fa-book" + }, + "109" : { + "icon" : "fa-shopping-cart", + "name" : "Shopping List", + "link" : "/bin/shopping_list.pl" + }, + "48" : { + "link" : "/ia5/modes/main.shtml", + "icon" : "fa-tasks", + "name" : "Control Modes & Events" + }, + "37" : { + "link" : "/ia5/statistics/speechlog.shtml", + "name" : "View Speech Log", + "icon" : "fa-bullhorn" + }, + "18" : { + "link" : "/ia7/#path=/objects&type=Type", + "name" : "Browse Items", + "icon" : "fa-info" + }, + "6" : { + "name" : "Security Cameras", + "icon" : "fa-video-camera", + "children" : [ + 68, + 69, + 70, + 71, + 72, + 73, + 74, + 75, + 76 + ] + }, + "107" : { + "link" : "/organizer/contacts.pl", + "icon" : "fa-book", + "name" : "Address Book" + }, + "26" : { + "link" : "/ia5/house/irman.shtml", + "name" : "Program IRMAN", + "icon" : "fa-rss" + }, + "57" : { + "link" : "/bin/floorplan.pl", + "name" : "Floorplan View", + "icon" : "fa-home" + }, + "49" : { + "link" : "/bin/menu.pl", + "icon" : "fa-list-alt", + "name" : "Menu Control" + }, + "30" : { + "icon" : "fa-save", + "name" : "List Save Variables", + "link" : "/ia7/#path=/vars/Save" + }, + "56" : { + "link" : "/ia7/#path=/objects&parents=Appliances", + "name" : "Browse Appliances", + "icon" : "fa-sitemap" + }, + "14" : { + "name" : "About 3Com Audrey", + "icon" : "fa-desktop", + "link" : "/ia7/house/aboutaudrey.shtml" + }, + "35" : { + "link" : "/ia7/widgets_checkbox", + "icon" : "fa-check-square-o", + "name" : "Checkbox Widgets" + }, + "11" : { + "children" : [ + 105, + 106, + 107, + 108, + 109, + 110, + 111, + 112, + 113, + 114, + 115 + ], + "name" : "Events, Calendar, & Clock", + "icon" : "fa-calendar" + }, + "10" : { + "children" : [ + 101, + 102, + 103, + 104 + ], + "name" : "Comics & Pictures", + "icon" : "fa-picture-o" + }, + "34" : { + "link" : "/ia7/widgets_radiobutton", + "name" : "Radiobutton Widgets", + "icon" : "fa-dot-circle-o" + }, + "19" : { + "name" : "Browse Widgets", + "icon" : "fa-gears", + "children" : [ + 31, + 32, + 33, + 34, + 35 + ] + }, + "97" : { + "link" : "/speech", + "icon" : "fa-bullhorn", + "name" : "View Speech Log" + }, + "86" : { + "name" : "MP3 Jukebox", + "icon" : "fa-music", + "link" : "/misc/mp3.html" + }, + "100" : { + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Speech", + "name" : "Browse Speech", + "icon" : "fa-microphone" + }, + "85" : { + "icon" : "fa-archive", + "name" : "Browse Phone", + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Phone" + }, + "15" : { + "name" : "Browse MrHouse", + "icon" : "fa-home", + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=MisterHouse" + }, + "23" : { + "icon" : "fa-clock-o", + "name" : "Edit Triggers", + "link" : "/bin/triggers.pl" + }, + "112" : { + "link" : "/misc/timers.shtml", + "icon" : "fa-exclamation", + "name" : "Timers" + }, + "114" : { + "name" : "Browse Timers", + "icon" : "fa-exclamation-circle", + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Timers" + }, + "60" : { + "name" : "Weather.com - National", + "external" : "http://www.weather.com/maps/maptype/currentweatherusnational/index_large.html", + "icon" : "fa-globe" + }, + "43" : { + "link" : "/ia5/news/main.shtml", + "name" : "Read e-mail", + "icon" : "fa-envelope" + }, + "61" : { + "icon" : "fa-bolt", + "name" : "Weather Station", + "link" : "/ia5/outside/weather_index.shtml" + }, + "92" : { + "name" : "Local Movies", + "external" : "http://www.google.com/search?&q=movie%3A+91403", + "icon" : "fa-film" + }, + "46" : { + "icon" : "fa-inbox", + "name" : "Postal Mailbox", + "link" : "/ia5/news/postalmail.shtml" + }, + "58" : { + "name" : "Weather Underground", + "icon" : "fa-sun-o", + "external" : "http://www.wunderground.com/cgi-bin/findweather/getForecast?query=91403" + }, + "115" : { + "name" : "Browse Timed_Events", + "icon" : "fa-archive", + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Timed_Events" + }, + "95" : { + "link" : "/ia7/#path=/objects&type=Voice_Cmd&category=Entertainment", + "name" : "Browse Entertainment", + "icon" : "fa-gamepad" + }, + "27" : { + "icon" : "fa-wrench", + "name" : "Header Control", + "link" : "/bin/headercontrol.pl" + }, + "78" : { + "name" : "Recent Outgoing Calls", + "icon" : "fa-arrow-up", + "link" : "/bin/phone_out.pl" + }, + "102" : { + "name" : "Picture Frame", + "icon" : "fa-desktop", + "external" : "http://home.krkeegan.com:8081/misc/photos.shtml" + }, + "105" : { + "link" : "/ia5/calendar/main.shtml", + "icon" : "fa-check", + "name" : "Calendar Facts" + }, + "83" : { + "icon" : "fa-home", + "external" : "http://www.whitepages.com/", + "name" : "White Pages" + }, + "20" : { + "name" : "Setup MrHouse", + "icon" : "fa-wrench", + "children" : [ + 21, + 22, + 23, + 24, + 25, + 26, + 27, + 28 + ] + }, + "66" : { + "link" : "/ia5/outside/tracking.shtml", + "name" : "GPS/ APRS Tracking", + "icon" : "fa-road" + }, + "91" : { + "name" : "TV Shortcuts", + "icon" : "fa-bookmark-o", + "link" : "/ia5/entertain/shortcuts.shtml" + }, + "36" : { + "name" : "View Print Log", + "icon" : "fa-list", + "link" : "/ia7/#path=/print_log" + }, + "75" : { + "name" : "Floorplan View", + "icon" : "fa-building-o", + "link" : "/bin/floorplan.pl" + }, + "50" : { + "link" : "/ia5/modes/browse.shtml", + "name" : "Browse Modes", + "icon" : "fa-th" + } +} \ No newline at end of file diff --git a/lib/File_Item.pm b/lib/File_Item.pm index 6b378a8e0..583bed153 100644 --- a/lib/File_Item.pm +++ b/lib/File_Item.pm @@ -322,6 +322,16 @@ sub set_index { $self->{index} = $state; } +=item C + +Returns the class (or type, in Misterhouse terminology) of this item. + +=cut + +sub get_type { + return ref $_[0]; +} + =back =head2 INI PARAMETERS diff --git a/lib/Generic_Item.pm b/lib/Generic_Item.pm index ccf012947..84df0e613 100644 --- a/lib/Generic_Item.pm +++ b/lib/Generic_Item.pm @@ -130,6 +130,7 @@ sub new { $$self{said} = undef; $$self{state_now} = undef; $$self{state_changed} = undef; + $self->restore_data('sort_order'); return $self; } @@ -1365,6 +1366,25 @@ sub debuglevel return 0; } +=item C + +Used to store an ordered list of object names. The purpose of which is to be +used to arrange the list of member objects in a specific order. + +NOTE: This routine does not verify that the objects are in fact members of this +object. + +=cut + +sub sort_order +{ + my ($self, $list_ref) = @_; + if (defined $list_ref) { + $$self{sort_order} = join(',', @{$list_ref}); + } + return [split(',', $$self{sort_order})]; +} + =back =head2 PACKAGE FUNCTIONS diff --git a/lib/Group.pm b/lib/Group.pm index b77cfedbb..fa275d6f5 100644 --- a/lib/Group.pm +++ b/lib/Group.pm @@ -54,7 +54,7 @@ package Group; sub new { my ($class, @items) = @_; - my $self = {state => undef}; + my $self = new Generic_Item(); $$self{members} = []; &add($self, @items) if @items; bless $self, $class; diff --git a/lib/Process_Item.pm b/lib/Process_Item.pm index 850df2bb9..74c3dd092 100644 --- a/lib/Process_Item.pm +++ b/lib/Process_Item.pm @@ -466,6 +466,16 @@ sub nice_level { } } +=item C + +Returns the class (or type, in Misterhouse terminology) of this item. + +=cut + +sub get_type { + return ref $_[0]; +} + # # $Log: Process_Item.pm,v $ # Revision 1.30 2005/10/02 23:53:39 winter diff --git a/lib/Timer.pm b/lib/Timer.pm index cb02ec2cf..cb1164cee 100644 --- a/lib/Timer.pm +++ b/lib/Timer.pm @@ -496,6 +496,16 @@ sub query { return $time; } +=item C + +Returns the class (or type, in Misterhouse terminology) of this item. + +=cut + +sub get_type { + return ref $_[0]; +} + 1; =back diff --git a/lib/ajax.pm b/lib/ajax.pm index 677150fc9..7bc8b852e 100644 --- a/lib/ajax.pm +++ b/lib/ajax.pm @@ -75,6 +75,9 @@ sub checkForUpdate { if (${$$self{expireTime}} < time()) { &main::print_log ("checkForUpdate waiter for sub ${$$self{sub}} timed out, closing socket") if $main::Debug{ajax}; + # Sending a status code makes it easier to distinish No Content from a lost + # connection on the client end. + &::print_socket_fork (${$$self{waitingSocket}}, "HTTP/1.0 204 No Content\n\n"); ${$$self{waitingSocket}}->close; return 1; } diff --git a/lib/http_server.pl b/lib/http_server.pl index a81e5cd63..720a272f3 100644 --- a/lib/http_server.pl +++ b/lib/http_server.pl @@ -6,11 +6,12 @@ # $Revision$ use strict; +use Text::ParseWords; require 'http_utils.pl'; #no warnings 'uninitialized'; # These seem to always show up. Dang, will not work with 5.0 -use vars qw(%Http %Cookies %Included_HTML %HTTP_ARGV $HTTP_REQUEST); +use vars qw(%Http %Cookies %Included_HTML %HTTP_ARGV $HTTP_REQUEST $HTTP_BODY $HTTP_REQ_TYPE); $Authorized = 0; my($leave_socket_open_passes, $leave_socket_open_action); @@ -59,6 +60,7 @@ my (%http_dirs, %html_icons, $html_info_overlib, %password_protect_dirs, %http_agent_formats, %http_agent_sizes); my ($http_fork_mem, $http_fork_page, $http_fork_count); + if ($config_parms{http_fork} eq 'memmap') { $http_fork_mem = new Win32::MemMap; $http_fork_page = $http_fork_mem->GetGranularitySize(); @@ -149,7 +151,7 @@ sub http_process_request { $_ = <$socket>; last unless $_ and /\S/; $temp .= $_; - if (/^ *(GET|POST) /) { + if (/^ *(GET|POST|PUT) /) { $header = $_; } elsif (my ($key, $value) = /(\S+?)\: ?(.+?)[\n\r]+/) { @@ -200,30 +202,50 @@ sub http_process_request { #Compaq IA1: Mozilla/4.0 (compatible; MSIE 4.01; Windows CE; MSN Companion 2.0; 800x600; Compaq). #Aquapad: Mozilla/4.0 (compatible; MSIE 4.01; Windows NT Windows CE) #Opera: Mozilla/4.0 (compatible; MSIE 5.0; Linux 2.4.6-rmk1-np2-embedix armv4l; 240x320) Opera 5.0 [en] - +#iPhone: Mozilla/5.0 (iPhone; CPU iPhone OS 8_1_3 like Mac OS X) AppleWebKit/600.1.4 (KHTML, like Gecko) Version/8.0 Mobile/12B466 Safari/600.1.4 + + my $ia7_enable = 'none'; + $ia7_enable = $main::config_parms{'ia7_enable'} if defined $main::config_parms{'ia7_enable'}; + my $mobile_html = 0; + my $modern_browser = 0; + if (($Http{'User-Agent'} =~ /iPhone/i) or ($Http{'User-Agent'} =~ /Android/i)) { + $mobile_html = 1; + } + if (($Http{'User-Agent'} =~ /AppleWebKit/i) or + ($Http{'User-Agent'} =~ /Chrome/i) or + ($Http{'User-Agent'} =~ /Gecko/i) or + ($Http{'User-Agent'} =~ /iPad/i)) { + $modern_browser = 1; + } + # print "db ua=$Http{'User-Agent'}\n"; if ($Http{'User-Agent'}) { $Http{'User-Agent-Size'} = $1 if $Http{'User-Agent'} =~ /\d{2,}x(\d){2,}/; if ($Http{'User-Agent'} =~ /Windows CE/i) { $Http{'User-Agent'} = 'MSCE'; + $modern_browser = 0; } elsif ($Http{'User-Agent'} =~ /Audrey/i) { $Http{'User-Agent'} = 'Audrey'; + $modern_browser = 0; } elsif ($Http{'User-Agent'} =~ /Photon/i) { $Http{'User-Agent'} = 'Photon'; + $modern_browser = 0; } elsif ($Http{'User-Agent'} =~ /MSIE/i) { $Http{'User-Agent'} = 'MSIE'; } elsif ($Http{'User-Agent'} =~ /Netscape6/i) { $Http{'User-Agent'} = 'Netscape6'; + $modern_browser = 0; } elsif ($Http{'User-Agent'} =~ /Mozilla/i) { $Http{'User-Agent'} = 'Mozilla'; } elsif ($Http{'User-Agent'} =~ /embedix/i) { $Http{'User-Agent'} = 'Zaurus'; + $modern_browser = 0; } elsif ($Http{'User-Agent'} =~ /Opera/i) { $Http{'User-Agent'} = 'Opera'; @@ -231,6 +253,7 @@ sub http_process_request { } else { $Http{'User-Agent'} = ''; + $modern_browser = 0; } $Http{format} = ''; @@ -247,8 +270,9 @@ sub http_process_request { $Authorized = &password_check($Cookies{password}, 'http', 'crypted'); } - my ($req_typ, $get_req, $get_arg) = $header =~ m|^(GET\|POST) (\/[^ \?]*)\??(\S+)? HTTP|; + my ($req_typ, $get_req, $get_arg) = $header =~ m|^(GET\|POST\|PUT) (\/[^ \?]*)\??(\S+)? HTTP|; $get_arg = '' unless defined $get_arg; + $HTTP_REQ_TYPE = $req_typ; $get_arg =~ s/(.*)\&__async.*/$1/; # RaK: Fast hack to ensure async requests @@ -257,18 +281,31 @@ sub http_process_request { print "http: gr=$get_req ga=$get_arg " . "A=$Authorized format=$Http{format} ua=$Http{'User-Agent'} h=$header" if $main::Debug{http}; - if ($req_typ eq "POST") { - $get_arg .= '&' if $get_arg; + if ($req_typ eq "POST" || $req_typ eq "PUT") { my $cl = $Http{'Content-Length'} || $Http{'Content-length'}; # Netscape uses lower case l print "http POST query has $cl bytes of args\n" if $main::Debug{http}; my $buf; read $socket, $buf, $cl; - $get_arg .= $buf; + # Save the body into the global var + $HTTP_BODY = $buf; + # This is a bad practice to merge the body and arguments together as the + # body may not always contain an argument string. It may contain JSON + # data, binary data, or anything. + # Since I can't figure out if any bad code relies on merging the body + # into the arguments, the following regex tests if the body is a valid + # argument string. If it is, the body is merged. + if ($buf =~ /^([-\+=&;%@.\w_]*)\s*$/){ + $get_arg .= "&" if ($get_arg ne ''); + $get_arg .= $buf; + } # shutdown($socket->fileno(), 0); # "how": 0=no more receives, 1=sends, 2=both } if (!$get_req or $get_req eq '/') { $get_req = $main::config_parms{'html_file' . $Http{format}}; + $get_req = '/ia7/' if (((lc $ia7_enable eq "mobile") or (lc $ia7_enable eq "all")) and $mobile_html); + $get_req = '/ia7/' if ((lc $ia7_enable eq "all") and $modern_browser); + $get_req = '/' . $get_req unless $get_req =~ /^\//; # Leading / is optional my $referer = "http://$Http{Host}"; # Some browsers (e.g. Audrey) do not echo port in Host data @@ -409,6 +446,9 @@ sub http_process_request { } # See if the request was for a file if (&test_for_file($socket, $get_req, $get_arg)) { + } + elsif ($get_req =~ /^\/JSON/i){ + &print_socket_fork($socket, json()); } # Test for RUN commands elsif ($get_req =~ /\/RUN$/i or @@ -889,11 +929,8 @@ sub html_sub { # Check for authorization if (($Authorized or $Password_Allow{"&$sub_name"} and $Password_Allow{"&$sub_name"} eq 'anyone')) { # If not quoted, split to multiple argument according to , -# $sub_arg = "'$sub_arg'" if $sub_arg and $sub_arg !~ /^[\'\"]/; # Add quotes if needed - unless ($sub_arg =~ /^[\'\"]/) { - my @args = split ',', $sub_arg; - $sub_arg = join ',', map {"'$_'"} @args; - } + my @args = parse_line(',', 0, $sub_arg); + $sub_arg = join ',', map {"'$_'"} @args; return(undef, "&$sub_name($sub_arg)"); } else { @@ -1367,7 +1404,7 @@ sub html_file { # Return right away if the file has not changed #http: header key=If-Modified-Since value=Sat, 27 Mar 2004 02:49:29 GMT; length=1685. - if ($cache and $Http{'If-Modified-Since'} and $Http{'If-Modified-Since'} =~ /(.+? GMT);/) { + if ($cache and $Http{'If-Modified-Since'} and $Http{'If-Modified-Since'} =~ /(.+? GMT)/) { my $time2 = &str2time($1); my $time3 = (stat($file))[9]; print "db web file cache check: f=$file t=$time2/$time3\n" if $main::Debug{http3}; diff --git a/lib/json_server.pl b/lib/json_server.pl index 7566eefe8..7af5dfedb 100644 --- a/lib/json_server.pl +++ b/lib/json_server.pl @@ -40,121 +40,150 @@ =head2 METHODS use strict; use HTML::Entities; # So we can encode characters like <>& etc -use JSON; +use JSON qw(decode_json); +use IO::Compress::Gzip qw(gzip); sub json { - my ( $request, $options ) = @_; - my ( %json, $json, $json_types, $json_groups, $json_categories, $json_vars, - $json_objects ); + my ($request_type, $path_str, $arguments, $body) = @_; - return &json_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; + # Passed arguments can be used to override the global parameters + # This is necessary for using the LONG_POLL interface + if ($request_type eq ''){ + $request_type = $HTTP_REQ_TYPE; } - - my %options; - foreach ( split ',', $options ) { - my ( $k, undef, $v ) = /(\w+)(=(.+))?/; - $options{$k}{active} = 1; - $options{$k}{members} = [ split /\|/, $v ] if $k and $v; + my %arg_hash = %HTTP_ARGV; + if ($arguments ne '') { + %arg_hash = (); + # Split the pairs apart first + # $pairs[0]="var1=val1", $pairs[1]="var2=val2", etc + my @pairs=split(/&/,$arguments); + + # Now split each individual pair and store in the hash + foreach my $pair (@pairs) { + my ($name, $value) = $pair =~ /(.*?)=(.*)/; + if ($value) { + $value =~ tr/\+/ /; # translate + back to spaces + $value =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/ge; + # Store in hash + $arg_hash{$name} = $value; + } + } } - - my %fields; - foreach ( @{ $options{fields}{members} } ) { - $fields{$_} = 1; + if ($body eq ''){ + $body = $HTTP_BODY; + } + if ($path_str eq ''){ + $path_str = $HTTP_REQUEST; } - print_log "json: request=$request options=$options" if $Debug{json}; - - # List objects by type - if ( $request{types} ) { - my @types; - my $name; - if ( $request{types}{members} and @{ $request{types}{members} } ) { - @types = @{ $request{types}{members} }; - } - else { - @types = @Object_Types; - } - foreach my $type ( sort @types ) { - print_log "json: type $type" if $Debug{json}; - unless ( $options{truncate} ) { - foreach my $object ( sort &list_objects_by_type($type) ) { - $object = &get_object_by_name($object); - $name = $object->{object_name}; - $json{'types'}{$type}{$name} = - &json_object_detail( $object, %fields ); - } - } - } + # Split arguments into arrays + my %args; + foreach my $k ( keys %arg_hash ) { + $args{$k} = [ split /,/, $arg_hash{$k} ] ; + } + + # Split Path into Array + $path_str =~ s/^\/json//i; # Remove leading 'json' path + $path_str =~ s/^\/|\/$//g; # Remove leadin trailing slash. + my @path = split ('/', $path_str); + + if (lc($request_type) eq "get"){ + return json_get($request_type, \@path, \%args, $body); } + elsif (lc($request_type) eq "put"){ + json_put($request_type, \@path, \%args, $body); + } +} - # List objects by groups - if ( $request{groups} ) { - my @groups; - my $name; - if ( $request{groups}{members} and @{ $request{groups}{members} } ) { - @groups = @{ $request{groups}{members} }; +# Handles Put (UPDATE) Requests +sub json_put { + my ($request_type, $path, $arguments, $body) = @_; + my ( %json); + my %args = %{$arguments}; + my @path = @{$path}; + my $output_time = ::get_tickcount(); + $body = decode_json($body); + + # Currently we only know how to do things with objects + if ($path[0] eq 'objects') { + my $object = ::get_object_by_name($path[1]); + if (ref $object){ + if ($path[2] ne '' && $object->can($path[2])){ + my $method = $path[2]; + my $response = $object->$method($body); + $json{data} = $response; + } + else { + $json{error}{msg} = 'Method not available on object'; + } } else { - @groups = &list_objects_by_type('Group'); - } - foreach my $group ( sort @groups ) { - print_log "json: group $group" if $Debug{json}; - my $group_object = &get_object_by_name($group); - next unless $group_object; - unless ( $options{truncate} ) { - foreach my $object ( list $group_object) { - $name = $object->{object_name}; - $json{'groups'}{$group}{$name} = - &json_object_detail( $object, %fields ); - } - } + $json{error}{msg} = 'Unable to locate object by that name'; } } + else { + $json{error}{msg} = 'PUT can only be used on the path objects'; + } - # List voice commands by category - if ( $request{categories} ) { - my @categories; - my $name; - 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 "json: cat $category" if $Debug{json}; - next if $category =~ /^none$/; - unless ( $options{truncate} ) { - foreach my $name ( sort &list_objects_by_webname($category) ) { - my ( $object, $type ); - $object = &get_object_by_name($name); - $name = $object->{object_name}; - $type = ref $object; - print_log "json: o $name t $type" if $Debug{json}; - next unless $type eq 'Voice_Cmd'; - $json{categories}{$category}{$name} = - &json_object_detail( $object, %fields ); - } - } + #Insert Meta Data fields + $json{meta}{time} = $output_time; + $json{meta}{path} = \@path; + $json{meta}{args} = \%args; + + my $json_raw = JSON->new->allow_nonref; + # Translate special characters + $json_raw = $json_raw->pretty->encode( \%json ); + return &json_page($json_raw); +} + +# Handles Get (READ) Requests +sub json_get { + my ($request_type, $path, $arguments, $body) = @_; + + my %args = %{$arguments}; + my @path = @{$path}; + my ( %json, %json_data, $json_vars, $json_objects); + my $output_time = ::get_tickcount(); + + # Build hash of fields requested for easy reference + my %fields; + if ($args{fields}){ + foreach ( @{ $args{fields} } ) { + $fields{$_} = 1; } } + $fields{all} = 1 unless %fields; + + + + # List defined collections + if ($path[0] eq 'collections' || $path[0] eq '') { + my $collection_file = "$Pgm_Root/data/web/collections.json"; + $collection_file = "$config_parms{data_dir}/web/collections.json" + if -e "$config_parms{data_dir}/web/collections.json"; + # Consider copying the source file to the user data dir here. + my $json_collections = file_read($collection_file); + $json_data{'collections'} = decode_json($json_collections); + } # List objects - if ( $request{objects} ) { + if ($path[0] eq 'objects' || $path[0] eq '') { + $json_data{objects} = {}; my @objects; - if ( $request{objects}{members} and @{ $request{objects}{members} } ) { - @objects = @{ $request{objects}{members} }; + # Building the list of parent groups for each object + # we could use &::list_groups_by_object() for each object, but that sub + # is time consuming, particularly when called numerous times. Instead, + # we create a lookup table one time, saving a lot of processing time. + my $parent_table = build_parent_table(); + + # Restrict object list by type here to make things faster + if ($args{type}){ + for (@{$args{type}}){ + push @objects, &list_objects_by_type($_); + } } else { - foreach my $object_type (@Object_Types) { + foreach my $object_type (list_object_types()) { push @objects, &list_objects_by_type($object_type); } } @@ -162,174 +191,190 @@ sub json { next unless $o; my $name = $o; $name = $o->{object_name}; + $name =~ s/\$|\%|\&|\@//g; print_log "json: object name=$name ref=" . ref $o if $Debug{json}; - $json{objects}{$name} = &json_object_detail( $o, %fields ); + if (my $data = &json_object_detail( $o, \%args, \%fields, $parent_table)){ + $json_data{objects}{$name} = $data; + } } - } - # List subroutines - if ( $request{subs} ) { - my $name; - if ( $request{subs}{members} and @{ $request{subs}{members} } ) { - foreach my $member ( @{ $request{subs}{members} } ) { - no strict 'refs'; - my $ref; - eval "\$ref = \\$member"; - print_log "json subs error: $@" if $@; - $json{subs}{$member} = &json_walk_var( $ref, $member, ('CODE') ); - print_log Dumper(%json) if $Debug{json}; + # Insert categories as an object + my @categories = &list_code_webnames('Voice_Cmd'); + for my $category ( sort @categories ) { + print_log "json: cat $category" if $Debug{json}; + my $temp_object = { + 'type' => 'Category', + 'members' => '' + }; + if (filter_object($temp_object, \%args)){ + $json_data{objects}{$category} = $temp_object; } } - else { - my $ref = \%::; - foreach my $key ( sort { lc $a cmp lc $b } keys %$ref ) { - my $iref = ${$ref}{$key}; - $json{subs}{$key} = &json_walk_var( $iref, $key, ('CODE') ); + + # List known types as objects + my @types = @Object_Types; + foreach my $type ( sort @types ) { + print_log "json: type $type" if $Debug{json}; + my $temp_object = { + 'type' => 'Type', + 'members' => '' + }; + if (filter_object($temp_object, \%args)){ + $json_data{objects}{$type} = $temp_object; } } } +; + # List subroutines + if ($path[0] eq 'subs' || $path[0] eq '') { + my $name; + my $ref = \%::; + foreach my $key ( sort { lc $a cmp lc $b } keys %$ref ) { + my $iref = ${$ref}{$key}; + $json_data{subs}{$key} = &json_walk_var( $iref, $key, ('CODE') ); + } + } # List packages - if ( $request{packages} or $request{package} ) { - if ( $request{packages}{members} and @{ $request{packages}{members} } ) - { - foreach my $member ( @{ $request{packages}{members} } ) { - no strict 'refs'; - my ( $type, $base ) = $member =~ /^(.)(.*)/; - my $ref; - eval "\$ref = \\$member"; - print_log "json packages error: $@" if $@; - $json{packages}{$member} = - &json_walk_var( $ref, $member, qw( SCALAR ARRAY HASH CODE ) ); - } - } - else { - my $ref = \%::; - foreach my $key ( sort { lc $a cmp lc $b } keys %$ref ) { - next unless $key =~ /.+::$/; - next if $key eq 'main::'; - my $iref = ${$ref}{$key}; - my ($k, $r) = &json_walk_var( $iref, $key, qw( SCALAR ARRAY HASH CODE ) ); - $json{packages}{$k} = $r if $k ne ""; - } + if ($path[0] eq 'packages' || $path[0] eq '') { + my $ref = \%::; + foreach my $key ( sort { lc $a cmp lc $b } keys %$ref ) { + next unless $key =~ /.+::$/; + next if $key eq 'main::'; + my $iref = ${$ref}{$key}; + my ($k, $r) = &json_walk_var( $iref, $key, qw( SCALAR ARRAY HASH CODE ) ); + $json_data{packages}{$k} = $r if $k ne ""; } + } # List Global vars - if ( $request{vars} or $request{var} ) { - if ( ( $request{vars}{members} and @{ $request{vars}{members} } ) - or ( $request{var}{members} and @{ $request{var}{members} } ) ) - { + if ($path[0] eq 'vars' || $path[0] eq '') { + my $ref = \%::; + my %json_vars; + foreach my $key ( sort { lc $a cmp lc $b } keys %$ref ) { + next unless $key =~ /^[[:print:]]+$/; + next if $key =~ /::$/; + next if $key =~ /^.$/; + next if $key =~ /^__/; + next if $key =~ /^_ 0) { + $json_data{'print_log'} = []; + push($json_data{'print_log'}, @log); + } + } + + # List speak phrases + if ( $path[0] eq 'print_speaklog' || $path[0] eq '' ) { + my (@log,@tmp); + my $name; + if ($args{time} + && int($args{time}[0]) < int(::print_speaklog_current_time())){ + #Only return messages since time + @log = ::print_speaklog_since($args{time}[0]); + push @log,''; #TODO HP - Kludge, the javascript seems to want an extra line in the array for some reason + #print "db/json: " . join(", ",@log) . "\n"; + } elsif (!$args{time}) { + @log = ::print_speaklog_since(); + } + if (scalar(@log) > 0) { + $json_data{'print_speaklog'} = []; + push($json_data{'print_speaklog'}, @log); } } - # List hash values - foreach my $hash ( - qw( config_parms Menus photos Save Socket_Ports triggers - User_Code Weather ) - ) - { - my $req = lc $hash; - my $ref = \%::; - next unless $request{$req}; - if ( $request{$req}{members} and @{ $request{$req}{members} } ) { - foreach my $member ( @{ $request{$req}{members} } ) { - my $iref = \${$ref}{$hash}{$member}; - my ($k, $r) = &json_walk_var( $iref, "$hash\{$member\}" ); - $json{$hash}{$member} = $r; - } + print_log Dumper(%json_data) if $Debug{json}; + + # Select appropriate data based on path request + my $output_ref; + if (scalar(@path) > 0) { + my @element_list = @path; #Prevent Altering the Master Reference + $output_ref = json_get_sub_element(\@element_list, \%json_data); + } + + # If this is a long_poll and there is no data, simply return + if ($args{long_poll} && (!$output_ref)){ + return; + } + + # Insert Data or Error Message + if ($output_ref) { + $json{data} = $output_ref; +# foreach my $key (sort (keys(%{$output_ref}))) { +# print "db:key = $key\n"; +# $json{data}{$key} = $output_ref->{$key}; +# } + } + else { + $json{error}{msg} = 'No data, or path does not exist.'; + } + + #Insert Meta Data fields + $json{meta}{time} = $output_time; + $json{meta}{path} = \@path; + $json{meta}{args} = \%args; + + my $json_raw = JSON->new->allow_nonref; + # Translate special characters + $json_raw->canonical(1); #Order the data so that objects show alphabetically + $json_raw = $json_raw->pretty->encode( \%json ); + return &json_page($json_raw); + +} + +sub json_get_sub_element { + my ($element_ref, $json_ref, $error_path) = @_; + my $out_ref = {}; + $error_path = "/" unless $error_path; + my $path = shift(@{$element_ref}); + $error_path .= $path . "/"; + if (ref $json_ref eq 'HASH' && exists $json_ref->{$path}){ + if (scalar(@{$element_ref}) > 0){ + return json_get_sub_element($element_ref, $json_ref->{$path}, $error_path); } else { - %json = &json_walk_var( ${$ref}{$hash}, $hash ); + #This is the end of the line + $out_ref = $json_ref->{$path}; + + #Check if this ref is empty + if (ref $out_ref eq 'ARRAY' && scalar(@{$out_ref}) == 0){ + return; + } + elsif (ref $out_ref eq 'HASH' && (!%{$out_ref})){ + return; + } + return $out_ref; } } - print_log Dumper(%json) if $Debug{json}; - $json = JSON->new->allow_nonref; - # Translate special characters - $json = $json->pretty->encode( \%json ); - return &json_page($json); + else { + return; + } } sub json_walk_var { @@ -423,21 +468,66 @@ sub json_walk_var { return %json_vars; } +sub build_parent_table { + my @groups; + my %parent_table; + for my $group_name (&list_objects_by_type('Group')) { + my $group = &get_object_by_name($group_name); + $group_name =~ s/\$|\%|\&|\@//g; + for my $object ($group->list(undef, undef,1)) { + my $obj_name = $object->get_object_name; + push (@{$parent_table{$obj_name}}, $group_name); + } + } + return \%parent_table; +} + sub json_object_detail { - my ( $object, %fields ) = @_; - return if exists $fields{none} and $fields{none}; + my ( $object, $args_ref, $fields_ref, $parent_table ) = @_; + # Use our own arguments hash so we can modify it + my %args = %{$args_ref}; + my %fields = %{$fields_ref}; + + # Skip this process if all fields are specifically excluded + return if exists $fields{none}; + my $ref = ref \$object; return unless $ref eq 'REF'; - return if $object->can('hidden') and $object->hidden; - $fields{all} = 1 unless %fields; + return if $object->can('hidden') and $object->hidden; #Not sure about this my $object_name = $object->{object_name}; + + # Skip object if time arg supplied and not changed + if ($args{time} && $args{time}[0] > 0){ + # Idle times are only reported in seconds + my $request_time = int($args{time}[0] / 1000); # Convert to seconds + my $current_time = int(::get_tickcount() / 1000); # Convert to seconds + + if (!($object->can('get_idle_time'))){ + #Items that do not have an idle time do not get reported at all in updates + return; + } + elsif ($object->get_idle_time eq ''){ + #Items that have NEVER been set to a state have a null idle time + return; + } + elsif ($request_time >= ($current_time - $object->get_idle_time)) { + #Should get_tickcount be replaced with output_time?? + #Object has not changed since time, so return undefined + return; + } + } + my %json_objects; - my @f = qw( category filename measurement rf_id set_by - state states state_log type + my %json_complete_object; + my @f = qw( category filename measurement rf_id set_by members + state states state_log type label sort_order groups parents idle_time text html seconds_remaining level); + # Build list of fields based on those requested. foreach my $f ( sort @f ) { - next unless $fields{all} or $fields{$f}; + # Lets skip fields that are neither called for nor filtered on + next unless ($fields{all} or $fields{$f} or $args{$f}); + my $value; my $method = $f; if ( @@ -446,6 +536,11 @@ sub json_object_detail { and $object->can($method) ) ) { + if ($f eq 'type'){ + # We need to hard code type, b/c x10 has a subroutine called + # type that screws with us. + $method = 'get_type'; + } if ( $f eq 'states' or $f eq 'state_log' ) { my @a = $object->$method; $value = \@a; @@ -457,6 +552,23 @@ sub json_object_detail { print_log "json: object_dets f $f m $method v $value" if $Debug{json}; } + elsif ($f eq 'members'){ + ## Currently only list members for group items, but at some point we + ## can add linked items too. + if (ref($object) eq 'Group') { + $value = []; + for my $obj_name (&list_objects_by_group($object->get_object_name, 1)) { + $obj_name =~ s/\$|\%|\&|\@//g; + push ($value, $obj_name); + } + } + } + elsif ($f eq 'parents'){ + $value = []; + for my $group_name ($$parent_table{$object_name}) { + $value = $group_name; + } + } elsif ( exists $object->{$f} ) { $value = $object->{$f}; $value = encode_entities( $value, "\200-\377&<>" ); @@ -470,33 +582,71 @@ sub json_object_detail { else { print_log "json: object_dets didn't find $f" if $Debug{json}; } - if ( ref $value eq 'ARRAY' ) { - my $i = 0; - foreach (@$value) { - $_ = 'No Value' unless defined $_; - $json_objects{$f}{$i} = $_; - $i = $i + 1; + + if (($fields{all} or $fields{$f}) && defined $value){ + $json_objects{$f} = $value; + } + $json_complete_object{$f} = $value; + } + + if (filter_object(\%json_complete_object, $args_ref)){ + return \%json_objects; + } + else { + return; + } +} + +sub filter_object { + my ($object, $args_ref) = @_; + my %args = %{$args_ref}; + # Check if object has required parameters + for my $f (keys %args){ + # Skip special fields + next if (lc($f) eq 'time'); + next if (lc($f) eq 'fields'); + next if (lc($f) eq 'long_poll'); + next if ($f eq ''); + if ($$object{$f}) { + for my $test_val (@{$args{$f}}) { + if (ref $$object{$f} eq 'ARRAY'){ + my $notfound = 1; + for (@{$$object{$f}}) { + if ($test_val eq $_) { + $notfound = 0; + last; + } + } + return if ($notfound); + } + elsif ($test_val ne $$object{$f}) { + # Required value was not a match + # not sure how the same value could equal an array of values + # but leave here for possible future expansion + return; + } } } else { - $json_objects{$f} = $value if defined $value; + #Object lacks the required field + return 0; } } - return \%json_objects; + return 1; } sub json_page { - my ($json) = @_; - - $json =~ s/\$|\%|\&|\@//g; - return < \$json; + my $output = "HTTP/1.0 200 OK\r\n"; + $output .= "Server: MisterHouse\r\n"; + $output .= "Content-type: application/json\r\n"; + $output .= "Content-Encoding: gzip\r\n"; + $output .= "\r\n"; + $output .= $json; + + return $output; } sub json_entities_encode { @@ -523,23 +673,26 @@ sub json_usage {

JSON Server

eof my @requests = qw( types groups categories config_parms socket_ports - user_code weather save objects photos subs menus triggers packages vars ); + user_code weather save objects photos subs menus triggers packages vars print_log print_speaklog); - my %options = ( + my %args = ( fields => { applyto => 'types|groups|categories|objects', }, + time => { + applyto => 'print_log|print_speaklog', + } ); foreach my $r (@requests) { my $url = "/sub?json($r)"; $html .= "

$r

\n

$url

\n