root/tv_grab_au @ 190

#!/usr/bin/perl -w

my $version = '0.3.2';

# tv_grab_au
# "Shepherd"
# A wrapper for various Aussie TV guide data grabbers
#
# Use --help for command-line options.
#
# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
# make one cohesive reliable data set. It works by calling a series of
# scripts that grab data from a large variety of sources, and then
# analysing the resulting XML data sets and determining which of the many
# is the most reliable.

# Shepherd runs in 4 passes:
#  pass 1: (tv_grab_au)  Checks that all components are up-to-date, auto-
#                        updates if not.
#                        Passes control onto shepherd
#  pass 2: (shepherd)    calls grabbers to fill in missing data
#  pass 3: (shepherd)    calls reconciler to reconcile overlapping data
#                        and normalize programme titles to our preferred title
#  pass 4: (shepherd)    calls postprocessors to postprocess data
#                        (e.g. flag HDTV programmes, augment with IMDb etc.)

# Changelog:
# 0.2.31  : split tv_grab_au (install/test/upgrade/enable/disable) from
#           shepherd (grab/reconcile/postprocess). Previous changelog history
#           is in shepherd
# 0.3.0   : This split deserves a real version bump, Linc! :)
# 0.3.1   : honour $option_ready

BEGIN { *CORE::GLOBAL::die = \&my_die; }

use strict;
no strict 'refs';

use LWP::UserAgent;
use Sort::Versions;
use Cwd;
use Getopt::Long;
use Data::Dumper;
use XMLTV;
use XMLTV::Ask;
use POSIX qw(strftime mktime);
use Date::Manip;
use Algorithm::Diff;
use List::Compare;
use Compress::Zlib;

# ---------------------------------------------------------------------------
# --- Global Variables
# ---------------------------------------------------------------------------

my $myprogname = 'tv_grab_au';
my $progname = 'shepherd';

my $HOME = 'http://www.whuffy.com/shepherd';

my $invoked = Cwd::realpath($0);
my @options = @ARGV;

# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
# it will try /opt/shepherd/ instead.
my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
chdir($CWD);

my $ARCHIVE_DIR = "$CWD/archive";

my $opt;
my $pref_title_source;
my $mirror_site;
my $debug = 0;
my $components = { };
my $region;
my $channels;
my $opt_channels;
my $config_file =   "$CWD/$progname.conf";
my $channels_file = "$CWD/channels.conf";
my $log_file = "$CWD/$progname.log";
my $days = 7;

# OBSOLETE: will be removed
my $preferred;
my $title_translation_table;
my $pref_order;

# ---------------------------------------------------------------------------
# --- Setup
# ---------------------------------------------------------------------------

# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
Getopt::Long::Configure(qw/pass_through/);

&get_initial_command_line_options;

&capabilities if ($opt->{capabilities});
&description if ($opt->{description});
&version if ($opt->{version});

$| = 1; 
print ucfirst($myprogname) . " v$version\n\n";

&help if ($opt->{help});

&read_config_file;
&read_channels_file;

&get_remaining_command_line_options;

if ($opt->{status})
{
    &status;
    exit;
}

if ($opt->{show_config})
{
    &show_config;
    exit;
}

&open_logfile unless ($opt->{nolog});

&process_setup_commands;

# ---------------------------------------------------------------------------
# --- Update
# ---------------------------------------------------------------------------

unless ($opt->{noupdate})
{
    if (&update()) 
    {
        &write_config_file;
    }
}

if ($opt->{configure})
{
    &configure;
}

# ---------------------------------------------------------------------------
# --- Go!
# ---------------------------------------------------------------------------

unless ($opt->{update})
{
    write_config_file();
    &log("Passing control to Shepherd: $CWD/shepherd @options\n");

    call_prog("$CWD/shepherd @options");
}

&log("Done.\n");
&close_logfile() unless $opt->{nolog};

# ---------------------------------------------------------------------------
# --- Subroutines
# ---------------------------------------------------------------------------

# -----------------------------------------
# Subs: Updates & Installations
# -----------------------------------------

