root/shepherd @ 94

#!/usr/bin/perl -w

# "Shepherd"

my $version = '0.2.14';

# A wrapper for various Aussie TV guide data grabbers
#
# Use --help for command-line options.
# See shepherd.txt for details.
#
#  A current version of this script, plus a README file, might be here:
#  http://www.whuffy.com/tv_grab_au/
#
# Changelog:
# 0.1.0   : Basic self-updating and grabber management
# 0.2.0   : --configure
# 0.2.1   : Has a home in ~/.shepherd/
# 0.2.2   : --check
# 0.2.3   : Bugfix: archives correctly
# 0.2.5   : Multi-grabber (potentially with partial data)
# 0.2.6   : Postprocessor support
# 0.2.7   : Changed online file structure
# 0.2.8   : Integrated reconciler
# 0.2.9   : Grabber config support
# 0.2.10  : Bugfix: don't call postprocessors that aren't ready,
#           rework accept-data-or-not postprocessor logic
# 0.2.11  : Dedicated external reconciler support
# 0.2.13  : revert 'alawys run' added in 0.2.12, --setorder bugfix
# 0.2.14  : Changed online status file format

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

use strict;

use LWP::Simple;
use Sort::Versions;
use Cwd;
use Getopt::Long;
use Data::Dumper;
use XMLTV;
use XMLTV::Ask;
use DateTime::Format::Strptime;
use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday tv_interval);
use Algorithm::Diff;

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

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";


#### analyzer settings ####

my $timeslot_size = (15 * 60);                  # 15 minute slots
my $channel_ok_threshold_percent = 90;          # 90% these may need to be 
                                                # tweaked but look ok for now
my $postprocessor_ok_threshold_percent = 80;    # 80% these may need to be 
                                                # tweaked but look ok for now
my $postprocessor_disable_failure_threshold = 5;# number of times a 
                                                # postprocessor has to fail 
                                                # in a row before it is 
                                                # automatically disabled

my $opt;
my $pref_order;
my $mirror_site;
my $made_changes = 0;
my $debug = 0;
my $recdebug = 0;
my $components = { };
my $gscore;
my $region;
my $channels;
my $config_file =   "$CWD/$progname.conf";
my $channels_file = "$CWD/channels.conf";
my $days = 7;
my $timeslice;

# postprocessing
my $title_translation_table = { };
my $langs = [ 'en' ];
my $num_timeslots;
my $plugin_data = { };
my $channel_data = { };
my $starttime, my $endtime;
my $input_postprocess_file = "";
my $grabber_data_percent = 0;
my $reconciler_data_percent = 0;

# OBSOLETE: will be removed
my $grabbers;
my $postprocessors;
my $preferred;

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

$| = 1;

print ucfirst($progname) . " v$version\n\n";
#print "Cwd: $CWD.\n";

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

get_initial_command_line_options();

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

unless ($opt->{configure})
{
    read_config_file();
    read_channels_file();
}

get_remaining_command_line_options();

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

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

if ($opt->{enable})
{
    enable($opt->{enable});
}

if ($opt->{disable})
{
    disable($opt->{disable});
}

if ($opt->{setorder})
{
    set_order(0, $opt->{setorder}); 
}

if ($opt->{check})
{
    check();
}

if ($opt->{enable} or
    $opt->{disable} or
    $opt->{setorder} or
    $opt->{check} or
    $opt->{mirror})
{
    set_order(1) if $made_changes;
    write_config_file() if $made_changes;
    status();
    exit;
}

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

unless ($opt->{noupdate})
{
    update($progname, $version);
    set_order(1) if $made_changes;
    write_config_file() if (($made_changes) && (! $opt->{configure}))
}

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

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

unless ($opt->{update})
{
    calc_date_range();
    grab_data();
    reconcile_data();
    postprocess_data();
    output_data();
}

print "Done.\n";

status();
write_config_file();

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

# -----------------------------------------
# Subs: Grabbing
# -----------------------------------------

