root/shepherd @ 191

#!/usr/bin/perl -w

# "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.)

my $version = '0.2.33';

# 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
# 0.2.15  : Intelli-random grabber ordering now kinda works
# 0.2.16  : config logic for HD channels
# 0.2.17  : bugfix timezone bogosities
# 0.2.18  : care less about missing data in early-morning/overnight
#           care more about missing data in evening/night
# 0.2.22  : remove ->{order}, order is now set by quality
#           explicitly tell reconciler the preferred _title_ source
# 0.2.24  : logging and log files
# 0.2.25  : use open-with-pipe rather than system() and look at
#           return codes from called programmes
# 0.2.27  : Identify self in useragent when fetching shepherd files
# 0.2.28  : Changing status file format again
# 0.2.30  : Run transitional grabber(s) as a once-off to establish preferred
#           title translations.
# 0.2.31  : split tv_grab_au (install/test/upgrade/enable/disable) from
#           shepherd (grab/reconcile/postprocess)
# 0.2.33  : remove logging (tv_grab_au does it for us)

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

use strict;
no strict 'refs';

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

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

my $progname = 'shepherd';

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

#### analyzer settings ####
# the following thresholds are used to control whether we keep calling grabbers or
# not.

my %policy;
$policy{timeslot_size} = (5 * 60);      # 5 minute slots

# PEAK timeslots -
#  between 4.30pm and 11.30pm every day, only allow a maximum of 
#  15 minutes "programming data" missing
#  if there is more than this, we will continue asking grabbers for more
#  programming on this channel
$policy{peak_max_missing} = 15*60;              # up to 15 mins max allowed missing
$policy{peak_start} = (16*(60*60))+(30*60);     # 4.30pm
$policy{peak_stop} = (23*(60*60))+(30*60);      # 11.30pm

# NON-PEAK timeslots -
#  between midnight and 6.15am every day, only allow up to 6 hours missing
#  if there is more than this, we will continue asking grabbers for more
#  programming on this channel
$policy{nonpeak_max_missing} = 6*(60*60);       # up to 6 hours can be missing
$policy{nonpeak_start} = 0;                     # midnight
$policy{nonpeak_stop} = (6*(60*60))+(15*60);    # 6.15am

# all other timeslots - (6.15am-4.30pm, 11.30pm-midnight)
#  allow up to 60 minutes maximum missing programming
$policy{other_max_missing} = 60*60;             # up to 60 mins max allowed missing

# if a postprocessor failed 5 times in a row, automatically disable it
$policy{postprocessor_disable_failure_threshold} = 5;

#### end analyzer section ####

my $opt;
my $pref_title_source;
my $mirror_site;
my $debug = 0;
my $components = { };
my $gscore;
my $region;
my $channels;
my $opt_channels;
my $config_file =   "$CWD/$progname.conf";
my $channels_file = "$CWD/channels.conf";
my $days = 7;
my $missing;
my $timeslice;
my $grabbed;
my $gmt_offset;
my $grabber_found_all_data;

# postprocessing
my $langs = [ 'en' ];
my $plugin_data = { };
my $channel_data = { };
my $reconciler_found_all_data;
my $input_postprocess_file = "";

# 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;
&version if ($opt->{version});

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

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

&read_config_file;
&read_channels_file;

&get_remaining_command_line_options;

&process_setup_commands;

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

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

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

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

