mythtv-status 0.10.8-1 / usr / bin / mythtv-status

#!/usr/bin/perl -w
# Copyright (c) 2007-2017 Andrew Ruthven <andrew@etc.gen.nz>
# This code is hereby licensed for public consumption under the GNU GPL v3.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# Display the current status of a MythTV system.

# While I would love to enable the 6.xx interface for Date::Manip we may
# still need to run on platforms that only have version 5.x.  So we'll
# turn on backwards compatible mode for now.
{
  no warnings 'once';
  $Date::Manip::Backend = 'DM5';
}

use LWP::UserAgent;
use XML::LibXML;
use Date::Manip;
use Date::Manip::Date;
use Getopt::Long;
use Text::Wrap;
use POSIX qw/strftime :sys_wait_h/;

use MIME::Entity;
use Pod::Usage;
use Config::Auto;
use Sys::SigAction qw/timeout_call/;
use Encode;

# Try and load a config file first, and then allow the command line
# to over ride what is in the config file.
my $c = eval {
  Config::Auto::parse("mythtv-status.yml",
    format => 'yaml',
  )
};
if ($@ && $@ !~ /^No config file found/) {
  # Die on any issues loading the config file, apart from it not existing.
  die $@;
}

# Some sane defaults.
$c->{'host'}    ||= "localhost";
$c->{'port'}    ||= "6544";
$c->{'colour'}  ||= 0;
$c->{'episode'} ||= 0;
$c->{'description'} ||= 0;
$c->{'encoder_details'}     ||= 0;
$c->{'encoder_skip_idle'}   //= 1;
$c->{'email_only_on_alert'} ||= 0;
my $help = 0;
my $verbose = 0;
$c->{'disk_space_warn'} ||= 95;  # Percent to warn at.
$c->{'guide_days_warn'} ||= 2;   # How many days we require.
$c->{'auto_expire_count'} ||= 10;      # How many auto expire shows to display.
$c->{'recording_in_warn'} ||= 60 * 60; # When is the next recording considered critical? (seconds)
$c->{'save_file'} ||= undef; # File to save the XML from the BE to.
$c->{'xml_file'}  ||= undef; # Load the BE XML from this file.

# We allow a hack for MS Outlook which normally recognises the
# oneliners block as a paragraph and wraps it.  If it sees "bullets"
# it believes it is a bulleted list and leaves it alone.
$c->{'oneliner_bullets'} ||= 0;

# What units we have available for converting diskspaces.
# The threshold is at what level we switch to using that unit.
my @size_thresholds = (
  {
    'unit' => 'TB',
    'threshold' => 2 * 1024 * 1024,
    'conversion' => 1024 * 1024,
  },
  {
    'unit' => 'GB',
    'threshold' => 50 * 1024,        # 50GB seems like a good threshold.
    'conversion' => 1024,
  },
  {
    'unit' => 'MB',
  },
);

my $return_code_only = 0;

my $VERSION = '0.10.8';

# Some display blocks are disabled by default:
$c->{'display'}{'Shows due to Auto Expire'} = 0;

GetOptions(
  'c|colour|color!' => \$c->{'colour'},
  'd|description!' => \$c->{'description'},
  'e|episode!'    => \$c->{'episode'},
  'encoder-details!' => \$c->{'encoder_details'},
  'h|host=s'     => \$c->{'host'},
  'p|port=i'     => \$c->{'port'},
  'v|version'    => \&print_version,
  'email=s@'     => \@{ $c->{'email'} },
  'email-only-on-conflict|email-only-on-alert|email-only-on-alerts'
    => \$c->{'email_only_on_alert'},
  'disk-space-warn=i'     => \$c->{'disk_space_warn'},
  'guide-days-warn=i'     => \$c->{'guide_days_warn'},
  'auto-expire-count=i'   => \$c->{'auto_expire_count'},
  'recording-in-warn=i'   => \$c->{'recording_in_warn'},
  'encoder-skip-idle!'    => \$c->{'encoder_skip_idle'},
  'oneliner-bullets!'     => \$c->{'oneliner_bullets'},

  'status!'               => \$c->{'display'}{'Status'},
  'encoders!'             => \$c->{'display'}{'Encoders'},
  'recording-now!'        => \$c->{'display'}{'Recording Now'},
  'scheduled-recordings!' => \$c->{'display'}{'Scheduled Recordings'},
  'schedule-conflicts!'   => \$c->{'display'}{'Schedule Conflicts'},
  'next-recording!'       => \$c->{'display'}{'Next Recording In'},
  'total-disk-space!'     => \$c->{'display'}{'Total Disk Space'},
  'disk-space!'           => \$c->{'display'}{'Disk Space'},
  'guide-data!'           => \$c->{'display'}{'Guide Data'},
  'auto-expire!'          => \$c->{'display'}{'Shows due to Auto Expire'},

  'return-code-only'      => \$return_code_only,

  'file=s'                => \$c->{'xml_file'},
  's|save-file=s'         => \$c->{'save_file'},

  'date=s'  => \$c->{'date'},
  'verbose' => \$verbose,
  'help|?'  => \$help,
  ) || pod2usage("\nUse --help for help.\n");

pod2usage(verbose => 1)
  if $help;

$0 = "mythtv-status - parent";

# Get the email address into a format we can use.
@{ $c->{'email'} } = split(',', join(',', @{ $c->{'email'} }));

# Default to not showing some blocks if we're sending email, but let the
# user override us.
if (scalar(@{ $c->{'email'} }) > 0) {
  for my $block ('Encoders', 'Recording Now', 'Next Recording In') {
    if (! defined $c->{'display'}{$block}) {
      $c->{'display'}{$block} = 0;
    }
  }
}

