root/applications/shepherd @ 214

Revision 214, 31.0 kB (checked in by lincoln, 7 years ago)

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