sub update
{
    &log("\nChecking for updates:\n\n");

    my $data = fetch_shepherd_file("status");

    return 0 unless ($data);

    my $made_changes = 0;
    my %clist = %$components;

    while ($data =~ /(\S+)\s+(\S+)\s+(\S+)/g)
    {
        my ($progtype, $proggy, $latestversion) = ($1,$2,$3);
        if (update_component($proggy, $latestversion, $progtype))
        {
            $made_changes = 1;
        }
        delete $clist{$proggy};
    }

    # work out what components disappeared (if any)
    foreach (keys %clist) {
        unless ($components->{$_}->{disabled}) {
            &log("\nDeleted component: $_.\n");
            disable($_, 2);
            $made_changes = 1;
        }
    }
    $made_changes;
}

sub update_component
{
    my ($proggy, $latestversion, $progtype) = @_;

    my $ver = 0;

    if ($progtype eq "shepherd")
    {
        if (-e "$CWD/$proggy")
        {
            $ver = `$CWD/$proggy --version`;
            chop($ver);
        }
    } else {
        $ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e ($progtype . "s/$proggy/$proggy"));
    }

    my $result = versioncmp($ver, $latestversion);
    my $action =    $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
                    $result ==  1 ? "DOWNGRADING" :
                    "up to date";
    &log(sprintf    "* %-40s %30s\n",
                    ucfirst($progtype) . " $proggy" .
                        ($ver ? " v$ver" : '') . "...",
                    $action);
    return 0 unless ($result);
    install($proggy, $latestversion, $progtype, $ver);
    return 1;
}

sub install
{
    my ($proggy, $latestversion, $progtype, $oldver) = @_;
    my $config;

    &log("Downloading $proggy v$latestversion.\n");

    my $rdir = "";
    my $ldir = query_ldir($proggy, $progtype);

    if ($progtype ne "shepherd") {
        $rdir = $progtype . "s";
        -d ("$CWD/$progtype" . "s") 
            or mkdir ("$CWD/$progtype" . "s") 
            or die "Cannot create directory $CWD/$progtype" . "s: $!";
    }
    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!";

    my $newfile = "$ldir/$proggy-$latestversion";
    my $rfile = "$rdir/$proggy";

    return unless (fetch_shepherd_file($rfile, $newfile));

    # Fetch grabber config file
    if ($progtype eq 'grabber')
    {
        $rfile .= ".conf";
        $config = fetch_shepherd_file($rfile);
        return unless ($config); # grabbers MUST have config files
        eval $config;
    }

    # Make component executable
    chmod 0755,$newfile;

    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!";

    if (-e "$ldir/$proggy")
    {
        rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$oldver");
    }
    rename($newfile, "$ldir/$proggy");
    
    &log("Installed $proggy v$latestversion.\n") if ($debug);

    # if the update was for shepherd itself, restart it
    if ($progtype eq "shepherd") {
        &log("\n*** Restarting ***\n\n");
        &close_logfile unless $opt->{nolog};
        exec("$CWD/$myprogname @options");
        # This exits.
        exit(0);
    }

    my $result = test_proggy($proggy, $progtype);

    $components->{$proggy}->{type} = $progtype;
    $components->{$proggy}->{ver} = $latestversion;
    $components->{$proggy}->{ready} = $result;
    $components->{$proggy}->{config} = $config if ($progtype eq 'grabber');

    # If this component was disabled automatically, re-enable it.
    # But if it was disabled manually, leave it off.
    my $d = $components->{$proggy}->{disabled};
    if ($d and $d == 2)
    {
        enable($proggy);
    }

    $components->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));

}

sub fetch_shepherd_file
{
    my ($fn, $store) = @_;

    my $sites = "";
    $sites = "$mirror_site," if ($mirror_site);
    $sites .= $HOME;

    my $ret;
    foreach my $site (split(/,/,$sites)) 
    {
        $ret = fetch_file("$site/$fn", $store, 1);
        return $ret if ($ret);
    }
    return undef;
}

sub test_proggy
{
    my ($proggy, $progtype) = @_;

    &log("Testing $proggy...\n");

    my $ldir = query_ldir($proggy, $progtype);
    my $opt_ready = query_config($proggy, 'option_ready');
    $opt_ready ||= '--version';
    
    chdir($ldir);
    my $result = call_prog(query_filename($proggy, $progtype) . " $opt_ready");
    chdir ($CWD);

    print "Return value: $result\n" if ($debug);

    if ($result)
    {
        &log("\n" . ucfirst($progtype) . " $proggy did not exit cleanly!\n" .
             "It may require configuration.\n\n");
    }
    else
    {
        &log("OK.\n");
    }
    return !$result;
}

