root/applications/shepherd @ 240

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

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