sub grab_data
{
    my $used_grabbers = 0;
    my $found_data_percent = 0;

    print "\nGrabber stage:\n";

    my $grabber;
    
    while ($grabber = choose_grabber())
    {
        $used_grabbers++;

        $components->{$grabber}->{lastdata} = time;
        $components->{$grabber}->{laststatus} = "unknown";

        printf "\nSHEPHERD: Using grabber: (%d) %s\n", $used_grabbers, $grabber;

        my $output = "$CWD/grabbers/$grabber/output.xmltv";

        my $comm = "$CWD/grabbers/$grabber/$grabber " .
                   "--region $region " .
                   "--output $output";

        # Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
        # that we need. Category 2 grabbers are requested to get everything, since there's
        # very little cost in grabbing that extra data, and we can use it in the reconciler
        # to verify that everything looks OK.
        if ($components->{$grabber}->{config}->{category} == 1)
        {
            print "CAT1 grabber: grabbing timeslice.\n";
            if ($timeslice->{start} != 1)
            {
                $comm .= " " . 
                         $components->{$grabber}->{config}->{option_offset} .
                         " " .
                         ($timeslice->{start} - 1);
            }

            my $n = $timeslice->{stop};
            if ($timeslice->{start} != 1 
                    and 
                !$components->{$grabber}->{config}->{option_offset_eats_days})
            {
                $n -= $timeslice->{start};
            }
            $comm .= " " .
                     $components->{$grabber}->{config}->{option_days} .
                     " " . 
                     $n;
            
            # Write a temporary channels file specifying only the channels we want
            my $tmpchans;
            foreach (@{$timeslice->{chans}})
            {
                $tmpchans->{$_} = $channels->{$_};
            }
            my $tmpcf = "$CWD/channels.conf.tmp";
            write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
            $comm .= " --channels_file $tmpcf";
        }
        else
        {
            $comm .= " --days $days" if ($days);
            $comm .= " --offset $opt->{offset}" if ($opt->{offset});
            $comm .= " --channels_file $channels_file";
        }
        $comm .= " --debug" if ($debug);
        $comm .= " @ARGV" if (@ARGV);

        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
            printf "SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n";
        } else {
            print "SHEPHERD: Excuting command: $comm\n";
            chdir "$CWD/grabbers/$grabber/";
            system($comm);
            chdir $CWD;
        }

        # soak up the data we just collected
        &soak_up_data($grabber, $output, "grabber");
        $components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};

        # check to see if we have all the data we want
        $found_data_percent = &analyze_plugin_data($channel_ok_threshold_percent, "AGGREGATE GRABBER");

        last if ($found_data_percent >= $channel_ok_threshold_percent);
    }


    if ($used_grabbers == 0)
    {
        print "No valid grabbers installed/enabled!\n";
        return;
    }

    if ($found_data_percent < $channel_ok_threshold_percent)
    {
        print "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
        $grabber_data_percent = $found_data_percent;
        return;
    }
}

# 
# 1. If set order, run them in that order
# 2. If first time ever run, run the transition grabber
# 3. Randomly select a grabber with a bias towards efficient and high-quality ones
#
sub choose_grabber
{
    unless (defined $gscore)
    {
        foreach (query_grabbers())
        {
            unless ($components->{$_}->{disabled})
            {
                $gscore->{$_} = 0;
# Cache stuff: not enabled yet
#               if ($components->{$_}->{config}->{category} == 1
#                       and
#                   $components->{$_}->{config}->{cache})
#               {
#                   $gscore->{$_ . ' [cache]'} = 0;
#               }
            }
        }
    }

    # score grabbers
    my $total = score_grabbers();
    return undef unless ($total);
    
    if ($debug)
    {
        print "Grabber selection probabilities:\n";
        foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
        {
            printf "%25s %6.1f%% %12s\n", 
                   $_, 100 * $gscore->{$_} / $total, "($gscore->{$_} pts)";
        }
    }

    return undef unless (scalar keys %$gscore);

    my $r = int(rand($total));

    my $c = 0;
    foreach my $grabber (keys %$gscore)
    {
        next if (!$gscore->{$grabber});
        if ($r >= $c and $r < ($c + $gscore->{$grabber}))
        {
            delete $gscore->{$grabber};
            print "Selected $grabber.\n" if ($debug);
            if ($grabber =~ /(.*) \[cache\]/)
            {
                return $1;
            }
            else
            {
                if ($components->{$grabber}->{config}->{category} == 2)
                {
                    # We might want to run C1 grabbers multiple times
                    # to grab various timeslices, but not C2 grabbers,
                    # which should get everything at once.
                    delete $gscore->{$grabber};
                }
                return $grabber;
            }
        }
        $c += $gscore->{$grabber};
    }
    die "ERROR: failed to choose grabber.";
}

# ****************************************
# Scoring grabbers:
#
# Earn points for each slot you can fill
# Multipliers:
# * C2 grabbers
# * C1 grabbers that have the data we're looking for cached
# * High 'quality' grabbers get a BIG bonus: low-quals should basically 
#   not run unless we need them
# ****************************************
sub score_grabbers
{
    my ($score, $total, $niceness, $granularity, $day, $hits, $cat, $dq, $mult);

    my $missing = detect_missing_data();

    calculate_best_timeslice($missing);
    
    print "Best timeslice: " . Dumper($timeslice) . "\n" if ($debug);

    my $missing_slice = create_missing_slice();

    # So! Compare C2 grabbers against the raw missing file, because we'll get
    # everything. But compare C1 grabbers against the timeslice, because we'll
    # only ask them for a slice. This goes for the [cache] and regular C1s.
    foreach my $grabber (keys %$gscore)
    {
        # for each slot, say whether we can fill it or not -- that is,
        # whether we support this channel and this day #.
        
        $hits = 0;

        if ($grabber =~ /(.*) \[cache\]$/)
        {
            $hits = find_cache_hits($1, $missing);
            $cat = 2;
            $dq = $components->{$1}->{config}->{quality};
        }
        else
        {
            my $key = $missing;
            if ($components->{$grabber}->{config}->{category} == 1)
            {
                $key = $missing_slice;
            }
            foreach my $day (sort keys %$key)
            {
                my $val = supports_day($grabber, $day);
                next unless ($val);
                print "Day $day:";
                foreach my $ch (@{$key->{$day}})
                {
                    if (supports_channel($grabber, $ch))
                    {
                        print " $ch";
                        $hits += $val;
                    }
                }
                print "\n";
                $hits = 1 if ($hits > 0 and $hits < 1);

                $cat = $components->{$grabber}->{config}->{category};
                unless ($cat)
                {
                    print "WARNING: Grabber $grabber has no category support ".
                    "in config.\n";
                    $cat = 1;
                }

                $dq = $components->{$grabber}->{config}->{quality};
                unless ($dq)
                {
                    print "WARNING: Grabber $grabber has no quality support ".
                    "in config.\n";
                    $dq = 1;
                }
            }
        }
        $mult = 1;
        $mult++ if ($cat == 2);
        $mult *= 2 ** ($dq-1);

        $score = int($hits * $mult);
        print "Grabber $grabber can fill $hits slots with multiplier $mult (cat: $cat, dq: $dq): scoring $score pts.\n";
        $gscore->{$grabber} = $score;
        $total += $score;
    }
    return $total;
}