sub enable
{
    my $proggy = shift;

    # confirm it exists first
    if (!$components->{$proggy}) {
        printf "No such component: \"%s\".\n",$proggy;
        return;
    }
    print "Enabling $proggy.\n";

    delete $components->{$proggy}->{disabled};
    $components->{$proggy}->{laststatus} = sprintf "enabled on %s, not run yet",(strftime "%a%d%b%y", localtime(time));
}

sub disable
{
    my ($proggy, $n) = @_;

    # confirm it exists first
    if (!$components->{$proggy}) {
        printf "No such component: \"%s\".\n",$proggy;
        return;
    }
    print "Disabling $proggy.\n";
    
    $n ||= 1;
    $components->{$proggy}->{disabled} = $n;
    $components->{$proggy}->{laststatus} = sprintf "manually disabled on %s",(strftime "%a%d%b%y", localtime(time));
}

sub check
{
    my $result;
    foreach my $proggy (keys %$components) {
        my $progtype = $components->{$proggy}->{type};
        $result = test_proggy($proggy, $components->{$proggy}->{type});
        if (!$result ne !$components->{$proggy}->{ready}) {
            $components->{$proggy}->{ready} = $result;
        }
    }
}
# -----------------------------------------
# Subs: Utilities
# -----------------------------------------
#

sub query_grabbers
{
    my ($conf, $val) = @_;
    return query_component_type('grabber',$conf,$val);
}

sub query_reconcilers
{
    return query_component_type('reconciler');
}

sub query_postprocessors
{
    return query_component_type('postprocessor');
}

sub query_component_type
{
    my ($progtype,$conf,$val) = @_;

    my @ret = ();
    foreach (keys %$components)
    {
        if ($components->{$_}->{type} eq $progtype) {
            if (defined $conf) {
                push (@ret, $_) if (query_config($_,$conf) eq $val);
            } else {
                push (@ret, $_);
            }
        }
    }
    return @ret;
}

sub query_name
{
    my $str = shift;
    if ($str =~ /(.*) \[cache\]/)
    {
        return $1;
    }
    return $str;
}

sub query_filename
{
    my ($proggy, $progtype) = @_;

    return query_ldir($proggy, $progtype) . "/$proggy";
}

sub query_ldir
{
    my ($proggy, $progtype) = @_;
    my $ret = $CWD;
    $ret .= ('/' . $progtype . "s/$proggy") if ($progtype ne 'shepherd');
    return $ret;
}

sub query_config
{
    my ($grabber, $key) = @_;

    $grabber = query_name($grabber);
    return undef unless ($components->{$grabber});
    return $components->{$grabber}->{config}->{$key};
}

sub rotate_logfiles
{
    # keep last 4 log files
    my $num;
    for ($num = 4; $num > 0; $num--) {
        my $f1 = sprintf "%s.%d.gz",$log_file,$num;
        my $f2 = sprintf "%s.%d.gz",$log_file,$num+1;
        unlink($f2);
        rename($f1,$f2);
    }

    my $f2 = sprintf "%s.1",$log_file;
    rename($log_file,$f2);
}

sub compress_file
{
    my $infile = shift;
    my $outfile = sprintf "%s.gz",$infile;
    my $gz;

    if (!(open(INFILE,"<$infile"))) {
        warn "could not open file $infile for reading: $!\n";
        return;
    }

    if (!($gz = gzopen($outfile,"wb"))) {
        warn "could not open file $outfile for writing: $!\n";
        return;
    }

    while (<INFILE>) {
        my $byteswritten = $gz->gzwrite($_);
        warn "error writing to compressed file: error $gz->gzerror"
          if ($byteswritten == 0);
    }
    close(INFILE);
    $gz->gzclose();
    unlink($infile);
}

sub open_logfile
{
    &rotate_logfiles;
    printf "Logging to $log_file.\n";
    open(LOG_FILE,">>$log_file") || die "can't open log file $log_file for writing: $!\n";

    my $now = localtime(time);
    printf LOG_FILE "$myprogname version $version started at $now\n\n";

    compress_file($log_file.".1");
}

sub close_logfile
{
    close(LOG_FILE);
}

