root/shepherd @ 3

#!/usr/bin/perl -w

# "Shepherd"

my $version = '0.2.5ng';

# 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.5ng : multi-grabber (potentially with partial data) & postprocessor support
#
# ToDo:
# * --mirror <url> option, to let you get software from somewhere other
#   than whuffy. Store this in shepherd.conf. Whuffy is merely the first
#   mirror.
# * Make it check compilation after installing by calling --version or
#   --desc or --ready
# * --ready  option that says whether config is required?
# * "Last Data" column in status

use strict;
use LWP::Simple;
use Sort::Versions;
use Cwd;
use Getopt::Long;
use Data::Dumper;
use XMLTV;
use XMLTV::Ask;

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

my $progname = 'shepherd';

my $HOME = 'http://www.whuffy.com';
my $STATUS = "$HOME/status";

my $invoked = Cwd::realpath($0);

# 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 $GRABBER_DIR = "$CWD/grabbers";
my $ARCHIVE_DIR = "$CWD/archive";

my $opt;
my $debug = 1;
my $grabbers = { };
my $preferred; # obsolete but may still exist in shepherd.conf
my $region;
my $channels;
my $config_file =   "$CWD/$progname.conf";
my $channels_file = "$CWD/channels.conf";
my $days;
my $grabber_data = { };
my $master_starttime = time;

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

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

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

get_initial_command_line_options();

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

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

get_remaining_command_line_options();

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

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

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

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

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

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

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

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

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

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

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

unless ($opt->{update})
{
    grab_data();
}

print "Done.\n";

status();

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

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

sub grab_data
{
    my $used_grabbers = 0;
    my $need_more_data = 1;

    # iterate across grabbers until we have all our data we want (or need)
    foreach my $grabber (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
        next if ($grabbers->{$grabber}->{disabled});
        $used_grabbers++;

        print "\nUsing grabber: $grabber.\n\n";

        my $output = $opt->{output};
        $output ||= "$CWD/output.xmltv";
        my $comm = "$GRABBER_DIR/$grabber/$grabber " .
                   "--region $region " .
                   "--channels_file $channels_file " .
                   "--output $output";

        # NOTE: ideally a grabber could be instructed to fetch partial data through --channel, --starttime & --endtime
        # we don't have that for now so instead whenever there is missing data, ALL 7 days for all channels will be collected
        # FIXME FUTURE: call grabbers just with what we want...
        $comm .= " --days $days" if ($days);
        $comm .= " --offset $opt->{offset}" if ($opt->{offset});
        $comm .= " --debug" if ($debug);
        $comm .= " @ARGV" if (@ARGV);
        print "Excuting command:\n$comm\n\n";

        chdir "$GRABBER_DIR/$grabber/";
        system($comm);
        chdir $CWD;

        # soak up the data we just collected
        &soak_up_grabber_data($grabber, $output);

        # check to see if we have all the data we want
        $need_more_data = &analyze_grabber_data();

        last if (!$need_more_data);
    }


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

    if ($need_more_data)
    {
        print "Ran through all grabbers but still missing data!!! :(\n";
        return;
    }
}


# interpret xmltv data from this grabber
sub soak_up_grabber_data
{
    my ($grabber, $output) = @_;
    eval { $grabber_data->{$grabber} = XMLTV::parsefiles($output); };
}


# analyze grabber data - do we have all the data we want?
# returns 1 if we need more data, 0 if we have all we want
sub analyze_grabber_data
{
    # normalize starttime to beginning of hour
    my ($sec,$min,@rest) = localtime($master_starttime);
    my $starttime = $master_starttime - ((60 * $min) + $sec);
    my $endtime;

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

    # XXX TODO!  for now just return 0 - we got all our data!
    return 0;

    # iterate across channels
    #foreach my $channel (sort keys %{$channels}) {
        # iterate across days

    return 0;
}

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

sub update
{
    print "\nFetching status file: $STATUS.\n";
    my $data = LWP::Simple::get($STATUS);
    unless ($data)
    {
        print "Failed to retrieve status file.\n";
        return;
    }

    my %glist = %$grabbers;
    while ($data =~ /(.*):(.*)/g)
    {
        update_component($1, $2);
        delete $glist{$1};
    }
    foreach (keys %glist)
    {
        unless ($grabbers->{$_}->{disabled})
        {
            print "\nDeleted grabber: $_.\n";
            disable($_);
        }
    }
}

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

    print "\n";

    if ($proggy eq $progname)
    {
        if(! -e "$CWD/$progname")
        {
            print "Missing: $CWD/$progname\n";
            install($progname, $latestversion);
            return;
        }
    }
    else
    {
        if (!$grabbers->{$proggy} or ! -e "$GRABBER_DIR/$proggy/$proggy")
        {
            print "New grabber: $proggy.\n";
            install($proggy, $latestversion);
            return;
        }
        if ($grabbers->{$proggy}->{disabled})
        {
            print "Warning: $proggy disabled by config file.\n";
        }
    }

    # Compare versions
    my $ver = ($proggy eq $progname ? $version : $grabbers->{$proggy}->{ver});

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

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

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

    my $rdir = $HOME;
    my $ldir = $CWD;
    my $ver = $version;

    if ($proggy ne $progname)
    {
        -d $GRABBER_DIR or mkdir $GRABBER_DIR
            or die "Cannot create directory $GRABBER_DIR: $!";

        $ldir = "$GRABBER_DIR/$proggy";
        -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!";
        $rdir = "$rdir/grabbers";
        $ver = $grabbers->{$proggy}->{ver};
    }

    my $newfile = "$ldir/$proggy-$latestversion";
    
    my $rc = LWP::Simple::getstore("$rdir/$proggy-$latestversion", $newfile);

    unless (is_success($rc))
    {
        print "Failed to retrieve $rdir/$proggy-$latestversion.\n";
        return;
    }

    # Make it executable
    system('chmod u+x ' . $newfile);

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

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

    if ($proggy eq $progname)
    {
        print "\n*** Restarting ***\n\n";
        exec("$ldir/$proggy");
        # This exits.
    }

    print "Testing $proggy...\n" if ($debug);
    my $result = test_grabber($proggy);

    # Update grabbers list
    my $disabled = $grabbers->{$proggy}->{disabled};
    $grabbers->{$proggy} = 
        { 
            'ver' => $latestversion, 
            'disabled' => $disabled,
            'ready' => $result
        };
}