sub supports_channel
{
    my ($grabber, $ch) = @_;

    my $channels_supported = $components->{$grabber}->{config}->{channels};
    unless (defined $channels_supported)
    {
        print "WARNING: Grabber $grabber has no channel support " .
              "specified in config.\n";
        $channels_supported = '';
    }

    return 1 unless ($channels_supported); # Empty string means we support all
    
    my $match = ($channels_supported =~ /\b$ch\b/);
    my $exceptions = ($channels_supported =~/^-/);
    return ($match != $exceptions);
}

sub supports_day
{
    my ($grabber, $day) = @_;

    return 0 unless ($day <= $components->{$grabber}->{config}->{max_days});
    return 0.5 if ($day > $components->{$grabber}->{config}->{max_reliable_days});
    return 1;
}

sub find_cache_hits
{
    my ($grabber, $missing) = @_;

    return 5;
}

# 
# Build a little hash of what channel/day data we're currently missing.
# I think granularity of one day is good for now; could possibly be
# made more fine-grained if we think grabbers will support that.
#
sub detect_missing_data
{
    my $missing = { };

    my $timeslots_per_day = (24 * 60 * 60) / $timeslot_size;

    foreach my $ch (keys %$channels)
    {
        if (defined $channel_data->{$ch})
        {
            for (my $slotnum = 0; $slotnum < $num_timeslots-1; $slotnum++) 
            {
                if (!@{$channel_data->{$ch}->{timeslots}}[$slotnum])
                {
                    my $day = int($slotnum / $timeslots_per_day) + 1;
                    push @{$missing->{$day}}, $ch;
                    $slotnum += $timeslots_per_day -
                                ($slotnum % $timeslots_per_day);

                }
            }
        }
        else
        {
            for my $day (1 .. $days)
            {
                push @{$missing->{$day}}, $ch;
            }
        }

    }

    foreach my $day (keys %$missing)
    {
        $missing->{$day} = [ sort @{$missing->{$day}} ];
    }

    if ($debug)
    {
        print "Need data for days " . join(", ", sort keys %$missing) . ".\n";
    }
    return $missing;
}

sub calculate_best_timeslice
{
    my $missing = shift;

    my ($overlap, $a);
    $timeslice = { 'chandays' => 0 };
    foreach my $day (1 .. $days)
    {
        consider_slice($day, $day, @{$missing->{$day}});
        $overlap = $missing->{$day};
        foreach my $nextday (($day + 1) .. $days)
        {
            last unless ($missing->{$nextday});
            $a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
            # print "Overlap: " . Dumper($a);
            last unless ($a and @{$a});
            consider_slice($day, $nextday, @{$a});
            $overlap = $a;
        }
    }
}

sub consider_slice
{
    my ($startday, $stopday, @chans) = @_;

    my $challenger = ($stopday - $startday + 1) * scalar(@chans);
    return unless ($challenger > $timeslice->{chandays});

    # We have a winner!
    $timeslice->{start} = $startday;
    $timeslice->{stop} = $stopday;
    $timeslice->{chans} = [ @chans ];
    $timeslice->{chandays} = $challenger;
}

sub create_missing_slice
{
    my $ret;

    foreach my $day ($timeslice->{start} .. $timeslice->{stop})
    {
        $ret->{$day} = [ @{$timeslice->{chans}} ];
    }
    return $ret;
}

