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