sub test_grabber
{
    my $proggy = shift;

    chdir("$GRABBER_DIR/$proggy");
    system("$GRABBER_DIR/$proggy/$proggy --ready");
    chdir ($CWD);

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

    if ($result)
    {
        print "\nGrabber $proggy did not exit cleanly!\n" .
              "It may require configuration.\n\n";
    }

    return !$result;
}

sub enable
{
    my $proggy = shift;

    print "Enabling $proggy.\n";
    if (!$grabbers->{$proggy})
    {
        print "No such grabber: \"$proggy\".\n";
    }
    else
    {
        delete $grabbers->{$proggy}->{disabled};
    }
}

sub disable
{
    my $proggy = shift;

    print "Disabling $proggy.\n";
    $grabbers->{$proggy}->{disabled} = 1;
}

sub set_order
{
    my $order = shift;
    my $all_ok = 1;

    # first check that user supplied a valid list of grabbers
    if ($order) {
        foreach my $proggy (split(/,/,$order)) {
            next if !$proggy;
            if (!$grabbers->{$proggy}) {
                $all_ok = 0;
                print "Invalid grabber: \"$proggy\".\n";
            }
        }
    }
    if ($all_ok) {
        # if list was ok then first reset current order to zero
        foreach my $proggy (keys %$grabbers) {
            $grabbers->{$proggy}->{order} = 0;
        }

        # and now set order
        my $order_num = 1;
        if ($order) {
            foreach my $proggy (split(/,/,$order)) {
                $grabbers->{$proggy}->{order} = $order_num;
                $order_num++;
            }
        }

        # set order of any grabbers not specified in a random manner
        foreach my $proggy (sort keys %$grabbers) {
            if ($grabbers->{$proggy}->{order} == 0) {
                $grabbers->{$proggy}->{order} = $order_num+int(rand(100));
            }
        }

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

sub check
{
    my $result;
    foreach (keys %$grabbers)
    {
        $result = test_grabber($_);
        print "Grabber $_: " . 
              ($result ? "OK" : "Failed") . "\n\n";
        if (!$result ne !$grabbers->{$_}->{ready})
        {
            $grabbers->{$_}->{ready} = $result;
        }
    }
}

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

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

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

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})
    {
        die "\nError in $name file!\nDetails:\n$@";
    }
}

sub write_config_file
{
    open(CONF, ">$config_file") or die "cannot write to $config_file: $!";
    print CONF Data::Dumper->Dump(
        [$region,  $grabbers ],
        ["region", "grabbers" ]);
    close CONF;
    print "\nUpdated configuration file $config_file.\n" if ($debug);
}

sub write_channels_file
{
    open(CHAN, ">$channels_file") or die "cannot write to $channels_file: $!";
    print CHAN Data::Dumper->Dump([$channels], ["channels"]);
    close CHAN;
    print "Updated channels file $channels_file.\n" if ($debug);
}

sub get_initial_command_line_options
{
  GetOptions( 'config-file=s'   => \$opt->{configfile},
              'help'            => \$opt->{help},
              'configure'       => \$opt->{configure},
              'debug'           => \$debug);
}

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

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

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

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


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

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

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

    print "\nFetching channel information... ";

    my @channellist = get_channels();

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


    print "\nRandomly selecting grabber order.\n\n";
    set_order();

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

    write_config_file();
    write_channels_file();

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

    status();

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

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

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

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

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

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

sub status
{
    print " Grabber                     Version  Enabled  Ready    Last Data\n" .
          " -----------------------------------------------------------------\n";
    my $star;
    foreach (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers)
    {
        my $h = $grabbers->{$_};
        printf  " %-26s %8s %5s %7s %10s\n",
                "$h->{order}. $_",
                $h->{ver},
                $h->{disabled} ? '' : 'Y',
                $h->{ready} ? 'Y' : '',
                $h->{lastdata} ? localtime($h->{lastdata}) : '';
    }

    printf "Grabbers shown in order of preference.\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

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

    --setorder <s>        Set order of grabbers to <s> (comma-seperated list of grabbers)
    --disable <s>         Don't ever use grabber <s>
    --enable <s>          Okay, maybe use it again then
    --uninstall <s>       Remove a disabled grabber

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

    --check               Check status of all grabbers
};
    exit 0;
}