# Possibly use some colour, but not in emails.
my $safe = '';
my $warning = '';
my $normal = '';
if ($c->{'colour'} && scalar(@{ $c->{'email'} }) == 0) {
  $safe    = "\033[0;32m";
  $warning = "\033[1;31m";
  $normal  = "\033[0m";
}

# Is a warning present?
my $warn_present = 0;

# Allow setting some defaults for the output blocks.
my %defaults = (
  'schedule' => {
    'attrs' => [ qw/title startTime NODE_TEXT subTitle channelName:.\/Channel[@channelName] chanNum:.\/Channel[@chanId] inputId:.\/Channel[@inputId]/ ],
    'template' => "__startTime__"
      . ($c->{'encoder_details'} ? " - Enc: __inputId__, Chan: __chanNum__" : '')
      . " - __title__"
      . ($c->{'episode'} ? " - __subTitle__" : '')
      . " (__channelName__)"
      . ($c->{'description'} ? "\n__NODE_TEXT__" : ''),
    'filter' =>  {

      # Only show recordings for today and tomorrow.
      'startTime' => sub {
        my $date = substr(ParseDate($_[0]), 0, 8);
        return ! (($date cmp $today) == 0
          || ($date cmp $tomorrow) == 0) }
      },
    'rewrite' => {
      '&startTime' => sub { return process_iso_date($_[0]); }
    }
  }
);

# The time of the next scheduled recording.
my $next_time = 'Never';

# Are there any alerts that should be notified via email?
my @alerts = ();

