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