sub grab_data
{
    my $used_grabbers = 0;

    printf "\nGrabber stage.\n";

    &analyze_plugin_data("",1);    

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

        $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 (query_config($grabber, 'category') == 1)
        {
            printf "$grabber is Category 1: grabbing timeslice.\n" if ($debug);

            record_requested_chandays($grabber, $timeslice);

            if ($timeslice->{start} != 0)
            {
                $comm .= " " . 
                         query_config($grabber, 'option_days_offset') .
                         " " .
                         $timeslice->{start};
            }

            my $n = $timeslice->{stop} + 1;
            if ($timeslice->{start} != 0 
                    and 
                !query_config($grabber, 'option_offset_eats_days'))
            {
                $n -= $timeslice->{start};
            }
            $comm .= " " .
                     query_config($grabber, '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
        {
            printf "$grabber is category 2: grabbing everything.\n" if ($debug);
            $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);

        my $retval = 0;
        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
            printf "SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n";
            printf "SHEPHERD: would have called: $comm\n" if ($debug);
        } else {
            printf "SHEPHERD: Excuting command: $comm\n";
            chdir "$CWD/grabbers/$grabber/";
            $retval = call_prog($comm);
            chdir $CWD;
        }

        if ($retval != 0) {
            printf "grabber returned with non-zero return code $retval: assuming it failed.\n";
            next;
        }

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

        # check to see if we have all the data we want
        $grabber_found_all_data = &analyze_plugin_data("analysis of all grabbers so far");

        # Record what we grabbed from cacheable C1 grabbers
        if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
        {
            my $missing_before = convert_dayhash_to_list($missing);
            my $missing_after = convert_dayhash_to_list(detect_missing_data());
            my $list = List::Compare->new($missing_before, $missing_after);
            my @grabbed = $list->get_symmetric_difference();
            printf "Grabbed: " . join (', ', @grabbed) . ".\n" if ($debug);
            record_cached($grabber, @grabbed);
            write_config_file();
        }

        last if ($grabber_found_all_data);
    }


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

    unless ($grabber_found_all_data)
    {
        printf "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
        return;
    }
}

# -----------------------------------------
# Subs: Intelli-random grabber selection
# -----------------------------------------

sub choose_grabber
{
    if (defined $gscore)        # Reset score hash
    {
        foreach (keys %$gscore)
        {
            $gscore->{$_} = 0;
        }
    }
    else                        # Create score hash
    {
        foreach (query_grabbers())
        {
            unless ($components->{$_}->{disabled})
            {
                $gscore->{$_} = 0;
                if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
                {
                    $gscore->{$_ . ' [cache]'} = 0;
                }
            }
        }
    }

    $missing = detect_missing_data();
    $timeslice = find_best_timeslice();

    if ($debug)
    {
        printf "Best timeslice: day%s of channels %s (%d chandays).\n",
                    ($timeslice->{start} == $timeslice->{stop} ?
                        " $timeslice->{start}" :
                        "s $timeslice->{start} - $timeslice->{stop}"),
                    join(', ', @{$timeslice->{chans}}),
                    $timeslice->{chandays};
    }

    my $total = score_grabbers();
 
    if ($debug)
    {
        printf "Grabber selection:\n";
        foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
        {
            next if ($_ =~ /\[cache\]/);

            my $score  = $gscore->{$_};
            my $cscore = $gscore->{"$_ [cache]"};
            my $cstr   = $cscore ? "(inc. $cscore cache pts)" : "";

            if ($opt->{randomize})
            {
                printf "%15s %6.1f%% %9s %s\n", 
                        $_, 
                        ($total ? 100* $score / $total : 0), 
                        "$score pts",
                        $cstr;
            }
            else
            {
                printf "%15s %4s pts %s\n", 
                        $_, 
                        $score,
                        $cstr;
            }
        }
    }

    return undef unless ($total);

    # Select a grabber

    # If the user has specified a pref_title_source -- i.e. he is
    # transitioning from a known grabber -- then we make sure it
    # has run at least once, to build the list of title translations.
    if ($pref_title_source)
    {
        my @prefs = split(/,/, $pref_title_source);
        foreach my $grabber (@prefs)
        {
            unless ($components->{$grabber}->{lastdata})
            {
                printf "Need to build title translation list for transitional grabber $grabber.\n";
                return select_grabber($grabber, $gscore) if ($gscore->{$grabber});
                printf "WARNING: Can't run $grabber to build title translation list!\n";
            }
        }
    }

    # Either do it randomly based on scores, or just return the
    # highest-scoring grabber, depending on whether --randomize has
    # been used.

    my $r = int(rand($total));
    my $c = 0;
    my $best;

    foreach my $grabber (keys %$gscore)
    {
        next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
        if ($opt->{randomize})
        {
            if ($r >= $c and $r < ($c + $gscore->{$grabber}))
            {
                return select_grabber($grabber, $gscore);
            }
            $c += $gscore->{$grabber};
        }
        else
        {
            if (!$best or $gscore->{$grabber} > $gscore->{$best})
            {
                $best = $grabber;
            }
        }
    }

    if ($opt->{randomize} or !$best)
    {
        die "ERROR: failed to choose grabber.";
    }
    return select_grabber($best, $gscore);
}

