root/applications/shepherd @ 213

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

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