sub log
{
    my $entry = shift;
    print $entry;
    printf LOG_FILE "%s",$entry unless $opt->{nolog};
}

sub call_prog
{
    my $prog = shift;
    if (!(open(PROG,"$prog|"))) {
        &log("warning: couldn't exec \"$prog\": $!\n");
        return -1;
    }
    while(<PROG>) {
        &log($_);
    }
    close(PROG);

    if ($? == -1) {
        &log("Failed to execute prog: $!\n");
        return -1;
    } elsif ($? & 127) {
        &log((sprintf "prog died with signal %d, %s coredump\n",
          ($? & 127),  ($? & 128) ? "with" : "without"));
        return $?;
    } else {
        &log((sprintf "prog exited with value %d\n", $? >> 8)) if ($debug or $?);
        return ($? >> 8);
    }
}

sub fetch_file
{
    my ($url, $store, $id_self) = @_;

    &log("Fetching $url.\n");
    
    my $ua = LWP::UserAgent->new();
    if ($id_self)
    {
        $ua->agent(ucfirst("$progname/$myprogname/$version"));
    }
    else
    {
        $ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322')
    }

    my $response = $ua->get($url);
    if ($response->is_success())
    {
        if ($store)
        {
            open (FILE, ">$store") 
                or (&log("ERROR: Unable to open $store for writing.\n") and return undef);
            print FILE $response->content();
            close FILE;
            return 1;
        }
        else 
        {
            return $response->content();
        } 
    }
    &log("Failed to retrieve $url!\n" . $response->status_line() . "\n");
    return undef;
}

# -----------------------------------------
# Subs: Setup
# -----------------------------------------

sub read_config_file
{
    read_file($config_file, 'configuration');
}

sub read_channels_file
{
    read_file($channels_file, 'channels');
}

sub read_file
{
    my $fn = shift;
    my $name = shift;

    print "Reading $name file: $fn\n";
    unless (-r $fn)
    {
        unless ($opt->{configure})
        {
            print "\nNo $name file found.\n" .
                  ucfirst($progname) . " must be configured: " .
                  "configuring now.\n\n";
            $opt->{'configure'} = 1;
        }
        return;
    }
    local (@ARGV, $/) = ($fn);
    no warnings 'all';
    eval <>;
    if ($@ and !$opt->{configure})
    {
        warn "\nERROR in $name file! Details:\n$@";
        print "You may wish to CTRL-C and fix this.\n\nContinuing anyway in:";
        foreach (1 .. 5)
        {
            print " " . (6 - $_);
            sleep 1;
        }
        print "\n";
    }
}

sub write_config_file
{
    write_file($config_file, 'configuration', 
        [$region,  $pref_title_source,  $mirror_site,  $components ],
        ["region", "pref_title_source", "mirror_site", "components" ]);
}

sub write_channels_file
{
    write_file($channels_file, 'channels',
        [ $channels,  $opt_channels ],
        [ 'channels', 'opt_channels' ]);
}

sub write_file
{
    my ($fn, $name, $vars, $varnames) = @_;
    open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
    print FN Data::Dumper->Dump($vars, $varnames);
    close FN;
    print "Wrote $name file $fn.\n" if ($debug);
}

sub get_initial_command_line_options
{
  GetOptions( 'config-file=s'   => \$opt->{configfile},
              'help'            => \$opt->{help},
              'configure'       => \$opt->{configure},
              'setmirror=s'     => \$opt->{setmirror},
              'setpreftitle=s'  => \$opt->{setpreftitlesource},
              'clearpreftitle'  => \$opt->{clearpreftitlesource},
              'dontcallgrabbers' => \$opt->{dontcallgrabbers},
              
              # http://xmltv.org/wiki/xmltvcapabilities.html
              'capabilities'    => \$opt->{capabilities},
              'description'     => \$opt->{description},
              'quiet'           => \$opt->{quiet},
              'version'         => \$opt->{version},

              'debug'           => \$debug);
}

sub get_remaining_command_line_options
{
    GetOptions(
              'status'          => \$opt->{status},
              'list'            => \$opt->{list},
              'show-config'     => \$opt->{show_config},

              'update'          => \$opt->{update},
              'noupdate'        => \$opt->{noupdate},

              'disable=s'       => \$opt->{disable},
              'enable=s'        => \$opt->{enable},

              'nolog'           => \$opt->{nolog},

              'days=i'          => \$days,
              'offset=i'        => \$opt->{offset},
              'show-channels'   => \$opt->{show_channels},
              'output=s'        => \$opt->{output},
              'randomize'       => \$opt->{randomize}, # experimental
              'check'           => \$opt->{check}
            );
}