# interpret xmltv data from this grabber/postprocessor
sub soak_up_data
{
    my ($plugin, $output, $plugintype) = @_;

    if (! -r $output) {
        printf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output;
        return;
    }

    my $parse_start_time = [gettimeofday];
    my $this_plugin = $plugin_data->{$plugin};
    printf STDERR "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output;
    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
    printf STDERR "SHEPHERD: Completed XMLTV parsing from '%s' in %0.2f seconds\n",$plugin,tv_interval($parse_start_time);

    if (!($this_plugin->{xmltv})) {
        printf "WARNING: Plugin %s didn't seem to return any valid XMLTV!\n",$plugin;
        return;
    }

    $this_plugin->{valid} = 1;
    $this_plugin->{output_filename} = $output;

    my $xmltv = $this_plugin->{xmltv};
    my ($encoding, $credits, $chan, $progs) = @$xmltv;
    $this_plugin->{total_duration} = 0;
    $this_plugin->{programmes} = 0;
    $this_plugin->{progs_with_invalid_date} = 0;        # explicitly track unparsable dates
    $this_plugin->{progs_with_unknown_channel} = 0;     # explicitly track unknown channels

    my $strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M %z");
    my $alt_strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M"); # alternate format 1: oztivo doesn't seem to output timezone
    my $seen_channels_with_data = 0;

    #
    # first iterate through all programmes and see if there are any channels we don't know about
    #
    my %chan_xml_list;
    foreach my $ch (sort keys %{$channels}) {
        $chan_xml_list{($channels->{$ch})} = 1;
    }
    foreach my $prog (@$progs) {
        if (!defined $chan_xml_list{($prog->{channel})}) {
            $this_plugin->{progs_with_unknown_channel}++;
            printf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel};
            $chan_xml_list{($prog->{channel})} = 1;     # so we warn only once
        }
    }
        
    # iterate thru channels
    foreach my $ch (sort keys %{$channels}) {
        my $seen_progs_on_this_channel = 0;

        # iterate thru programmes per channel
        foreach my $prog (@$progs) {
            next if ($prog->{channel} ne $channels->{$ch});

            my $t1 = $strptime->parse_datetime($prog->{start});
            my $t2 = $strptime->parse_datetime($prog->{stop});
            $t1 = $alt_strptime->parse_datetime($prog->{start}) if (!$t1);
            $t2 = $alt_strptime->parse_datetime($prog->{stop}) if (!$t2);

            if (!$t1 || !$t2) {
                printf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
                    $plugin,(!$t1 ? $prog->{start} : $prog->{stop}) if (!$this_plugin->{progs_with_invalid_date});
                $this_plugin->{progs_with_invalid_date}++;
                next;
            }

            # store t1 and t2 times in the xmltv data for later on (shh.. ton't tell anyone..)
            $prog->{start_epoch} = $t1->epoch;
            $prog->{stop_epoch} = $t2->epoch;

            # store plugin-specific stats
            $this_plugin->{programmes}++;
            $this_plugin->{total_duration} += ($t2->epoch - $t1->epoch);
            $seen_progs_on_this_channel++;
            $this_plugin->{earliest_data_seen} = $t1->epoch if (!defined $this_plugin->{earliest_data_seen});
            $this_plugin->{earliest_data_seen} = $t1->epoch if ($t1->epoch < $this_plugin->{earliest_data_seen});
            $this_plugin->{latest_data_seen} = $t2->epoch if (!defined $this_plugin->{latest_data_seen});
            $this_plugin->{latest_data_seen} = $t2->epoch if ($t2->epoch > $this_plugin->{latest_data_seen});

            # store channel-specific stats
            $channel_data->{$ch}->{programmes}++;
            $channel_data->{$ch}->{total_duration} += ($t2->epoch - $t1->epoch);

            # store timeslot info
            next if ($t1->epoch > $endtime);    # programme starts after timeslots we are interested .. nice that we have it ... but we really don't care about it!
            next if ($t2->epoch < $starttime);  # programme ends  before timeslots we are interested .. nice that we have it ... but we really don't care about it!
            my $start_slotnum;
            if ($t1->epoch >= $starttime) {
                $start_slotnum = int(($t1->epoch - $starttime) / $timeslot_size);
            } else {
                $start_slotnum = 0;
            }
            my $end_slotnum;
            if ($t2->epoch < $endtime) {
                $end_slotnum = int(($t2->epoch - $starttime) / $timeslot_size);
            } else {
                $end_slotnum = ($num_timeslots-1);
            }

            # add this programme into the global timeslots table for this channel
            foreach my $slotnum ($start_slotnum..$end_slotnum) {
                $channel_data->{$ch}->{timeslots}[$slotnum]++;
            }
        }

        $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
    }

    # print some stats about what we saw!
    printf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
        ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
        int($this_plugin->{total_duration} / 86400),            # days
        int(($this_plugin->{total_duration} % 86400) / 3600),   # hours
        int(($this_plugin->{total_duration} % 3600) / 60),      # mins
        int($this_plugin->{total_duration} % 60),               # sec
        (defined $this_plugin->{earliest_data_seen} ? (strftime "%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
        (defined $this_plugin->{latest_data_seen} ? (strftime "%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '');
    $this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
        $seen_channels_with_data, $this_plugin->{programmes},
        int($this_plugin->{total_duration} / 3600),
        (defined $this_plugin->{earliest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($this_plugin->{earliest_data_seen})) : 'no'),
        (defined $this_plugin->{latest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($this_plugin->{latest_data_seen})) : 'data');

    $plugin_data->{$plugin} = $this_plugin;
}


# analyze grabber data - do we have all the data we want?
# returns percent of data found
sub analyze_plugin_data
{
    my ($threshold,$analysistype) = @_;
    my $total_data_percent = 0, my $total_channels = 0;
    my $statusstring = "";

    # iterate across each channel
    foreach my $ch (sort keys %{$channels}) {
        $total_channels++;
        if (defined $channel_data->{$ch}) {
            my $data_in_channel = 0;
            for my $slotnum (0..($num_timeslots-1)) {
                $data_in_channel++ if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) && ($channel_data->{$ch}->{timeslots}[$slotnum] > 0));
            }

            # do we have enough data for this channel?
            my $data_in_channel_percent = $data_in_channel / ($num_timeslots-1) * 100;
            if ($data_in_channel_percent >= $threshold) {
                $statusstring .= sprintf "%s: %0.1f%% [complete], ",$ch,$data_in_channel_percent;
            } else {
                $statusstring .= sprintf "%s: %0.1f%% [hungry], ",$ch,$data_in_channel_percent;
            }
            $total_data_percent += $data_in_channel_percent;
        } else {
            $statusstring .= sprintf "%s: 0%% [starving], ",$ch;
        }
    }

    if ($total_channels > 0) {
        $total_data_percent = $total_data_percent / $total_channels;
    } else {
        $total_data_percent = 0;
    }

    # print some stats about what our analysis says!
    printf "SHEPHERD: %s ANALYSIS: %sTOTAL %0.2f%% %s %0.2f%%: %s\n",
        uc($analysistype), $statusstring, $total_data_percent,
        ($total_data_percent >= $channel_ok_threshold_percent ? ">" : "<"), $channel_ok_threshold_percent,
        (($total_data_percent < $channel_ok_threshold_percent) ? "WANT MORE DATA" : "COMPLETE");
    return $total_data_percent;
}


# work out date range we are expecting data to be in
sub calc_date_range
{
    # normalize starttime to beginning of hour
    my $now = time;
    my ($sec,$min,@rest) = localtime($now);

    $starttime = $now - ((60 * $min) + $sec);

    if ($days) {
        $endtime = $starttime + ($days * 86400);
    } else {
        $endtime = $starttime + (7*86400);
    }
    $starttime += (86400 * $opt->{offset}) if ($opt->{offset});

    $num_timeslots = ($endtime - $starttime) / $timeslot_size;
}

# -----------------------------------------
# Subs: Reconciling data
# -----------------------------------------

# for all the data we have, try to pick the best bits!
sub reconcile_data
{
    printf "\nReconciling data:\n\n";

    my $num_grabbers = 0;
    my $input_files = "";
    my @input_file_list;

    printf "Preference for whose data we prefer as follows:\n";
    foreach my $proggy (sort { $components->{$a}->{order} <=> $components->{$b}->{order} } query_grabbers()) {
        if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
            $num_grabbers++;
            printf "  %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename};

            $input_files .= $plugin_data->{$proggy}->{output_filename}." ";
            push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
        }
    }

    if ($num_grabbers == 0) {
        die "Nothing to reconcile!  There is no valid grabber data!\n";
    }

    foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
        next if ($components->{$reconciler}->{disabled});
        next if (!$components->{$reconciler}->{ready});

        $reconciler_data_percent = &call_data_processor("reconciler",$reconciler,$input_files);

        if ($reconciler_data_percent < $postprocessor_ok_threshold_percent) {
            # how bad is the data?  is it significantly different to that of what the grabber run finished with?
            # allow at most 15% of the data to go away
            if ($grabber_data_percent > ($reconciler_data_percent + 15)) {
                # urgh.  this reconciler did a bad bad thing ...
                printf "SHEPHERD: XML data from reconciler %s appears bogus, will try to use another reconciler\n",$reconciler;
            } else {
                printf "SHEPHERD: Allowing marginal data from reconciler %s (was %d%%, really wanted at least %d%%)\n",
                  $reconciler,$reconciler_data_percent,$postprocessor_ok_threshold_percent;
                $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
            }
        } else {
            printf "SHEPHERD: Data from reconciler %s looks good (got %d%%, wanted at least %d%%)\n",
              $reconciler,$reconciler_data_percent,$postprocessor_ok_threshold_percent;
            $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
        }

        last if ($input_postprocess_file ne "");
    }

    if ($input_postprocess_file eq "") {
        # no reconcilers worked!!
        printf "SHEPHERD: WARNING: No reconcilers seemed to work!  Falling back to concatenating the data together!\n";

        my %w_args = ();
        $input_postprocess_file = "$CWD/input_preprocess.xmltv";
        my $fh = new IO::File ">$input_postprocess_file" || die "could not open $input_postprocess_file for writing: $!\n";
        %w_args = (OUTPUT => $fh);
        XMLTV::catfiles(\%w_args, @input_file_list);
    }
}