sub select_grabber
{
    my ($grabber, $gscore) = @_;

    printf "Selected $grabber.\n" if ($debug);
    if (query_config($grabber, '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;
}

# Grabbers earn 1 point for each slot or chanday they can fill.
# This score is multiplied if the grabber:
# * is a category 2 grabber (i.e. fast/cheap)
# * is a category 1 grabber that has the data we want in a cache
# * can supply high-quality data
# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
sub score_grabbers
{
    my ($score, $total, $day, $catbonus, $dqbonus, $mult, $key);

    my $bestdq = 0;

    # 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 #.

        my $hits = 0;
        my $cat = query_config($grabber, 'category');
        my $dq = query_config($grabber, 'quality');

        if ($cat == 1)
        {
            $key = cut_down_missing($grabber);
            # printf "Grabber $grabber is Category 1: comparing capability to best timeslice.\n" if ($debug);
        }
        else
        {
            $key = $missing;
            # printf "Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n" if ($debug);
        }

        if ($grabber =~ /\[cache\]/)
        {
            $hits = find_cache_hits($grabber, $key);
        }
        else
        {
            foreach my $day (sort keys %$key)
            {
                my $val = supports_day($grabber, $day);
                next unless ($val);
                # printf "Day $day:" if ($debug);
                foreach my $ch (@{$key->{$day}})
                {
                    if (supports_channel($grabber, $ch, $day))
                    {
                        # printf " $ch" if ($debug);
                        $hits += $val;
                    }
                }
                # printf "\n" if $debug;
                $hits = 1 if ($hits > 0 and $hits < 1);
            }
        }

        my $catbonus = 1;
        $catbonus = 3 if ($cat == 2);
        if ($grabber =~ /\[cache\]/)
        {
            # Bonus is on a sliding scale between 1 and 2 depending on 
            # % of required data in cache
            $catbonus += $hits / $timeslice->{chandays};
        }

        my $dqbonus = 2 ** ($dq-1);

        my $mult = $dq ** $catbonus;

        my $score = int($hits * $mult);

        if ($debug)
        {
            my $str = sprintf "Grabber %s can supply %d chandays",
                                $grabber, $hits;
            if ($hits)
            {
                $str .= sprintf " at x%.1f (cat: %d, DQ: %d): %d pts",
                            $mult,
                            $cat,
                            $dq,
                            $score;
            }
            printf "$str.\n";
        }

        $gscore->{$grabber} += $score;
        $total += $score;
        if ($grabber =~ /\[cache\]/)
        {
            $gscore->{query_name($grabber)} += $score;
        }

        if ($score and $dq > $bestdq)
        {
            $bestdq = $dq;
        }
    }

    # Eliminate grabbers of data quality 1 if there are any better-quality
    # alternatives when using randomize.
    if ($opt->{randomize})
    {
        foreach (keys %$gscore)
        {
            if ($gscore->{$_}
                    and
                query_config($_, 'quality') == 1
                    and
                $bestdq > 1)
            {
                $total -= $gscore->{$_};
                $gscore->{$_} = 0;
                printf "Zeroing grabber $_ due to low data quality.\n" if ($debug);
            }
        }
    }

    return $total;
}

# Return 1 if the grabber can provide data for this channel, else 0.
sub supports_channel
{
    my ($grabber, $ch, $day) = @_;

    my $mdpc = query_config($grabber, 'max_days_per_chan');
    if ($mdpc)
    {
        if ($mdpc->{$ch})
        {
            return ($mdpc->{$ch} > $day);
        }
    }

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

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

# Return 0 if the grabber can't provide data for this day,
# 1 if it can reliably, and 0.5 if it can unreliably.
#
# Note that a max_days of 7 means the grabber can retrieve data for
# today plus 6 days.
sub supports_day
{
    my ($grabber, $day) = @_;

    return 0 unless ($day < query_config($grabber, 'max_days'));
    return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
    return 1;
}

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

    $grabber = query_name($grabber);

    return 0 unless ($components->{$grabber}->{cached});

    my $hits = 0;

    foreach my $day (keys %$key)
    {
        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
        foreach my $ch (@{$key->{$day}})
        {
            $hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
        }
    }
    return $hits;
}

# Build a dayhash 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 $m = { };

    my $chandays = 0;
    foreach my $ch (keys %$channels)
    {
        # is this channel missing too much data?
        unless ($channel_data->{$ch}->{analysis}->{data_ok}) {
            # not ok - record which days are bad
            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) {
                push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
            }
        }
    }

    foreach my $day (keys %$m)
    {
        $m->{$day} = [ sort @{$m->{$day}} ];
        $chandays += scalar(@{$m->{$day}}) if ($debug);
    }

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

