#!/usr/bin/perl -w

my $myprogname = 'shepherd';
my $progname = 'shepherd';
my $version = '0.3.12';

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

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

# Changelog:
# 0.2.31  : split tv_grab_au (install/test/upgrade/enable/disable) from
#           shepherd (grab/reconcile/postprocess). Previous changelog history
#           is in shepherd
# 0.3.0   : This split deserves a real version bump, Linc! :)
# 0.3.1   : honour $option_ready
# 0.3.10  : split out into apps directory, renamed back to 'shepherd' with
#           an auto symlink to tv_grab_au
#           logging to logs/ directory

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

use strict;
no strict 'refs';

# ---------------------------------------------------------------------------
# --- required perl modules
# ---------------------------------------------------------------------------

&require_module("LWP::UserAgent");
&require_module("Getopt::Long");
&require_module("Data::Dumper");
&require_module("XMLTV::Ask");
&require_module("POSIX", qw(strftime mktime getcwd));
&require_module("Compress::Zlib");

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

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

my @options = @ARGV;

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

my $ARCHIVE_DIR = "$CWD/archive";
my $LOG_DIR = "$CWD/log";

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

my $invoked = get_full_path($0);

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

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

&get_command_line_options;

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

$| = 1; 
print "$myprogname v$version\n\n";

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

&check_user;

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

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

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

if ($opt->{'show-channels'})
{
    &show_channels;
    exit;
}

&process_setup_commands;

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

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

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

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

unless ($opt->{update})
{
    write_config_file();
    my $shepexec = query_filename('dog', 'engine'); # really shouldn't hardcode 'dog'..
    &log("Passing control to Engine: $shepexec @options\n");

    call_prog("$shepexec @options");
}

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

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

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

sub update
{
    if ($invoked ne get_full_path(query_filename('shepherd','application')))
    {
	&log("\nWARNING: you should really be running ".ucfirst($progname)."\n".
	   "    as '".query_filename('shepherd','application')."'\n".
           "    rather than '$invoked'!\n".
           "    Auto-update has been disabled until you fix this!\n\n".
           "You may wish to CTRL-C and fix this.\n".
           "Continuing (without auto-update) in: ");
	foreach (1 .. 10)
	{
	    print " " . (11 - $_);
	    sleep 1;
	}
	&log("\nSkipped auto-update.\n\n");
	return 0;
    }

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

    my $data = fetch_shepherd_file("status");

    return 0 unless ($data);

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

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

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

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

    my $ver = 0;
    $ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e query_filename($proggy,$progtype));

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

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

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

    my $rdir = "";
    my $basedir = $CWD."/".$progtype."s";
    my $ldir = query_ldir($proggy, $progtype);
    
    -d $basedir or mkdir $basedir or die "Cannot create directory $basedir: $!\n";
    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!\n";
    my $newfile = "$ldir/$proggy-$latestversion";

    $rdir = $progtype . 's';
    my $rfile = "$rdir/$proggy";

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

    $rfile .= ".conf";
    $config = fetch_shepherd_file($rfile);
    return unless ($config); # everyone 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: $!\n";

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

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

    # if the update was for the main app, restart it
    if ($proggy eq $myprogname) {
	$components->{$proggy}->{ready} = 1;
	&write_config_file;

	# special case for main app - we create a symlink also
	unlink("$CWD/tv_grab_au","$CWD/shepherd");
	eval { symlink("$ldir/$proggy","$CWD/tv_grab_au"); 1 };
	eval { symlink("$ldir/$proggy","$CWD/shepherd"); 1 };

	&log("\n*** Restarting ***\n\n");
	&close_logfile unless $opt->{nolog};
	exec("$ldir/$proggy @options");
	# This exits.
	exit(0);
    }

    $components->{$proggy}->{ready} = test_proggy($proggy, $progtype);

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

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

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

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

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

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

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

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

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

sub enable
{
    my $proggy = shift;

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

    print "Enabling $proggy.\n";

    delete $components->{$proggy}->{disabled};
    $components->{$proggy}->{laststatus} = sprintf "enabled on %s, not run yet",POSIX::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;
    }

    if (($components->{$proggy}->{type} eq "application") || ($components->{$proggy}->{type} eq "engine")) {
	printf "Can't disable component: \"%s\".\n",$proggy;
	return;
    }

    print "Disabling $proggy.\n";
    
    $n ||= 1;
    $components->{$proggy}->{disabled} = $n;
    $components->{$proggy}->{laststatus} = sprintf "manually disabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
}

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