# The blocks of output which we might generate.
my @blocks = (

  # All the one liners together
  {
    'name' => 'One Liners',
    'type' => 'sub',
    'template' => '',
    'sub' => sub { return 'Place holder' },
  },

  # Date/Time from server
  {
    'name'  => 'Status',
    'type'  => 'xpath',
    'xpath' => "//Status",
    'attrs' => [ qw/ISODate time date/ ],
    'template' => "__date__",
    'format' => 'one line',
    'rewrite' => {
      '&date' => sub {
        my ($value, $vars) = @_;

	if (defined $vars->{ISODate} && $vars->{ISODate} =~ /Z$/) {
	  return process_iso_date($vars->{ISODate});
	} else {
	  return $vars->{date} . ", " . $vars->{time};
	}
      },
    },
  },

  # Info about the encoders before TV OSD Declutter (Changeset 20037).
  {
    'name'  => 'Encoders',
    'type'  => 'xpath',
    'xpath' => "//Status/Encoders/Encoder",
    'protocol_version' => [ "<= 43" ],
    'attrs' => [ qw/hostname id state connected/ ],
    'template' => "__hostname__ (__id__) - __state____connected__",
    'rewrite' => {
      '/connected/' => { '1' => '', '0' => "${warning}(Disconnected)${normal}" },
      '/state/' => {
        '^0$' => "${safe}Idle${normal}",
        '^1$' => "${warning}Watching LiveTV${normal}",
        '^2$' => "${warning}Watching Pre-recorded${normal}",
        '^3$' => "${warning}Watching Recording${normal}",
        '^4$' => "${warning}Recording${normal}" },
    },
    'filter' => {
      'state' => sub { return $c->{'encoder_skip_idle'} && $_[0] == 0 },
    },
  },

  # Info about the encoders after TV OSD Declutter (Changeset 20037).
  {
    'name'  => 'Encoders',
    'type'  => 'xpath',
    'xpath' => "//Status/Encoders/Encoder",
    'protocol_version' => [ ">= 44", "< 58" ],
    'attrs' => [ qw/hostname id state connected/ ],
    'template' => "__hostname__ (__id__) - __state____connected__",
    'rewrite' => {
      '/connected/' => { '1' => '', '0' => "${warning}(Disconnected)${normal}" },
      '/state/' => {
         '^-1$' => "${warning}Error${normal}",
         '^0$' => "${safe}Idle${normal}",
         '^1$' => "${warning}Watching LiveTV${normal}",
         '^2$' => "${warning}Watching Pre-recorded${normal}",
         '^3$' => "${warning}Watching DVD${normal}",
         '^4$' => "${warning}Watching Video${normal}",
         '^5$' => "${warning}Watching Recording${normal}",
         '^6$' => "${warning}Recording${normal}" },
    },
    'filter' => {
      'state' => sub { return $c->{'encoder_skip_idle'} && $_[0] == 0 },
    },
  },

  # Info about the encoders after adding Blu-ray (Changeset 25058).
  #  The protocol version is from svn commit 25362 but is the closest commit
  #  for mythtv/libs/libmythdb/mythversion.h.
  {
    'name'  => 'Encoders',
    'type'  => 'xpath',
    'xpath' => "//Status/Encoders/Encoder",
    'protocol_version' => [ ">= 58" ],
    'attrs' => [ qw/hostname id state connected/ ],
    'template' => "__hostname__ (__id__) - __state____connected__",
    'rewrite' => {
      '/connected/' => { '1' => '', '0' => "${warning}(Disconnected)${normal}" },
      '/state/' => {
         '^-1$' => "${warning}Error${normal}",
         '^0$' => "${safe}Idle${normal}",
         '^1$' => "${warning}Watching LiveTV${normal}",
         '^2$' => "${warning}Watching Pre-recorded${normal}",
         '^3$' => "${warning}Watching DVD${normal}",
         '^4$' => "${warning}Watching Blu-ray${normal}",
         '^5$' => "${warning}Watching Video${normal}",
         '^6$' => "${warning}Watching Recording${normal}",
         '^7$' => "${warning}Recording${normal}" },
    },
    'filter' => {
      'state' => sub { return $c->{'encoder_skip_idle'} && $_[0] == 0 },
    },
  },

  # What programs (if any) are being recorded right now?
  {
    'name'  => 'Recording Now',
    'type'  => 'xpath',
    'xpath' => "//Status/Encoders/Encoder/Program",
    'hide'  => 'after',
    'attrs' => [ qw/title endTime channelName:.\/Channel[@channelName]
    		    encoderId:.\/Recording[@encoderId]
		    chanNum:.\/Channel[@chanNum]/ ],
    'template' => "__title__ (__channelName__"
      . ($c->{'encoder_details'} ? ", Enc: __encoderId__, Chan: __chanNum__" : '')
      . ") Ends: __endTime__",
    'rewrite' => {
      '&endTime' => sub {
        my ($value, $vars) = @_;

	if ($value =~ /Z$/) {
	  $value = process_iso_date($value, { date => 0 });
	} else {
	  $value =~ s/.*T//;
	}

	return $value;
      },
    },
    'subs' => {
      'find_next' =>
        sub {
          $warn_present ||= 1;
          $next_time    = $c->{'date'} || 'now';
        }
      }
  },

  # The upcoming recordings.
  {
    'name'  => 'Scheduled Recordings',
    'type'  => 'xpath',
    'xpath' => '//Status/Scheduled/Program',
    'defaults' => 'schedule',
    'hide'  => 'after',
    'subs' => {
      'find_next' => sub {
        my $vars = shift;
        return
          if defined $next_time && $next_time eq 'now';

        my $date = ParseDate($vars->{'startTime'});
        if ($next_time eq 'Never' || Date_Cmp($date, $next_time) < 0) {
          $next_time = $date
        };
        }
      }
  },

  # Conflicts
  {
    'name' => 'Schedule Conflicts',
    'type' => 'sub',
    'defaults' => 'schedule',
    'sub' => \&process_conflicts
  },

  # Auto Expire
  {
    'name' => 'Shows due to Auto Expire',
    'type' => 'sub',
    'defaults' => 'schedule',
    'sub' => \&process_auto_expire,
    'filter' =>  {},   # Over ride the default filter from 'schedule'.
  },

  # Diskspace, before storage groups
  {
    'name' => 'Total Disk Space',
    'type' => 'xpath',
    'xpath' => '//Status/MachineInfo/Storage',
    'protocol_version' => [ "<= 31" ],
    'attrs' => [ qw/_total_total _total_used/ ],
    'commify' => [ qw/_total_total _total_used/ ],
    'human_readable_sizes' => [ qw/_total_total _total_used/ ],
    'template' => "Total space is ___total_total__ ___total_total_unit__, with ___total_used__ ___total_used_unit__ used (__percent__)",
    'format' => 'one line',
    'optional' => 1,
    'subs' => {
      'percent' => sub {
        calc_disk_space_percentage("$_[0]->{'_total_used'} $_[0]->{'_total_used_unit'}", "$_[0]->{'_total_total'} $_[0]->{'_total_total_unit'}")
        },
      }
  },

  # Diskspace, with storage groups
  {
    'name' => 'Total Disk Space',
    'type' => 'xpath',
    'xpath' => '//Status/MachineInfo/Storage',
    'protocol_version' => [ ">= 32" ],
    'xml_version' => [ "== 0" ],
    'attrs' => [ qw/drive_total_total drive_total_used/ ],
    'commify' => [ qw/drive_total_total drive_total_used/ ],
    'human_readable_sizes' => [ qw/drive_total_total drive_total_used/ ],
    'template' => "Total space is __drive_total_total__ __drive_total_total_unit__, with __drive_total_used__ __drive_total_used_unit__ used (__percent__)",
    'format' => 'one line',
    'optional' => 1,
    'subs' => {
      'percent' => sub {
        calc_disk_space_percentage("$_[0]->{'drive_total_used'} $_[0]->{'drive_total_used_unit'}", "$_[0]->{'drive_total_total'} $_[0]->{'drive_total_total_unit'}")
        }
      }
  },

  # Diskspace, with storage groups and sensible XML layout.
  {
    'name' => 'Total Disk Space',
    'type' => 'xpath',
    'xpath' => '//Status/MachineInfo/Storage/Group[@id="total"]',
    'protocol_version' => [ ">= 39" ],
    'attrs' => [ qw/total used/ ],
    'commify' => [ qw/total used/ ],
    'human_readable_sizes' => [ qw/total used/ ],
    'template' => "Total space is __total__ __total_unit__, with __used__ __used_unit__ used (__percent__)",
    'format' => 'one line',
    'optional' => 1,
    'subs' => {
      'percent' => sub {
        calc_disk_space_percentage("$_[0]->{'used'} $_[0]->{'used_unit'}", "$_[0]->{'total'} $_[0]->{'total_unit'}")
        }
      }
  },

  # Diskspace, with storage groups and sensible XML layout.
  {
    'name' => 'Disk Space',
    'type' => 'xpath',
    'xpath' => '//Status/MachineInfo/Storage/Group',
    'protocol_version' => [ ">= 39" ],
    'attrs' => [ qw/id total used/ ],
    'commify' => [ qw/total used/ ],
    'human_readable_sizes' => [ qw/total used/ ],
    'template' => "Total space for group __id__ is __total__ __total_unit__, with __used__ __used_unit__ used (__percent__)",
    'filter' =>  {
      'id' => sub { return $_[0] eq 'total' },
      'used' => sub {
        return ! (
          (defined $c->{'display'}{'Disk Space'} && $c->{'display'}{'Disk Space'})
          || ($_[1]->{'used'} / $_[1]->{'total'}) * 100 > $c->{'disk_space_warn'})
        }
      },
    'subs' => {
      'percent' => sub {
        calc_disk_space_percentage("$_[0]->{'used'} $_[0]->{'used_unit'}", "$_[0]->{'total'} $_[0]->{'total_unit'}")
        }
      }
  },

  # How many hours till the next recording.
  {
    'name' => 'Next Recording In',
    'type' => 'sub',
    'format' => 'one line',
    'template' => '__next_time__',
    'rewrite' => {
      '&next_time' => sub {
        return $next_time
          if $next_time eq 'Never' || $next_time eq 'now';

        my $err;
        my $delta   = DateCalc($c->{'date'} || 'now', $next_time, \$err, 1);
        my $seconds = Delta_Format($delta, 'approx', 0, '%sh');

	# If the next recording is more than 1 day in the future,
	# print out the days and hours.
	my $str;
	if ($seconds > 24 * 3600) {
	  $str = Delta_Format($delta, 0, '%dh Days, %hv Hours');
	} else {
	  $str = Delta_Format($delta, 0, '%hh Hours, %mv Minutes');
	}

        $str =~ s/\b1 (Day|Hour|Minute)s/1 $1/g;
        $str =~ s/\b0 (Days|Hours)(, )?//;
        $str =~ s/, 0 Minutes$//;

        if ($seconds <= $c->{'recording_in_warn'}) {
          $warn_present ||= 1;
          $str = "$warning$str$normal";
        }

        return $str;
        }
      },
    'filter' =>  {
      'next_time' => sub { return $_[0] eq 'now' }
      },
    'sub' => sub {
      return substitute_vars($_[0], { 'next_time' => $next_time });
      }
  },

  # Check how much Guide data we have
  {
    'name'     => 'Guide Data',
    'format'   => 'one line',
    'type'     => 'xpath',
    'xpath'    => '//Status/MachineInfo/Guide[@guideDays]',
    'attrs'    => [qw/guideDays status guideThru/],
    'template' => 'There is __guideDays__ days worth of data, through to __guideThru__',
    'filter' => {
      'guideDays' => sub {
        if ($_[0] > $c->{'guide_days_warn'}) {
          return
            (defined $c->{'display'}{'Guide Data'} && ! $c->{'display'}{'Guide Data'}) || 1;
        } else {
          $warn_present ||= 1;
          push @alerts, "GUIDE DATA";
          return 0;
        }
        },
      },
    'rewrite'  => {
      '&guideDays' => sub {
        if ($_[0] <= $c->{'guide_days_warn'}) {
          $warn_present ||= 1;
          return "$warning$_[0]$normal";
        } else {
          return "$safe$_[0]$normal";
        }
        },
      '/guideThru/' => { 'T\d+:\d+:\d+' => ' ' },
      '&guideThru' => sub {
        if ($_[1]->{'guideDays'} <= $c->{'guide_days_warn'}) {
          $warn_present ||= 1;
          return "$warning$_[0]$normal";
        } else {
          return "$safe$_[0]$normal";
        }
        },
      },
  },

  {
    'name'     => 'Guide Data',
    'format'   => 'one line',
    'type'     => 'xpath',
    'xpath'    => '//Status/MachineInfo/Guide[@status=""]',
    'template' => "${warning}No guide data!${normal}",
  },
  );

