root/apps/shepherd @ 209

Revision 209, 30.8 kB (checked in by lincoln, 7 years ago)

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