root/shepherd @ 172

#!/usr/bin/perl -w

# "Shepherd"

my $version = '0.2.29';

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

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

use strict;
no strict 'refs';

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

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

my $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 ####
# 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 $log_file = "$CWD/$progname.log";
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
# ---------------------------------------------------------------------------

$| = 1;

print ucfirst($progname) . " v$version\n\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});

&read_config_file;
&read_channels_file;

&get_remaining_command_line_options;

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

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

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

&process_setup_commands;

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

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

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

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

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

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

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

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

sub grab_data
{
    my $used_grabbers = 0;

    &log("\nGrabber stage.\n");

    &analyze_plugin_data("",1);    

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

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

        &log((sprintf "\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)
        {
            &log("$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
        {
            &log("$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})) {
            &log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
            &log("SHEPHERD: would have called: $comm\n") if ($debug);
        } else {
            &log("SHEPHERD: Excuting command: $comm\n");
            chdir "$CWD/grabbers/$grabber/";
            $retval = call_prog($comm);
            chdir $CWD;
        }

        if ($retval != 0) {
            &log("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};

        # 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();
            &log("Grabbed: " . join (', ', @grabbed) . ".\n") if ($debug);
            record_cached($grabber, @grabbed);
            write_config_file();
        }

        last if ($grabber_found_all_data);
    }


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

    unless ($grabber_found_all_data)
    {
        &log("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)
    {
        &log((sprintf "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)
    {
        &log("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})
            {
                &log((sprintf "%15s %6.1f%% %9s %s\n", 
                        $_, 
                        ($total ? 100* $score / $total : 0), 
                        "$score pts",
                        $cstr));
            }
            else
            {
                &log((sprintf   "%15s %4s pts %s\n", 
                        $_, 
                        $score,
                        $cstr));
            }
        }
    }

    return undef unless ($total);

    # Select a grabber
    #
    # 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) = @_;

    &log("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);
            # &log("Grabber $grabber is Category 1: comparing capability to best timeslice.\n") if ($debug);
        }
        else
        {
            $key = $missing;
            # &log("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);
                # &log("Day $day:") if ($debug);
                foreach my $ch (@{$key->{$day}})
                {
                    if (supports_channel($grabber, $ch, $day))
                    {
                        # &log(" $ch") if ($debug);
                        $hits += $val;
                    }
                }
                # &log("\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;
            }
            &log("$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;
                &log("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)
    {
        &log("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)
    {
        &log("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) = @_;

    &log("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) = @_;

    &log("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) {
        &log((sprintf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output));
        return;
    }

    my $this_plugin = $plugin_data->{$plugin};
    &log((sprintf "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output));
    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
    &log((sprintf "SHEPHERD: Completed XMLTV parsing from '%s'\n",$plugin));

    if (!($this_plugin->{xmltv})) {
        &log("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}++;
            &log((sprintf " - 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) {
                &log((sprintf " - 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!
    &log((sprintf "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) = @_;
    &log("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";
            }
        }
        &log($statusstring) unless $quiet;

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

    &log((sprintf " > 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
{
    &log("\nReconciling data:\n\n");

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

    &log("Preferred title preferences from '$pref_title_source'\n")
        if ((defined $pref_title_source) &&
            ($plugin_data->{$pref_title_source}) &&
            ($plugin_data->{$pref_title_source}->{valid}));

    &log("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++;
            &log((sprintf "  %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 ...
            &log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
        } else {
            &log("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!!
        &log("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)

    &log("\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 ...
            &log("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 ...
        &log("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;
        }
        &log((sprintf "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}) {
            &log("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";

    &log((sprintf "\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";
    &log("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) {
        &log("$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"))) {
        &log((sprintf "WARNING: could not open input file \"%s\": %s\n", $input_postprocess_file, $!));
        &log("Output XMLTV data may be damanged as a result!\n");
    } else {
        while (<INFILE>) {
            print OUTFILE $_;
        }
        close(INFILE);
        close(OUTFILE);
    }

    &log("Final output stored in $output_filename.\n");
}

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

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

    my $data = fetch_shepherd_file("status");

    return 0 unless ($data);

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

    # TEMPORARY CODE FOR TRANSITION TO NEW FORMAT: REMOVE THIS LATER
    if ($data =~ /:/)
    {
        while ($data =~ /(.*):(.*):(.*)/g)
        {
            my ($progtype, $proggy, $latestversion) = ($1,$2,$3);
            # TEMP HACK FOR TRANSITION: REMOVE LATER
            if ($latestversion eq 'shepherd')
            {
                $latestversion = $proggy;
                $proggy = 'shepherd';
            }
            if (update_component($proggy, $latestversion, $progtype))
            {
                $made_changes = 1;
            }
            delete $clist{$proggy};
        }
    }
    else
    {
    # END TEMPORARY CODE
        while ($data =~ /(\S+)\s+(\S+)\s+(\S+)/g)
        {
            my ($progtype, $proggy, $latestversion) = ($1,$2,$3);
            if (update_component($proggy, $latestversion, $progtype))
            {
                $made_changes = 1;
            }
            delete $clist{$proggy};
        }
    }

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

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

    my $ver = 0;

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

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

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

    &log("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_shepherd_file($rfile, $newfile));

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

    # Make component executable
    chmod 0755,$newfile;

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

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

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

    my $result = test_proggy($ldir,"$ldir/$proggy");

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

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

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

}

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

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

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

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

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

    chdir($testdir);
    my $result = call_prog("$proggyexec --ready");
    chdir ($CWD);

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

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

sub enable
{
    my $proggy = shift;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

sub close_logfile
{
    close(LOG_FILE);
    compress_file($log_file.".1");
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

sub get_initial_command_line_options
{
  GetOptions( 'config-file=s'   => \$opt->{configfile},
              'help'            => \$opt->{help},
              'configure'       => \$opt->{configure},
              'setmirror=s'     => \$opt->{setmirror},
              'setpreftitle=s'  => \$opt->{setpreftitlesource},
              'clearpreftitle'  => \$opt->{clearpreftitlesource},
              'dontcallgrabbers' => \$opt->{dontcallgrabbers},
              '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},

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

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

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

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

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

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

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

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

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

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

    print "\nFetching channel information... ";

    my @channellist = get_channels();

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

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

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


    print "\nHave you been running a grabber previously?\n\n".
          "Some data sources show the programme \"Spicks & Specks\"\n".
          "with an '&', some show it as \"Spicks and Specks\" with 'and'.\n".
          "It doesn't matter which way it is - other than if you have an existing\n".
          "recording policy set one way or the other, it would be preferable\n".
          "to not have to go and re-enter recording schedules.\n\n".
          "Shepherd's \"reconciler\" is smart enough to work out many subtle\n".
          "differences in title names and will automatically rename programmes\n".
          "to match the same format as previously seen.\n\n".
          "If you have been using a grabber in the past, if you let Shepherd\n".
          "know what it is, it can use that to ask the reconciler to 'learn'\n".
          "the subtle programme name changes between different grabbers,\n".
          "hopefully resulting in consistent programme names, regardless of\n".
          "the data source.\n\n".
          "Were you using one of the following data sources previously?\n".
          "If so, type the name of it here or leave blank if you haven't\n".
          "run a grabber previously or don't care about having to fix existing\n".
          "recording schedules.\n\n".
          "Choose from: ".join(", ",query_grabbers())."\nChoice: ";

    my $pref = ask("Order? ");
    $pref_title_source = $pref if ($pref);

    print "\n";
    show_channels();
    unless(ask_boolean("\nCreate configuration file?"))
    {
        print "Aborting configuration.\n";
        exit 0;
    }

    write_config_file();
    write_channels_file();

    print "Finished configuring.\n\n" .
          "Shepherd is installed into $CWD.\n\n";
    
    if ($invoked ne "$CWD/$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 = fetch_file(
        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
        ($date[5] + 1900) . "-$date[4]-$date[3]");
    my @channellist;
    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
    {
        push @channellist, $1;
    }
    return @channellist;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    --check               Check status of all grabbers and postprocessors

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

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

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

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