# -----------------------------------------
# Subs: Postprocessing
# -----------------------------------------

sub postprocess_data
{
    # for our first postprocessor, we feed it ALL of the XMLTV files we have
    # as each postprocessor runs, we feed in the output from the previous one
    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
    # reverts back to the previous postprocessor if it was shown to be bad

    # first time around: feed in reconciled data ($input_postprocess_file)

    printf "\nPostprocessing stage:\n";

    foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
        next if ($components->{$postprocessor}->{disabled});
        next if (!$components->{$postprocessor}->{ready});

        my $found_data_percent;
        $found_data_percent = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);

        if ($found_data_percent < $postprocessor_ok_threshold_percent) {
            # how bad is the data?  is it significantly different to that of what the grabber run finished with?
            # allow at most 15% of the data to go away
            if ($grabber_data_percent > ($found_data_percent + 15)) {
                # urgh.  this postprocessor did a bad bad thing ...
                printf "SHEPHERD: XML data from postprocessor %s rejected, using XML from previous stage\n",$postprocessor;

                if (defined $components->{$postprocessor}->{conescutive_failures}) {
                    $components->{$postprocessor}->{conescutive_failures}++;
                } else {
                    $components->{$postprocessor}->{conescutive_failures} = 1;
                }
                printf "SHEPHERD: Postprocessor \"%s\" has now failed %d times in a row.  %d more and it will be automatically disabled.\n",
                    $postprocessor,
                    $components->{$postprocessor}->{conescutive_failures},
                    ($postprocessor_disable_failure_threshold - $components->{$postprocessor}->{conescutive_failures});

                if ($components->{$postprocessor}->{conescutive_failures} >= $postprocessor_disable_failure_threshold) {
                    printf "SHEPHERD: Disabling Postprocessor \"%s\".\n",$postprocessor;
                    $components->{$postprocessor}->{disabled} = 1;
                }
            } else {
                # accept what this postprocessor did to our output ...
                printf "SHEPHERD: accepting output from postprocessor %s, feeding it into next stage\n",$postprocessor;
                $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
                delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
            }
        } else {
            # accept what this postprocessor did to our output ...
            printf "SHEPHERD: accepting output from postprocessor %s, feeding it into next stage\n",$postprocessor;
            $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
            delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
        }
    }
}