###
### Set some useful variables
###
our $today    = substr(ParseDate('today'), 0, 8);
our $tomorrow = substr(ParseDate('tomorrow'), 0, 8);

if ($c->{'date'}) {
  $today    = substr(ParseDate($c->{'date'}), 0, 8);
  $tomorrow = substr(DateCalc($c->{'date'}, ParseDateDelta('1 day')), 0, 8);
}

if ($verbose) {
  print "Today:    $today\n";
  print "Tomorrow: $tomorrow\n";
}

# If we're in return code only mode then we disable all blocks
# except for those explicitly enabled.
if ($return_code_only) {
  warn "In return-code-only mode, disabling all blocks by default.\n"
    if $verbose;

  for my $block (@blocks) {
    $c->{'display'}{ $block->{'name'} } ||= 0;
  }
}

# A couple of global variables
my ($xml, $charset, $myth);
my %version;

my $exit_value = 0;
my $title =  "MythTV status for $c->{'host'}";
my $output = "$title\n";
$output .= '=' x length($title) . "\n";

for my $block (@blocks) {
  $block->{'format'} ||= 'multi line';
  $block->{'optional'} ||= 0;

  warn "Considering: $block->{'name'}\n"
    if $verbose;

  my $hide = undef;
  if (defined $c->{'display'}{ $block->{'name'} }
    && $c->{'display'}{ $block->{'name'} } == 0) {
    if (defined $block->{'hide'} && lc($block->{'hide'}) eq 'after') {
      $hide = 1;
    } else {
      next;
    }
  }

  warn "  Going to process: $block->{'name'}\n"
    if $verbose;

  # We might need to set some defaults.
  if (defined $block->{'defaults'}) {
    for my $field (keys %{ $defaults{ $block->{'defaults'} } }) {
      $block->{$field} ||= $defaults{ $block->{'defaults'} }{$field};
    }
  }

  my $result = undef;
  $warn_present = 0;
  if ($block->{'type'} eq 'xpath') {
    ($xml, $charset) = load_xml()
      unless defined $xml;

    $result = process_xml($block, $xml);

  } elsif ($block->{'type'} eq 'sub') {

    $result = &{ $block->{'sub'} }($block)
      if defined $block->{'sub'};
  }

  if (defined $result && $result ne '' && ! defined $hide) {
    $exit_value ||= $warn_present;

    if ($block->{'format'} eq 'one line') {
      push @oneliners, [ $block->{'name'}, $result ];
    } else {
      $output .= "$block->{'name'}:\n";
      $output .= $result . "\n\n";
    }
  }
}