sub process_setup_commands
{
    my @opts = qw( enable disable setorder check \
                   setpreftitlesource clearpreftitlesource setmirror );

    my $run = 0;
    foreach (@opts)
    {
        if ($opt->{$_})
        {
            $run = 1;
            &$_($opt->{$_});
        }
    }
    return unless ($run);
    write_config_file();
    status();
    exit;
}

# if a preferred title source has been specified, add it to our config
sub setpreftitlesource
{
    my $arg = shift;
    $pref_title_source = $arg;
    print "Added preferred title source: $pref_title_source\n";
    1;
}

# if requesting to clear preferred title and we have one, remove it
sub clearpreftitlesource
{
    $pref_title_source = undef;
    print "Removed preferred title source $pref_title_source\n";
    1;
}

# if a mirror has been specified, add it into our config
sub setmirror
{
    my $arg = shift;
    $mirror_site = $arg;
    print "Setting mirror site(s): $mirror_site\n";
}

# -----------------------------------------
# Subs: Configuration
# -----------------------------------------

sub configure
{
    my $REGIONS = {
        "ACT" => 126,
        "NSW: Sydney" => 73,
        "NSW: Newcastle" => 184,
        "NSW: Central Coast" => 66,
        "NSW: Griffith" => 67,
        "NSW: Broken Hill" => 63,
        "NSW: Northern NSW" => 69,
        "NSW: Southern NSW" => 71,
        "NSW: Remote and Central" => 106,
        "NT: Darwin" => 74,
        "NT: Remote & Central" => 108,
        "QLD: Brisbane" => 75,
        "QLD: Gold Coast" => 78,
        "QLD: Regional" => 79,
        "QLD: Remote & Central" => 114,
        "SA: Adelaide" => 81,
        "SA: Renmark" => 82,
        "SA: Riverland" => 83,
        "SA: South East SA" => 85,
        "SA: Spencer Gulf" => 86,
        "SA: Remote & Central" => 107,
        "Tasmania" => 88,
        "VIC: Melbourne" => 94,
        "VIC: Geelong" => 93,
        "VIC: Eastern Victoria" => 90,
        "VIC: Mildura/Sunraysia" => 95,
        "VIC: Western Victoria" => 98,
        "WA: Perth" => 101,
        "WA: Regional" => 102
    };

    print "\nConfiguring.\n\n" .
          "Select your region:\n";
    foreach (sort keys %$REGIONS)
    {
        printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
    }
    $region = ask_choice("Enter region code:", "94", values %$REGIONS);

    print "\nFetching channel information... ";

    my @channellist = get_channels();

    print "done.\n\n" .
          "For each channel you want guide data for, enter an XMLTV id\n" .
          "of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
          "guide data for this channel, just press Enter.\n\n" .
          "Please don't subscribe to unneeded channels.\n\nChannels:\n";
    $channels = {};
    my $line;
    foreach (@channellist)
    {
        $line = ask(" \"$_\"? ");
        $channels->{$_} = $line if ($line);
    }

    print "\nHigh Definition TV (HDTV)\n".
          "Most Australian TV networks broadcast at least some\n".
          "programmes in HDTV each week, but for the most part\n".
          "either upsample SD to HD or play a rolling demonstration\n".
          "HD clip when they don't have the programme in HD format.\n\n".
          "If you have a HDTV capable system and are interested in\n".
          "having Shepherd's postprocessors populate HDTV content\n".
          "then Shepherd will need to know the XMLTV IDs for the HD\n".
          "channels also.\n";
    if (ask_boolean("\nDo you wish to include HDTV channels?")) {
        print "\nFor each channel you want guide data for, enter an XMLTV id\n" .
              "of your choice (e.g. \"sevenhd.free.au\"). If you don't need\n" .
              "guide data for this channel, just press Enter.\n\n";

        $opt_channels = {};
        foreach (@channellist)
        {
            next if (($_ =~ /ABC2/i) || ($_ =~ /SBS News/i) || ($_ =~ /31/));
            $_ .= "HD";
            $line = ask(" \"$_\"? ");
            $opt_channels->{$_} = $line if ($line);
        }
    }


    print "\nWould you like to transition seamlessly from your current grabber?\n\n".
          "Different data sources can have different names for the same show. For\n".
          "example, one grabber might call a show \"Spicks & Specks\" while another\n".
          "calls it \"Spicks and Specks\". These differences can make MythTV think\n".
          "they're actually different shows.\n\n".
          ucfirst($progname) . " is able to merge these differences so that it always\n".
          "presents shows with a consistent name, no matter where it actually sourced\n".
          "show data from. If you'd like, it can also rename shows so they're consistent\n".
          "with whichever grabber you've been using until now.\n\n".
          "The advantage of this is that you should get a smoother transition to\n".
          ucfirst($progname) . ", with no shows changing names and no need to re-create\n".
          "any recording rules. The main disadvantage is that if your previous grabber\n".
          "used an inferior data source -- i.e. it sometimes has typos or less\n".
          "informative program names -- then you'll continue to see these.\n\n".
          "If you were using one of the following grabbers previously AND you want\n".
          ucfirst($progname) . " to use that grabber's program names, select it here.\n\n";

    my $def = "Do not transition; just use best quality titles";
    my %transition = (  "ltd (aka tv_grab_au, versions 1,30, 1.40 or 1.41)" => "yahoo7widget,abc2_website",
                        "OzTivo" => 'oztivo',
                        "Rex" => 'rex',
                        "JRobbo" => 'jrobbo' );
    my $pref = ask_choice("Transition from grabber?", $def,
                $def, keys %transition);
    $pref_title_source = $transition{$pref};
    
    print "\n";
    show_channels();
    unless(ask_boolean("\nCreate configuration file?"))
    {
        print "Aborting configuration.\n";
        exit 0;
    }

    write_config_file();
    write_channels_file();

    print "Finished configuring.\n\n" .
          "Shepherd is installed into $CWD.\n\n";
    
    if ($invoked ne "$CWD/$myprogname" and $invoked =~ /$myprogname/)
    {
        print "Warning: you invoked this program as $invoked.\n" .
            "In the future, it should be run as $CWD/$myprogname,\n" .
            "to avoid constantly re-downloading the latest version.\n\n" .
            "MythTV users may wish to create the following symlink, by " .
            "doing this (as root):\n" .
            "\"ln -s $CWD/$myprogname /usr/bin/tv_grab_au\".\n\n" .
            "You may safely delete $invoked.\n\n";
    }

    status();

    unless (ask_boolean("\nGrab data now?"))
    {
        exit 0;
    }
}