# -----------------------------------------
# Subs: Postprocessing/Reconciler helpers
# -----------------------------------------

sub call_data_processor
{
    my ($data_processor_type, $data_processor_name, $input_files) = @_;

    $components->{$data_processor_name}->{lastdata} = time;
    $components->{$data_processor_name}->{laststatus} = "unknown";

    printf "\nSHEPHERD: Using %s: %s\n",$data_processor_type,$data_processor_name;

    my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
    my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
    $comm .= " --region $region" .
             " --channels_file $channels_file" .
             " --output $output";
    $comm .= " --days $days" if ($days);
    $comm .= " --offset $opt->{offset}" if ($opt->{offset});
    $comm .= " --debug" if ($debug);
    $comm .= " @ARGV" if (@ARGV);
    $comm .= " $input_files";
    print "SHEPHERD: Excuting command: $comm\n";

    my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
    chdir $dir;
    system($comm);
    chdir $CWD;

    #
    # soak up the data we just collected and check it
    # YES - these are the SAME routines we used in the previous 'grabber' phase
    # but the difference here is that we clear out our 'channel_data' beforehand
    # so we can independently analyze the impact of this postprocessor.
    # if it clearly returns bad data, don't use that data (go back one step) and
    # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
    #

    # clear out channel_data
    foreach my $ch (keys %{$channels}) {
        delete $channel_data->{$ch};
    }

    # process and analyze it!
    &soak_up_data($data_processor_name, $output, $data_processor_type);
    my $found_data_percent = &analyze_plugin_data($postprocessor_ok_threshold_percent, "POSTPROCESSOR");

    $components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};

    return $found_data_percent;
}


sub output_data
{
    # $input_postprocess_file contains our final output
    # send it to whereever --output told us to!

    my $output_filename = "$CWD/output.xmltv";
    $output_filename = $opt->{output} if ($opt->{output});

    open(OUTFILE,">$output_filename") || die "could not open output file $output_filename for writing: $!\n";

    if (!(open(INFILE,"<$input_postprocess_file"))) {
        printf "WARNING: could not open input file \"%s\": %s\n", $input_postprocess_file, $!;
        printf "Output XMLTV data may be damanged as a result!\n";
    } else {
        while (<INFILE>) {
            print OUTFILE $_;
        }
        close(INFILE);
        close(OUTFILE);
    }

    printf "Final output stored in $output_filename.\n";
}

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

