So many changes, and now 11 years old. Time for a 1.0 release.
[mythtv-status.git] / bin / mythtv-status
1 #!/usr/bin/perl
2 # Copyright (c) 2007-2018 Andrew Ruthven <andrew@etc.gen.nz>
3 # This code is hereby licensed for public consumption under the GNU GPL v3.
4 #
5 # You should have received a copy of the GNU General Public License along
6 # with this program; if not, write to the Free Software Foundation, Inc.,
7 # 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
8
9 # Display the current status of a MythTV system.
10
11 # While I would love to enable the 6.xx interface for Date::Manip we may
12 # still need to run on platforms that only have version 5.x.  So we'll
13 # turn on backwards compatible mode for now.
14 {
15   no warnings 'once';
16   $Date::Manip::Backend = 'DM5';
17 }
18
19 use warnings;
20 use LWP::UserAgent;
21 use XML::LibXML;
22 use Date::Manip;
23 use Date::Manip::Date;
24 use Getopt::Long;
25 use Text::Wrap;
26 use POSIX qw/strftime :sys_wait_h :signal_h/;
27
28 use MIME::Entity;
29 use Pod::Usage;
30 use Encode;
31
32 # Try and load a config file first, and then allow the command line
33 # to override what is in the config file.
34 my $c;
35
36 if (eval("{ local \$SIG{__DIE__}; require Config::Auto; }")) {
37   $c = eval {
38     Config::Auto::parse("mythtv-status.yml", format => 'yaml')
39   };
40
41   if ($@) {
42     # Die on any issues loading the config file, apart from it not existing.
43     if ($@ =~ /^No config file found/) {
44       $c->{'config_file_loaded'} = 0;
45     } else {
46       die $@;
47     }
48   } else {
49     $c->{'config_file_loaded'} = 1;
50   }
51 }
52
53 # Some sane defaults.
54 $c->{'host'}    ||= "localhost";
55 $c->{'port'}    ||= "6544";
56 $c->{'colour'}  ||= 0;
57 $c->{'highlight'} ||= -1;
58 $c->{'episode'} ||= 0;
59 $c->{'description'} ||= 0;
60 $c->{'encoder_details'}     ||= 0;
61 $c->{'encoder_skip_idle'}   //= 1;
62 $c->{'encoder_warn_non_idle'} //= 1;
63 $c->{'email_only_on_alert'} ||= 0;
64 my $help = 0;
65 my $verbose = 0;
66 $c->{'disk_space_warn'} ||= 95;  # Percent to warn at.
67 $c->{'guide_days_warn'} ||= 2;   # How many days we require.
68 $c->{'auto_expire_count'} ||= 10;      # How many auto expire shows to display.
69 $c->{'recording_in_warn'} ||= 60 * 60; # When is the next recording considered critical? (seconds)
70 $c->{'save_file'} ||= undef; # File to save the XML from the BE to.
71 $c->{'xml_file'}  ||= undef; # Load the BE XML from this file.
72
73 # We allow a hack for MS Outlook which normally recognises the
74 # oneliners block as a paragraph and wraps it.  If it sees "bullets"
75 # it believes it is a bulleted list and leaves it alone.
76 $c->{'oneliner_bullets'} ||= 0;
77
78 # What units we have available for converting diskspaces. The order is
79 # important, the largest unit should come first.
80 #
81 # Allowed keys:
82 #   unit -                   SI unit to use
83 #   threshold -              Any value greater than threshold uses this unit
84 #   make_integer -           Strip off anything after the decimal point
85 #   make_integer_threshold - Anything over this value will have the
86 #     decimal point removed if make_integer is set to 1. This test is applied
87 #     after the size has been converted, so the value should be in the 'new'
88 #     unit.
89 #
90 my @size_thresholds = (
91   {
92     'unit' => 'TB',
93     'threshold' => 1024 * 1024,
94     'conversion' => 1024 * 1024,
95     'make_integer' => 1,
96     'make_integer_threshold' => 500,
97   },
98   {
99     'unit' => 'GB',
100     'threshold' => 50 * 1024,        # 50GB seems like a good threshold.
101     'conversion' => 1024,
102     'make_integer' => 1,
103     'make_integer_threshold' => 500,
104   },
105   {
106     'unit' => 'MB',
107   },
108 );
109
110 my $return_code_only = 0;
111
112 my $VERSION = '1.0.0';
113
114 # Some display blocks are disabled by default:
115 $c->{'display'}{'Shows due to Auto Expire'} = 0;
116
117 GetOptions(
118   'c|colour|color!' => \$c->{'colour'},
119   'd|description!' => \$c->{'description'},
120   'e|episode!'    => \$c->{'episode'},
121   'encoder-details!' => \$c->{'encoder_details'},
122   'h|host=s'     => \$c->{'host'},
123   'highlight!'   => \$c->{'highlight'},
124   'p|port=i'     => \$c->{'port'},
125   'v|version'    => \&print_version,
126   'email=s@'     => \@{ $c->{'email'} },
127   'email-only-on-conflict|email-only-on-alert|email-only-on-alerts'
128     => \$c->{'email_only_on_alert'},
129   'disk-space-warn=i'     => \$c->{'disk_space_warn'},
130   'guide-days-warn=i'     => \$c->{'guide_days_warn'},
131   'auto-expire-count=i'   => \$c->{'auto_expire_count'},
132   'recording-in-warn=i'   => \$c->{'recording_in_warn'},
133   'encoder-skip-idle!'    => \$c->{'encoder_skip_idle'},
134   'encoder-warn-non-idle!' => \$c->{'encoder_warn_non_idle'},
135   'oneliner-bullets!'     => \$c->{'oneliner_bullets'},
136
137   'status!'               => \$c->{'display'}{'Status as of'},
138   'encoders!'             => \$c->{'display'}{'Encoders'},
139   'recording-now!'        => \$c->{'display'}{'Recording Now'},
140   'scheduled-recordings!' => \$c->{'display'}{'Scheduled Recordings'},
141   'schedule-conflicts!'   => \$c->{'display'}{'Schedule Conflicts'},
142   'next-recording!'       => \$c->{'display'}{'Next Recording In'},
143   'total-disk-space!'     => \$c->{'display'}{'Total Disk Space'},
144   'disk-space!'           => \$c->{'display'}{'Disk Space'},
145   'guide-data!'           => \$c->{'display'}{'Guide Data'},
146   'auto-expire!'          => \$c->{'display'}{'Shows due to Auto Expire'},
147
148   'return-code-only'      => \$return_code_only,
149
150   'file=s'                => \$c->{'xml_file'},
151   's|save-file=s'         => \$c->{'save_file'},
152
153   'date=s'  => \$c->{'date'},
154   'verbose' => \$verbose,
155   'help|?'  => \$help,
156   ) || pod2usage("\nUse --help for help.\n");
157
158 pod2usage(verbose => 1)
159   if $help;
160
161 $0 = "mythtv-status - parent";
162
163 # Get the email address into a format we can use.
164 @{ $c->{'email'} } = split(',', join(',', @{ $c->{'email'} }));
165
166 # Default settings for emails but let the user override us.
167 if (scalar(@{ $c->{'email'} }) > 0) {
168   # Disable these blocks
169   for my $block ('Encoders', 'Recording Now', 'Next Recording In') {
170     if (! defined $c->{'display'}{$block}) {
171       $c->{'display'}{$block} = 0;
172     }
173   }
174
175   # Enable highlight
176   if ($c->{'highlight'} == -1) {
177     $c->{'highlight'} = 1;
178   }
179 }
180
181 # Possibly use some colour or highlighting, but not no colour in  emails.
182 my $safe = '';
183 my $warn = '';
184 my $warn_to_normal = '';
185 my $safe_to_normal = '';
186
187 if ($c->{'colour'} && scalar(@{ $c->{'email'} }) == 0) {
188   $safe = "\033[0;32m";
189   $warn = "\033[1;31m";
190   $safe_to_normal  = "\033[0m";
191   $warn_to_normal  = "\033[0m";
192 }
193
194 if ($c->{'highlight'} > 0) {
195   $warn .= '*';
196   $warn_to_normal   = "*$warn_to_normal";
197 }
198
199 # Is a warning present?
200 my $warn_present = 0;
201
202 # Allow setting some defaults for the output blocks.
203 my %defaults = (
204   'schedule' => {
205     'attrs' => [ qw/title startTime NODE_TEXT subTitle channelName:.\/Channel[@channelName] chanNum:.\/Channel[@chanId] inputId:.\/Channel[@inputId]/ ],
206     'template' => "__startTime__"
207       . " - __title__"
208       . ($c->{'episode'} ? " - __subTitle__" : '')
209       . " (__channelName__)"
210       . ($c->{'encoder_details'} ? " - Enc: __inputId__, Chan: __chanNum__" : '')
211       . ($c->{'description'} ? "\n__NODE_TEXT__" : ''),
212
213     'filter' =>  {
214
215       # Only show recordings for today and tomorrow.
216       'startTime' => sub {
217         my $date = substr(ParseDate($_[0]), 0, 8);
218         return ! (($date cmp $today) == 0
219           || ($date cmp $tomorrow) == 0) }
220       },
221     'rewrite' => {
222       '&startTime' => sub { return process_iso_date($_[0]); }
223     }
224   }
225 );
226
227 # The time of the next scheduled recording.
228 my $next_time = 'Never';
229
230 # Are there any alerts that should be notified via email?
231 my @alerts = ();
232
233 # The blocks of output which we might generate.
234 #
235 # Generally, these blocks of output are generated in the order that they
236 # appear below.  However, if a block has the tag "format", who's value is
237 # "one line" it will appear at the start of the output, on a single line,
238 # all one liners grouped together.
239 my @blocks = (
240
241   # All the one liners together
242   {
243     'name' => 'One Liners',
244     'type' => 'sub',
245     'template' => '',
246     'sub' => sub { return 'Place holder' },
247   },
248
249   # Date/Time from server
250   {
251     'name'  => 'Status as of',
252     'type'  => 'xpath',
253     'xpath' => "//Status",
254     'attrs' => [ qw/ISODate time date/ ],
255     'optional_attrs' => [ qw/ISODate/ ],
256     'template' => "__date__",
257     'format' => 'one line',
258     'rewrite' => {
259       '&date' => sub {
260         my ($value, $vars) = @_;
261
262         if (defined $vars->{ISODate} && $vars->{ISODate} =~ /Z$/) {
263           return process_iso_date($vars->{ISODate});
264         } else {
265           return $vars->{date} . ", " . $vars->{time};
266         }
267       },
268     },
269   },
270
271   # Info about the encoders before TV OSD Declutter (Changeset 20037).
272   {
273     'name'  => 'Encoders',
274     'type'  => 'xpath',
275     'xpath' => "//Status/Encoders/Encoder",
276     'protocol_version' => [ "<= 43" ],
277     'attrs' => [ qw/hostname id state connected/ ],
278     'template' => "__hostname__ (__id__) - __state_colour____state____state_normal____connected__",
279     'rewrite' => {
280       '/connected/' => { '1' => '', '0' => "${warn}(Disconnected)${warn_to_normal}" },
281       '/state/' => {
282         '^0$' => "Idle",
283         '^1$' => "Watching LiveTV",
284         '^2$' => "Watching Pre-recorded",
285         '^3$' => "Watching Recording",
286         '^4$' => "Recording",
287       },
288     },
289     'filter' => {
290       'state' => sub { return $c->{'encoder_skip_idle'} && $_[0] == 0 },
291     },
292     'subs' => {
293       'state_colour' => sub {
294         if ($c->{'encoder_warn_non_idle'}) {
295             if ($_[0]->{'state'} eq '0') {
296                 return $safe;
297             } else {
298                 return $warn;
299             }
300         } else {
301             if ($_[0]->{'state'} eq '0') {
302                 return $safe;
303             } elsif ($_[0]->{'state'} eq '-1') {
304                 return $warn;
305             } else {
306                 return '';
307             }
308         }
309       },
310       'state_normal' => sub {
311         if ($c->{'encoder_warn_non_idle'}) {
312             if ($_[0]->{'state'} eq '0') {
313                 return $safe_to_normal;
314             } else {
315                 return $warn_to_normal;
316             }
317         } else {
318             if ($_[0]->{'state'} eq '0') {
319                 return $safe_to_normal;
320             } elsif ($_[0]->{'state'} eq '-1') {
321                 return $warn_to_normal;
322             } else {
323                 return '';
324             }
325         }
326       },
327     },
328   },
329
330   # Info about the encoders after TV OSD Declutter (Changeset 20037).
331   {
332     'name'  => 'Encoders',
333     'type'  => 'xpath',
334     'xpath' => "//Status/Encoders/Encoder",
335     'protocol_version' => [ ">= 44", "< 58" ],
336     'attrs' => [ qw/hostname id state connected/ ],
337     'template' => "__hostname__ (__id__) - __state_colour____state____state_normal____connected__",
338     'rewrite' => {
339       '/connected/' => { '1' => '', '0' => "${warn}(Disconnected)${warn_to_normal}" },
340       '/state/' => {
341          '^-1$' => "${warn}Error${warn_to_normal}",
342          '^0$' => "${safe}Idle${safe_to_normal}",
343          '^1$' => "${warn}Watching LiveTV${warn_to_normal}",
344          '^2$' => "${warn}Watching Pre-recorded${warn_to_normal}",
345          '^3$' => "${warn}Watching DVD${warn_to_normal}",
346          '^4$' => "${warn}Watching Video${warn_to_normal}",
347          '^5$' => "${warn}Watching Recording${warn_to_normal}",
348          '^6$' => "${warn}Recording${warn_to_normal}",
349        },
350     },
351     'filter' => {
352       'state' => sub { return $c->{'encoder_skip_idle'} && $_[0] == 0 },
353     },
354     'subs' => {
355       'state_colour' => sub {
356         if ($c->{'encoder_warn_non_idle'}) {
357             if ($_[0]->{'state'} eq '0') {
358                 return $safe;
359             } else {
360                 return $warn;
361             }
362         } else {
363             if ($_[0]->{'state'} eq '0') {
364                 return $safe;
365             } elsif ($_[0]->{'state'} eq '-1') {
366                 return $warn;
367             } else {
368                 return '';
369             }
370         }
371       },
372       'state_normal' => sub {
373         if ($c->{'encoder_warn_non_idle'}) {
374             if ($_[0]->{'state'} eq '0') {
375                 return $safe_to_normal;
376             } else {
377                 return $warn_to_normal;
378             }
379         } else {
380             if ($_[0]->{'state'} eq '0') {
381                 return $safe_to_normal;
382             } elsif ($_[0]->{'state'} eq '-1') {
383                 return $warn_to_normal;
384             } else {
385                 return '';
386             }
387         }
388       },
389     },
390   },
391
392   # Info about the encoders after adding Blu-ray (Changeset 25058).
393   #  The protocol version is from svn commit 25362 but is the closest commit
394   #  for mythtv/libs/libmythdb/mythversion.h.
395   {
396     'name'  => 'Encoders',
397     'type'  => 'xpath',
398     'xpath' => "//Status/Encoders/Encoder",
399     'protocol_version' => [ ">= 58" ],
400     'attrs' => [ qw/hostname id state devlabel connected/ ],
401     'template' => "__hostname__ (__id____devtype__) - __state_colour____state____state_normal____connected__",
402     'rewrite' => {
403       '/connected/' => { '1' => '', '0' => "${warn}(Disconnected)${warn_to_normal}" },
404       '/state/' => {
405          '^-1$' => "${warn}Error${warn_to_normal}",
406          '^0$'  => "${safe}Idle${safe_to_normal}",
407          '^1$'  => "${warn}Watching LiveTV${warn_to_normal}",
408          '^2$'  => "${warn}Watching Pre-recorded${warn_to_normal}",
409          '^3$'  => "${warn}Watching DVD${warn_to_normal}",
410          '^4$'  => "${warn}Watching Blu-ray${warn_to_normal}",
411          '^5$'  => "${warn}Watching Video${warn_to_normal}",
412          '^6$'  => "${warn}Watching Recording${warn_to_normal}",
413          '^7$'  => "${warn}Recording${warn_to_normal}",
414        },
415     },
416     'filter' => {
417       'state' => sub { return $c->{'encoder_skip_idle'} && $_[0] == 0 },
418     },
419     'subs' => {
420       'devtype' => sub {
421         if    ($_[0]->{'devlabel'} =~ /\[ (.+) :/)   { ", $1" }
422         else { '' }
423       },
424       'state_colour' => sub {
425         if ($c->{'encoder_warn_non_idle'}) {
426             if ($_[0]->{'state'} eq '0') {
427                 return $safe;
428             } else {
429                 return $warn;
430             }
431         } else {
432             if ($_[0]->{'state'} eq '0') {
433                 return $safe;
434             } elsif ($_[0]->{'state'} eq '-1') {
435                 return $warn;
436             } else {
437                 return '';
438             }
439         }
440       },
441       'state_normal' => sub {
442         if ($c->{'encoder_warn_non_idle'}) {
443             if ($_[0]->{'state'} eq '0') {
444                 return $safe_to_normal;
445             } else {
446                 return $warn_to_normal;
447             }
448         } else {
449             if ($_[0]->{'state'} eq '0') {
450                 return $safe_to_normal;
451             } elsif ($_[0]->{'state'} eq '-1') {
452                 return $warn_to_normal;
453             } else {
454                 return '';
455             }
456         }
457       },
458     },
459   },
460
461   # What programs (if any) are being recorded right now?
462   {
463     'name'  => 'Recording Now',
464     'type'  => 'xpath',
465     'xpath' => "//Status/Encoders/Encoder/Program",
466     'hide'  => 'after',
467     'attrs' => [ qw/title endTime channelName:.\/Channel[@channelName]
468                     encoderId:.\/Recording[@encoderId]
469                     chanNum:.\/Channel[@chanNum]/ ],
470     'template' => "__title__ (__channelName__)"
471       . ($c->{'encoder_details'} ? ", Enc: __encoderId__, Chan: __chanNum__" : '')
472       . ", Ends: __endTime__",
473     'rewrite' => {
474       '&endTime' => sub {
475         my ($value, $vars) = @_;
476
477         if ($value =~ /Z$/) {
478           $value = process_iso_date($value, { date => 0 });
479         } else {
480           $value =~ s/.*T//;
481         }
482
483         return $value;
484       },
485     },
486     'subs' => {
487       'find_next' => sub {
488         $warn_present ||= 1;
489         $next_time    = $c->{'date'} || 'now';
490       },
491     },
492   },
493
494   # The upcoming recordings.
495   {
496     'name'  => 'Scheduled Recordings',
497     'type'  => 'xpath',
498     'xpath' => '//Status/Scheduled/Program',
499     'defaults' => 'schedule',
500     'hide'  => 'after',
501     'subs' => {
502       'find_next' => sub {
503         my $vars = shift;
504         return
505           if defined $next_time && $next_time eq 'now';
506
507         my $date = ParseDate($vars->{'startTime'});
508         if ($next_time eq 'Never' || Date_Cmp($date, $next_time) < 0) {
509           $next_time = $date
510         };
511       },
512     },
513   },
514
515   # Conflicts
516   {
517     'name' => 'Schedule Conflicts',
518     'type' => 'sub',
519     'defaults' => 'schedule',
520     'sub' => \&process_conflicts
521   },
522
523   # Auto Expire
524   {
525     'name' => 'Shows due to Auto Expire',
526     'type' => 'sub',
527     'defaults' => 'schedule',
528     'sub' => \&process_auto_expire,
529     'filter' =>  {},   # Over ride the default filter from 'schedule'.
530   },
531
532   # Diskspace, before storage groups
533   {
534     'name' => 'Total Disk Space',
535     'type' => 'xpath',
536     'xpath' => '//Status/MachineInfo/Storage',
537     'protocol_version' => [ "<= 31" ],
538     'attrs' => [ qw/_total_total _total_used/ ],
539     'commify' => [ qw/si__total_total si__total_used/ ],
540     'human_readable_sizes' => [ qw/_total_total _total_used/ ],
541     'template' => "Total space is __si__total_total__ __si__total_total_unit__, with __si__total_used__ __si__total_used_unit__ used (__percent__)",
542     'format' => 'one line',
543     'optional' => 1,
544     'subs' => {
545       'percent' => sub {
546         calc_disk_space_percentage($_[0]->{'_total_used'}, $_[0]->{'_total_total'})
547       },
548     },
549   },
550
551   # Diskspace, with storage groups
552   {
553     'name' => 'Total Disk Space',
554     'type' => 'xpath',
555     'xpath' => '//Status/MachineInfo/Storage',
556     'protocol_version' => [ ">= 32" ],
557     'xml_version' => [ "== 0" ],
558     'attrs' => [ qw/drive_total_total drive_total_used/ ],
559     'commify' => [ qw/si_drive_total_total si_drive_total_used/ ],
560     'human_readable_sizes' => [ qw/drive_total_total drive_total_used/ ],
561     'template' => "Total space is __si_drive_total_total__ __si_drive_total_total_unit__, with __si_drive_total_used__ __si_drive_total_used_unit__ used (__percent__)",
562     'format' => 'one line',
563     'optional' => 1,
564     'subs' => {
565       'percent' => sub {
566         calc_disk_space_percentage($_[0]->{'drive_total_used'}, $_[0]->{'drive_total_total'})
567       },
568     },
569   },
570
571   # Diskspace, with storage groups and sensible XML layout.
572   {
573     'name' => 'Total Disk Space',
574     'type' => 'xpath',
575     'xpath' => '//Status/MachineInfo/Storage/Group[@id="total"]',
576     'protocol_version' => [ ">= 39" ],
577     'attrs' => [ qw/total used/ ],
578     'commify' => [ qw/si_total used/ ],
579     'human_readable_sizes' => [ qw/total used/ ],
580     'template' => "Total space is __si_total__ __si_total_unit__, with __si_used__ __si_used_unit__ used (__percent__)",
581     'format' => 'one line',
582     'optional' => 1,
583     'subs' => {
584       'percent' => sub {
585         calc_disk_space_percentage($_[0]->{'used'}, $_[0]->{'total'})
586       },
587     },
588   },
589
590   # Diskspace, with storage groups and sensible XML layout.
591   {
592     'name' => 'Disk Space',
593     'type' => 'xpath',
594     'xpath' => '//Status/MachineInfo/Storage/Group',
595     'protocol_version' => [ ">= 39" ],
596     'attrs' => [ qw/id total used/ ],
597     'commify' => [ qw/si_total used/ ],
598     'human_readable_sizes' => [ qw/total used/ ],
599     'template' => "Total space for group __id__ is __si_total__ __si_total_unit__, with __si_used__ __si_used_unit__ used (__percent__)",
600     'filter' =>  {
601       'id' => sub { return $_[0] eq 'total' },
602       'used' => sub {
603         return ! (
604           (defined $c->{'display'}{'Disk Space'} && $c->{'display'}{'Disk Space'})
605           || ($_[1]->{'used'} / $_[1]->{'total'}) * 100 > $c->{'disk_space_warn'})
606       },
607     },
608     'subs' => {
609       'percent' => sub {
610         calc_disk_space_percentage($_[0]->{'used'}, $_[0]->{'total'})
611       },
612     },
613   },
614
615   # How many hours till the next recording.
616   {
617     'name' => 'Next Recording In',
618     'type' => 'sub',
619     'format' => 'one line',
620     'template' => '__next_time__',
621     'rewrite' => {
622       '&next_time' => sub {
623         return $next_time
624           if $next_time eq 'Never' || $next_time eq 'now';
625
626         my $err;
627         my $delta   = DateCalc($c->{'date'} || 'now', $next_time, \$err, 1);
628         my $seconds = Delta_Format($delta, 'approx', 0, '%sh');
629         my $remsec  = $seconds;   # Remaining seconds
630         my $str     = '';
631
632         # Days
633         if ($remsec > 24 * 3600) {
634           $str = sprintf("%d Days, ", $remsec / 24 / 3600);
635           $remsec = $remsec % (24 * 3600);
636         }
637         # Hours
638         if ($remsec > 3600) {
639           $str .= sprintf("%d Hours, ", $remsec / 3600);
640           $remsec = $remsec % 3600;
641         }
642         # Minutes
643         if ($remsec > 60) {
644           $str .= sprintf("%d Minutes", $remsec / 60);
645         }
646         # Clean up the string.
647         $str =~ s/, $//;
648         $str =~ s/\b1 (Day|Hour|Minute)s/1 $1/g;
649
650         if ($seconds <= $c->{'recording_in_warn'}) {
651           $warn_present ||= 1;
652           $str = "$warn$str$warn_to_normal";
653         }
654
655         return $str;
656       },
657     },
658     'filter' =>  {
659       'next_time' => sub { return $_[0] eq 'now' }
660     },
661     'sub' => sub {
662       return substitute_vars($_[0], { 'next_time' => $next_time });
663     },
664   },
665
666   # Check how much Guide data we have
667   {
668     'name'     => 'Guide Data',
669     'format'   => 'one line',
670     'type'     => 'xpath',
671     'xpath'    => '//Status/MachineInfo/Guide[@guideDays]',
672     'attrs'    => [qw/guideDays status guideThru/],
673     'template' => 'There is __guideDays__ days worth of data, through to __guideThru__',
674     'filter' => {
675       'guideDays' => sub {
676         if ($_[0] > $c->{'guide_days_warn'}) {
677           return
678             (defined $c->{'display'}{'Guide Data'} && ! $c->{'display'}{'Guide Data'}) || 1;
679         } else {
680           $warn_present ||= 1;
681           push @alerts, "GUIDE DATA";
682           return 0;
683         }
684       },
685     },
686     'rewrite'  => {
687       '&guideDays' => sub {
688         if ($_[0] <= $c->{'guide_days_warn'}) {
689           $warn_present ||= 1;
690           return "$warn$_[0]$warn_to_normal";
691         } else {
692           return "$safe$_[0]$safe_to_normal";
693         }
694       },
695       '/guideThru/' => { 'T\d+:\d+:\d+' => ' ' },
696       '&guideThru' => sub {
697         if ($_[1]->{'guideDays'} <= $c->{'guide_days_warn'}) {
698           $warn_present ||= 1;
699           return "$warn$_[0]$warn_to_normal";
700         } else {
701           return "$safe$_[0]$safe_to_normal";
702         }
703       },
704     },
705   },
706
707   {
708     'name'     => 'Guide Data',
709     'format'   => 'one line',
710     'type'     => 'xpath',
711     'xpath'    => '//Status/MachineInfo/Guide[@status=""]',
712     'template' => "${warn}No guide data!${warn_to_normal}",
713   },
714 );
715
716 ###
717 ### Set some useful variables
718 ###
719 our $today    = substr(ParseDate('today'), 0, 8);
720 our $tomorrow = substr(ParseDate('tomorrow'), 0, 8);
721
722 if ($c->{'date'}) {
723   $today    = substr(ParseDate($c->{'date'}), 0, 8);
724   $tomorrow = substr(DateCalc($c->{'date'}, ParseDateDelta('1 day')), 0, 8);
725 }
726
727 if ($verbose) {
728   print "Today:               $today\n";
729   print "Tomorrow:            $tomorrow\n";
730   print "Config::Auto module: " . (defined $INC{'Config/Auto.pm'} ? 'Loaded' : 'Not Loaded') . "\n";
731   print "Config file loaded:  " . ($c->{'config_file_loaded'} ? 'Yes' : 'No') . "\n";
732 }
733
734 # If we're in return code only mode then we disable all blocks
735 # except for those explicitly enabled.
736 if ($return_code_only) {
737   warn "In return-code-only mode, disabling all blocks by default.\n"
738     if $verbose;
739
740   for my $block (@blocks) {
741     $c->{'display'}{ $block->{'name'} } ||= 0;
742   }
743 }
744
745 # A couple of global variables
746 my ($xml, $charset, $myth);
747 my %version;
748
749 my $exit_value = 0;
750 my $title =  "MythTV status for $c->{'host'}";
751 my $output = "$title\n";
752 $output .= '=' x length($title) . "\n";
753
754 for my $block (@blocks) {
755   $block->{'format'} ||= 'multi line';
756   $block->{'optional'} ||= 0;
757
758   warn "Considering: $block->{'name'}\n"
759     if $verbose;
760
761   my $hide = undef;
762   if (defined $c->{'display'}{ $block->{'name'} }
763     && $c->{'display'}{ $block->{'name'} } == 0) {
764     if (defined $block->{'hide'} && lc($block->{'hide'}) eq 'after') {
765       $hide = 1;
766     } else {
767       next;
768     }
769   }
770
771   warn "  Going to process: $block->{'name'}\n"
772     if $verbose;
773
774   # We might need to set some defaults.
775   if (defined $block->{'defaults'}) {
776     for my $field (keys %{ $defaults{ $block->{'defaults'} } }) {
777       $block->{$field} ||= $defaults{ $block->{'defaults'} }{$field};
778     }
779   }
780
781   my $result = undef;
782   $warn_present = 0;
783   if ($block->{'type'} eq 'xpath') {
784     ($xml, $charset) = load_xml()
785       unless defined $xml;
786
787     $result = process_xml($block, $xml);
788
789   } elsif ($block->{'type'} eq 'sub') {
790
791     $result = &{ $block->{'sub'} }($block)
792       if defined $block->{'sub'};
793   }
794
795   if (defined $result && $result ne '' && ! defined $hide) {
796     $exit_value ||= $warn_present;
797
798     if ($block->{'format'} eq 'one line') {
799       push @oneliners, [ $block->{'name'}, $result ];
800     } else {
801       $output .= "$block->{'name'}:\n";
802       $output .= $result . "\n\n";
803     }
804   }
805 }
806
807 # Deal with the one liners.
808 if (scalar(@oneliners) > 0) {
809
810   # Find the longest header
811   my $length = 0;
812   for $line (@oneliners) {
813     if (length($line->[0]) > $length) {
814       $length = length($line->[0]);
815     }
816   }
817
818   # Put the one liners together, with leading dots to the colon.
819   # We allow a hack for MS Outlook which normally recognises the
820   # oneliners block as a paragrap and wraps it.  If it sees "bullets"
821   # it believes it is a bulleted list and leaves it alone.
822   my $oneliners = "";
823   for $line (@oneliners) {
824     $oneliners .= ($c->{'oneliner_bullets'} ? '* ' : '' )
825       . "$line->[0]"
826       . ('.' x ($length - length($line->[0]))) . ": $line->[1]\n";
827   }
828
829   # What a hacky way of putting the one liners where I want them...
830   $output =~ s/^One Liners:\nPlace holder\n/$oneliners/m;
831 }
832
833 # Either print the status out, or email it.
834 if ($return_code_only) {
835   exit $exit_value;
836 } elsif (scalar(@{ $c->{'email'} }) == 0) {
837   if ($charset =~ /utf(-)?8/i) {
838     $output = encode('UTF-8', $output);
839   }
840   print "\n$output";
841 } else {
842   if ((! $c->{'email_only_on_alert'}) ||
843     ($c->{'email_only_on_alert'} && scalar(@alerts) > 0)) {
844     my $suffix = undef;
845     if (@alerts == 1) {
846       $suffix = $alerts[0];
847     } elsif (@alerts > 1) {
848       $suffix = "MULTIPLE WARNINGS";
849     }
850
851     my $mail = MIME::Entity->build(
852       To      => $c->{'email'},
853       Subject => encode('UTF-8', $title . (defined $suffix ? " - $suffix" : '')),
854       Charset => $charset,
855       Encoding=> "quoted-printable",
856       Data    => encode('UTF-8', $output),
857       );
858
859     $mail->send('sendmail');
860   }
861 }
862
863 exit $exit_value;
864
865 # Fetch the XML status from the backend.
866 sub load_xml {
867   my $status = '';
868   my $charset = '';
869
870   if (defined $c->{'xml_file'}) {
871     open (IN, "< $c->{'xml_file'}")
872       || die "Failed to open $c->{'xml_file'} for reading: $!\n";
873
874     $status = join("", <IN>);
875     $charset = 'UTF-8';
876
877     close IN;
878   } else {
879     my $content_type;
880     # In MythTV 0.25 the path changed from /xml to /Status/GetStatus
881     for my $path ('Status/GetStatus', 'xml') {
882       my $url = "http://$c->{'host'}:$c->{'port'}/$path";
883       ($content_type, $status) = xml_fetch($url);
884
885       last
886         if defined $status;
887     }
888
889     die "Nothing was received from the MythTV Backend.\n"
890       unless defined $status;
891     ($charset)  = ($content_type =~ /charset="(\S+?)"/);
892   }
893
894   if (defined $c->{'save_file'}) {
895     open(OUT, "> $c->{'save_file'}")
896       || die "Failed to open " . $c->{'save_file'} . " for writing: $!\n";
897     print OUT $status;
898     close OUT;
899   }
900
901   # Parse the XML
902   my $parser = XML::LibXML->new();
903
904   # Some XML data seems to have badness in it, including non-existant
905   # UTF-8 characters.  We'll try and recover.
906   $parser->recover(1);
907   $parser->recover_silently(1)
908     unless $verbose;
909
910   clean_xml(\$status);
911
912   # Try and hide any error messages that XML::LibXML insists on printing out.
913   open my $olderr, ">&STDERR";
914   open(STDERR, "> /dev/null") || die "Can't redirect stderr to /dev/null: $!";
915
916   my $xml = eval { $parser->parse_string( $status ) };
917
918   close (STDERR);
919   open (STDERR, ">&", $olderr);
920
921   if ($@) {
922     die "Failed to parse XML: $@\n";
923   }
924
925   # Pick out the XML version.
926   my $items = $xml->documentElement->find('//Status');
927   $version{'xml'}      = @{ $items }[0]->getAttribute('xmlVer') || 0;
928   $version{'protocol'} = @{ $items }[0]->getAttribute('protoVer');
929
930   warn "Loaded XML from " . ($c->{'xml_file'} || $c->{'host'}) . "\n"
931     if $verbose;
932
933   return ($xml, $charset);
934 }
935
936 # Prep the Perl MythTV API if available.
937 sub load_perl_api {
938   my $myth = undef;
939
940   eval { require MythTV };
941   if ($@) {
942     print $@
943       if $verbose;
944   } else {
945
946     # Surpress warnings from DBI.  I tried unsetting $^W but that is ignored.
947     local($SIG{__WARN__}) = sub { if ($verbose) { print shift } };
948     eval { $myth = new MythTV() };
949
950     if ($@) {
951       if ($verbose) {
952         warn "Failed to load Perl API\n";
953         print $@;
954         return undef;
955       }
956     } elsif ($verbose) {
957       warn "Loaded Perl API\n";
958     }
959   }
960
961   return $myth;
962 }
963
964 # We are sometimes passed dodgy XML from MythTV, make some attempts to clean
965 # it.
966 sub clean_xml {
967   my ($xml) = shift;
968
969   # Deal to invalid Unicode.
970   for my $bad ("&#xdbff;", "&#xdee9;") {
971     if ($$xml =~ s/$bad/?/g) {
972       warn "Found and replaced: $bad\n"
973         if $verbose;
974     }
975   }
976 }
977
978 sub process_xml {
979   my ($block, $xml) = @_;
980
981   # Only work on this block if we have received the appropriate version of
982   # the XML.
983   for my $vers (qw/protocol xml/) {
984     if (defined $block->{"${vers}_version"}) {
985       my $result = undef;
986
987       # All the version checks must pass.
988       for my $check (@{ $block->{"${vers}_version"} }) {
989         my $res = eval ( "$version{$vers} $check" );
990
991         if (! defined $result || $res != 1) {
992           $result = $res;
993         }
994       }
995
996       return
997         unless defined $result && $result ne '';
998
999       warn "We have the correct $vers version for $block->{'name'}\n"
1000         if $verbose;
1001     }
1002   }
1003
1004   my $items = $xml->documentElement->find($block->{'xpath'});
1005
1006   # Don't do any work on this block if there is nothing for it.
1007   return undef
1008     if (scalar(@$items) == 0);
1009
1010   my @lines;
1011   for my $item (@{ $items }) {
1012     my %vars;
1013     for my $key (@{ $block->{'attrs'} }) {
1014       if ($key =~ /(.*?):(.*)/) {
1015         my $subitem = $item->findnodes($2);
1016         $vars{$1} = @{ $subitem }[0]->getAttribute($1)
1017           if defined @{ $subitem }[0];
1018       } else {
1019         $vars{$key} = $key eq 'NODE_TEXT' ? $item->string_value : $item->getAttribute($key);
1020       }
1021     }
1022
1023     my $str = substitute_vars($block, \%vars);
1024     push @lines, $str
1025       if defined $str;
1026   }
1027
1028   return join("\n", @lines);
1029 }
1030
1031 sub process_conflicts {
1032   my ($block) = @_;
1033   $myth ||= load_perl_api();
1034
1035   return "Unable to access MythTV Perl API.  Try with --verbose to find out why."
1036     unless defined $myth;
1037
1038   my @lines;
1039
1040   # This isn't defined in the 0.20 version of the API.  It is in 0.21svn.
1041   my $recstatus_conflict = 7;
1042
1043   my %rows = $myth->backend_rows('QUERY_GETALLPENDING', 2);
1044
1045   foreach my $row (@{$rows{'rows'}}) {
1046     my $show;
1047     {
1048       # MythTV::Program currently has a slightly broken line with a numeric
1049       # comparision.
1050       local($^W) = undef;
1051       $show = new MythTV::Program(@$row);
1052     }
1053
1054     if ($show->{'recstatus'} == $recstatus_conflict) {
1055       my %vars = (
1056         'title'     => $show->{'title'},
1057         'startTime' => strftime("%FT%T", localtime($show->{'starttime'})),
1058         'NODE_TEXT' => $show->{'description'},
1059         'subTitle'  => $show->{'subtitle'},
1060         'channelName' => $show->{'channame'},
1061         'inputId'   => $show->{'inputid'},
1062         'chanNum'   => $show->{'channum'},
1063       );
1064
1065       my $str = substitute_vars($block, \%vars);
1066       push @lines, decode('UTF-8', $str)
1067         if defined $str;
1068     }
1069   }
1070
1071   if (scalar(@lines) == 1) {
1072     push @alerts, "CONFLICT";
1073   } elsif (scalar(@lines) > 1) {
1074     push @alerts, "CONFLICTS";
1075   }
1076
1077   return join("\n", @lines);
1078 }
1079
1080 sub process_auto_expire {
1081   my ($block) = @_;
1082   $myth ||= load_perl_api();
1083
1084   return "Unable to access MythTV Perl API.  Try with --verbose to find out why."
1085     unless defined $myth;
1086
1087   my @lines;
1088
1089   # This isn't defined in the 0.20 version of the API.  It is in 0.21svn.
1090   my %rows = $myth->backend_rows('QUERY_RECORDINGS Delete', 2);
1091
1092   # Returned in date order, desc.  So reverse it to make the oldest
1093   # ones come first.
1094   foreach my $row (reverse @{$rows{'rows'}}) {
1095     my $show;
1096     {
1097       # MythTV::Program currently has a slightly broken line with a numeric
1098       # comparision.
1099       local($^W) = undef;
1100       $show = new MythTV::Program(@$row);
1101     }
1102
1103     # Who cares about LiveTV recordings?
1104     next if $show->{'progflags'} eq 'LiveTV';
1105
1106     my %vars = (
1107       'title'     => $show->{'parentid'} || 'Unknown',
1108       'startTime' => strftime("%FT%T", localtime($show->{'starttime'})),
1109       'NODE_TEXT' => $show->{'description'},
1110       'subTitle'  => $show->{'subtitle'},
1111       'channelName' => $show->{'callsign'},
1112       'inputId'   => $show->{'inputid'},
1113       'chanNum'   => $show->{'chanid'},
1114     );
1115
1116     my $str = substitute_vars($block, \%vars);
1117     push @lines, decode('UTF-8', $str)
1118       if defined $str;
1119
1120     # Don't do more work than is required.
1121     last if --$c->{'auto_expire_count'} <= 0;
1122   }
1123
1124   return join("\n", @lines);
1125 }
1126
1127 # If either date or time are set to 0, then we don't display that bit of
1128 # info.  For example:
1129 #   process_iso_date($date, { date => 0 })
1130 # Will only show the time.
1131 sub process_iso_date {
1132   my $date = shift;
1133   my $options = shift;
1134   $options->{'date'} //= 1;
1135   $options->{'time'} //= 1;
1136
1137   # 2012-10-17T23:50:08Z
1138   my $d = new Date::Manip::Date;
1139   $d->parse($date);
1140
1141   # Work out our local timezone. The Date::Manip::Date
1142   # docs say that convert will default to the local timezone,
1143   # this appears to be lies.
1144   my $dmb = $d->base();
1145   my ($tz) = $dmb->_now('tz',1);
1146   $d->convert($tz);
1147
1148   # Sample of what MythTV uses:
1149   # Thu 18 Oct 2012, 10:20
1150   my $format = '';
1151   $format .= '%Y-%m-%d' if $options->{'date'};
1152   $format .= ' '        if $options->{'date'} && $options->{'time'};
1153   $format .= '%X'       if $options->{'time'};
1154
1155   return $d->printf($format);
1156 }
1157
1158 sub substitute_vars {
1159   my $block = shift;
1160   my $vars  = shift;
1161
1162   my %commify = map { $_ => 1 } @{ $block->{'commify'} }
1163     if defined $block->{'commify'};
1164
1165   my $template = $block->{'template'};
1166   my $skip = undef;
1167   my ($key, $value);
1168
1169   # Convert disk spaces into more suitable units.
1170   if (defined $block->{'human_readable_sizes'}) {
1171     for my $key (@{ $block->{'human_readable_sizes'}}) {
1172       for my $unit (@size_thresholds) {
1173         if (defined $vars->{$key} && defined $unit->{'threshold'}) {
1174           if ($vars->{$key} > $unit->{'threshold'}) {
1175             $vars->{"si_$key"} = sprintf("%.1f", $vars->{$key} / $unit->{'conversion'});
1176             $vars->{"si_$key"} =~ s/\.0//;
1177             $vars->{"si_${key}_unit"} = $unit->{'unit'};
1178
1179             if ($unit->{'make_integer'} &&
1180                 (! defined $unit->{'make_integer_threshold'}
1181                  || $vars->{"si_$key"} > $unit->{'make_integer_threshold'})) {
1182                 $vars->{"si_$key"} =~ s/\.[0-9]+//;
1183             }
1184
1185             last;
1186           }
1187         } else {
1188           $vars->{"si_${key}"}      = $vars->{$key};
1189           $vars->{"si_${key}_unit"} = $unit->{'unit'};
1190         }
1191       }
1192     }
1193   }
1194
1195   while (($key, $value) = (each %{ $vars })) {
1196     if (! defined $value) {
1197       if ($block->{'optional'}) {
1198         warn "Unable to find any value for $key while at $block->{'name'}, marked as optional, skipping block.\n"
1199           if $verbose;
1200         return undef;
1201       } else {
1202         warn "Unable to find any value for $key while looking at $block->{'name'}\n"
1203             if $verbose || ! grep /^$key$/, @{$block->{'optional_attrs'}};
1204         next;
1205       }
1206     }
1207
1208     $value = wrap('  ', '  ', $value)
1209       if $key eq 'NODE_TEXT';
1210
1211     $value =~ s/\s+$//;
1212     $value = 'Unknown'
1213       if $value eq '';
1214
1215     $skip = 1
1216       if defined $block->{'filter'}{$key} &&
1217       &{ $block->{'filter'}{$key} }($value, $vars);
1218
1219     if (defined $block->{'rewrite'}{"/$key/"}) {
1220       my ($search, $replace);
1221       while (($search, $replace) = each %{ $block->{'rewrite'}{"/$key/"} } ) {
1222         $value =~ s/$search/$replace/g;
1223       }
1224     }
1225
1226     if (defined $block->{'rewrite'}{"&$key"}) {
1227       $value = &{ $block->{'rewrite'}{"&$key"} }($value, $vars);
1228     }
1229
1230     $value = commify($value)
1231       if defined $commify{$key};
1232
1233     $template =~ s/__${key}__/$value/g;
1234   }
1235
1236   my ($name, $sub);
1237   while (($name, $sub) =  each %{ $block->{'subs'} }) {
1238     $value = &$sub($vars);
1239
1240     $template =~ s/__${name}__/$value/g
1241       if defined $value;
1242   }
1243
1244   return defined $skip ? undef : $template;
1245 }
1246
1247 # Work out the disk space percentage, possibly setting a flag that we should
1248 # raise an alert.
1249 sub calc_disk_space_percentage {
1250   my ($used, $total) = @_;
1251
1252   if (! (defined $used && defined $total) ){
1253     warn "Something is wrong calculating the disk space percentage.\n";
1254     return 'unknown';
1255   }
1256
1257   # Guard against zero disk space.
1258   $total = normalise_disk_space($total);
1259   if ($total == 0) {
1260     warn "Total disk space is 0 MB, I can't use that to calculate a percentage!\n";
1261     return 'unknown';
1262   }
1263
1264   my $percent = int((normalise_disk_space($used) / $total * 100) + 0.5);
1265
1266   if ($percent >= $c->{'disk_space_warn'}) {
1267     $exit_value ||= 1;
1268     push @alerts, "DISK SPACE";
1269     return "$warn$percent\%$warn_to_normal";
1270   } else {
1271     return "$safe$percent\%$safe_to_normal";
1272   }
1273 }
1274
1275 # Make sure that the disk space is in a common unit.
1276 # Currently that is MB.
1277 sub normalise_disk_space {
1278   if ($_[0] =~ /^[.0-9]+$/) {
1279     return $_[0];
1280   } elsif ($_[0] =~ /^([.0-9]+) (\w+)$/) {
1281     my $space = $1;
1282     my $unit = $2;
1283
1284     if ($unit eq 'B') {
1285       return $space / (1024 * 1024);
1286     } elsif ($unit eq 'KB') {
1287       return $space / 1024;
1288     } elsif ($unit eq 'MB') {
1289       return $space;
1290     } elsif ($unit eq 'GB') {
1291       return $space * 1024;
1292     } elsif ($unit eq 'TB') {
1293       return $space * 1024 * 1024;
1294     }
1295
1296     warn "Unknown unit for disk space: $unit.  Please let the author of mythtv-status know.\n";
1297     return $space;
1298   }
1299
1300   warn "Unrecognised format for disk space: $_[0].  Please let the author of mythtv-status know.\n";
1301   return $_[0];
1302 }
1303
1304 # Perform the fetch from the MythTV Backend in a child process.
1305 sub xml_fetch {
1306   my ($url) = @_;
1307
1308   $| = 1;
1309   my $pid = pipe_from_fork('CHILD');
1310   if ($pid) {
1311     # parent
1312     my $content_type;
1313     my $status;
1314
1315     eval {
1316       local $SIG{ALRM} = sub { die "alarm\n" };
1317       alarm(10);
1318       $content_type = <CHILD>;
1319       while (<CHILD>) {
1320         $status .= $_;
1321       }
1322       alarm(0);
1323     };
1324
1325     # The child didn't get back to us in time, kill them off
1326     # and forget what they sent us.
1327     if ($@) {
1328       $status = undef;
1329       my $result;
1330       warn "Our child has stopped talking to us, kill it off.\n";
1331       do {
1332         kill 9, $pid;
1333         $result = waitpid($pid, WNOHANG);
1334       } while $result > 0;
1335
1336       die "Unknown error during retrieval of status from the MythTV backend.\n";
1337     }
1338     $| = 0;
1339
1340     if (defined $content_type && $content_type =~ /utf(-)?8/i) {
1341       $status = decode('UTF-8', $status);
1342     }
1343     return ($content_type, $status);
1344   } else {
1345     # child
1346     $0 = "mythtv-status - child";
1347     my $ua = LWP::UserAgent->new;
1348     $ua->timeout(30);
1349     $ua->env_proxy;
1350
1351     my $response = ua_request_with_timeout($ua, $url);
1352     die "Sorry, failed to fetch $url: Connection to MythTV timed out.\n"
1353       unless defined $response;
1354
1355     # If we get a page doesn't exist, then just ignore it, we need to try
1356     # fetching the status page from a few different locations.
1357     if ($response->code == 404) {
1358       exit 1;
1359     }
1360
1361     die "Sorry, failed to fetch $url: " . $response->status_line . "\n"
1362       unless $response->is_success;
1363
1364     my $content = $response->decoded_content;
1365     if ($response->header('Content-Type') =~ /utf(-)?8/i) {
1366       $content = encode('UTF-8', $content);
1367     }
1368     print $response->header('Content-Type') . "\n";
1369     print $content . "\n";
1370
1371     exit 0;
1372   }
1373 }
1374
1375 # simulate open(FOO, "-|")
1376 sub pipe_from_fork ($) {
1377   my $parent = shift;
1378
1379   $SIG{CHLD} = 'IGNORE';
1380   pipe $parent, my $child or die;
1381   my $pid = fork();
1382   die "fork() failed: $!" unless defined $pid;
1383
1384   if ($pid) {
1385     close $child;
1386   } else {
1387     close $parent;
1388     open(STDOUT, ">&=" . fileno($child)) or die;
1389   }
1390   $pid;
1391 }
1392
1393 # Takes a LWP::UserAgent and an HTTP::Request.  Returns the result of the
1394 # HTTP::Request.  Handles hung servers as well as timeouts.  Based on:
1395 # http://stackoverflow.com/questions/73308/true-timeout-on-lwpuseragent-\
1396 #   request-method
1397 sub ua_request_with_timeout {
1398   my ($ua, $url) = @_;
1399   my ($req_timeout);
1400
1401   # Pick up LWP's request timeout setting.
1402   $req_timeout = $ua->timeout();
1403
1404   # If Sys::SigAction is available, we can use it to get whatever timeout
1405   # is set for LWP and use that to enforce a maximum timeout per request
1406   # in case of server deadlock.
1407   if (eval("{ local \$SIG{__DIE__}; require Sys::SigAction; }")) {
1408     our $resp = undef;
1409
1410     if (Sys::SigAction::timeout_call( $req_timeout,
1411         sub {$resp = $ua->get($url);})) {
1412       return undef;
1413     } else {
1414       return $resp;
1415     }
1416   }
1417
1418   # Otherwise, we roll a hard six with a SIGALRM for the timeout.
1419   else {
1420     my $resp = undef;
1421     our $req_has_timedout = 0;
1422     my ($newaction, $oldaction);
1423
1424     # Create a new SIGALRM handler to set the timed out flag if the
1425     # backend request is not answered before the interval has elapsed.
1426     # Note that die ends the request within the eval (below).  It is
1427     # caught by eval, allowing the code herein to continue and check
1428     # for a timeout.
1429     $newaction = POSIX::SigAction->new(
1430         sub { $req_has_timedout = 1; die "Backend request timeout"; },
1431         POSIX::SigSet->new(SIGALRM) );
1432
1433     # Replace the current SIGALRM handler with our new one, saving the
1434     # old one for restoration, later on.  If this fails, we just issue
1435     # the request directly and hope for the best.
1436     $oldaction = POSIX::SigAction->new();
1437
1438     if (!sigaction(SIGALRM, $newaction, $oldaction)) {
1439       warn "Error setting SIGALRM handler: ".$!."\n" if $verbose;
1440       return $ua->get($url);
1441     }
1442
1443     # Within an eval, set the timer and request a response from the
1444     # backend.  If the timer pops, the SIGALRM routine will set a flag
1445     # and kill the request.  The eval will catch it and we'll get on
1446     # with our lives.
1447     eval {
1448       alarm($req_timeout);
1449       $resp = $ua->get($url);
1450       alarm(0);
1451     };
1452
1453     # Cancel the SIGALRM, if the eval failed for any reason.  Reset the
1454     # SIGALRM handler back to its original state.
1455     alarm(0);
1456
1457     if (!sigaction(SIGALRM, $oldaction )) {
1458       warn "Error resetting SIGALRM handler: ".$!."\n" if $verbose;
1459     };
1460
1461     # If the request has timed out, return a HTTP 408 (timeout) response
1462     # or maybe just undef.  Otherwise, return the backend's response.
1463     if ($req_has_timedout) {
1464       warn "Backend request timed out (".$req_timeout." secs)\n" if $verbose;
1465 #      return HTTP::Response->new(408);
1466       return undef;
1467     } else {
1468       return $resp;
1469     }
1470   }
1471 }
1472
1473 # Beautify numbers by sticking commas in.
1474 sub commify {
1475   my ($num) = shift;
1476
1477   $num = reverse $num;
1478   $num =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g;
1479   return reverse $num;
1480 }
1481
1482 sub print_version {
1483   print "mythtv-status, version $VERSION.\n";
1484   print "Written by Andrew Ruthven <andrew\@etc.gen.nz>\n";
1485   print "\n";
1486   exit;
1487 }
1488
1489 =head1 NAME
1490
1491 mythtv-status - Display the status of a MythTV backend
1492
1493 =head1 SYNOPSIS
1494
1495  mythtv-status [options]
1496
1497 =head1 DESCRIPTION
1498
1499 This script queries a MythTV backend and reports on the status of it,
1500 any upcoming recordings and any which are happening right now.
1501
1502 The intention is to warn you if there is a program being recorded or
1503 about to be recorded.
1504
1505 =head1 OPTIONS
1506
1507 =over
1508
1509 =item B<-c, --colour>
1510
1511 Use colour when showing the status of the encoder(s).
1512
1513 =item B<--date>
1514
1515 Set the date to run as, used for debugging purposes.
1516
1517 =item B<-d, --description>
1518
1519 Display the description for the scheduled recordings.
1520
1521 =item B<--disk-space-warn>
1522
1523 The threshold (in percent) of used disk space that we should show
1524 the disk space in red (if using colour) or send an email if we're
1525 in email mode with email only on warnings.
1526
1527 =item B<--encoder-details>
1528
1529 Display the input ID and channel name against the recording details.
1530
1531 =item B<--encoder-skip-idle>
1532
1533 Suppress displaying idle encoders in the Encoders block.
1534
1535 =item B<--encoder-warn-non-idle>
1536
1537 Display warnings if an encoder is not idle. This is the default, it allows
1538 you to know if an encoder or the MythTV system is busy. To disable, use
1539 B<--no-encoder-warn-non-idle>.
1540
1541 =item B<-e, --episode>
1542
1543 Display the episode (subtitle) for the scheduled recordings.
1544
1545 =item B<< --email <address>[ --email <address> ...] >>
1546
1547 Send the output to the listed email addresses.  By default the encoder status,
1548 currently recording shows and time till next recording is suppressed from
1549 the email.
1550
1551 To turn the additional blocks on you can use B<--encoders>, B<--recording-now>
1552 and/or B<--next-recording>.
1553
1554 By default highlight is turned on, to disable it use B<--nohighlight>.
1555
1556 =item B<--email-only-on-alert>
1557
1558 Only send an email out (if --email is present) if there is an alert
1559 (i.e., schedule conflict or low disk space).
1560
1561 =item B<-?, --help>
1562
1563 Display help.
1564
1565 =item B<< --file <file> >>
1566
1567 Load XML from the file specified instead of querying a MythTV backend.
1568 Handy for debugging things.
1569
1570 =item B<< --save-file <file> >>
1571
1572 Save the XML we received from the MythTV backend.
1573 Handy for debugging things.
1574
1575 =item B<< --guide-days-warn <days> >>
1576
1577 Warn if the number of days of guide data present is equal to or below
1578 this level.  Default is 2 days.
1579
1580 =item B<-h HOST, --host=HOST>
1581
1582 The host to check, defaults to localhost.
1583
1584 =item B<--highlight>
1585
1586 Surround any items that are considered a warning with asterisks. This helps
1587 to highlight an issue if colour mode is disabled.
1588
1589 =item B<--nostatus>, B<--noencoders>, B<--norecording-now>, B<--noscheduled-recordings>, B<--noschedule-conflicts>, B<--nonext-recording>, B<--nototal-disk-space>, B<--nodisk-space>, B<--noguide-data>, B<--noauto-expire>
1590
1591 Suppress displaying blocks of the output if they would normally be displayed.
1592
1593 =item B<-p PORT, --port=PORT>
1594
1595 The port to use when connecting to MythTV, defaults to 6544.
1596
1597 =item B<--oneliner-bullets>
1598
1599 Insert asterisks (*) before each of the oneliners to stop some
1600 email clients from thinking the oneliner block is a paragraph and
1601 trying to word wrap them.
1602
1603 =item B<--auto-expire>
1604
1605 Display the shows due to auto expire (output is normally suppressed).
1606
1607 =item B<--auto-expire-count>
1608
1609 How many of the auto expire shows to display, defaults to 10.
1610
1611 =item B<--recording-in-warn>
1612
1613 If the "Next Recording In" time is less than this amount, display it
1614 in red.  This in seconds, and defaults to 3600 (1 hour).
1615
1616 =item B<--verbose>
1617
1618 Have slightly more verbose output.  This includes any warnings that might
1619 be generated while parsing the XML.
1620
1621 =item B<-v, --version>
1622
1623 Show the version of mythtv-status and then exit.
1624
1625 =back
1626
1627 =head1 OUTPUT
1628
1629 The output of this script is broken up into several chunks they are:
1630
1631 =over
1632
1633 =item Status
1634
1635 Some general info about the backend, currently just the timestamp of when
1636 this program was run.
1637
1638 =item Guide Data
1639
1640 The number of days of guide data is present.  By default it is only shown
1641 if the number of days is below the warning level.  To show it regardless
1642 of the warning level use --guide-data.
1643
1644 =item Encoders
1645
1646 Each encoder that the backend knows about are listed, with the hostname
1647 they are on, the encoder ID (in brackets) and the current status.
1648
1649 =item Recording Now
1650
1651 Any programs which are being recorded right now.
1652
1653 =item Scheduled Recordings
1654
1655 Up to 10 programs which are scheduled to be recorded today and tomorrow.
1656
1657 =item Schedule Conflicts
1658
1659 Any upcoming schedule conflicts (not just limited to today or tomorrow).
1660
1661 =item Shows due to Auto Expire
1662
1663 The shows which will be deleted and the order they'll be deleted if the
1664 auto expirer kicks in.
1665
1666 =item Total Disk Space
1667
1668 The amount of disk space in total, and used by MythTV.
1669
1670 =item Next Recording In
1671
1672 If there are no recordings currently happening, then the amount of time until
1673 the next recording is displayed.
1674
1675 =item Disk Space
1676
1677 Details about each storage group that MythTV knows about.  By default this
1678 only shows storage groups that are above the warning level.  Use
1679 B<--disk-space> to turn on display of all storage groups.
1680
1681 =back
1682
1683 =head1 RETURN CODES
1684
1685 mythtv-status provides some return codes.
1686
1687 =over
1688
1689 =item 0Z<>
1690
1691 Standard return code
1692
1693 =item 1Z<>
1694
1695 A warning is generated
1696
1697 =back
1698
1699 =head1 AUTHOR
1700
1701 Andrew Ruthven, andrew@etc.gen.nz
1702
1703 =head1 LICENSE
1704
1705 Copyright (c) 2007-2018 Andrew Ruthven <andrew@etc.gen.nz>
1706 This code is hereby licensed for public consumption under the GNU GPL v3.
1707
1708 =cut
1709