sub get_channels
{
    my @date = localtime;
    my $page = fetch_file(
        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
        ($date[5] + 1900) . "-$date[4]-$date[3]");
    my @channellist;
    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
    {
        push @channellist, $1;
    }
    return @channellist;
}

# -----------------------------------------
# Subs: Status & Help
# -----------------------------------------

sub show_config
{
    print "\nConfiguration\n".
          "-------------\n" .
          "Config file: $config_file\n" .
          "Debug mode : " . is_set($debug) . "\n" .
          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
          "Region ID  : $region\n";
  show_channels();
  print "\n";
  status();
  print "\n";
}

sub show_channels
{
  print "Subscribed channels:\n";
  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
  print "Optional (HDTV) channels:\n";
  print "    $_ -> $opt_channels->{$_}\n" for sort keys %$opt_channels;
}

sub is_set
{
    my $arg = shift;
    return $arg ? "Yes" : "No";
}

sub pretty_print
{
    my ($p, $len) = @_;
    my $spaces = ' ' x (79-$len);
    my $ret = "";

    while (length($p) > 0) {
        if (length($p) <= $len) {
            $ret .= $p;
            $p = "";
        } else {
            # find a space to the left of cutoff
            my $len2 = $len;
            while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
                $len2--;
            }
            if ($len2 == 0) {
                # no space - just print it with cutoff
                $ret .= substr($p,0,$len);
                $p = substr($p,$len,(length($p)-$len));
            } else {
                # print up to space
                $ret .= substr($p,0,$len2);
                $p = substr($p,($len2+1),(length($p)-$len2+1));
            }
            # print whitespace
            $ret .= "\n".$spaces;
        }
    }
    return $ret;
}

