root/applications/shepherd @ 282

Revision 282, 33.0 kB (checked in by lincoln, 6 years ago)

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