sub update
{
    printf "\nChecking for updates:\n\n";

    my $data = fetch_file("status");

    return unless ($data);

    my %clist = %$components;
    while ($data =~ /(.*):(.*):(.*)/g)
    {
        my ($progtype, $proggy, $latestversion) = ($1,$2,$3);
        # TEMP HACK FOR TRANSITION: REMOVE LATER
        if ($latestversion eq 'shepherd')
        {
            $latestversion = $proggy;
            $proggy = 'shepherd';
        }
        update_component($proggy, $latestversion, $progtype);
        delete $clist{$proggy};
    }

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

}

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

    # handle new installs..
    if ($progtype eq "shepherd") {
        if(! -e "$CWD/$progname") {
            print "Missing: $CWD/$progname\n";
            install($progname, $latestversion, $progtype);
            return;
        }
    } else {
        if (!defined $components->{$proggy} or ! -e ($progtype . "s/$proggy/$proggy")) {
            print "New $progtype: $proggy.\n";
            install($proggy, $latestversion, $progtype);
            return;
        }
        if ($components->{$proggy}->{disabled}) {
            print "Warning: grabber $proggy disabled by config file.\n";
        }
    }

    # upgrade/downgrades
    my $ver;
    if ($progtype eq "shepherd") {
        $ver = $version;
    }
    else {
        $ver = $components->{$proggy}->{ver};
    } 

    my $result = versioncmp($ver, $latestversion);
    if ($result == -1) {
        print "UPGRADING $proggy from v$ver to v$latestversion.\n";
    } elsif ($result == 1) {
        print "DOWNGRADING $proggy from v$ver to v$latestversion.\n";
    } else {
        print "Already have latest version of $proggy: v$ver.\n";
        return;
    }
    install($proggy, $latestversion, $progtype);
}

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

    print "Downloading $proggy v$latestversion.\n";

    my $rdir = "";
    my $ldir = $CWD;
    my $ver = "unknown";

    if ($progtype eq "shepherd") {
        $ver = $version;
    } else {
        $rdir = $progtype . "s";
        $ldir = "$CWD/$progtype" . "s/$proggy";
        $ver = $components->{$proggy}->{ver} if ((defined $components->{$proggy}) && $components->{$proggy}->{ver});
        -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_file($rfile, $newfile));

    if ($progtype ne "shepherd") {    
        # Fetch grabber config file
        $rfile .= ".conf";
        $config = fetch_file($rfile);
        return unless ($config);

        eval $config;
    }

    # Make component executable
    system('chmod u+x ' . $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-$ver");
    }
    rename($newfile, "$ldir/$proggy");
    
    print "Installed $proggy v$latestversion.\n" if ($debug);

    # if the update was for shepherd itself, restart it
    if ($progtype eq "shepherd") {
        print "\n*** Restarting ***\n\n";
        exec("$ldir/$proggy @options");
        # This exits.
    }

    print "Testing $proggy...\n" if ($debug);
    my $result = test_proggy($ldir,"$ldir/$proggy");

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

    $made_changes = 1;
}

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

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

    my $ret;
    foreach my $site (split(/,/,$sites)) 
    {
        printf "Fetching $site/$fn.\n";
        if ($store)
        {
            $ret = LWP::Simple::getstore("$site/$fn", $store);
            return 1 if (is_success($ret));
        }
        else
        {
            $ret = LWP::Simple::get("$site/$fn");
            return $ret if ($ret);
        }
        print "Failed to retrieve $site/$fn.\n";
    }
    return undef;
}

sub test_proggy
{
    my ($testdir,$proggyexec) = @_;

    chdir($testdir);
    system("$proggyexec --ready");
    chdir ($CWD);

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

    print "\nComponent $proggyexec did not exit cleanly!\n" .
         "It may require configuration.\n\n" if ($result);
    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));
    $made_changes = 1;
}

sub disable
{
    my $proggy = shift;

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

    $components->{$proggy}->{disabled} = 1;
    $components->{$proggy}->{laststatus} = sprintf "manually disabled on %s",(strftime "%a%d%b%y", localtime(time));
    $made_changes = 1;
}

sub set_order
{
    my ($quiet,$order) = @_;
    $pref_order = $order if ($order);

    # reset current order to zero
    foreach my $proggy (query_grabbers()) {
        $components->{$proggy}->{order} = 0;
    }

    # and now set order
    my $order_num = 1;
    if ($pref_order) {
        foreach my $proggy (split(/,/,$pref_order)) {
            if (defined $components->{$proggy} and $components->{$proggy}->{type} eq 'grabber') {
                $components->{$proggy}->{order} = $order_num;
                $order_num++;
            }
        }
    }

    # set order of any grabbers not specified in a random manner
    foreach my $proggy (query_grabbers()) {
        if ((!defined $components->{$proggy}->{order}) || ($components->{$proggy}->{order} == 0)) {
            $components->{$proggy}->{order} = $order_num+int(rand(1000));
        }
    }

    # .. and finally normalize the order (& show the user the order we chose)
    print "Grabber order set as follows:\n" unless $quiet;
    $order_num = 0;
    foreach my $proggy (sort { $components->{$a}->{order} <=> $components->{$b}->{order} } query_grabbers()) {
        $order_num++;
        $components->{$proggy}->{order} = $order_num;
        printf " #%d. %s%s\n",$components->{$proggy}->{order},$proggy,($components->{$proggy}->{disabled} ? " [disabled]" : "") unless $quiet;
    }

    $made_changes = 1;
}