sub status
{
    print "\nThe following plugins are known:\n",
          " Type     Name           Version Description\n".
          " -------- -------------- ------- ----------------------------------------------\n";

    foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) {
        printf " %-8s %-15s%7s %46s\n",
          substr($components->{$_}->{type},0,8), 
          length($_) > 15 ? substr($_,0,13).".." : $_,
          ($components->{$_}->{ver} ? substr($components->{$_}->{ver},0,7) : "unknown"),
          (defined $components->{$_}->{config}->{desc} ?
            pretty_print($components->{$_}->{config}->{desc},46) : "");
    }
    printf "\n";

    print "Grabbers, listed in order of quality:\n".
          "                   Enabled/\n".
          " Grabber        Qual Ready Last Run   Status\n" .
          " -------------- ---- ----- ---------- -----------------------------------------\n";
    my %qual_table = ( 3 => "Best", 2 => "Good", 1 => "Avg" );
    foreach (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
        my $h = $components->{$_};
        printf  " %-15s%-4s  %1s/%1s %11s %s\n",
          length($_) > 15 ? substr($_,0,13).".." : $_,
          $qual_table{($h->{config}->{quality})},
          $h->{disabled} ? 'N' : 'Y',
          $h->{ready} ? 'Y' : 'N',
          $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
          $h->{laststatus} ? pretty_print($h->{laststatus},41) : '';
    }

    print "\n".
          "              Enabled/\n".
          " Reconciler     Ready Last Run   Status\n" .
          " -------------- ----- ---------- ----------------------------------------------\n";
    foreach (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
        my $h = $components->{$_};
        printf  " %-15s %1s/%1s %11s %s\n",
          length($_) > 15 ? substr($_,0,13).".." : $_,
          $h->{disabled} ? 'N' : 'Y',
          $h->{ready} ? 'Y' : 'N',
          $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
          $h->{laststatus} ? pretty_print($h->{laststatus},46) : '';
    }

    print "\n".
          "              Enabled/\n".
          " Postprocessor  Ready Last Run   Status\n" .
          " -------------- ----- ---------- ----------------------------------------------\n";
    foreach (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
        my $h = $components->{$_};
        printf  " %-15s %1s/%1s %11s %s\n",
          length($_) > 15 ? substr($_,0,13).".." : $_,
          $h->{disabled} ? 'N' : 'Y',
          $h->{ready} ? 'Y' : 'N',
          $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
          $h->{laststatus} ? pretty_print($h->{laststatus},46) : '';
    }
    printf "\nPreferred titles from grabber '%s'\n",$pref_title_source if ($pref_title_source);
    printf "\n";
}

sub capabilities
{
    print "baseline\nmanualconfig\n";
    exit 0;
}

sub description
{
    print "Australia\n";
    exit 0;
}

sub version
{
    print "$version\n";
    exit 0;
}

sub help
{
    print q{
Command-line options:
    --help                Print this message

    --status              Print a list of grabbers maintained
    --list                Print a detailed list of grabbers
    --setmirror <s>       Set URL <s> as primary location to check for updates

    --configure           Setup
    --show-config         Print setup details

    --setpreftitle <s>    Set preferred 'title' source as grabber <s>
    --clearpreftitle      clear preferred 'title' source

    --disable <s>         Don't ever use grabber/postprocessor <s>
    --enable <s>          Okay, maybe use it again then
    --uninstall <s>       Remove a disabled grabber/postprocessor

    --noupdate            Do not attempt to update before running
    --update              Update only; do not grab data

    --check               Check status of all grabbers and postprocessors

    --capabilities        Report capabilities to XMLTV

    --nolog               Don't write a logfile
};
    exit 0;
}

# -----------------------------------------
# Subs: override handlers for standard perl.
# -----------------------------------------

# ugly hack. please don't try this at home kids!
sub my_die {
    my ($arg,@rest) = @_;
    my ($pack,$file,$line,$sub) = caller(0);

    # check if we are in an eval()
    if ($^S) {
        printf STDERR "  shepherd caught a die() within eval{} from file $file line $line\n";
    } else {
            printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
            if ($arg) {
                CORE::die($arg,@rest);
            } else {
                CORE::die(join("",@rest));
            }
    }
}