Allow warn status only for encoders for errors - enable with --no-encoder-warn-non...
[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'},
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           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
630         # If the next recording is more than 1 day in the future,
631         # print out the days and hours.
632         my $str;
633         if ($seconds > 24 * 3600) {
634           $str = Delta_Format($delta, 0, '%dh Days, %hv Hours');
635         } else {
636           $str = Delta_Format($delta, 0, '%hh Hours, %mv Minutes');
637         }
638
639         $str =~ s/\b1 (Day|Hour|Minute)s/1 $1/g;
640         $str =~ s/\b0 (Days|Hours)(, )?//;
641         $str =~ s/, 0 Minutes$//;
642
643         if ($seconds <= $c->{'recording_in_warn'}) {
644           $warn_present ||= 1;
645           $str = "$warn$str$warn_to_normal";
646         }
647
648         return $str;
649       },
650     },
651     'filter' =>  {
652       'next_time' => sub { return $_[0] eq 'now' }
653     },
654     'sub' => sub {
655       return substitute_vars($_[0], { 'next_time' => $next_time });
656     },
657   },
658
659   # Check how much Guide data we have
660   {
661     'name'     => 'Guide Data',
662     'format'   => 'one line',
663     'type'     => 'xpath',
664     'xpath'    => '//Status/MachineInfo/Guide[@guideDays]',
665     'attrs'    => [qw/guideDays status guideThru/],
666     'template' => 'There is __guideDays__ days worth of data, through to __guideThru__',
667     'filter' => {
668       'guideDays' => sub {
669         if ($_[0] > $c->{'guide_days_warn'}) {
670           return
671             (defined $c->{'display'}{'Guide Data'} && ! $c->{'display'}{'Guide Data'}) || 1;
672         } else {
673           $warn_present ||= 1;
674           push @alerts, "GUIDE DATA";
675           return 0;
676         }
677       },
678     },
679     'rewrite'  => {
680       '&guideDays' => sub {
681         if ($_[0] <= $c->{'guide_days_warn'}) {
682           $warn_present ||= 1;
683           return "$warn$_[0]$warn_to_normal";
684         } else {
685           return "$safe$_[0]$safe_to_normal";
686         }
687       },
688       '/guideThru/' => { 'T\d+:\d+:\d+' => ' ' },
689       '&guideThru' => sub {
690         if ($_[1]->{'guideDays'} <= $c->{'guide_days_warn'}) {
691           $warn_present ||= 1;
692           return "$warn$_[0]$warn_to_normal";
693         } else {
694           return "$safe$_[0]$safe_to_normal";
695         }
696       },
697     },
698   },
699
700   {
701     'name'     => 'Guide Data',
702     'format'   => 'one line',
703     'type'     => 'xpath',
704     'xpath'    => '//Status/MachineInfo/Guide[@status=""]',
705     'template' => "${warn}No guide data!${warn_to_normal}",
706   },
707 );
708
709 ###
710 ### Set some useful variables
711 ###
712 our $today    = substr(ParseDate('today'), 0, 8);
713 our $tomorrow = substr(ParseDate('tomorrow'), 0, 8);
714
715 if ($c->{'date'}) {
716   $today    = substr(ParseDate($c->{'date'}), 0, 8);
717   $tomorrow = substr(DateCalc($c->{'date'}, ParseDateDelta('1 day')), 0, 8);
718 }
719
720 if ($verbose) {
721   print "Today:               $today\n";
722   print "Tomorrow:            $tomorrow\n";
723   print "Config::Auto module: " . (defined $INC{'Config/Auto.pm'} ? 'Loaded' : 'Not Loaded') . "\n";
724   print "Config file loaded:  " . ($c->{'config_file_loaded'} ? 'Yes' : 'No') . "\n";
725 }
726
727 # If we're in return code only mode then we disable all blocks
728 # except for those explicitly enabled.
729 if ($return_code_only) {
730   warn "In return-code-only mode, disabling all blocks by default.\n"
731     if $verbose;
732
733   for my $block (@blocks) {
734     $c->{'display'}{ $block->{'name'} } ||= 0;
735   }
736 }
737
738 # A couple of global variables
739 my ($xml, $charset, $myth);
740 my %version;
741
742 my $exit_value = 0;
743 my $title =  "MythTV status for $c->{'host'}";
744 my $output = "$title\n";
745 $output .= '=' x length($title) . "\n";
746
747 for my $block (@blocks) {
748   $block->{'format'} ||= 'multi line';
749   $block->{'optional'} ||= 0;
750
751   warn "Considering: $block->{'name'}\n"
752     if $verbose;
753
754   my $hide = undef;
755   if (defined $c->{'display'}{ $block->{'name'} }
756     && $c->{'display'}{ $block->{'name'} } == 0) {
757     if (defined $block->{'hide'} && lc($block->{'hide'}) eq 'after') {
758       $hide = 1;
759     } else {
760       next;
761     }
762   }
763
764   warn "  Going to process: $block->{'name'}\n"
765     if $verbose;
766
767   # We might need to set some defaults.
768   if (defined $block->{'defaults'}) {
769     for my $field (keys %{ $defaults{ $block->{'defaults'} } }) {
770       $block->{$field} ||= $defaults{ $block->{'defaults'} }{$field};
771     }
772   }
773
774   my $result = undef;
775   $warn_present = 0;
776   if ($block->{'type'} eq 'xpath') {
777     ($xml, $charset) = load_xml()
778       unless defined $xml;
779
780     $result = process_xml($block, $xml);
781
782   } elsif ($block->{'type'} eq 'sub') {
783
784     $result = &{ $block->{'sub'} }($block)
785       if defined $block->{'sub'};
786   }
787
788   if (defined $result && $result ne '' && ! defined $hide) {
789     $exit_value ||= $warn_present;
790
791     if ($block->{'format'} eq 'one line') {
792       push @oneliners, [ $block->{'name'}, $result ];
793     } else {
794       $output .= "$block->{'name'}:\n";
795       $output .= $result . "\n\n";
796     }
797   }
798 }
799
800 # Deal with the one liners.
801 if (scalar(@oneliners) > 0) {
802
803   # Find the longest header
804   my $length = 0;
805   for $line (@oneliners) {
806     if (length($line->[0]) > $length) {
807       $length = length($line->[0]);
808     }
809   }
810
811   # Put the one liners together, with leading dots to the colon.
812   # We allow a hack for MS Outlook which normally recognises the
813   # oneliners block as a paragrap and wraps it.  If it sees "bullets"
814   # it believes it is a bulleted list and leaves it alone.
815   my $oneliners = "";
816   for $line (@oneliners) {
817     $oneliners .= ($c->{'oneliner_bullets'} ? '* ' : '' )
818       . "$line->[0]"
819       . ('.' x ($length - length($line->[0]))) . ": $line->[1]\n";
820   }
821
822   # What a hacky way of putting the one liners where I want them...
823   $output =~ s/^One Liners:\nPlace holder\n/$oneliners/m;
824 }
825
826 # Either print the status out, or email it.
827 if ($return_code_only) {
828   exit $exit_value;
829 } elsif (scalar(@{ $c->{'email'} }) == 0) {
830   if ($charset =~ /utf(-)?8/i) {
831     $output = encode('UTF-8', $output);
832   }
833   print "\n$output";
834 } else {
835   if ((! $c->{'email_only_on_alert'}) ||
836     ($c->{'email_only_on_alert'} && scalar(@alerts) > 0)) {
837     my $suffix = undef;
838     if (@alerts == 1) {
839       $suffix = $alerts[0];
840     } elsif (@alerts > 1) {
841       $suffix = "MULTIPLE WARNINGS";
842     }
843
844     my $mail = MIME::Entity->build(
845       To      => $c->{'email'},
846       Subject => encode('UTF-8', $title . (defined $suffix ? " - $suffix" : '')),
847       Charset => $charset,
848       Encoding=> "quoted-printable",
849       Data    => encode('UTF-8', $output),
850       );
851
852     $mail->send('sendmail');
853   }
854 }
855
856 exit $exit_value;
857
858 # Fetch the XML status from the backend.
859 sub load_xml {
860   my $status = '';
861   my $charset = '';
862
863   if (defined $c->{'xml_file'}) {
864     open (IN, "< $c->{'xml_file'}")
865       || die "Failed to open $c->{'xml_file'} for reading: $!\n";
866
867     $status = join("", <IN>);
868     $charset = 'UTF-8';
869
870     close IN;
871   } else {
872     my $content_type;
873     # In MythTV 0.25 the path changed from /xml to /Status/GetStatus
874     for my $path ('Status/GetStatus', 'xml') {
875       my $url = "http://$c->{'host'}:$c->{'port'}/$path";
876       ($content_type, $status) = xml_fetch($url);
877
878       last
879         if defined $status;
880     }
881
882     die "Nothing was received from the MythTV Backend.\n"
883       unless defined $status;
884     ($charset)  = ($content_type =~ /charset="(\S+?)"/);
885   }
886
887   if (defined $c->{'save_file'}) {
888     open(OUT, "> $c->{'save_file'}")
889       || die "Failed to open " . $c->{'save_file'} . " for writing: $!\n";
890     print OUT $status;
891     close OUT;
892   }
893
894   # Parse the XML
895   my $parser = XML::LibXML->new();
896
897   # Some XML data seems to have badness in it, including non-existant
898   # UTF-8 characters.  We'll try and recover.
899   $parser->recover(1);
900   $parser->recover_silently(1)
901     unless $verbose;
902
903   clean_xml(\$status);
904
905   # Try and hide any error messages that XML::LibXML insists on printing out.
906   open my $olderr, ">&STDERR";
907   open(STDERR, "> /dev/null") || die "Can't redirect stderr to /dev/null: $!";
908
909   my $xml = eval { $parser->parse_string( $status ) };
910
911   close (STDERR);
912   open (STDERR, ">&", $olderr);
913
914   if ($@) {
915     die "Failed to parse XML: $@\n";
916   }
917
918   # Pick out the XML version.
919   my $items = $xml->documentElement->find('//Status');
920   $version{'xml'}      = @{ $items }[0]->getAttribute('xmlVer') || 0;
921   $version{'protocol'} = @{ $items }[0]->getAttribute('protoVer');
922
923   warn "Loaded XML from " . ($c->{'xml_file'} || $c->{'host'}) . "\n"
924     if $verbose;
925
926   return ($xml, $charset);
927 }
928
929 # Prep the Perl MythTV API if available.
930 sub load_perl_api {
931   my $myth = undef;
932
933   eval { require MythTV };
934   if ($@) {
935     print $@
936       if $verbose;
937   } else {
938
939     # Surpress warnings from DBI.  I tried unsetting $^W but that is ignored.
940     local($SIG{__WARN__}) = sub { if ($verbose) { print shift } };
941     eval { $myth = new MythTV() };
942
943     if ($@) {
944       if ($verbose) {
945         warn "Failed to load Perl API\n";
946         print $@;
947         return undef;
948       }
949     } elsif ($verbose) {
950       warn "Loaded Perl API\n";
951     }
952   }
953
954   return $myth;
955 }
956
957 # We are sometimes passed dodgy XML from MythTV, make some attempts to clean
958 # it.
959 sub clean_xml {
960   my ($xml) = shift;
961
962   # Deal to invalid Unicode.
963   for my $bad ("&#xdbff;", "&#xdee9;") {
964     if ($$xml =~ s/$bad/?/g) {
965       warn "Found and replaced: $bad\n"
966         if $verbose;
967     }
968   }
969 }
970
971 sub process_xml {
972   my ($block, $xml) = @_;
973
974   # Only work on this block if we have received the appropriate version of
975   # the XML.
976   for my $vers (qw/protocol xml/) {
977     if (defined $block->{"${vers}_version"}) {
978       my $result = undef;
979
980       # All the version checks must pass.
981       for my $check (@{ $block->{"${vers}_version"} }) {
982         my $res = eval ( "$version{$vers} $check" );
983
984         if (! defined $result || $res != 1) {
985           $result = $res;
986         }
987       }
988
989       return
990         unless defined $result && $result ne '';
991
992       warn "We have the correct $vers version for $block->{'name'}\n"
993         if $verbose;
994     }
995   }
996
997   my $items = $xml->documentElement->find($block->{'xpath'});
998
999   # Don't do any work on this block if there is nothing for it.
1000   return undef
1001     if (scalar(@$items) == 0);
1002
1003   my @lines;
1004   for my $item (@{ $items }) {
1005     my %vars;
1006     for my $key (@{ $block->{'attrs'} }) {
1007       if ($key =~ /(.*?):(.*)/) {
1008         my $subitem = $item->findnodes($2);
1009         $vars{$1} = @{ $subitem }[0]->getAttribute($1)
1010           if defined @{ $subitem }[0];
1011       } else {
1012         $vars{$key} = $key eq 'NODE_TEXT' ? $item->string_value : $item->getAttribute($key);
1013       }
1014     }
1015
1016     my $str = substitute_vars($block, \%vars);
1017     push @lines, $str
1018       if defined $str;
1019   }
1020
1021   return join("\n", @lines);
1022 }
1023
1024 sub process_conflicts {
1025   my ($block) = @_;
1026   $myth ||= load_perl_api();
1027
1028   return "Unable to access MythTV Perl API.  Try with --verbose to find out why."
1029     unless defined $myth;
1030
1031   my @lines;
1032
1033   # This isn't defined in the 0.20 version of the API.  It is in 0.21svn.
1034   my $recstatus_conflict = 7;
1035
1036   my %rows = $myth->backend_rows('QUERY_GETALLPENDING', 2);
1037
1038   foreach my $row (@{$rows{'rows'}}) {
1039     my $show;
1040     {
1041       # MythTV::Program currently has a slightly broken line with a numeric
1042       # comparision.
1043       local($^W) = undef;
1044       $show = new MythTV::Program(@$row);
1045     }
1046
1047     if ($show->{'recstatus'} == $recstatus_conflict) {
1048       my %vars = (
1049         'title'     => $show->{'title'},
1050         'startTime' => strftime("%FT%T", localtime($show->{'starttime'})),
1051         'NODE_TEXT' => $show->{'description'},
1052         'subTitle'  => $show->{'subtitle'},
1053         'channelName' => $show->{'channame'},
1054         'inputId'   => $show->{'inputid'},
1055         'chanNum'   => $show->{'channum'},
1056       );
1057
1058       my $str = substitute_vars($block, \%vars);
1059       push @lines, decode('UTF-8', $str)
1060         if defined $str;
1061     }
1062   }
1063
1064   if (scalar(@lines) == 1) {
1065     push @alerts, "CONFLICT";
1066   } elsif (scalar(@lines) > 1) {
1067     push @alerts, "CONFLICTS";
1068   }
1069
1070   return join("\n", @lines);
1071 }
1072
1073 sub process_auto_expire {
1074   my ($block) = @_;
1075   $myth ||= load_perl_api();
1076
1077   return "Unable to access MythTV Perl API.  Try with --verbose to find out why."
1078     unless defined $myth;
1079
1080   my @lines;
1081
1082   # This isn't defined in the 0.20 version of the API.  It is in 0.21svn.
1083   my %rows = $myth->backend_rows('QUERY_RECORDINGS Delete', 2);
1084
1085   # Returned in date order, desc.  So reverse it to make the oldest
1086   # ones come first.
1087   foreach my $row (reverse @{$rows{'rows'}}) {
1088     my $show;
1089     {
1090       # MythTV::Program currently has a slightly broken line with a numeric
1091       # comparision.
1092       local($^W) = undef;
1093       $show = new MythTV::Program(@$row);
1094     }
1095
1096     # Who cares about LiveTV recordings?
1097     next if $show->{'progflags'} eq 'LiveTV';
1098
1099     my %vars = (
1100       'title'     => $show->{'parentid'} || 'Unknown',
1101       'startTime' => strftime("%FT%T", localtime($show->{'starttime'})),
1102       'NODE_TEXT' => $show->{'description'},
1103       'subTitle'  => $show->{'subtitle'},
1104       'channelName' => $show->{'callsign'},
1105       'inputId'   => $show->{'inputid'},
1106       'chanNum'   => $show->{'chanid'},
1107     );
1108
1109     my $str = substitute_vars($block, \%vars);
1110     push @lines, decode('UTF-8', $str)
1111       if defined $str;
1112
1113     # Don't do more work than is required.
1114     last if --$c->{'auto_expire_count'} <= 0;
1115   }
1116
1117   return join("\n", @lines);
1118 }
1119
1120 # If either date or time are set to 0, then we don't display that bit of
1121 # info.  For example:
1122 #   process_iso_date($date, { date => 0 })
1123 # Will only show the time.
1124 sub process_iso_date {
1125   my $date = shift;
1126   my $options = shift;
1127   $options->{'date'} //= 1;
1128   $options->{'time'} //= 1;
1129
1130   # 2012-10-17T23:50:08Z
1131   my $d = new Date::Manip::Date;
1132   $d->parse($date);
1133
1134   # Work out our local timezone. The Date::Manip::Date
1135   # docs say that convert will default to the local timezone,
1136   # this appears to be lies.
1137   my $dmb = $d->base();
1138   my ($tz) = $dmb->_now('tz',1);
1139   $d->convert($tz);
1140
1141   # Sample of what MythTV uses:
1142   # Thu 18 Oct 2012, 10:20
1143   my $format = '';
1144   $format .= '%Y-%m-%d' if $options->{'date'};
1145   $format .= ' '        if $options->{'date'} && $options->{'time'};
1146   $format .= '%X'       if $options->{'time'};
1147
1148   return $d->printf($format);
1149 }
1150
1151 sub substitute_vars {
1152   my $block = shift;
1153   my $vars  = shift;
1154
1155   my %commify = map { $_ => 1 } @{ $block->{'commify'} }
1156     if defined $block->{'commify'};
1157
1158   my $template = $block->{'template'};
1159   my $skip = undef;
1160   my ($key, $value);
1161
1162   # Convert disk spaces into more suitable units.
1163   if (defined $block->{'human_readable_sizes'}) {
1164     for my $key (@{ $block->{'human_readable_sizes'}}) {
1165       for my $unit (@size_thresholds) {
1166         if (defined $vars->{$key} && defined $unit->{'threshold'}) {
1167           if ($vars->{$key} > $unit->{'threshold'}) {
1168             $vars->{"si_$key"} = sprintf("%.1f", $vars->{$key} / $unit->{'conversion'});
1169             $vars->{"si_$key"} =~ s/\.0//;
1170             $vars->{"si_${key}_unit"} = $unit->{'unit'};
1171
1172             if ($unit->{'make_integer'} &&
1173                 (! defined $unit->{'make_integer_threshold'}
1174                  || $vars->{"si_$key"} > $unit->{'make_integer_threshold'})) {
1175                 $vars->{"si_$key"} =~ s/\.[0-9]+//;
1176             }
1177
1178             last;
1179           }
1180         } else {
1181           $vars->{"si_${key}"}      = $vars->{$key};
1182           $vars->{"si_${key}_unit"} = $unit->{'unit'};
1183         }
1184       }
1185     }
1186   }
1187
1188   while (($key, $value) = (each %{ $vars })) {
1189     if (! defined $value) {
1190       if ($block->{'optional'}) {
1191         warn "Unable to find any value for $key while at $block->{'name'}, marked as optional, skipping block.\n"
1192           if $verbose;
1193         return undef;
1194       } else {
1195         warn "Unable to find any value for $key while looking at $block->{'name'}\n"
1196             if $verbose || ! grep /^$key$/, @{$block->{'optional_attrs'}};
1197         next;
1198       }
1199     }
1200
1201     $value = wrap('  ', '  ', $value)
1202       if $key eq 'NODE_TEXT';
1203
1204     $value =~ s/\s+$//;
1205     $value = 'Unknown'
1206       if $value eq '';
1207
1208     $skip = 1
1209       if defined $block->{'filter'}{$key} &&
1210       &{ $block->{'filter'}{$key} }($value, $vars);
1211
1212     if (defined $block->{'rewrite'}{"/$key/"}) {
1213       my ($search, $replace);
1214       while (($search, $replace) = each %{ $block->{'rewrite'}{"/$key/"} } ) {
1215         $value =~ s/$search/$replace/g;
1216       }
1217     }
1218
1219     if (defined $block->{'rewrite'}{"&$key"}) {
1220       $value = &{ $block->{'rewrite'}{"&$key"} }($value, $vars);
1221     }
1222
1223     $value = commify($value)
1224       if defined $commify{$key};
1225
1226     $template =~ s/__${key}__/$value/g;
1227   }
1228
1229   my ($name, $sub);
1230   while (($name, $sub) =  each %{ $block->{'subs'} }) {
1231     $value = &$sub($vars);
1232
1233     $template =~ s/__${name}__/$value/g
1234       if defined $value;
1235   }
1236
1237   return defined $skip ? undef : $template;
1238 }
1239
1240 # Work out the disk space percentage, possibly setting a flag that we should
1241 # raise an alert.
1242 sub calc_disk_space_percentage {
1243   my ($used, $total) = @_;
1244
1245   if (! (defined $used && defined $total) ){
1246     warn "Something is wrong calculating the disk space percentage.\n";
1247     return 'unknown';
1248   }
1249
1250   # Guard against zero disk space.
1251   $total = normalise_disk_space($total);
1252   if ($total == 0) {
1253     warn "Total disk space is 0 MB, I can't use that to calculate a percentage!\n";
1254     return 'unknown';
1255   }
1256
1257   my $percent = int((normalise_disk_space($used) / $total * 100) + 0.5);
1258
1259   if ($percent >= $c->{'disk_space_warn'}) {
1260     $exit_value ||= 1;
1261     push @alerts, "DISK SPACE";
1262     return "$warn$percent\%$warn_to_normal";
1263   } else {
1264     return "$safe$percent\%$safe_to_normal";
1265   }
1266 }
1267
1268 # Make sure that the disk space is in a common unit.
1269 # Currently that is MB.
1270 sub normalise_disk_space {
1271   if ($_[0] =~ /^[.0-9]+$/) {
1272     return $_[0];
1273   } elsif ($_[0] =~ /^([.0-9]+) (\w+)$/) {
1274     my $space = $1;
1275     my $unit = $2;
1276
1277     if ($unit eq 'B') {
1278       return $space / (1024 * 1024);
1279     } elsif ($unit eq 'KB') {
1280       return $space / 1024;
1281     } elsif ($unit eq 'MB') {
1282       return $space;
1283     } elsif ($unit eq 'GB') {
1284       return $space * 1024;
1285     } elsif ($unit eq 'TB') {
1286       return $space * 1024 * 1024;
1287     }
1288
1289     warn "Unknown unit for disk space: $unit.  Please let the author of mythtv-status know.\n";
1290     return $space;
1291   }
1292
1293   warn "Unrecognised format for disk space: $_[0].  Please let the author of mythtv-status know.\n";
1294   return $_[0];
1295 }
1296
1297 # Perform the fetch from the MythTV Backend in a child process.
1298 sub xml_fetch {
1299   my ($url) = @_;
1300
1301   $| = 1;
1302   my $pid = pipe_from_fork('CHILD');
1303   if ($pid) {
1304     # parent
1305     my $content_type;
1306     my $status;
1307
1308     eval {
1309       local $SIG{ALRM} = sub { die "alarm\n" };
1310       alarm(10);
1311       $content_type = <CHILD>;
1312       while (<CHILD>) {
1313         $status .= $_;
1314       }
1315       alarm(0);
1316     };
1317
1318     # The child didn't get back to us in time, kill them off
1319     # and forget what they sent us.
1320     if ($@) {
1321       $status = undef;
1322       my $result;
1323       warn "Our child has stopped talking to us, kill it off.\n";
1324       do {
1325         kill 9, $pid;
1326         $result = waitpid($pid, WNOHANG);
1327       } while $result > 0;
1328
1329       die "Unknown error during retrieval of status from the MythTV backend.\n";
1330     }
1331     $| = 0;
1332
1333     if (defined $content_type && $content_type =~ /utf(-)?8/i) {
1334       $status = decode('UTF-8', $status);
1335     }
1336     return ($content_type, $status);
1337   } else {
1338     # child
1339     $0 = "mythtv-status - child";
1340     my $ua = LWP::UserAgent->new;
1341     $ua->timeout(30);
1342     $ua->env_proxy;
1343
1344     my $response = ua_request_with_timeout($ua, $url);
1345     die "Sorry, failed to fetch $url: Connection to MythTV timed out.\n"
1346       unless defined $response;
1347
1348     # If we get a page doesn't exist, then just ignore it, we need to try
1349     # fetching the status page from a few different locations.
1350     if ($response->code == 404) {
1351       exit 1;
1352     }
1353
1354     die "Sorry, failed to fetch $url: " . $response->status_line . "\n"
1355       unless $response->is_success;
1356
1357     my $content = $response->decoded_content;
1358     if ($response->header('Content-Type') =~ /utf(-)?8/i) {
1359       $content = encode('UTF-8', $content);
1360     }
1361     print $response->header('Content-Type') . "\n";
1362     print $content . "\n";
1363
1364     exit 0;
1365   }
1366 }
1367
1368 # simulate open(FOO, "-|")
1369 sub pipe_from_fork ($) {
1370   my $parent = shift;
1371
1372   $SIG{CHLD} = 'IGNORE';
1373   pipe $parent, my $child or die;
1374   my $pid = fork();
1375   die "fork() failed: $!" unless defined $pid;
1376
1377   if ($pid) {
1378     close $child;
1379   } else {
1380     close $parent;
1381     open(STDOUT, ">&=" . fileno($child)) or die;
1382   }
1383   $pid;
1384 }
1385
1386 # Takes a LWP::UserAgent and an HTTP::Request.  Returns the result of the
1387 # HTTP::Request.  Handles hung servers as well as timeouts.  Based on:
1388 # http://stackoverflow.com/questions/73308/true-timeout-on-lwpuseragent-\
1389 #   request-method
1390 sub ua_request_with_timeout {
1391   my ($ua, $url) = @_;
1392   my ($req_timeout);
1393
1394   # Pick up LWP's request timeout setting.
1395   $req_timeout = $ua->timeout();
1396
1397   # If Sys::SigAction is available, we can use it to get whatever timeout
1398   # is set for LWP and use that to enforce a maximum timeout per request
1399   # in case of server deadlock.
1400   if (eval("{ local \$SIG{__DIE__}; require Sys::SigAction; }")) {
1401     our $resp = undef;
1402
1403     if (Sys::SigAction::timeout_call( $req_timeout,
1404         sub {$resp = $ua->get($url);})) {
1405       return undef;
1406     } else {
1407       return $resp;
1408     }
1409   }
1410
1411   # Otherwise, we roll a hard six with a SIGALRM for the timeout.
1412   else {
1413     my $resp = undef;
1414     our $req_has_timedout = 0;
1415     my ($newaction, $oldaction);
1416
1417     # Create a new SIGALRM handler to set the timed out flag if the
1418     # backend request is not answered before the interval has elapsed.
1419     # Note that die ends the request within the eval (below).  It is
1420     # caught by eval, allowing the code herein to continue and check
1421     # for a timeout.
1422     $newaction = POSIX::SigAction->new(
1423         sub { $req_has_timedout = 1; die "Backend request timeout"; },
1424         POSIX::SigSet->new(SIGALRM) );
1425
1426     # Replace the current SIGALRM handler with our new one, saving the
1427     # old one for restoration, later on.  If this fails, we just issue
1428     # the request directly and hope for the best.
1429     $oldaction = POSIX::SigAction->new();
1430
1431     if (!sigaction(SIGALRM, $newaction, $oldaction)) {
1432       warn "Error setting SIGALRM handler: ".$!."\n" if $verbose;
1433       return $ua->get($url);
1434     }
1435
1436     # Within an eval, set the timer and request a response from the
1437     # backend.  If the timer pops, the SIGALRM routine will set a flag
1438     # and kill the request.  The eval will catch it and we'll get on
1439     # with our lives.
1440     eval {
1441       alarm($req_timeout);
1442       $resp = $ua->get($url);
1443       alarm(0);
1444     };
1445
1446     # Cancel the SIGALRM, if the eval failed for any reason.  Reset the
1447     # SIGALRM handler back to its original state.
1448     alarm(0);
1449
1450     if (!sigaction(SIGALRM, $oldaction )) {
1451       warn "Error resetting SIGALRM handler: ".$!."\n" if $verbose;
1452     };
1453
1454     # If the request has timed out, return a HTTP 408 (timeout) response
1455     # or maybe just undef.  Otherwise, return the backend's response.
1456     if ($req_has_timedout) {
1457       warn "Backend request timed out (".$req_timeout." secs)\n" if $verbose;
1458 #      return HTTP::Response->new(408);
1459       return undef;
1460     } else {
1461       return $resp;
1462     }
1463   }
1464 }
1465
1466 # Beautify numbers by sticking commas in.
1467 sub commify {
1468   my ($num) = shift;
1469
1470   $num = reverse $num;
1471   $num =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g;
1472   return reverse $num;
1473 }
1474
1475 sub print_version {
1476   print "mythtv-status, version $VERSION.\n";
1477   print "Written by Andrew Ruthven <andrew\@etc.gen.nz>\n";
1478   print "\n";
1479   exit;
1480 }
1481
1482 =head1 NAME
1483
1484 mythtv-status - Display the status of a MythTV backend
1485
1486 =head1 SYNOPSIS
1487
1488  mythtv-status [options]
1489
1490 =head1 DESCRIPTION
1491
1492 This script queries a MythTV backend and reports on the status of it,
1493 any upcoming recordings and any which are happening right now.
1494
1495 The intention is to warn you if there is a program being recorded or
1496 about to be recorded.
1497
1498 =head1 OPTIONS
1499
1500 =over
1501
1502 =item B<-c, --colour>
1503
1504 Use colour when showing the status of the encoder(s).
1505
1506 =item B<--date>
1507
1508 Set the date to run as, used for debugging purposes.
1509
1510 =item B<-d, --description>
1511
1512 Display the description for the scheduled recordings.
1513
1514 =item B<--disk-space-warn>
1515
1516 The threshold (in percent) of used disk space that we should show
1517 the disk space in red (if using colour) or send an email if we're
1518 in email mode with email only on warnings.
1519
1520 =item B<--encoder-details>
1521
1522 Display the input ID and channel name against the recording details.
1523
1524 =item B<--encoder-skip-idle>
1525
1526 Suppress displaying idle encoders in the Encoders block.
1527
1528 =item B<--encoder-warn-non-idle>
1529
1530 Display warnings if an encoder is not idle. This is the default, it allows
1531 you to know if an encoder or the MythTV system is busy. To disable, use
1532 B<--no-encoder-warn-non-idle>.
1533
1534 =item B<-e, --episode>
1535
1536 Display the episode (subtitle) for the scheduled recordings.
1537
1538 =item B<< --email <address>[ --email <address> ...] >>
1539
1540 Send the output to the listed email addresses.  By default the encoder status,
1541 currently recording shows and time till next recording is suppressed from
1542 the email.
1543
1544 To turn the additional blocks on you can use B<--encoders>, B<--recording-now>
1545 and/or B<--next-recording>.
1546
1547 By default highlight is turned on, to disable it use B<--nohighlight>.
1548
1549 =item B<--email-only-on-alert>
1550
1551 Only send an email out (if --email is present) if there is an alert
1552 (i.e., schedule conflict or low disk space).
1553
1554 =item B<-?, --help>
1555
1556 Display help.
1557
1558 =item B<< --file <file> >>
1559
1560 Load XML from the file specified instead of querying a MythTV backend.
1561 Handy for debugging things.
1562
1563 =item B<< --save-file <file> >>
1564
1565 Save the XML we received from the MythTV backend.
1566 Handy for debugging things.
1567
1568 =item B<< --guide-days-warn <days> >>
1569
1570 Warn if the number of days of guide data present is equal to or below
1571 this level.  Default is 2 days.
1572
1573 =item B<-h HOST, --host=HOST>
1574
1575 The host to check, defaults to localhost.
1576
1577 =item B<--highlight>
1578
1579 Surround any items that are considered a warning with asterisks. This helps
1580 to highlight an issue if colour mode is disabled.
1581
1582 =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>
1583
1584 Suppress displaying blocks of the output if they would normally be displayed.
1585
1586 =item B<-p PORT, --port=PORT>
1587
1588 The port to use when connecting to MythTV, defaults to 6544.
1589
1590 =item B<--oneliner-bullets>
1591
1592 Insert asterisks (*) before each of the oneliners to stop some
1593 email clients from thinking the oneliner block is a paragraph and
1594 trying to word wrap them.
1595
1596 =item B<--auto-expire>
1597
1598 Display the shows due to auto expire (output is normally suppressed).
1599
1600 =item B<--auto-expire-count>
1601
1602 How many of the auto expire shows to display, defaults to 10.
1603
1604 =item B<--recording-in-warn>
1605
1606 If the "Next Recording In" time is less than this amount, display it
1607 in red.  This in seconds, and defaults to 3600 (1 hour).
1608
1609 =item B<--verbose>
1610
1611 Have slightly more verbose output.  This includes any warnings that might
1612 be generated while parsing the XML.
1613
1614 =item B<-v, --version>
1615
1616 Show the version of mythtv-status and then exit.
1617
1618 =back
1619
1620 =head1 OUTPUT
1621
1622 The output of this script is broken up into several chunks they are:
1623
1624 =over
1625
1626 =item Status
1627
1628 Some general info about the backend, currently just the timestamp of when
1629 this program was run.
1630
1631 =item Guide Data
1632
1633 The number of days of guide data is present.  By default it is only shown
1634 if the number of days is below the warning level.  To show it regardless
1635 of the warning level use --guide-data.
1636
1637 =item Encoders
1638
1639 Each encoder that the backend knows about are listed, with the hostname
1640 they are on, the encoder ID (in brackets) and the current status.
1641
1642 =item Recording Now
1643
1644 Any programs which are being recorded right now.
1645
1646 =item Scheduled Recordings
1647
1648 Up to 10 programs which are scheduled to be recorded today and tomorrow.
1649
1650 =item Schedule Conflicts
1651
1652 Any upcoming schedule conflicts (not just limited to today or tomorrow).
1653
1654 =item Shows due to Auto Expire
1655
1656 The shows which will be deleted and the order they'll be deleted if the
1657 auto expirer kicks in.
1658
1659 =item Total Disk Space
1660
1661 The amount of disk space in total, and used by MythTV.
1662
1663 =item Next Recording In
1664
1665 If there are no recordings currently happening, then the amount of time until
1666 the next recording is displayed.
1667
1668 =item Disk Space
1669
1670 Details about each storage group that MythTV knows about.  By default this
1671 only shows storage groups that are above the warning level.  Use
1672 B<--disk-space> to turn on display of all storage groups.
1673
1674 =back
1675
1676 =head1 RETURN CODES
1677
1678 mythtv-status provides some return codes.
1679
1680 =over
1681
1682 =item 0Z<>
1683
1684 Standard return code
1685
1686 =item 1Z<>
1687
1688 A warning is generated
1689
1690 =back
1691
1692 =head1 AUTHOR
1693
1694 Andrew Ruthven, andrew@etc.gen.nz
1695
1696 =head1 LICENSE
1697
1698 Copyright (c) 2007-2018 Andrew Ruthven <andrew@etc.gen.nz>
1699 This code is hereby licensed for public consumption under the GNU GPL v3.
1700
1701 =cut
1702