# Find the largest timeslice in the current $missing dayhash; i.e.
# something like "Days 4 - 6 of ABC and SBS." This works by iterating
# through the days and looking for overlaps where consecutive days
# want the same channels.
sub find_best_timeslice
{
    my ($overlap, $a);
    my $slice = { 'chandays' => 0 };

    foreach my $day (0 .. $days-1)
    {
        consider_slice($slice, $day, $day, @{$missing->{$day}});
        $overlap = $missing->{$day};
        foreach my $nextday (($day + 1) .. $days-1)
        {
            last unless ($missing->{$nextday});
            $a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
            last unless ($a and @{$a});
            consider_slice($slice, $day, $nextday, @{$a});
            $overlap = $a;
        }
    }
    return $slice;
}

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

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

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

# Record what a cacheable C1 grabber has just retrieved for us,
# so we know next time that this data can be grabbed quickly.
sub record_cached
{
    my ($grabber, @grabbed) = @_;

    printf "Recording cache for grabber $grabber.\n" if ($debug);

    my $gcache = $components->{$grabber}->{cached};
    $gcache = [ ] unless ($gcache);
    my @newcache;
    my $today = strftime("%Y%m%d", localtime);

    # remove old chandays
    foreach my $chanday (@$gcache)
    {
        $chanday =~ /(\d+):(.*)/;
        if ($1 >= $today)
        {
            push (@newcache, $chanday);
        }
    }

    # record new chandays
    foreach my $chanday (@grabbed)
    {
        push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
    }
    $components->{$grabber}->{cached} = [ @newcache ];
}

# Takes a dayhash and returns it as a list like this:
# ( "20061018:ABC", "20061018:Seven", ... )
sub convert_dayhash_to_list
{
    my $h = shift;

    my @ret;
    foreach my $day (keys %$h)
    {
        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
        foreach my $ch (@{$h->{$day}})
        {
            push (@ret, "$date:$ch");
        }
    }
    @ret = sort @ret;
    return \@ret;
}

# If we're about to re-try a grabber, make sure that we're not asking
# it for the same data. That is, prevent a broken C1 grabber causing
# an infinite loop.
sub record_requested_chandays
{
    my ($grabber, $slice) = @_;

    printf "Recording timeslice request; will not request these chandays " .
         "from $grabber again.\n" if ($debug);

    my @requested;
    for my $day ($slice->{start} .. $slice->{stop})
    {
        foreach my $ch (@{$slice->{chans}})
        {
            push @requested, "$day:$ch";
        }
    }
    if ($grabbed->{$grabber})
    {
        push @{$grabbed->{$grabber}}, @requested;
    }
    else
    {
        $grabbed->{$grabber} = [ @requested ];
    }
}