sub check
{
    my $result;
    foreach my $proggy (keys %$components) {
        my $progtype = $components->{$proggy}->{type};
        $result = test_proggy("$CWD/$progtype" . "s/$proggy", "$CWD/$progtype" . "s/$proggy/$proggy");
        printf "%s %s: %s\n",ucfirst($progtype), $proggy,($result ? "OK" : "Failed");
        if (!$result ne !$components->{$proggy}->{ready}) {
            $components->{$proggy}->{ready} = $result;
            $made_changes = 1;
        }
    }
}
# -----------------------------------------
# Subs: Utilities
# -----------------------------------------
#

sub query_grabbers
{
    return query_component_type('grabber');
}

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

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

sub query_component_type
{
    my $progtype = shift;

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

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

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

    # TEMPORARY! Convert old $grabbers/$postprocessors config file to
    # new $components format.
    if (defined $grabbers or defined $postprocessors)
    {
        foreach (keys %$grabbers) {
            $grabbers->{$_}->{type} = 'grabber';
        }
        foreach (keys %$postprocessors) {
            $postprocessors->{$_}->{type} = 'postprocessor';
        }
        $components = { %$grabbers, %$postprocessors };
        $grabbers = undef;
        $postprocessors = undef;
    }


    # if we are updating from a previous rev of shepherd.conf we may not
    # have any 'order' fields set .. check here
    my $found_order = 1;
    foreach (query_grabbers())
    {
        $found_order = 0 if (!defined $components->{$_}->{order});
    }
    if (($found_order == 0) && (!$opt->{setorder}))
    {
        # at least one 'order' was missing .. we need to put it in!
        printf "Legacy shepherd.conf file didn't contain any grabber order! Automatically updating using a random order, use --setorder to manually set this if you care.\n";
        &set_order(1);
    }

    # if a mirror has been specified, add it into our config
    if ($opt->{mirror}) {
        $mirror_site = $opt->{mirror};
        $made_changes = 1;
        print "Adding mirror: $mirror_site\n";
    }
}

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_order,  $mirror_site,  $components, $title_translation_table  ],
        ["region", "pref_order", "mirror_site", "components", "title_translation_table" ]);
}

sub write_channels_file
{
    write_file($channels_file, 'channels', [ $channels ], [ '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},
              'mirror=s'        => \$opt->{mirror},
              'dontcallgrabbers' => \$opt->{dontcallgrabbers},
              'debug'           => \$debug);
}

sub get_remaining_command_line_options
{
    GetOptions(
              'version'         => \$opt->{status},
              '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},
              'setorder=s'      => \$opt->{setorder},

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


# -----------------------------------------
# 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 "\nRandomly selecting grabber order.\n\n";
    set_order(0);

    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/$progname" and $invoked =~ /$progname/)
    {
        print "Warning: you invoked this program as $invoked.\n" .
            "In the future, it should be run as $CWD/$progname,\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/$progname /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 = LWP::Simple::get(
        "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;
}

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

sub status
{
    print " Grabber           Version Enabled Ready Last Run   Status\n" .
          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
    foreach (sort { $components->{$a}->{order} <=> $components->{$b}->{order} } query_grabbers()) {
        my $h = $components->{$_};
        printf  " %-16s %8s %4s %6s  %11s %s\n",
                "$h->{order}. $_",
                ($h->{ver} ? $h->{ver} : "unknown"),
                $h->{disabled} ? '' : 'Y',
                $h->{ready} ? 'Y' : '',
                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
                $h->{laststatus} ? $h->{laststatus} : '';
    }
    printf "Grabbers shown in order of preference.\n\n";

    print " Reconciler        Version Enabled Ready Last Run   Status\n" .
          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
    foreach (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
        my $h = $components->{$_};
        printf  " %-16s %8s %4s %6s  %11s %s\n",
                $_,
                ($h->{ver} ? $h->{ver} : "unknown"),
                $h->{disabled} ? '' : 'Y',
                $h->{ready} ? 'Y' : '',
                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
                $h->{laststatus} ? $h->{laststatus} : '';
    }

    print " Postprocessor     Version Enabled Ready Last Run   Status\n" .
          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
    foreach (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
        my $h = $components->{$_};
        printf  " %-16s %8s %4s %6s  %11s %s\n",
                $_,
                ($h->{ver} ? $h->{ver} : "unknown"),
                $h->{disabled} ? '' : 'Y',
                $h->{ready} ? 'Y' : '',
                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
                $h->{laststatus} ? $h->{laststatus} : '';
    }
    printf "Reconcilers and Postprocessors shown in order of execution.\n\n";
}

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
    --mirror <s>          Set URL <s> as primary location to check for updates

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

    --setorder <s>        Set order of grabbers to <s> (comma-seperated list of grabbers)

    --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
};
    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));
            }
    }
}