# Deal with the one liners.
if (scalar(@oneliners) > 0) {

  # Find the longest header
  my $length = 0;
  for $line (@oneliners) {
    if (length($line->[0]) > $length) {
      $length = length($line->[0]);
    }
  }

  # Put the one liners together, with leading dots to the colon.
  # We allow a hack for MS Outlook which normally recognises the
  # oneliners block as a paragrap and wraps it.  If it sees "bullets"
  # it believes it is a bulleted list and leaves it alone.
  my $oneliners = "";
  for $line (@oneliners) {
    $oneliners .= ($c->{'oneliner_bullets'} ? '* ' : '' )
      . "$line->[0]"
      . ('.' x ($length - length($line->[0]))) . ": $line->[1]\n";
  }

  # What a hacky way of putting the one liners where I want them...
  $output =~ s/^One Liners:\nPlace holder\n/$oneliners/m;
}

# Either print the status out, or email it.
if ($return_code_only) {
  exit $exit_value;
} elsif (scalar(@{ $c->{'email'} }) == 0) {
  if ($charset =~ /utf(-)?8/i) {
    $output = encode('UTF-8', $output);
  }
  print "\n$output";
} else {
  if ((! $c->{'email_only_on_alert'}) ||
    ($c->{'email_only_on_alert'} && scalar(@alerts) > 0)) {
    my $suffix = undef;
    if (@alerts == 1) {
      $suffix = $alerts[0];
    } elsif (@alerts > 1) {
      $suffix = "MULTIPLE WARNINGS";
    }

    my $mail = MIME::Entity->build(
      To      => $c->{'email'},
      Subject => encode('UTF-8', $title . (defined $suffix ? " - $suffix" : '')),
      Charset => $charset,
      Encoding=> "quoted-printable",
      Data    => encode('UTF-8', $output),
      );

    $mail->send('sendmail');
  }
}

exit $exit_value;

# Fetch the XML status from the backend.
sub load_xml {
  my $status = '';
  my $charset = '';

  if (defined $c->{'xml_file'}) {
    open (IN, "< $c->{'xml_file'}")
      || die "Failed to open $c->{'xml_file'} for reading: $!\n";

    $status = join("", <IN>);
    $charset = 'UTF-8';

    close IN;
  } else {
    my $content_type;
    # In MythTV 0.25 the path changed from /xml to /Status/GetStatus
    for my $path ('Status/GetStatus', 'xml') {
      my $url = "http://$c->{'host'}:$c->{'port'}/$path";
      ($content_type, $status) = xml_fetch($url);

      last
        if defined $status;
    }

    die "Nothing was received from the MythTV Backend.\n"
      unless defined $status;
    ($charset)  = ($content_type =~ /charset="(\S+?)"/);
  }

  if (defined $c->{'save_file'}) {
    open(OUT, "> $c->{'save_file'}")
      || die "Failed to open " . $c->{'save_file'} . " for writing: $!\n";
    print OUT $status;
    close OUT;
  }

  # Parse the XML
  my $parser = XML::LibXML->new();

  # Some XML data seems to have badness in it, including non-existant
  # UTF-8 characters.  We'll try and recover.
  $parser->recover(1);
  $parser->recover_silently(1)
    unless $verbose;

  clean_xml(\$status);

  # Try and hide any error messages that XML::LibXML insists on printing out.
  open my $olderr, ">&STDERR";
  open(STDERR, "> /dev/null") || die "Can't redirect stderr to /dev/null: $!";

  my $xml = eval { $parser->parse_string( $status ) };

  close (STDERR);
  open (STDERR, ">&", $olderr);

  if ($@) {
    die "Failed to parse XML: $@\n";
  }

  # Pick out the XML version.
  my $items = $xml->documentElement->find('//Status');
  $version{'xml'}      = @{ $items }[0]->getAttribute('xmlVer') || 0;
  $version{'protocol'} = @{ $items }[0]->getAttribute('protoVer');

  warn "Loaded XML from " . ($c->{'xml_file'} || $c->{'host'}) . "\n"
    if $verbose;

  return ($xml, $charset);
}

# Prep the Perl MythTV API if available.
sub load_perl_api {
  my $myth = undef;

  eval { require MythTV };
  if ($@) {
    print $@
      if $verbose;
  } else {

    # Surpress warnings from DBI.  I tried unsetting $^W but that is ignored.
    local($SIG{__WARN__}) = sub { if ($verbose) { print shift } };
    eval { $myth = new MythTV() };

    if ($@) {
      if ($verbose) {
        warn "Failed to load Perl API\n";
        print $@;
	return undef;
      }
    } elsif ($verbose) {
      warn "Loaded Perl API\n";
    }
  }

  return $myth;
}

# We are sometimes passed dodgy XML from MythTV, make some attempts to clean
# it.
sub clean_xml {
  my ($xml) = shift;

  # Deal to invalid Unicode.
  for my $bad ("&#xdbff;", "&#xdee9;") {
    if ($$xml =~ s/$bad/?/g) {
      warn "Found and replaced: $bad\n"
        if $verbose;
    }
  }
}

