root/tv_grab_au @ 185

Revision 185, 29.3 kB (checked in by max, 7 years ago)

Added rex as a transitional grabber.
  • Property svn:executable set to *
Line 
1#!/usr/bin/perl -w
2
3# "Shepherd"
4# A wrapper for various Aussie TV guide data grabbers
5#
6# Use --help for command-line options.
7#
8# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
9# make one cohesive reliable data set. It works by calling a series of
10# scripts that grab data from a large variety of sources, and then
11# analysing the resulting XML data sets and determining which of the many
12# is the most reliable.
13
14# Shepherd runs in 4 passes:
15#  pass 1: (tv_grab_au)  Checks that all components are up-to-date, auto-
16#                        updates if not.
17#                        Passes control onto shepherd
18#  pass 2: (shepherd)    calls grabbers to fill in missing data
19#  pass 3: (shepherd)    calls reconciler to reconcile overlapping data
20#                        and normalize programme titles to our preferred title
21#  pass 4: (shepherd)    calls postprocessors to postprocess data
22#                        (e.g. flag HDTV programmes, augment with IMDb etc.)
23
24my $version = '0.2.32';
25
26# Changelog:
27# 0.1.0   : Basic self-updating and grabber management
28# 0.2.0   : --configure
29# 0.2.1   : Has a home in ~/.shepherd/
30# 0.2.2   : --check
31# 0.2.3   : Bugfix: archives correctly
32# 0.2.5   : Multi-grabber (potentially with partial data)
33# 0.2.6   : Postprocessor support
34# 0.2.7   : Changed online file structure
35# 0.2.8   : Integrated reconciler
36# 0.2.9   : Grabber config support
37# 0.2.10  : Bugfix: don't call postprocessors that aren't ready,
38#           rework accept-data-or-not postprocessor logic
39# 0.2.11  : Dedicated external reconciler support
40# 0.2.13  : revert 'alawys run' added in 0.2.12, --setorder bugfix
41# 0.2.14  : Changed online status file format
42# 0.2.15  : Intelli-random grabber ordering now kinda works
43# 0.2.16  : config logic for HD channels
44# 0.2.17  : bugfix timezone bogosities
45# 0.2.18  : care less about missing data in early-morning/overnight
46#           care more about missing data in evening/night
47# 0.2.22  : remove ->{order}, order is now set by quality
48#           explicitly tell reconciler the preferred _title_ source
49# 0.2.24  : logging and log files
50# 0.2.25  : use open-with-pipe rather than system() and look at
51#           return codes from called programmes
52# 0.2.27  : Identify self in useragent when fetching shepherd files
53# 0.2.28  : Changing status file format again
54# 0.2.30  : Run transitional grabber(s) as a once-off to establish preferred
55#           title translations.
56# 0.2.31  : split tv_grab_au (install/test/upgrade/enable/disable) from
57#           shepherd (grab/reconcile/postprocess)
58
59BEGIN { *CORE::GLOBAL::die = \&my_die; }
60
61use strict;
62no strict 'refs';
63
64use LWP::UserAgent;
65use Sort::Versions;
66use Cwd;
67use Getopt::Long;
68use Data::Dumper;
69use XMLTV;
70use XMLTV::Ask;
71use POSIX qw(strftime mktime);
72use Date::Manip;
73use Algorithm::Diff;
74use List::Compare;
75use Compress::Zlib;
76
77# ---------------------------------------------------------------------------
78# --- Global Variables
79# ---------------------------------------------------------------------------
80
81my $myprogname = 'tv_grab_au';
82my $progname = 'shepherd';
83
84my $HOME = 'http://www.whuffy.com/shepherd';
85
86my $invoked = Cwd::realpath($0);
87my @options = @ARGV;
88
89# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
90# it will try /opt/shepherd/ instead.
91my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
92-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
93chdir($CWD);
94
95my $ARCHIVE_DIR = "$CWD/archive";
96
97my $opt;
98my $pref_title_source;
99my $mirror_site;
100my $debug = 0;
101my $components = { };
102my $region;
103my $channels;
104my $opt_channels;
105my $config_file =   "$CWD/$progname.conf";
106my $channels_file = "$CWD/channels.conf";
107my $log_file = "$CWD/$progname.log";
108my $days = 7;
109
110# OBSOLETE: will be removed
111my $preferred;
112my $title_translation_table;
113my $pref_order;
114
115# ---------------------------------------------------------------------------
116# --- Setup
117# ---------------------------------------------------------------------------
118
119# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
120Getopt::Long::Configure(qw/pass_through/);
121
122&get_initial_command_line_options;
123
124&capabilities if ($opt->{capabilities});
125&description if ($opt->{description});
126&version if ($opt->{version});
127
128$| = 1; 
129print ucfirst($myprogname) . " v$version\n\n";
130
131&help if ($opt->{help});
132
133&read_config_file;
134&read_channels_file;
135
136&get_remaining_command_line_options;
137
138if ($opt->{status})
139{
140    &status;
141    exit;
142}
143
144if ($opt->{show_config})
145{
146    &show_config;
147    exit;
148}
149
150&open_logfile unless ($opt->{nolog});
151
152&process_setup_commands;
153
154# ---------------------------------------------------------------------------
155# --- Update
156# ---------------------------------------------------------------------------
157
158unless ($opt->{noupdate})
159{
160    if (&update()) 
161    {
162        &write_config_file;
163    }
164}
165
166if ($opt->{configure})
167{
168    &configure;
169}
170
171# ---------------------------------------------------------------------------
172# --- Go!
173# ---------------------------------------------------------------------------
174
175unless ($opt->{update})
176{
177    write_config_file();
178    &log("Passing control to Shepherd.\n");
179    &close_logfile() unless $opt->{nolog};
180
181    exec("$CWD/shepherd @options"); # doesn't return
182}
183
184&log("Done.\n");
185&close_logfile() unless $opt->{nolog};
186
187# ---------------------------------------------------------------------------
188# --- Subroutines
189# ---------------------------------------------------------------------------
190
191# -----------------------------------------
192# Subs: Updates & Installations
193# -----------------------------------------
194
195sub update
196{
197    &log("\nChecking for updates:\n\n");
198
199    my $data = fetch_shepherd_file("status");
200
201    return 0 unless ($data);
202
203    my $made_changes = 0;
204    my %clist = %$components;
205
206    while ($data =~ /(\S+)\s+(\S+)\s+(\S+)/g)
207    {
208        my ($progtype, $proggy, $latestversion) = ($1,$2,$3);
209        if (update_component($proggy, $latestversion, $progtype))
210        {
211            $made_changes = 1;
212        }
213        delete $clist{$proggy};
214    }
215
216    # work out what components disappeared (if any)
217    foreach (keys %clist) {
218        unless ($components->{$_}->{disabled}) {
219            &log("\nDeleted component: $_.\n");
220            disable($_, 2);
221            $made_changes = 1;
222        }
223    }
224    $made_changes;
225}
226
227sub update_component
228{
229    my ($proggy, $latestversion, $progtype) = @_;
230
231    my $ver = 0;
232
233    if ($progtype eq "shepherd")
234    {
235        if (-e "$CWD/$proggy")
236        {
237            $ver = `$CWD/$proggy --version`;
238            chop($ver);
239        }
240    } else {
241        $ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e ($progtype . "s/$proggy/$proggy"));
242    }
243
244    my $result = versioncmp($ver, $latestversion);
245    my $action =    $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
246                    $result ==  1 ? "DOWNGRADING" :
247                    "up to date";
248    &log(sprintf    "* %-40s %30s\n",
249                    ucfirst($progtype) . " $proggy" .
250                        ($ver ? " v$ver" : '') . "...",
251                    $action);
252    return 0 unless ($result);
253    install($proggy, $latestversion, $progtype, $ver);
254    return 1;
255}
256
257sub install
258{
259    my ($proggy, $latestversion, $progtype, $oldver) = @_;
260    my $config;
261
262    &log("Downloading $proggy v$latestversion.\n");
263
264    my $rdir = "";
265    my $ldir = $CWD;
266
267    if ($progtype ne "shepherd") {
268        $rdir = $progtype . "s";
269        $ldir = "$CWD/$progtype" . "s/$proggy";
270        -d ("$CWD/$progtype" . "s") or mkdir ("$CWD/$progtype" . "s") or die "Cannot create directory $CWD/$progtype" . "s: $!";
271    }
272    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!";
273
274    my $newfile = "$ldir/$proggy-$latestversion";
275    my $rfile = "$rdir/$proggy";
276
277    return unless (fetch_shepherd_file($rfile, $newfile));
278
279    # Fetch grabber config file
280    if ($progtype eq 'grabber')
281    {
282        $rfile .= ".conf";
283        $config = fetch_shepherd_file($rfile);
284        return unless ($config); # grabbers MUST have config files
285        eval $config;
286    }
287
288    # Make component executable
289    chmod 0755,$newfile;
290
291    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!";
292
293    if (-e "$ldir/$proggy")
294    {
295        rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$oldver");
296    }
297    rename($newfile, "$ldir/$proggy");
298   
299    &log("Installed $proggy v$latestversion.\n") if ($debug);
300
301    # if the update was for shepherd itself, restart it
302    if ($progtype eq "shepherd") {
303        &log("\n*** Restarting ***\n\n");
304        &close_logfile unless $opt->{nolog};
305        exec("$CWD/$myprogname @options");
306        # This exits.
307        exit(0);
308    }
309
310    my $result = test_proggy($ldir,"$ldir/$proggy");
311
312    $components->{$proggy}->{type} = $progtype;
313    $components->{$proggy}->{ver} = $latestversion;
314    $components->{$proggy}->{ready} = $result;
315    $components->{$proggy}->{config} = $config if ($progtype eq 'grabber');
316
317    # If this component was disabled automatically, re-enable it.
318    # But if it was disabled manually, leave it off.
319    my $d = $components->{$proggy}->{disabled};
320    if ($d and $d == 2)
321    {
322        enable($proggy);
323    }
324
325    $components->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));
326
327}
328
329sub fetch_shepherd_file
330{
331    my ($fn, $store) = @_;
332
333    my $sites = "";
334    $sites = "$mirror_site," if ($mirror_site);
335    $sites .= $HOME;
336
337    my $ret;
338    foreach my $site (split(/,/,$sites)) 
339    {
340        $ret = fetch_file("$site/$fn", $store, 1);
341        return $ret if ($ret);
342    }
343    return undef;
344}
345
346sub test_proggy
347{
348    my ($testdir,$proggyexec) = @_;
349
350    &log("Testing $proggyexec...\n");
351
352    chdir($testdir);
353    my $result = call_prog("$proggyexec --ready");
354    chdir ($CWD);
355
356    print "Return value: $result\n" if ($debug);
357
358    if ($result)
359    {
360        &log("\nComponent $proggyexec did not exit cleanly!\n" .
361             "It may require configuration.\n\n");
362    }
363    else
364    {
365        &log("OK.\n");
366    }
367    return !$result;
368}
369
370sub enable
371{
372    my $proggy = shift;
373
374    # confirm it exists first
375    if (!$components->{$proggy}) {
376        printf "No such component: \"%s\".\n",$proggy;
377        return;
378    }
379    print "Enabling $proggy.\n";
380
381    delete $components->{$proggy}->{disabled};
382    $components->{$proggy}->{laststatus} = sprintf "enabled on %s, not run yet",(strftime "%a%d%b%y", localtime(time));
383}
384
385sub disable
386{
387    my ($proggy, $n) = @_;
388
389    # confirm it exists first
390    if (!$components->{$proggy}) {
391        printf "No such component: \"%s\".\n",$proggy;
392        return;
393    }
394    print "Disabling $proggy.\n";
395   
396    $n ||= 1;
397    $components->{$proggy}->{disabled} = $n;
398    $components->{$proggy}->{laststatus} = sprintf "manually disabled on %s",(strftime "%a%d%b%y", localtime(time));
399}
400
401sub check
402{
403    my $result;
404    foreach my $proggy (keys %$components) {
405        my $progtype = $components->{$proggy}->{type};
406        $result = test_proggy("$CWD/$progtype" . "s/$proggy", "$CWD/$progtype" . "s/$proggy/$proggy");
407        if (!$result ne !$components->{$proggy}->{ready}) {
408            $components->{$proggy}->{ready} = $result;
409        }
410    }
411}
412# -----------------------------------------
413# Subs: Utilities
414# -----------------------------------------
415#
416
417sub query_grabbers
418{
419    my ($conf, $val) = @_;
420    return query_component_type('grabber',$conf,$val);
421}
422
423sub query_reconcilers
424{
425    return query_component_type('reconciler');
426}
427
428sub query_postprocessors
429{
430    return query_component_type('postprocessor');
431}
432
433sub query_component_type
434{
435    my ($progtype,$conf,$val) = @_;
436
437    my @ret = ();
438    foreach (keys %$components)
439    {
440        if ($components->{$_}->{type} eq $progtype) {
441            if (defined $conf) {
442                push (@ret, $_) if (query_config($_,$conf) eq $val);
443            } else {
444                push (@ret, $_);
445            }
446        }
447    }
448    return @ret;
449}
450
451sub query_name
452{
453    my $str = shift;
454    if ($str =~ /(.*) \[cache\]/)
455    {
456        return $1;
457    }
458    return $str;
459}
460
461sub query_config
462{
463    my ($grabber, $key) = @_;
464
465    $grabber = query_name($grabber);
466    return undef unless ($components->{$grabber});
467    return $components->{$grabber}->{config}->{$key};
468}
469
470sub rotate_logfiles
471{
472    # keep last 4 log files
473    my $num;
474    for ($num = 4; $num > 0; $num--) {
475        my $f1 = sprintf "%s.%d.gz",$log_file,$num;
476        my $f2 = sprintf "%s.%d.gz",$log_file,$num+1;
477        unlink($f2);
478        rename($f1,$f2);
479    }
480
481    my $f2 = sprintf "%s.1",$log_file;
482    rename($log_file,$f2);
483}
484
485sub compress_file
486{
487    my $infile = shift;
488    my $outfile = sprintf "%s.gz",$infile;
489    my $gz;
490
491    if (!(open(INFILE,"<$infile"))) {
492        warn "could not open file $infile for reading: $!\n";
493        return;
494    }
495
496    if (!($gz = gzopen($outfile,"wb"))) {
497        warn "could not open file $outfile for writing: $!\n";
498        return;
499    }
500
501    while (<INFILE>) {
502        my $byteswritten = $gz->gzwrite($_);
503        warn "error writing to compressed file: error $gz->gzerror"
504          if ($byteswritten == 0);
505    }
506    close(INFILE);
507    $gz->gzclose();
508    unlink($infile);
509}
510
511sub open_logfile
512{
513    &rotate_logfiles;
514    printf "Logging to $log_file.\n";
515    open(LOG_FILE,">>$log_file") || die "can't open log file $log_file for writing: $!\n";
516
517    my $now = localtime(time);
518    printf LOG_FILE "$myprogname version $version started at $now\n\n";
519
520    compress_file($log_file.".1");
521}
522
523sub close_logfile
524{
525    close(LOG_FILE);
526}
527
528sub log
529{
530    my $entry = shift;
531    print $entry;
532    printf LOG_FILE "%s",$entry unless $opt->{nolog};
533}
534
535sub call_prog
536{
537    my $prog = shift;
538    if (!(open(PROG,"$prog|"))) {
539        &log("warning: couldn't exec \"$prog\": $!\n");
540        return -1;
541    }
542    while(<PROG>) {
543        &log($_);
544    }
545    close(PROG);
546
547    if ($? == -1) {
548        &log("Failed to execute prog: $!\n");
549        return -1;
550    } elsif ($? & 127) {
551        &log((sprintf "prog died with signal %d, %s coredump\n",
552          ($? & 127),  ($? & 128) ? "with" : "without"));
553        return $?;
554    } else {
555        &log((sprintf "prog exited with value %d\n", $? >> 8)) if ($debug or $?);
556        return ($? >> 8);
557    }
558}
559
560sub fetch_file
561{
562    my ($url, $store, $id_self) = @_;
563
564    &log("Fetching $url.\n");
565   
566    my $ua = LWP::UserAgent->new();
567    if ($id_self)
568    {
569        $ua->agent(ucfirst("$progname/$myprogname/$version"));
570    }
571    else
572    {
573        $ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322')
574    }
575
576    my $response = $ua->get($url);
577    if ($response->is_success())
578    {
579        if ($store)
580        {
581            open (FILE, ">$store") 
582                or (&log("ERROR: Unable to open $store for writing.\n") and return undef);
583            print FILE $response->content();
584            close FILE;
585            return 1;
586        }
587        else 
588        {
589            return $response->content();
590        } 
591    }
592    &log("Failed to retrieve $url!\n" . $response->status_line() . "\n");
593    return undef;
594}
595
596# -----------------------------------------
597# Subs: Setup
598# -----------------------------------------
599
600sub read_config_file
601{
602    read_file($config_file, 'configuration');
603}
604
605sub read_channels_file
606{
607    read_file($channels_file, 'channels');
608}
609
610sub read_file
611{
612    my $fn = shift;
613    my $name = shift;
614
615    print "Reading $name file: $fn\n";
616    unless (-r $fn)
617    {
618        unless ($opt->{configure})
619        {
620            print "\nNo $name file found.\n" .
621                  ucfirst($progname) . " must be configured: " .
622                  "configuring now.\n\n";
623            $opt->{'configure'} = 1;
624        }
625        return;
626    }
627    local (@ARGV, $/) = ($fn);
628    no warnings 'all';
629    eval <>;
630    if ($@ and !$opt->{configure})
631    {
632        warn "\nERROR in $name file! Details:\n$@";
633        print "You may wish to CTRL-C and fix this.\n\nContinuing anyway in:";
634        foreach (1 .. 5)
635        {
636            print " " . (6 - $_);
637            sleep 1;
638        }
639        print "\n";
640    }
641}
642
643sub write_config_file
644{
645    write_file($config_file, 'configuration', 
646        [$region,  $pref_title_source,  $mirror_site,  $components ],
647        ["region", "pref_title_source", "mirror_site", "components" ]);
648}
649
650sub write_channels_file
651{
652    write_file($channels_file, 'channels',
653        [ $channels,  $opt_channels ],
654        [ 'channels', 'opt_channels' ]);
655}
656
657sub write_file
658{
659    my ($fn, $name, $vars, $varnames) = @_;
660    open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
661    print FN Data::Dumper->Dump($vars, $varnames);
662    close FN;
663    print "Wrote $name file $fn.\n" if ($debug);
664}
665
666sub get_initial_command_line_options
667{
668  GetOptions( 'config-file=s'   => \$opt->{configfile},
669              'help'            => \$opt->{help},
670              'configure'       => \$opt->{configure},
671              'setmirror=s'     => \$opt->{setmirror},
672              'setpreftitle=s'  => \$opt->{setpreftitlesource},
673              'clearpreftitle'  => \$opt->{clearpreftitlesource},
674              'dontcallgrabbers' => \$opt->{dontcallgrabbers},
675             
676              # http://xmltv.org/wiki/xmltvcapabilities.html
677              'capabilities'    => \$opt->{capabilities},
678              'description'     => \$opt->{description},
679              'quiet'           => \$opt->{quiet},
680              'version'         => \$opt->{version},
681
682              'debug'           => \$debug);
683}
684
685sub get_remaining_command_line_options
686{
687    GetOptions(
688              'status'          => \$opt->{status},
689              'list'            => \$opt->{list},
690              'show-config'     => \$opt->{show_config},
691
692              'update'          => \$opt->{update},
693              'noupdate'        => \$opt->{noupdate},
694
695              'disable=s'       => \$opt->{disable},
696              'enable=s'        => \$opt->{enable},
697
698              'nolog'           => \$opt->{nolog},
699
700              'days=i'          => \$days,
701              'offset=i'        => \$opt->{offset},
702              'show-channels'   => \$opt->{show_channels},
703              'output=s'        => \$opt->{output},
704              'randomize'       => \$opt->{randomize}, # experimental
705              'check'           => \$opt->{check}
706            );
707}
708
709sub process_setup_commands
710{
711    my @opts = qw( enable disable setorder check \
712                   setpreftitlesource clearpreftitlesource setmirror );
713
714    my $run = 0;
715    foreach (@opts)
716    {
717        if ($opt->{$_})
718        {
719            $run = 1;
720            &$_($opt->{$_});
721        }
722    }
723    return unless ($run);
724    write_config_file();
725    status();
726    exit;
727}
728
729# if a preferred title source has been specified, add it to our config
730sub setpreftitlesource
731{
732    my $arg = shift;
733    $pref_title_source = $arg;
734    print "Added preferred title source: $pref_title_source\n";
735    1;
736}
737
738# if requesting to clear preferred title and we have one, remove it
739sub clearpreftitlesource
740{
741    $pref_title_source = undef;
742    print "Removed preferred title source $pref_title_source\n";
743    1;
744}
745
746# if a mirror has been specified, add it into our config
747sub setmirror
748{
749    my $arg = shift;
750    $mirror_site = $arg;
751    print "Setting mirror site(s): $mirror_site\n";
752}
753
754# -----------------------------------------
755# Subs: Configuration
756# -----------------------------------------
757
758sub configure
759{
760    my $REGIONS = {
761        "ACT" => 126,
762        "NSW: Sydney" => 73,
763        "NSW: Newcastle" => 184,
764        "NSW: Central Coast" => 66,
765        "NSW: Griffith" => 67,
766        "NSW: Broken Hill" => 63,
767        "NSW: Northern NSW" => 69,
768        "NSW: Southern NSW" => 71,
769        "NSW: Remote and Central" => 106,
770        "NT: Darwin" => 74,
771        "NT: Remote & Central" => 108,
772        "QLD: Brisbane" => 75,
773        "QLD: Gold Coast" => 78,
774        "QLD: Regional" => 79,
775        "QLD: Remote & Central" => 114,
776        "SA: Adelaide" => 81,
777        "SA: Renmark" => 82,
778        "SA: Riverland" => 83,
779        "SA: South East SA" => 85,
780        "SA: Spencer Gulf" => 86,
781        "SA: Remote & Central" => 107,
782        "Tasmania" => 88,
783        "VIC: Melbourne" => 94,
784        "VIC: Geelong" => 93,
785        "VIC: Eastern Victoria" => 90,
786        "VIC: Mildura/Sunraysia" => 95,
787        "VIC: Western Victoria" => 98,
788        "WA: Perth" => 101,
789        "WA: Regional" => 102
790    };
791
792    print "\nConfiguring.\n\n" .
793          "Select your region:\n";
794    foreach (sort keys %$REGIONS)
795    {
796        printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
797    }
798    $region = ask_choice("Enter region code:", "94", values %$REGIONS);
799
800    print "\nFetching channel information... ";
801
802    my @channellist = get_channels();
803
804    print "done.\n\n" .
805          "For each channel you want guide data for, enter an XMLTV id\n" .
806          "of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
807          "guide data for this channel, just press Enter.\n\n" .
808          "Please don't subscribe to unneeded channels.\n\nChannels:\n";
809    $channels = {};
810    my $line;
811    foreach (@channellist)
812    {
813        $line = ask(" \"$_\"? ");
814        $channels->{$_} = $line if ($line);
815    }
816
817    print "\nHigh Definition TV (HDTV)\n".
818          "Most Australian TV networks broadcast at least some\n".
819          "programmes in HDTV each week, but for the most part\n".
820          "either upsample SD to HD or play a rolling demonstration\n".
821          "HD clip when they don't have the programme in HD format.\n\n".
822          "If you have a HDTV capable system and are interested in\n".
823          "having Shepherd's postprocessors populate HDTV content\n".
824          "then Shepherd will need to know the XMLTV IDs for the HD\n".
825          "channels also.\n";
826    if (ask_boolean("\nDo you wish to include HDTV channels?")) {
827        print "\nFor each channel you want guide data for, enter an XMLTV id\n" .
828              "of your choice (e.g. \"sevenhd.free.au\"). If you don't need\n" .
829              "guide data for this channel, just press Enter.\n\n";
830
831        $opt_channels = {};
832        foreach (@channellist)
833        {
834            next if (($_ =~ /ABC2/i) || ($_ =~ /SBS News/i) || ($_ =~ /31/));
835            $_ .= "HD";
836            $line = ask(" \"$_\"? ");
837            $opt_channels->{$_} = $line if ($line);
838        }
839    }
840
841
842    print "\nWould you like to transition seamlessly from your current grabber?\n\n".
843          "Different data sources can have different names for the same show. For\n".
844          "example, one grabber might call a show \"Spicks & Specks\" while another\n".
845          "calls it \"Spicks and Specks\". These differences can make MythTV think\n".
846          "they're actually different shows.\n\n".
847          ucfirst($progname) . " is able to merge these differences so that it always\n".
848          "presents shows with a consistent name, no matter where it actually sourced\n".
849          "show data from. If you'd like, it can also rename shows so they're consistent\n".
850          "with whichever grabber you've been using until now.\n\n".
851          "The advantage of this is that you should get a smoother transition to\n".
852          ucfirst($progname) . ", with no shows changing names and no need to re-create\n".
853          "any recording rules. The main disadvantage is that if your previous grabber\n".
854          "used an inferior data source -- i.e. it sometimes has typos or less\n".
855          "informative program names -- then you'll continue to see these.\n\n".
856          "If you were using one of the following grabbers previously AND you want\n".
857          ucfirst($progname) . " to use that grabber's program names, select it here.\n\n";
858
859    my $def = "Do not transition; just use best quality titles";
860    my %transition = (  "ltd (aka tv_grab_au, versions 1,30, 1.40 or 1.41)" => "yahoo7widget,abc2_website",
861                        "OzTivo" => 'oztivo',
862                        "Rex" => 'rex',
863                        "JRobbo" => 'jrobbo' );
864    my $pref = ask_choice("Transition from grabber?", $def,
865                $def, keys %transition);
866    $pref_title_source = $transition{$pref};
867   
868    print "\n";
869    show_channels();
870    unless(ask_boolean("\nCreate configuration file?"))
871    {
872        print "Aborting configuration.\n";
873        exit 0;
874    }
875
876    write_config_file();
877    write_channels_file();
878
879    print "Finished configuring.\n\n" .
880          "Shepherd is installed into $CWD.\n\n";
881   
882    if ($invoked ne "$CWD/$myprogname" and $invoked =~ /$myprogname/)
883    {
884        print "Warning: you invoked this program as $invoked.\n" .
885            "In the future, it should be run as $CWD/$myprogname,\n" .
886            "to avoid constantly re-downloading the latest version.\n\n" .
887            "MythTV users may wish to create the following symlink, by " .
888            "doing this (as root):\n" .
889            "\"ln -s $CWD/$myprogname /usr/bin/tv_grab_au\".\n\n" .
890            "You may safely delete $invoked.\n\n";
891    }
892
893    status();
894
895    unless (ask_boolean("\nGrab data now?"))
896    {
897        exit 0;
898    }
899}
900
901sub get_channels
902{
903    my @date = localtime;
904    my $page = fetch_file(
905        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
906        ($date[5] + 1900) . "-$date[4]-$date[3]");
907    my @channellist;
908    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
909    {
910        push @channellist, $1;
911    }
912    return @channellist;
913}
914
915# -----------------------------------------
916# Subs: Status & Help
917# -----------------------------------------
918
919sub show_config
920{
921    print "\nConfiguration\n".
922          "-------------\n" .
923          "Config file: $config_file\n" .
924          "Debug mode : " . is_set($debug) . "\n" .
925          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
926          "Region ID  : $region\n";
927  show_channels();
928  print "\n";
929  status();
930  print "\n";
931}
932
933sub show_channels
934{
935  print "Subscribed channels:\n";
936  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
937  print "Optional (HDTV) channels:\n";
938  print "    $_ -> $opt_channels->{$_}\n" for sort keys %$opt_channels;
939}
940
941sub is_set
942{
943    my $arg = shift;
944    return $arg ? "Yes" : "No";
945}
946
947sub pretty_print
948{
949    my ($p, $len) = @_;
950    my $spaces = ' ' x (79-$len);
951    my $ret = "";
952
953    while (length($p) > 0) {
954        if (length($p) <= $len) {
955            $ret .= $p;
956            $p = "";
957        } else {
958            # find a space to the left of cutoff
959            my $len2 = $len;
960            while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
961                $len2--;
962            }
963            if ($len2 == 0) {
964                # no space - just print it with cutoff
965                $ret .= substr($p,0,$len);
966                $p = substr($p,$len,(length($p)-$len));
967            } else {
968                # print up to space
969                $ret .= substr($p,0,$len2);
970                $p = substr($p,($len2+1),(length($p)-$len2+1));
971            }
972            # print whitespace
973            $ret .= "\n".$spaces;
974        }
975    }
976    return $ret;
977}
978
979sub status
980{
981    print "\nThe following plugins are known:\n",
982          " Type     Name           Version Description\n".
983          " -------- -------------- ------- ----------------------------------------------\n";
984
985    foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) {
986        printf " %-8s %-15s%7s %46s\n",
987          substr($components->{$_}->{type},0,8), 
988          length($_) > 15 ? substr($_,0,13).".." : $_,
989          ($components->{$_}->{ver} ? substr($components->{$_}->{ver},0,7) : "unknown"),
990          (defined $components->{$_}->{config}->{desc} ?
991            pretty_print($components->{$_}->{config}->{desc},46) : "");
992    }
993    printf "\n";
994
995    print "Grabbers, listed in order of quality:\n".
996          "                   Enabled/\n".
997          " Grabber        Qual Ready Last Run   Status\n" .
998          " -------------- ---- ----- ---------- -----------------------------------------\n";
999    my %qual_table = ( 3 => "Best", 2 => "Good", 1 => "Avg" );
1000    foreach (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
1001        my $h = $components->{$_};
1002        printf  " %-15s%-4s  %1s/%1s %11s %s\n",
1003          length($_) > 15 ? substr($_,0,13).".." : $_,
1004          $qual_table{($h->{config}->{quality})},
1005          $h->{disabled} ? 'N' : 'Y',
1006          $h->{ready} ? 'Y' : 'N',
1007          $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1008          $h->{laststatus} ? pretty_print($h->{laststatus},41) : '';
1009    }
1010
1011    print "\n".
1012          "              Enabled/\n".
1013          " Reconciler     Ready Last Run   Status\n" .
1014          " -------------- ----- ---------- ----------------------------------------------\n";
1015    foreach (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
1016        my $h = $components->{$_};
1017        printf  " %-15s %1s/%1s %11s %s\n",
1018          length($_) > 15 ? substr($_,0,13).".." : $_,
1019          $h->{disabled} ? 'N' : 'Y',
1020          $h->{ready} ? 'Y' : 'N',
1021          $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1022          $h->{laststatus} ? pretty_print($h->{laststatus},46) : '';
1023    }
1024
1025    print "\n".
1026          "              Enabled/\n".
1027          " Postprocessor  Ready Last Run   Status\n" .
1028          " -------------- ----- ---------- ----------------------------------------------\n";
1029    foreach (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
1030        my $h = $components->{$_};
1031        printf  " %-15s %1s/%1s %11s %s\n",
1032          length($_) > 15 ? substr($_,0,13).".." : $_,
1033          $h->{disabled} ? 'N' : 'Y',
1034          $h->{ready} ? 'Y' : 'N',
1035          $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1036          $h->{laststatus} ? pretty_print($h->{laststatus},46) : '';
1037    }
1038    printf "\nPreferred titles from grabber '%s'\n",$pref_title_source if ($pref_title_source);
1039    printf "\n";
1040}
1041
1042sub capabilities
1043{
1044    print "baseline\nmanualconfig\n";
1045    exit 0;
1046}
1047
1048sub description
1049{
1050    print "Australia\n";
1051    exit 0;
1052}
1053
1054sub version
1055{
1056    print "$version\n";
1057    exit 0;
1058}
1059
1060sub help
1061{
1062    print q{
1063Command-line options:
1064    --help                Print this message
1065
1066    --status              Print a list of grabbers maintained
1067    --list                Print a detailed list of grabbers
1068    --setmirror <s>       Set URL <s> as primary location to check for updates
1069
1070    --configure           Setup
1071    --show-config         Print setup details
1072
1073    --setpreftitle <s>    Set preferred 'title' source as grabber <s>
1074    --clearpreftitle      clear preferred 'title' source
1075
1076    --disable <s>         Don't ever use grabber/postprocessor <s>
1077    --enable <s>          Okay, maybe use it again then
1078    --uninstall <s>       Remove a disabled grabber/postprocessor
1079
1080    --noupdate            Do not attempt to update before running
1081    --update              Update only; do not grab data
1082
1083    --check               Check status of all grabbers and postprocessors
1084
1085    --capabilities        Report capabilities to XMLTV
1086
1087    --nolog               Don't write a logfile
1088};
1089    exit 0;
1090}
1091
1092# -----------------------------------------
1093# Subs: override handlers for standard perl.
1094# -----------------------------------------
1095
1096# ugly hack. please don't try this at home kids!
1097sub my_die {
1098    my ($arg,@rest) = @_;
1099    my ($pack,$file,$line,$sub) = caller(0);
1100
1101    # check if we are in an eval()
1102    if ($^S) {
1103        printf STDERR "  shepherd caught a die() within eval{} from file $file line $line\n";
1104    } else {
1105            printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
1106            if ($arg) {
1107                CORE::die($arg,@rest);
1108            } else {
1109                CORE::die(join("",@rest));
1110            }
1111    }
1112}
Note: See TracBrowser for help on using the browser.