# If this grabber has been called previously, remove those chandays
# from the current request -- we don't want to ask it over and over
# for a timeslice that it has already failed to provide.
sub cut_down_missing
{
    my $grabber = shift;

    $grabber = query_name($grabber);
    my $dayhash = {};

    # Take the timeslice and expand it to a dayhash, while pruning
    # any chandays that have previously been requested from this
    # grabber.
    foreach my $day ($timeslice->{start} .. $timeslice->{stop})
    {
        my @chans;
        foreach my $ch (@{$timeslice->{chans}})
        {
            unless ($grabbed->{$grabber} and grep(/$day:$ch/, @{$grabbed->{$grabber}}))
            {
                push (@chans, $ch)
            }
        }
        $dayhash->{$day} = [ @chans ] if (@chans);
    }

    return $dayhash;
}

# -----------------------------------------
# Subs: Analyzing data
# -----------------------------------------

# 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 $this_plugin = $plugin_data->{$plugin};
    printf "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 "SHEPHERD: Completed XMLTV parsing from '%s'\n",$plugin;

    if (!($this_plugin->{xmltv})) {
        printf "WARNING: Plugin $plugin didn't seem to return any valid XMLTV!\n";
        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 $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 = &parse_xmltv_date($prog->{start});
            my $t2 = &parse_xmltv_date($prog->{stop});

            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 plugin-specific stats
            $this_plugin->{programmes}++;
            $this_plugin->{total_duration} += ($t2 - $t1);
            $seen_progs_on_this_channel++;
            $this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
            $this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
            $this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
            $this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});

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

            # programme is outside the timeslots we are interested in.
            next if ($t1 > $policy{endtime});
            next if ($t2 < $policy{starttime});

            # store timeslot info
            my $start_slotnum = 0;
            $start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
                if ($t1 >= $policy{starttime});

            my $end_slotnum = ($policy{num_timeslots}-1);
            $end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
                if ($t2 < $policy{endtime});

            # 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", localtime($this_plugin->{earliest_data_seen})) : 'no'),
        (defined $this_plugin->{latest_data_seen} ? (strftime "%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');

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


# analyze grabber data - do we have all the data we want?
sub analyze_plugin_data
{
    my ($analysistype,$quiet) = @_;
    printf "SHEPHERD: $analysistype:\n" unless $quiet;

    my $total_channels = 0;

    my $overall_data_ok = 1; # until proven otherwise

    # iterate across each channel
    foreach my $ch (sort keys %{$channels}) {
        $total_channels++;

        my $data;
        my $lastpol = "";
        $data->{data_ok} = 1; # unless proven otherwise
        $data->{have} = 0;
        $data->{missing} = 0;

        for my $slotnum (0..($policy{num_timeslots}-1)) {
            my $bucket_start_offset = ($slotnum * $policy{timeslot_size});

            # work out day number of when this bucket is.
            # number from 0 onwards.  (i.e. today=0).
            # for a typical 7 day grabber this will actually mean 8 days of data (0-7)
            # with days 0 and 7 truncated to half-days
            my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);

            if (!defined $data->{day}->[$day]) {
                $data->{day}->[$day]->{num} = $day;
                $data->{day}->[$day]->{have} = 0;
                $data->{day}->[$day]->{missing} = 0;
                $data->{day}->[$day]->{missing_peak} = 0;
                $data->{day}->[$day]->{missing_nonpeak} = 0;
                $data->{day}->[$day]->{missing_other} = 0;

                $data->{day}->[$day]->{day_ok} = 1; # until proven otherwise

                # day changed, dump any 'already_missing' data
                &dump_already_missing($data);
            }

            # we have programming data for this bucket.  great!  process next bucket
            if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
                ($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) {

                # if we have missing data queued up, push it now
                &dump_already_missing($data);

                &dump_already_missing_period($data->{day}->[$day],$lastpol)
                  if ($lastpol ne "");

                $data->{day}->[$day]->{have} += $policy{timeslot_size};
                $data->{have} += $policy{timeslot_size};
                next;
            }

            # we don't have programming for this channel for this bucket

            # some grabbers take HOURS to run. if this bucket (missing data) is for
            # a time period now in the past, then don't include it
            next if (($bucket_start_offset + $policy{starttime}) < time);

            # work out the localtime of when this bucket is
            my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;

            # store details of where we are missing data
            if (!defined $data->{already_missing}) {
                $data->{already_missing} = sprintf "#%d/%02d:%02d",
                  $day,
                  int($bucket_seconds_offset / 3600),
                  int(($bucket_seconds_offset % 3600) / 60);
            }
            $data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;

            $data->{day}->[$day]->{missing} += $policy{timeslot_size};
            $data->{missing} += $policy{timeslot_size};

            # work out what policy missing data for this bucket fits into
            my $pol;
            if (($bucket_seconds_offset >= $policy{peak_start}) &&
                (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
                $pol = "peak";
            } elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
                     (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
                $pol = "nonpeak";
            } else {
                $pol = "other";
            }

            &dump_already_missing_period($data->{day}->[$day],$lastpol)
              if (($lastpol ne $pol) && ($lastpol ne ""));

            $lastpol = $pol;

            $data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};

            $data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
              if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
            $data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;

            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
            $data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
            $overall_data_ok = 0 if ($data->{data_ok} == 0);
        }

        # finished all timeslots in this channel.
        # if we have missing data queued up, push it now
        &dump_already_missing($data);

        # fill in any last missing period data
        foreach my $day (@{($data->{day})}) {
            &dump_already_missing_period($day,"peak");
            &dump_already_missing_period($day,"nonpeak");
            &dump_already_missing_period($day,"other");
        }

        my $statusstring = sprintf " > ch %s: %s programming: %s\n", 
          $ch, pretty_duration($data->{have}),
          $data->{data_ok} ? "PASS (within thresholds)" : "FAIL, missing data over policy threshold:";

        # display per-day missing data statistics
        foreach my $day (@{($data->{day})}) {
            unless ($day->{day_ok}) {
                $statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": ";

                # do we have any data for this day?
                $statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
                  if (($day->{missing_peak}) && ($day->{missing_peak} > $policy{peak_max_missing}));

                $statusstring .= sprintf "%snon-peak %s",
                  ($day->{missing_peak} ? " / " : ""),
                  join(", ",(@{($day->{missing_nonpeak_table})}))
                  if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak} > $policy{nonpeak_max_missing}));

                $statusstring .= sprintf "%sother %s",
                  (($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
                  join(", ",(@{($day->{missing_other_table})}))
                  if (($day->{missing_other}) && ($day->{missing_other} > $policy{other_max_missing}));

                $statusstring .= "\n";
            }
        }
        printf $statusstring unless $quiet;

        delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
        $channel_data->{$ch}->{analysis} = $data;
    }

    printf " > OVERALL: %s\n", ($overall_data_ok ? "PASS" : "FAIL") unless $quiet;

    return $overall_data_ok; # return 1 for good, 0 for need more
}