sub process_xml {
  my ($block, $xml) = @_;

  # Only work on this block if we have received the appropriate version of
  # the XML.
  for my $vers (qw/protocol xml/) {
    if (defined $block->{"${vers}_version"}) {
      my $result = undef;

      # All the version checks must pass.
      for my $check (@{ $block->{"${vers}_version"} }) {
        my $res = eval ( "$version{$vers} $check" );

        if (! defined $result || $res != 1) {
          $result = $res;
        }
      }

      return
        unless defined $result && $result ne '';

      warn "We have the correct $vers version for $block->{'name'}\n"
        if $verbose;
    }
  }

  my $items = $xml->documentElement->find($block->{'xpath'});

  # Don't do any work on this block if there is nothing for it.
  return undef
    if (scalar(@$items) == 0);

  my @lines;
  for my $item (@{ $items }) {
    my %vars;
    for my $key (@{ $block->{'attrs'} }) {
      if ($key =~ /(.*?):(.*)/) {
        my $subitem = $item->findnodes($2);
        $vars{$1} = @{ $subitem }[0]->getAttribute($1)
          if defined @{ $subitem }[0];
      } else {
        $vars{$key} = $key eq 'NODE_TEXT' ? $item->string_value : $item->getAttribute($key);
      }
    }

    my $str = substitute_vars($block, \%vars);
    push @lines, $str
      if defined $str;
  }

  return join("\n", @lines);
}

sub process_conflicts {
  my ($block) = @_;
  $myth ||= load_perl_api();

  return "Unable to access MythTV Perl API.  Try with --verbose to find out why."
    unless defined $myth;

  my @lines;

  # This isn't defined in the 0.20 version of the API.  It is in 0.21svn.
  my $recstatus_conflict = 7;

  my %rows = $myth->backend_rows('QUERY_GETALLPENDING', 2);

  foreach my $row (@{$rows{'rows'}}) {
    my $show;
    {

      # MythTV::Program currently has a slightly broken line with a numeric
      # comparision.
      local($^W) = undef;
      $show = new MythTV::Program(@$row);
    }

    if ($show->{'recstatus'} == $recstatus_conflict) {
      my %vars = (
        'title'     => $show->{'title'},
        'startTime' => strftime("%FT%T", localtime($show->{'starttime'})),
        'NODE_TEXT' => $show->{'description'},
        'subTitle'  => $show->{'subtitle'},
        'channelName' => $show->{'channame'},
        'inputId'   => $show->{'inputid'},
        'chanNum'   => $show->{'channum'},
        );

      my $str = substitute_vars($block, \%vars);
      push @lines, decode('UTF-8', $str)
        if defined $str;
    }
  }

  if (scalar(@lines) == 1) {
    push @alerts, "CONFLICT";
  } elsif (scalar(@lines) > 1) {
    push @alerts, "CONFLICTS";
  }

  return join("\n", @lines);
}

sub process_auto_expire {
  my ($block) = @_;
  $myth ||= load_perl_api();

  return "Unable to access MythTV Perl API.  Try with --verbose to find out why."
    unless defined $myth;

  my @lines;

  # This isn't defined in the 0.20 version of the API.  It is in 0.21svn.
  my %rows = $myth->backend_rows('QUERY_RECORDINGS Delete', 2);

  # Returned in date order, desc.  So reverse it to make the oldest
  # ones come first.
  foreach my $row (reverse @{$rows{'rows'}}) {
    my $show;
    {

      # MythTV::Program currently has a slightly broken line with a numeric
      # comparision.
      local($^W) = undef;
      $show = new MythTV::Program(@$row);
    }

    # Who cares about LiveTV recordings?
    next if $show->{'progflags'} eq 'LiveTV';

    my %vars = (
      'title'     => $show->{'parentid'} || 'Unknown',
      'startTime' => strftime("%FT%T", localtime($show->{'starttime'})),
      'NODE_TEXT' => $show->{'description'},
      'subTitle'  => $show->{'subtitle'},
      'channelName' => $show->{'callsign'},
      'inputId'   => $show->{'inputid'},
      'chanNum'   => $show->{'chanid'},
      );

    my $str = substitute_vars($block, \%vars);
    push @lines, decode('UTF-8', $str)
      if defined $str;

    # Don't do more work than is required.
    last if --$c->{'auto_expire_count'} <= 0;
  }

  return join("\n", @lines);
}

# If either date or time are set to 0, then we don't display that bit of
# info.  For example:
#   process_iso_date($date, { date => 0 })
# Will only show the time.
sub process_iso_date {
  my $date = shift;
  my $options = shift;
  $options->{'date'} //= 1;
  $options->{'time'} //= 1;

  # 2012-10-17T23:50:08Z
  my $d = new Date::Manip::Date;
  $d->parse($date);

  # Work out our local timezone. The Date::Manip::Date
  # docs say that convert will default to the local timezone,
  # this appears to be lies.
  my $dmb = $d->base();
  my ($tz) = $dmb->_now('tz',1);
  $d->convert($tz);

  # Sample of what MythTV uses:
  # Thu 18 Oct 2012, 10:20
  my $format = '';
  $format .= '%Y-%m-%d' if $options->{'date'};
  $format .= ' '        if $options->{'date'} && $options->{'time'};
  $format .= '%X'       if $options->{'time'};

  return $d->printf($format);
}