# versioncmp from Sort::Versions by Kenneth J. Albanowski
sub versioncmp( $$ ) {
    my @A = ($_[0] =~ /([-.]|\d+|[^-.\d]+)/g);
    my @B = ($_[1] =~ /([-.]|\d+|[^-.\d]+)/g);

    my ($A, $B);
    while (@A and @B) {
	$A = shift @A;
	$B = shift @B;
	if ($A eq '-' and $B eq '-') {
	    next;
	} elsif ( $A eq '-' ) {
	    return -1;
	} elsif ( $B eq '-') {
	    return 1;
	} elsif ($A eq '.' and $B eq '.') {
	    next;
	} elsif ( $A eq '.' ) {
	    return -1;
	} elsif ( $B eq '.' ) {
	    return 1;
	} elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
	    if ($A =~ /^0/ || $B =~ /^0/) {
		return $A cmp $B if $A cmp $B;
	    } else {
		return $A <=> $B if $A <=> $B;
	    }
	} else {
	    $A = uc $A;
	    $B = uc $B;
	    return $A cmp $B if $A cmp $B;
	}	
    }
    @A <=> @B;
}

# simplified version of Cwd::getrealpath that is portable that doesn't pull
# in a long list of dependencies
sub get_full_path
{
    my $path = shift;
    my $fname = $path;

    # strip filename from path
    chop($path) while (substr($path,(length($path)-1),1) ne "/");

    # strip path from filename
    $fname = substr($fname,length($path),500);

    return $ENV{PWD}."/".$fname if ($path eq "");

    chdir($path);
    my $retdir = POSIX::getcwd();
    chdir($ENV{PWD}) if ($ENV{PWD});

    return $retdir."/".$fname;
}

sub require_module
{
    my ($mod, @imports) = @_;

    my $modname = $mod.".pm";
    $modname =~ s/::/\//g;

    eval { require $modname; };
    if ($@) {
	printf STDERR "\nERROR:\nMandatory module '%s' not found.\n\n",$mod;
	printf STDERR "Please consult your Unix/Linux distribution for how to install this CPAN module,\n";
	printf STDERR "or try installing it via the command:\n";
	printf STDERR "    cpan %s\n",$mod;
	exit(1);
    }

    import $mod @imports;
}

# check that user isn't root, warn them if they are!
sub check_user
{
    if ($< == 0) {
	printf STDERR "WARNING:\n You are running ".ucfirst($progname).
	    " as 'root' super-user.\n".
	    " It is HIGHLY RECOMMENDED that you set your system to run ".
	    ucfirst($progname)."\n from within a normal user account!\n\n".
	    "You may wish to CTRL-C and fix this.\n".
	    "Continuing in: ";
	foreach (1 .. 10)
	{
	    printf STDERR " " . (11 - $_);
	    sleep 1;
	}
	printf STDERR "\n";
    }
}

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

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

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

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

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

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

sub query_filename
{
    my ($proggy, $progtype) = @_;
    return query_ldir($proggy,$progtype).'/'.$proggy;
}

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

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 10 log files
    my $num;
    for ($num = 10; $num > 0; $num--) {
	my $f1 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num;
	my $f2 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num+1;
	unlink($f2);
	rename($f1,$f2);
    }

    my $f1 = sprintf "%s/%s",$LOG_DIR,$log_file;
    my $f2 = sprintf "%s/%s.1",$LOG_DIR,$log_file;
    rename($f1,$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
{
    -d $LOG_DIR or mkdir $LOG_DIR or die "Cannot create directory $LOG_DIR: $!";

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

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

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

sub close_logfile
{
    close(LOG_FILE);
}

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

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

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

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

    &log("Fetching $url.\n");
    
    my $ua = LWP::UserAgent->new();
    if ($id_self)
    {
	$ua->agent(ucfirst("$progname/$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_command_line_options
{
  Getopt::Long::Configure(qw/pass_through/);

  GetOptions($opt, qw(	config-file=s
			help
			configure
			setmirror=s
			setpreftitle=s
			clearpreftitle
			capabilities
			description
			quiet
			version
			debug
			status
			show-config
			show-channels
			update
			noupdate
			disable=s
			enable=s
			nolog
			check
		     ));
  $debug = $opt->{debug};
  $config_file = $opt->{'config-file'} if ($opt->{'config-file'});
}

sub process_setup_commands
{
    my @opts = qw( enable disable setorder check \
		   setpreftitle clearpreftitle 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 setpreftitle
{
    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 clearpreftitle
{
    $pref_title_source = undef;
    print "Removed preferred title source $pref_title_source\n";
    1;
}

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

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

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

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

    print "\nFetching channel information... ";

    my @channellist = get_channels();

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

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

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


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

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

    write_config_file();
    write_channels_file();

    print "Finished configuring.\n\n" .
          "Shepherd is installed into $CWD.\n\n";

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

    status();

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

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

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

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

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

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

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

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

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

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

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

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

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

sub help
{
    print q{Command-line options:
    --help                Display this message
    --version             Display version
    --status              Display status of various components

    --configure           Setup
    --show-config         Display setup details
    --show-channels       Display subscribed channels

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

    --noupdate            Don't update; just grab data
    --update              Update only; don't grab data

    --check               Check status of all grabbers and postprocessors

    --debug               Print lots of debugging messages
    --quiet               Don't print anything except errors
    --nolog               Don't write a logfile

    --setmirror <s>       Set URL <s> as primary location to check for updates
    --setpreftitle <s>    Set preferred 'title' source as grabber <s>
    --clearpreftitle      Clear preferred 'title' source
};
    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 "* 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));
	    }
    }
}