# helper routine for filling in 'missing_all' array
sub dump_already_missing
{
    my $d = shift;
    if (defined $d->{already_missing}) {
        $d->{already_missing} .= sprintf "-%02d:%02d",
          int($d->{already_missing_last} / 3600),
          int(($d->{already_missing_last} % 3600) / 60)
          if (defined $d->{already_missing_last});
        push(@{($d->{missing_all})}, $d->{already_missing});
        delete $d->{already_missing};
        delete $d->{already_missing_last};
    }
}

# helper routine for filling in per-day missing data
# specific to peak/nonpeak/other
sub dump_already_missing_period
{
    my ($d,$p) = @_;
    my $startvar = "already_missing_".$p."_start";
    my $stopvar = "already_missing_".$p."_stop";

    if (defined $d->{$startvar}) {
        push(@{($d->{"missing_".$p."_table"})},
          sprintf "%02d:%02d-%02d:%02d",
            int($d->{$startvar} / 3600),
            int(($d->{$startvar} % 3600) / 60),
            int($d->{$stopvar} / 3600),
            int(($d->{$stopvar} % 3600) / 60));
        delete $d->{$startvar};
        delete $d->{$stopvar};
    }
}

# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
# and indication of whether the duration is over its threshold or not
sub pretty_duration
{
    my ($d,$crit) = @_;
    my $s = "";
    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if (($d % (60*60*24)) >= (60*60));
    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if (($d % (60*60)) >= 60);
    $s .= "no" if ($s eq "");

    if (defined $crit) {
        $s .= "[!]" if ($d > $crit);
    }
    return $s;
}