sub substitute_vars {
  my $block = shift;
  my $vars  = shift;

  my %commify = map { $_ => 1 } @{ $block->{'commify'} }
    if defined $block->{'commify'};

  my $template = $block->{'template'};
  my $skip = undef;
  my ($key, $value);

  # Convert disk spaces into more suitable units.
  if (defined $block->{'human_readable_sizes'}) {
    for my $key (@{ $block->{'human_readable_sizes'}}) {
      for my $unit (@size_thresholds) {
        if (defined $vars->{$key} && defined $unit->{'threshold'}) {
          if ($vars->{$key} > $unit->{'threshold'}) {
            $vars->{$key} = sprintf("%.1f", $vars->{$key} / $unit->{'conversion'});
            $vars->{"${key}_unit"} = $unit->{'unit'};

            last;
          }
        } else {
          $vars->{"${key}_unit"} = $unit->{'unit'};
        }
      }
    }
  }

  while (($key, $value) = (each %{ $vars })) {
    if (! defined $value) {
      if ($block->{'optional'}) {
        warn "Unable to find any value for $key while at $block->{'name'}, marked as optional, skipping block.\n"
          if $verbose;
        return undef;
      } else {
        warn "Unable to find any value for $key while looking at $block->{'name'}\n";
        next;
      }
    }

    $value = wrap('  ', '  ', $value)
      if $key eq 'NODE_TEXT';

    $value =~ s/\s+$//;
    $value = 'Unknown'
      if $value eq '';

    $skip = 1
      if defined $block->{'filter'}{$key} &&
      &{ $block->{'filter'}{$key} }($value, $vars);

    if (defined $block->{'rewrite'}{"/$key/"}) {
      my ($search, $replace);
      while (($search, $replace) = each %{ $block->{'rewrite'}{"/$key/"} } ) {
        $value =~ s/$search/$replace/g;
      }
    }

    if (defined $block->{'rewrite'}{"&$key"}) {
      $value = &{ $block->{'rewrite'}{"&$key"} }($value, $vars);
    }

    $value = commify($value)
      if defined $commify{$key};

    $template =~ s/__${key}__/$value/g;
  }

  my ($name, $sub);
  while (($name, $sub) =  each %{ $block->{'subs'} }) {
    $value = &$sub($vars);

    $template =~ s/__${name}__/$value/g
      if defined $value;
  }

  return defined $skip ? undef : $template;
}

# Work out the disk space percentage, possibly setting a flag that we should
# raise an alert.
sub calc_disk_space_percentage {
  my ($used, $total) = @_;

  if (! (defined $used && defined $total) ){
    warn "Something is wrong calculating the disk space percentage.\n";
    return 'unknown';
  }

  # Guard against zero disk space.
  $total = normalise_disk_space($total);
  if ($total == 0) {
    warn "Total disk space is 0 MB, I can't use that to calculate a percentage!\n";
    return 'unknown';
  }

  my $percent = sprintf("%.1f",
    normalise_disk_space($used) / $total * 100);

  if ($percent >= $c->{'disk_space_warn'}) {
    $exit_value ||= 1;
    push @alerts, "DISK SPACE";
    return "$warning$percent\%$normal";
  } else {
    return "$safe$percent\%$normal";
  }
}

# Make sure that the disk space is in a common unit.
# Currently that is MB.
sub normalise_disk_space {
  if ($_[0] =~ /^([.0-9]+) (\w+)$/) {
    my $space = $1;
    my $unit = $2;

    if ($unit eq 'B') {
      return $space / (1024 * 1024);
    } elsif ($unit eq 'KB') {
      return $space / 1024;
    } elsif ($unit eq 'MB') {
      return $space;
    } elsif ($unit eq 'GB') {
      return $space * 1024;
    } elsif ($unit eq 'TB') {
      return $space * 1024 * 1024;
    }

    warn "Unknown unit for disk space: $unit.  Please let the author of mythtv-status know.\n";
    return $space;
  }

  warn "Unrecognised format for disk space: $_[0].  Please let the author of mythtv-status know.\n";
  return $_[0];
}

# Perform the fetch from the MythTV Backend in a child process.
sub xml_fetch {
  my ($url) = @_;

  $| = 1;
  my $pid = pipe_from_fork('CHILD');
  if ($pid) {
    # parent
    my $content_type;
    my $status;

    eval {
      local $SIG{ALRM} = sub { die "alarm\n" };
      alarm(10);
      $content_type = <CHILD>;
      while (<CHILD>) {
        $status .= $_;
      }
      alarm(0);
    };

    # The child didn't get back to us in time, kill them off
    # and forget what they sent us.
    if ($@) {
      $status = undef;
      my $result;
      warn "Our child has stopped talking to us, kill it off.\n";
      do {
	kill 9, $pid;
        $result = waitpid($pid, WNOHANG);
      } while $result > 0;

      die "Unknown error during retrieval of status from the MythTV backend.\n";
    }
    $| = 0;

    if (defined $content_type && $content_type =~ /utf(-)?8/i) {
      $status = decode('UTF-8', $status);
    }
    return ($content_type, $status);
  } else {
    # child
    $0 = "mythtv-status - child";
    my $ua = LWP::UserAgent->new;
    $ua->timeout(30);
    $ua->env_proxy;

    my $response = ua_request_with_timeout($ua, $url);
    die "Sorry, failed to fetch $url: Connection to MythTV timed out.\n"
      unless defined $response;

    # If we get a page doesn't exist, then just ignore it, we need to try
    # fetching the status page from a few different locations.
    if ($response->code == 404) {
      exit 1;
    }

    die "Sorry, failed to fetch $url: " . $response->status_line . "\n"
      unless $response->is_success;

    my $content = $response->decoded_content;
    if ($response->header('Content-Type') =~ /utf(-)?8/i) {
      $content = encode('UTF-8', $content);
    }
    print $response->header('Content-Type') . "\n";
    print $content . "\n";

    exit 0;
  }
}

# simulate open(FOO, "-|")
sub pipe_from_fork ($) {
  my $parent = shift;

  $SIG{CHLD} = 'IGNORE';
  pipe $parent, my $child or die;
  my $pid = fork();
  die "fork() failed: $!" unless defined $pid;

  if ($pid) {
    close $child;
  } else {
    close $parent;
    open(STDOUT, ">&=" . fileno($child)) or die;
  }
  $pid;
}

# Takes a LWP::UserAgent, and a HTTP::Request, returns a HTTP::Request
# Based on:
# http://stackoverflow.com/questions/73308/true-timeout-on-lwpuseragent-request-method
sub ua_request_with_timeout {
  my ($ua, $url) = @_;

  # Get whatever timeout is set for LWP and use that to 
  #  enforce a maximum timeout per request in case of server
  #  deadlock. (This has happened.)
  our $res = undef;
  if( timeout_call( $ua->timeout(), sub {$res = $ua->get($url);}) ) {
      return undef;
  } else {
      return $res;
  }
}

# Beautify numbers by sticking commas in.
sub commify {
  my ($num) = shift;

  $num = reverse $num;
  $num =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g;
  return reverse $num;
}

sub print_version {
  print "mythtv-status, version $VERSION.\n";
  print "Written by Andrew Ruthven <andrew\@etc.gen.nz>\n";
  print "\n";
  exit;
}

=head1 NAME

mythtv-status - Display the status of a MythTV backend

=head1 SYNOPSIS

 mythtv-status [options]

=head1 DESCRIPTION

This script queries a MythTV backend and reports on the status of it,
any upcoming recordings and any which are happening right now.

The intention is to warn you if there is a program being recorded or
about to be recorded.

=head1 OPTIONS

=over

=item B<-c, --colour>

Use colour when showing the status of the encoder(s).

=item B<--date>

Set the date to run as, used for debugging purposes.

=item B<-d, --description>

Display the description for the scheduled recordings.

=item B<--disk-space-warn>

The threshold (in percent) of used disk space that we should show
the disk space in red (if using colour) or send an email if we're
in email mode with email only on warnings.

=item B<--encoder-details>

Display the input ID and channel name against the recording details.

=item B<--encoder-skip-idle>

Suppress displaying idle encoders in the Encoders block.

=item B<-e, --episode>

Display the episode (subtitle) for the scheduled recordings.

=item B<< --email <address>[ --email <address> ...] >>

Send the output to the listed email addresses.  By default the encoder status,
currently recording shows and time till next recording is suppressed from
the email.

To turn the additional blocks on you can use B<--encoders>, B<--recording-now>
and/or B<--next-recording>.

=item B<--email-only-on-alert>

Only send an email out (if --email is present) if there is an alert
(i.e., schedule conflict or low disk space).

=item B<-?, --help>

Display help.

=item B<< --file <file> >>

Load XML from the file specified instead of querying a MythTV backend.
Handy for debugging things.

=item B<< --save-file <file> >>

Save the XML we received from the MythTV backend.
Handy for debugging things.

=item B<< --guide-days-warn <days> >>

Warn if the number of days of guide data present is equal to or below
this level.  Default is 2 days.

=item B<-h HOST, --host=HOST>

The host to check, defaults to localhost.

=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>

Suppress displaying blocks of the output if they would normally be displayed.

=item B<-p PORT, --port=PORT>

The port to use when connecting to MythTV, defaults to 6544.

=item B<--oneliner-bullets>

Insert asterisks (*) before each of the oneliners to stop some
email clients from thinking the oneliner block is a paragraph and
trying to word wrap them.

=item B<--auto-expire>

Display the shows due to auto expire (output is normally suppressed).

=item B<--auto-expire-count>

How many of the auto expire shows to display, defaults to 10.

=item B<--recording-in-warn>

If the "Next Recording In" time is less than this amount, display it
in red.  This in seconds, and defaults to 3600 (1 hour).

=item B<--verbose>

Have slightly more verbose output.  This includes any warnings that might
be generated while parsing the XML.

=item B<-v, --version>

Show the version of mythtv-status and then exit.

=back

=head1 OUTPUT

The output of this script is broken up into several chunks they are:

=over

=item Status

Some general info about the backend, currently just the timestamp of when
this program was run.

=item Guide Data

The number of days of guide data is present.  By default it is only shown
if the number of days is below the warning level.  To show it regardless
of the warning level use --guide-data.

=item Encoders

Each encoder that the backend knows about are listed, with the hostname
they are on, the encoder ID (in brackets) and the current status.

=item Recording Now

Any programs which are being recorded right now.

=item Scheduled Recordings

Up to 10 programs which are scheduled to be recorded today and tomorrow.

=item Schedule Conflicts

Any upcoming schedule conflicts (not just limited to today or tomorrow).

=item Shows due to Auto Expire

The shows which will be deleted and the order they'll be deleted if the
auto expirer kicks in.

=item Total Disk Space

The amount of disk space in total, and used by MythTV.

=item Next Recording In

If there are no recordings currently happening, then the amount of time until
the next recording is displayed.

=item Disk Space

Details about each storage group that MythTV knows about.  By default this
only shows storage groups that are above the warning level.  Use
B<--disk-space> to turn on display of all storage groups.

=back

=head1 RETURN CODES

mythtv-status provides some return codes.

=over

=item 0Z<>

Standard return code

=item 1Z<>

A warning is generated

=back

=head1 AUTHOR

Andrew Ruthven, andrew@etc.gen.nz

=head1 LICENSE

Copyright (c) 2007-2017 Andrew Ruthven <andrew@etc.gen.nz>
This code is hereby licensed for public consumption under the GNU GPL v3.

=cut