# work out date range we are expecting data to be in
sub calc_date_range
{
    # work out GMT offset - we only do this once
    if (!$gmt_offset) {
        # work out our gmt offset
        my @l = localtime(43200), my @g = gmtime(43200);
        $gmt_offset = (($l[2] - $g[2])*(60*60)) + (($l[1] - $g[1])*60);
    }

    $policy{starttime} = time;

    # set endtime as per $days less 1 day + hours left today
    $policy{endtime} = $policy{starttime} + ((60*60*24)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));

    # normalize starttime to beginning of next bucket
    $policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));

    # work out how many seconds into a day our first bucket starts
    $policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;

    # normalize endtime to end of previous bucket
    $policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});

    # if we are working with an --offset, apply it now.
    $policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});

    # work out number of buckets
    $policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
}


# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
# rather than the various other perl implementation which treat it as being in UTC/GMT
sub parse_xmltv_date
{
    my $datestring = shift;
    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
    my $tz_offset = 0;

    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
        ($t[5],$t[4],$t[3],$t[2],$t[1],$t[0]) = (int($1)-1900,int($2)-1,int($3),int($4),int($5),0);
        ($t[6],$t[7],$t[8]) = (-1,-1,-1);

        # if input data has a timezone offset, then offset by that
        if ($datestring =~ /\+(\d{2})(\d{2})/) {
            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
        }

        my $e = mktime(@t);
        return ($e+$tz_offset) if ($e > 1);
    }
    return undef;
}

# -----------------------------------------
# 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 "Preferred title preferences from '$pref_title_source'\n"
        if ((defined $pref_title_source) &&
            ($plugin_data->{$pref_title_source}) &&
            ($plugin_data->{$pref_title_source}->{valid}));

    printf "Preference for whose data we prefer as follows:\n";
    foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } 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_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);

        if ((!$reconciler_found_all_data) && ($grabber_found_all_data)) {
            # urgh.  this reconciler did a bad bad thing ...
            printf "SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n";
        } else {
            printf "SHEPHERD: Data from reconciler $reconciler looks good\n";
            $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_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);

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

        # urgh.  this postprocessor did a bad bad thing ...
        printf "SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n";

        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},
            ($policy{postprocessor_disable_failure_threshold} - $components->{$postprocessor}->{conescutive_failures});

        if ($components->{$postprocessor}->{conescutive_failures} >= $policy{postprocessor_disable_failure_threshold}) {
            printf "SHEPHERD: Disabling Postprocessor \"$postprocessor\".\n";
            $components->{$postprocessor}->{disabled} = 1;
        }
    }
}


# -----------------------------------------
# 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 .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
      if (($data_processor_type eq "reconciler") &&
          (defined $pref_title_source) &&
          ($plugin_data->{$pref_title_source}) &&
          ($plugin_data->{$pref_title_source}->{valid}));

    $comm .= " $input_files";
    printf "SHEPHERD: Excuting command: $comm\n";

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

    if ($retval != 0) {
        printf "$data_processor_type returned with non-zero return code $retval: assuming it failed.\n";
        return 0;
    }

    #
    # 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 $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name");

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

    return $have_all_data;
}


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: 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_config
{
    my ($grabber, $key) = @_;

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

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

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

# -----------------------------------------
# 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},
              '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},

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

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

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

    --capabilities        Report capabilities to XMLTV

};
    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 "  shepherd caught a die() within eval{} from file $file line $line\n";
    } else {
            printf "\nDIE: line %d in file %s\n",$line,$file;
            if ($arg) {
                CORE::die($arg,@rest);
            } else {
                CORE::die(join("",@rest));
            }
    }
}