root/shepherd @ 11

Revision 11, 35.1 kB (checked in by lincoln, 7 years ago)

custom DIE() handler to catch die statements in XMLTV and XML::Parser modules because wrapping in eval{} didn't actually work right. bit of an ugly hack but seems to work well.
Line 
1#!/usr/bin/perl -w
2
3# "Shepherd"
4
5my $version = '0.2.6';
6
7# A wrapper for various Aussie TV guide data grabbers
8#
9# Use --help for command-line options.
10# See shepherd.txt for details.
11#
12#  A current version of this script, plus a README file, might be here:
13#  http://www.whuffy.com/tv_grab_au/
14#
15# Changelog:
16# 0.1.0   : Basic self-updating and grabber management
17# 0.2.0   : --configure
18# 0.2.1   : Has a home in ~/.shepherd/
19# 0.2.2   : --check
20# 0.2.3   : Bugfix: archives correctly
21# 0.2.5   : multi-grabber (potentially with partial data)
22# 0.2.6   : postprocessor support
23#
24# ToDo:
25# * --mirror <url> option, to let you get software from somewhere other
26#   than whuffy. Store this in shepherd.conf. Whuffy is merely the first
27#   mirror.
28# * Make it check compilation after installing by calling --version or
29#   --desc or --ready
30# * --ready  option that says whether config is required?
31
32BEGIN { *CORE::GLOBAL::die = \&my_die; }
33use strict;
34use LWP::Simple;
35use Sort::Versions;
36use Cwd;
37use Getopt::Long;
38use Data::Dumper;
39use XMLTV;
40use XMLTV::Ask;
41use DateTime::Format::Strptime;
42use POSIX qw(strftime);
43use Time::HiRes qw(gettimeofday tv_interval);
44
45# ---------------------------------------------------------------------------
46# --- Global Variables
47# ---------------------------------------------------------------------------
48
49my $progname = 'shepherd';
50
51my $HOME = 'http://www.whuffy.com';
52my $STATUS = "$HOME/status";
53
54my $invoked = Cwd::realpath($0);
55
56# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
57# it will try /opt/shepherd/ instead.
58my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
59-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
60chdir($CWD);
61
62my $GRABBER_DIR = "$CWD/grabbers";
63my $POSTPROCESSOR_DIR = "$CWD/postprocessors";
64my $ARCHIVE_DIR = "$CWD/archive";
65
66my $timeslot_size = (15 * 60);                  # 15 minute slots
67my $channel_ok_threshold_percent = 90;          # 90% these may need to be tweaked but look ok for now
68my $postprocessor_ok_threshold_percent = 80;    # 80% these may need to be tweaked but look ok for now
69my $postprocessor_disable_failure_threshold = 5; # number of times a postprocessor has to fail in a row before it is automatically disabled
70
71my $opt;
72my $pref_order;
73my $made_changes = 0;
74my $debug = 1;
75my $grabbers = { };
76my $postprocessors = { };
77my $preferred; # obsolete but may still exist in shepherd.conf
78my $region;
79my $channels;
80my $config_file =   "$CWD/$progname.conf";
81my $channels_file = "$CWD/channels.conf";
82my $days;
83
84# postprocessing
85my $langs = [ 'en' ];
86my $num_timeslots;
87my $plugin_data = { };
88my $channel_data = { };
89my $starttime, my $endtime;
90my $input_postprocess_files = "";
91my $insufficient_grabber_data = 0;
92
93# ---------------------------------------------------------------------------
94# --- Setup
95# ---------------------------------------------------------------------------
96
97print ucfirst($progname) . " v$version\n\n";
98#print "Cwd: $CWD.\n";
99
100# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
101Getopt::Long::Configure(qw/pass_through/);
102
103get_initial_command_line_options();
104
105help() if ($opt->{help});
106
107unless ($opt->{configure})
108{
109    read_config_file();
110    read_channels_file();
111}
112
113get_remaining_command_line_options();
114
115if ($opt->{status})
116{
117    status();
118    exit;
119}
120
121if ($opt->{show_config})
122{
123    show_config();
124    exit;
125}
126
127if ($opt->{enable})
128{
129    enable($opt->{enable});
130}
131
132if ($opt->{disable})
133{
134    disable($opt->{disable});
135}
136
137&set_order(0,$opt->{setorder}) if ($opt->{setorder});
138&check() if ($opt->{check});
139
140if ($opt->{enable} or $opt->{disable} or $opt->{setorder} or $opt->{check})
141{
142    set_order(1) if $made_changes;
143    write_config_file() if $made_changes;
144    status();
145    exit;
146}
147
148# ---------------------------------------------------------------------------
149# --- Update
150# ---------------------------------------------------------------------------
151
152unless ($opt->{noupdate})
153{
154    update($progname, $version);
155    set_order(1) if $made_changes;
156    write_config_file() if (($made_changes) && (! $opt->{configure}))
157}
158
159if ($opt->{configure})
160{
161    configure();
162}
163
164# ---------------------------------------------------------------------------
165# --- Go!
166# ---------------------------------------------------------------------------
167
168unless ($opt->{update})
169{
170    calc_date_range();
171    grab_data();
172    postprocess_data();
173    output_data();
174}
175
176print "Done.\n";
177
178status();
179write_config_file();
180
181# ---------------------------------------------------------------------------
182# --- Subroutines
183# ---------------------------------------------------------------------------
184
185# -----------------------------------------
186# Subs: Grabbing
187# -----------------------------------------
188
189sub grab_data
190{
191    my $used_grabbers = 0;
192    my $need_more_data = 1;
193
194    printf "\nGrabber stage:\n";
195
196    # iterate across grabbers until we have all our data we want (or need)
197    foreach my $grabber (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
198        next if ($grabbers->{$grabber}->{disabled});
199        $used_grabbers++;
200
201        $grabbers->{$grabber}->{lastdata} = time;
202        $grabbers->{$grabber}->{laststatus} = "unknown";
203
204        printf "\nSHEPHERD: Using grabber: (%d) %s\n",$grabbers->{$grabber}->{order},$grabber;
205
206        my $output = "$GRABBER_DIR/$grabber/output.xmltv";
207        $input_postprocess_files .= "$output ";
208
209        my $comm = "$GRABBER_DIR/$grabber/$grabber " .
210                   "--region $region " .
211                   "--channels_file $channels_file " .
212                   "--output $output";
213
214        # NOTE: ideally a grabber could be instructed to fetch partial data through --channel, --starttime & --endtime
215        # we don't have that for now so instead whenever there is missing data, ALL 7 days for all channels will be collected
216        # FIXME FUTURE: call grabbers just with what we want...
217        $comm .= " --days $days" if ($days);
218        $comm .= " --offset $opt->{offset}" if ($opt->{offset});
219        $comm .= " --debug" if ($debug);
220        $comm .= " @ARGV" if (@ARGV);
221        print "SHEPHERD: Excuting command: $comm\n";
222
223        chdir "$GRABBER_DIR/$grabber/";
224        system($comm);
225        chdir $CWD;
226
227        # soak up the data we just collected
228        &soak_up_data($grabber, $output, "grabber");
229        $grabbers->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
230
231        # check to see if we have all the data we want
232        $need_more_data = &analyze_plugin_data($channel_ok_threshold_percent, "AGGREGATE GRABBER");
233
234        last if (!$need_more_data);
235    }
236
237
238    if ($used_grabbers == 0)
239    {
240        print "No valid grabbers installed/enabled!\n";
241        return;
242    }
243
244    if ($need_more_data)
245    {
246        print "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
247        $insufficient_grabber_data = 1;
248        return;
249    }
250}
251
252
253# interpret xmltv data from this grabber/postprocessor
254sub soak_up_data
255{
256    my ($plugin, $output, $plugintype) = @_;
257
258    if (! -r $output) {
259        printf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output;
260        return;
261    }
262
263    my $parse_start_time = [gettimeofday];
264    printf STDERR "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output;
265    eval { $plugin_data->{$plugin}->{xmltv} = XMLTV::parsefiles($output); };
266    printf STDERR "SHEPHERD: Completed XMLTV parsing from '%s' in %0.2f seconds\n",$plugin,tv_interval($parse_start_time);
267
268    if (defined $plugin_data->{$plugin}->{xmltv}) {
269        $plugin_data->{$plugin}->{valid} = 1;
270
271        my $xmltv = $plugin_data->{$plugin}->{xmltv};
272        my ($encoding, $credits, $chan, $progs) = @$xmltv;
273        $plugin_data->{$plugin}->{total_duration} = 0;
274        $plugin_data->{$plugin}->{programmes} = 0;
275
276        my $strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M %z");
277        my $seen_channels_with_data = 0;
278
279        # iterate thru channels
280        foreach my $ch (sort keys %{$channels}) {
281            my $seen_progs_on_this_channel = 0;
282
283            # iterate thru programmes per channel
284            foreach my $prog (@$progs) {
285                next if ($prog->{channel} ne $channels->{$ch});
286
287                my $t1 = $strptime->parse_datetime($prog->{start});
288                my $t2 = $strptime->parse_datetime($prog->{stop});
289                next if (!$t1 || !$t2); # if we can't parse stop/start then clearly THIS data is bunk!
290
291                # store plugin-specific stats
292                $plugin_data->{$plugin}->{programmes}++;
293                $plugin_data->{$plugin}->{total_duration} += ($t2->epoch - $t1->epoch);
294                $seen_progs_on_this_channel++;
295                $plugin_data->{$plugin}->{earliest_data_seen} = $t1->epoch if (!defined $plugin_data->{$plugin}->{earliest_data_seen});
296                $plugin_data->{$plugin}->{earliest_data_seen} = $t1->epoch if ($t1->epoch < $plugin_data->{$plugin}->{earliest_data_seen});
297                $plugin_data->{$plugin}->{latest_data_seen} = $t2->epoch if (!defined $plugin_data->{$plugin}->{latest_data_seen});
298                $plugin_data->{$plugin}->{latest_data_seen} = $t2->epoch if ($t2->epoch > $plugin_data->{$plugin}->{latest_data_seen});
299
300                # store channel-specific stats
301                $channel_data->{$ch}->{programmes}++;
302                $channel_data->{$ch}->{total_duration} += ($t2->epoch - $t1->epoch);
303
304                # store timeslot info
305                next if ($t1->epoch > $endtime);        # programme starts after timeslots we are interested .. nice that we have it ... but we really don't care about it!
306                next if ($t2->epoch < $starttime);      # programme ends  before timeslots we are interested .. nice that we have it ... but we really don't care about it!
307                my $start_slotnum;
308                if ($t1->epoch >= $starttime) {
309                    $start_slotnum = int(($t1->epoch - $starttime) / $timeslot_size);
310                } else {
311                    $start_slotnum = 0;
312                }
313                my $end_slotnum;
314                if ($t2->epoch < $endtime) {
315                    $end_slotnum = int(($t2->epoch - $starttime) / $timeslot_size);
316                } else {
317                    $end_slotnum = ($num_timeslots-1);
318                }
319
320                # add this programme into the global timeslots table for this channel
321                foreach my $slotnum ($start_slotnum..$end_slotnum) {
322                    $channel_data->{$ch}->{timeslots}[$slotnum]++;
323                }
324            }
325
326            $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
327        }
328
329        # print some stats about what we saw!
330        printf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
331            ucfirst($plugintype), $plugin, $seen_channels_with_data, $plugin_data->{$plugin}->{programmes},
332            int($plugin_data->{$plugin}->{total_duration} / 86400),             # days
333            int(($plugin_data->{$plugin}->{total_duration} % 86400) / 3600),    # hours
334            int(($plugin_data->{$plugin}->{total_duration} % 3600) / 60),       # mins
335            int($plugin_data->{$plugin}->{total_duration} % 60),                # sec
336            (defined $plugin_data->{$plugin}->{earliest_data_seen} ? (strftime "%a %e %b %H:%M - ", localtime($plugin_data->{$plugin}->{earliest_data_seen})) : 'no data'),
337            (defined $plugin_data->{$plugin}->{latest_data_seen} ? (strftime "%a %e %b %H:%M", localtime($plugin_data->{$plugin}->{latest_data_seen})) : '');
338        $plugin_data->{$plugin}->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
339            $seen_channels_with_data, $plugin_data->{$plugin}->{programmes},
340            int($plugin_data->{$plugin}->{total_duration} / 3600),
341            (defined $plugin_data->{$plugin}->{earliest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($plugin_data->{$plugin}->{earliest_data_seen})) : 'no'),
342            (defined $plugin_data->{$plugin}->{latest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($plugin_data->{$plugin}->{latest_data_seen})) : 'data');
343
344    } else {
345        printf "WARNING: Plugin %s didn't seem to return any valid XMLTV!\n",$plugin;
346        delete $plugin_data->{$plugin}->{valid};
347    }
348}
349
350
351# analyze grabber data - do we have all the data we want?
352# returns 1 if we need more data, 0 if we have all we want
353sub analyze_plugin_data
354{
355    my ($threshold,$analysistype) = @_;
356    my $retval = 0; # until proven otherwise
357    my $total_data_percent = 0, my $total_channels = 0;
358    my $statusstring = "";
359
360    # iterate across each channel
361    foreach my $ch (sort keys %{$channels}) {
362        $total_channels++;
363        if (defined $channel_data->{$ch}) {
364            my $data_in_channel = 0;
365            for my $slotnum (0..($num_timeslots-1)) {
366                $data_in_channel++ if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) && ($channel_data->{$ch}->{timeslots}[$slotnum] > 0));
367            }
368
369            # do we have enough data for this channel?
370            my $data_in_channel_percent = $data_in_channel / ($num_timeslots-1) * 100;
371            if ($data_in_channel_percent >= $threshold) {
372                $statusstring .= sprintf "%s: %0.1f%% [complete], ",$ch,$data_in_channel_percent;
373            } else {
374                $statusstring .= sprintf "%s: %0.1f%% [hungry], ",$ch,$data_in_channel_percent;
375                $retval = 1;
376            }
377            $total_data_percent += $data_in_channel_percent;
378        } else {
379            $statusstring .= sprintf "%s: 0%% [starving], ",$ch;
380            $retval = 1;
381        }
382    }
383
384    if ($total_channels > 0) {
385        $total_data_percent = $total_data_percent / $total_channels;
386    } else {
387        $total_data_percent = 0;
388    }
389
390    # print some stats about what our analysis says!
391    printf "SHEPHERD: %s ANALYSIS: %sTOTAL %0.2f%% %s %0.2f%%: %s\n",
392        uc($analysistype), $statusstring, $total_data_percent,
393        ($total_data_percent >= $channel_ok_threshold_percent ? ">" : "<"), $channel_ok_threshold_percent,
394        ($retval ? "WANT MORE DATA" : "COMPLETE");
395    return $retval;
396}
397
398
399# work out date range we are expecting data to be in
400sub calc_date_range
401{
402    # normalize starttime to beginning of hour
403    my $now = time;
404    my ($sec,$min,@rest) = localtime($now);
405
406    $starttime = $now - ((60 * $min) + $sec);
407
408    if ($days) {
409        $endtime = $starttime + ($days * 86400);
410    } else {
411        $endtime = $starttime + (7*86400);
412    }
413    $starttime += (86400 * $opt->{offset}) if ($opt->{offset});
414
415    $num_timeslots = ($endtime - $starttime) / $timeslot_size;
416}
417
418# -----------------------------------------
419# Subs: Postprocessing
420# -----------------------------------------
421
422sub postprocess_data
423{
424    # for our first postprocessor, we feed it ALL of the XMLTV files we have
425    # as each postprocessor runs, we feed in the output from the previous one
426    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
427    # reverts back to the previous postprocessor if it was shown to be bad
428
429    # first time around: feed in $input_postprocess_files
430    my $need_more_data;
431
432    printf "\nPostprocessing stage:\n";
433
434    foreach my $postprocessor (sort { $postprocessors->{$a} <=> $postprocessors->{$b} } keys %$postprocessors) {
435        next if ($postprocessors->{$postprocessor}->{disabled});
436
437        $postprocessors->{$postprocessor}->{lastdata} = time;
438        $postprocessors->{$postprocessor}->{laststatus} = "unknown";
439
440        printf "\nSHEPHERD: Using postprocessor: %s\n",$postprocessor;
441
442        my $output = "$POSTPROCESSOR_DIR/$postprocessor/output.xmltv";
443        my $comm = "$POSTPROCESSOR_DIR/$postprocessor/$postprocessor " .
444                   "--region $region " .
445                   "--channels_file $channels_file " .
446                   "--output $output";
447        $comm .= " --days $days" if ($days);
448        $comm .= " --offset $opt->{offset}" if ($opt->{offset});
449        $comm .= " --debug" if ($debug);
450        $comm .= " @ARGV" if (@ARGV);
451        $comm .= " $input_postprocess_files";
452        print "SHEPHERD: Excuting command: $comm\n";
453
454        chdir "$POSTPROCESSOR_DIR/$postprocessor/";
455        system($comm);
456        chdir $CWD;
457
458        #
459        # soak up the data we just collected and check it
460        # YES - these are the SAME routines we used in the previous 'grabber' phase
461        # but the difference here is that we clear out our 'channel_data' beforehand
462        # so we can independently analyze the impact of this postprocessor.
463        # if it clearly returns bad data, don't use that data (go back one step) and
464        # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
465        #
466
467        # clear out channel_data
468        foreach my $ch (keys %{$channels}) {
469            delete $channel_data->{$ch};
470        }
471
472        # process and analyze it!
473        &soak_up_data($postprocessor, $output, "postprocessor");
474        $need_more_data = &analyze_plugin_data($postprocessor_ok_threshold_percent, "POSTPROCESSOR");
475
476        $postprocessors->{$postprocessor}->{laststatus} = $plugin_data->{$postprocessor}->{laststatus};
477
478        if (($need_more_data) && (!$insufficient_grabber_data)) {
479            # urgh.  this postprocessor did a bad bad thing ...
480            printf "SHEPHERD: XML data from postprocessor %s rejected, using XML from previous stage\n",$postprocessor;
481
482            if (defined $postprocessors->{$postprocessor}->{conescutive_failures}) {
483                $postprocessors->{$postprocessor}->{conescutive_failures}++;
484            } else {
485                $postprocessors->{$postprocessor}->{conescutive_failures} = 1;
486            }
487            printf "SHEPHERD: Postprocessor \"%s\" has now failed %d times in a row.  %d more and it will be automatically disabled.\n",
488                $postprocessor,
489                $postprocessors->{$postprocessor}->{conescutive_failures},
490                ($postprocessor_disable_failure_threshold - $postprocessors->{$postprocessor}->{conescutive_failures});
491
492            if ($postprocessors->{$postprocessor}->{conescutive_failures} >= $postprocessor_disable_failure_threshold) {
493                printf "SHEPHERD: Disabling Postprocessor \"%s\".\n",$postprocessor;
494                $postprocessors->{$postprocessor}->{disabled} = 1;
495            }
496        } else {
497            # accept what this postprocessor did to our output ...
498            printf "SHEPHERD: accepting output from postprocessor %s, feeding it into next stage\n",$postprocessor;
499            $input_postprocess_files = $output;
500            delete $postprocessors->{$postprocessor}->{conescutive_failures} if (defined $postprocessors->{$postprocessor}->{conescutive_failures});
501        }
502    }
503}
504
505
506sub output_data
507{
508    # $input_postprocess_files (hopefully just one file now) contains our final output
509    # send it to whereever --output told us to!
510
511    if ($opt->{output}) {
512        open(F,">$opt->{output}") || die "could not open outputfile $opt->{output} for writing: $!\n";
513    }
514
515    foreach my $infile (split(/ /,$input_postprocess_files)) {
516        if (!(open(INFILE,"<$infile"))) {
517            printf "WARNING: could not open input file \"%s\": %s\n", $infile, $!;
518            printf "Output XMLTV data may be damanged as a result!\n";
519        } else {
520            while (<INFILE>) {
521                if ($opt->{output}) {
522                    print F $_ if ($opt->{output});
523                } else {
524                    print $_;
525                }
526            }
527            close(INFILE);
528        }
529    }
530    close(F) if ($opt->{output});
531}
532
533# -----------------------------------------
534# Subs: Updates & Installations
535# -----------------------------------------
536
537sub update
538{
539    printf "\nChecking for updates:\n\n";
540
541    print "Fetching status file: $STATUS.";
542    my $data = LWP::Simple::get($STATUS);
543    unless ($data)
544    {
545        print "Failed to retrieve status file.\n";
546        return;
547    }
548
549    my %glist = %$grabbers;
550    my %plist = %$postprocessors;
551    while ($data =~ /(.*):(.*):(.*)/g)
552    {
553        my ($proggy, $latestversion, $progtype) = ($1,$2,$3);
554        update_component($proggy, $latestversion, $progtype);
555        delete $glist{$proggy} if ($progtype eq "grabber");
556        delete $plist{$proggy} if ($progtype eq "postprocessor");
557    }
558
559    # work out what grabbers disappeared (if any)
560    foreach (keys %glist) {
561        unless ($grabbers->{$_}->{disabled}) {
562            print "\nDeleted grabber: $_.\n";
563            disable($_,"grabber");
564            $made_changes = 1;
565        }
566    }
567
568    # work out what postprocessors disappeared (if any)
569    foreach (keys %plist) {
570        unless ($postprocessors->{$_}->{disabled}) {
571            print "\nDeleted Postprocessor: $_.\n";
572            disable($_,"postprocessor");
573            $made_changes = 1;
574        }
575    }
576}
577
578sub update_component
579{
580    my ($proggy, $latestversion, $progtype) = @_;
581
582    # handle new installs..
583    if (($proggy eq $progname) && ($progtype eq "shepherd")) {
584        # shepherd itself..
585        if(! -e "$CWD/$progname") {
586            print "Missing: $CWD/$progname\n";
587            install($progname, $latestversion, $progtype);
588            return;
589        }
590    } elsif ($progtype eq "grabber") {
591        if (!defined $grabbers->{$proggy} or ! -e "$GRABBER_DIR/$proggy/$proggy") {
592            print "New grabber: $proggy.\n";
593            install($proggy, $latestversion, $progtype);
594            return;
595        }
596        print "Warning: grabber $proggy disabled by config file.\n" if ($grabbers->{$proggy}->{disabled});
597    } elsif ($progtype eq "postprocessor") {
598        if (!defined $postprocessors->{$proggy} or ! -e "$POSTPROCESSOR_DIR/$proggy/$proggy") {
599            print "New postprocessor: $proggy.\n";
600            install($proggy, $latestversion, $progtype);
601            return;
602        }
603        print "Warning: postprocessor $proggy disabled by config file.\n" if ($postprocessors->{$proggy}->{disabled});
604    }
605
606    # upgrade/downgrades
607    my $ver;
608    if ($progtype eq "grabber") {
609        $ver = ($proggy eq $progname ? $version : $grabbers->{$proggy}->{ver});
610    } elsif ($progtype eq "postprocessor") {
611        $ver = ($proggy eq $progname ? $version : $postprocessors->{$proggy}->{ver});
612    } elsif (($proggy eq $progname) && ($progtype eq "shepherd")) {
613        $ver = $version;
614    } else {
615        print "Warning: unknown type of programme: prog '$proggy' progtype '$progtype' not installed.\n";
616        return;
617    }
618
619    my $result = versioncmp($ver, $latestversion);
620    if ($result == -1) {
621        print "Upgrading $proggy from v$ver to v$latestversion.\n";
622    } elsif ($result == 1) {
623        print "Downgrading $proggy from v$ver to v$latestversion.\n";
624    } else {
625        print "Already have latest version of $proggy: v$ver.\n";
626        return;
627    }
628    install($proggy, $latestversion, $progtype);
629}
630
631sub install
632{
633    my ($proggy, $latestversion, $progtype) = @_;
634
635    print "Downloading $proggy v$latestversion.\n";
636
637    my $rdir = $HOME;
638    my $ldir = $CWD;
639    my $ver = "unkown";
640
641    if (($proggy eq $progname) && ($progtype eq "shepherd")) {
642        $rdir = $HOME;
643        $ldir = $CWD;
644        $ver = $version;
645    } elsif ($progtype eq "grabber") {
646        $rdir = $HOME . "/grabbers";
647        $ldir = "$GRABBER_DIR/$proggy";
648        $ver = $grabbers->{$proggy}->{ver} if ((defined $grabbers->{$proggy}) && $grabbers->{$proggy}->{ver});
649        -d $GRABBER_DIR or mkdir $GRABBER_DIR or die "Cannot create directory $GRABBER_DIR: $!";
650    } elsif ($progtype eq "postprocessor") {
651        $rdir = $HOME . "/postprocessors";
652        $ldir = "$POSTPROCESSOR_DIR/$proggy";
653        $ver = $postprocessors->{$proggy}->{ver} if ((defined $postprocessors->{$proggy}) && $postprocessors->{$proggy}->{ver});
654        -d $POSTPROCESSOR_DIR or mkdir $POSTPROCESSOR_DIR or die "Cannot create directory $POSTPROCESSOR_DIR: $!";
655    } else {
656        print "Warning: unknown type of programme: prog '$proggy' progtype '$progtype' not installed.\n";
657        return;
658    }
659    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!";
660
661    my $newfile = "$ldir/$proggy-$latestversion";
662    my $rc = LWP::Simple::getstore("$rdir/$proggy-$latestversion", $newfile);
663
664    unless (is_success($rc))
665    {
666        print "Failed to retrieve $rdir/$proggy-$latestversion.\n";
667        return;
668    }
669
670    # Make it executable
671    system('chmod u+x ' . $newfile);
672
673    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!";
674
675    if (-e "$ldir/$proggy")
676    {
677        rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$ver");
678    }
679    rename($newfile, "$ldir/$proggy");
680   
681    print "Installed $proggy v$latestversion.\n" if ($debug);
682
683    # if the update was for shepherd itself, restart it
684    if (($proggy eq $progname) && ($progtype eq "shepherd")) {
685        print "\n*** Restarting ***\n\n";
686        exec("$ldir/$proggy");
687        # This exits.
688    }
689
690    print "Testing $proggy...\n" if ($debug);
691    my $result = test_proggy($ldir,"$ldir/$proggy");
692
693    if ($progtype eq "grabber") {
694        $grabbers->{$proggy}->{ver} = $latestversion;
695        $grabbers->{$proggy}->{ready} = $result;
696        $grabbers->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));
697    } elsif ($progtype eq "postprocessor") {
698        $postprocessors->{$proggy}->{ver} = $latestversion;
699        $postprocessors->{$proggy}->{ready} = $result;
700        $postprocessors->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));
701    }
702
703    $made_changes = 1;
704}
705
706sub test_proggy
707{
708    my ($testdir,$proggyexec) = @_;
709
710    chdir($testdir);
711    system("$proggyexec --ready");
712    chdir ($CWD);
713
714    my $result = $?;
715    print "Return value: $result\n" if ($debug);
716
717    print "\nprogramme $proggyexec did not exit cleanly!\n" .
718         "It may require configuration.\n\n" if ($result);
719    return !$result;
720}
721
722sub enable
723{
724    my $proggy = shift;
725
726    # confirm it exists first
727    if ((!$grabbers->{$proggy}) && (!$postprocessors->{$proggy})) {
728        printf "No such grabber/postprocessor: \"%s\".\n",$proggy;
729        return;
730    }
731    print "Enabling $proggy.\n";
732
733    delete $grabbers->{$proggy}->{disabled} if ($grabbers->{$proggy});
734    delete $postprocessors->{$proggy}->{disabled} if ($postprocessors->{$proggy});
735    $made_changes = 1;
736}
737
738sub disable
739{
740    my $proggy = shift;
741
742    # confirm it exists first
743    if ((!$grabbers->{$proggy}) && (!$postprocessors->{$proggy})) {
744        printf "No such grabber/postprocessor: \"%s\".\n",$proggy;
745        return;
746    }
747    print "Disabling $proggy.\n";
748
749    $grabbers->{$proggy}->{disabled} = 1 if ($grabbers->{$proggy});
750    $postprocessors->{$proggy}->{disabled} = 1 if ($postprocessors->{$proggy});
751    $made_changes = 1;
752}
753
754sub set_order
755{
756    my ($quiet,$order) = @_;
757    $pref_order = $order if ($order);
758
759    # reset current order to zero
760    foreach my $proggy (keys %$grabbers) {
761        $grabbers->{$proggy}->{order} = 0;
762    }
763
764    # and now set order
765    my $order_num = 1;
766    if ($pref_order) {
767        foreach my $proggy (split(/,/,$pref_order)) {
768            if (defined $grabbers->{$proggy}) {
769                $grabbers->{$proggy}->{order} = $order_num;
770                $order_num++;
771            }
772        }
773    }
774
775    # set order of any grabbers not specified in a random manner
776    foreach my $proggy (sort keys %$grabbers) {
777        if ((!defined $grabbers->{$proggy}->{order}) || ($grabbers->{$proggy}->{order} == 0)) {
778            $grabbers->{$proggy}->{order} = $order_num+int(rand(1000));
779        }
780    }
781
782    # .. and finally normalize the order (& show the user the order we chose)
783    print "Grabber order set as follows:\n" unless $quiet;
784    $order_num = 0;
785    foreach my $proggy (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
786        $order_num++;
787        $grabbers->{$proggy}->{order} = $order_num;
788        printf " #%d. %s%s\n",$grabbers->{$proggy}->{order},$proggy,($grabbers->{$proggy}->{disabled} ? " [disabled]" : "") unless $quiet;
789    }
790
791    $made_changes = 1;
792}
793
794sub check
795{
796    my $result;
797    foreach my $proggy (keys %$grabbers) {
798        $result = test_proggy("$GRABBER_DIR/$proggy","$GRABBER_DIR/$proggy/$proggy");
799        printf "Grabber %s: %s\n",$proggy,($result ? "OK" : "Failed");
800        if (!$result ne !$grabbers->{$proggy}->{ready}) {
801            $grabbers->{$proggy}->{ready} = $result;
802            $made_changes = 1;
803        }
804    }
805
806    foreach my $proggy (keys %$postprocessors) {
807        $result = test_proggy("$POSTPROCESSOR_DIR/$proggy","$POSTPROCESSOR_DIR/$proggy/$proggy");
808        printf "Postprocessor %s: %s\n",$proggy,($result ? "OK" : "Failed");
809        if (!$result ne !$postprocessors->{$proggy}->{ready}) {
810            $postprocessors->{$proggy}->{ready} = $result;
811            $made_changes = 1;
812        }
813    }
814}
815
816# -----------------------------------------
817# Subs: Setup
818# -----------------------------------------
819
820sub read_config_file
821{
822    read_file($config_file, 'configuration');
823
824    # if we are updating from a previous rev of shepherd.conf we may not
825    # have any 'order' fields set .. check here
826    my $found_order = 1;
827    foreach (keys %$grabbers)
828    {
829        $found_order = 0 if (!defined $grabbers->{$_}->{order});
830    }
831    if (($found_order == 0) && (!$opt->{setorder}))
832    {
833        # at least one 'order' was missing .. we need to put it in!
834        printf "Legacy shepherd.conf file didn't contain any grabber order! Automatically updating using a random order, use --setorder to manually set this if you care.\n";
835        &set_order(1);
836    }
837}
838
839sub read_channels_file
840{
841    read_file($channels_file, 'channels');
842}
843
844sub read_file
845{
846    my $fn = shift;
847    my $name = shift;
848
849    print "Reading $name file: $fn\n";
850    unless (-r $fn)
851    {
852        unless ($opt->{configure})
853        {
854            print "\nNo $name file found.\n" .
855                  ucfirst($progname) . " must be configured: " .
856                  "configuring now.\n\n";
857            $opt->{'configure'} = 1;
858        }
859        return;
860    }
861    local (@ARGV, $/) = ($fn);
862    no warnings 'all';
863    eval <>;
864    if ($@ and !$opt->{configure})
865    {
866        die "\nError in $name file!\nDetails:\n$@";
867    }
868}
869
870sub write_config_file
871{
872    open(CONF, ">$config_file") or die "cannot write to $config_file: $!";
873    print CONF Data::Dumper->Dump(
874        [$region,  $pref_order,   $grabbers, $postprocessors  ],
875        ["region", "pref_order", "grabbers", "postprocessors" ]);
876    close CONF;
877    print "\nUpdated configuration file $config_file.\n" if ($debug);
878}
879
880sub write_channels_file
881{
882    open(CHAN, ">$channels_file") or die "cannot write to $channels_file: $!";
883    print CHAN Data::Dumper->Dump([$channels], ["channels"]);
884    close CHAN;
885    print "Updated channels file $channels_file.\n" if ($debug);
886}
887
888sub get_initial_command_line_options
889{
890  GetOptions( 'config-file=s'   => \$opt->{configfile},
891              'help'            => \$opt->{help},
892              'configure'       => \$opt->{configure},
893              'output'          => \$opt->{output},
894              'debug'           => \$debug);
895}
896
897sub get_remaining_command_line_options
898{
899    GetOptions(
900              'version'         => \$opt->{status},
901              'status'          => \$opt->{status},
902              'list'            => \$opt->{list},
903              'show-config'     => \$opt->{show_config},
904
905              'update'          => \$opt->{update},
906              'noupdate'        => \$opt->{noupdate},
907
908              'disable=s'       => \$opt->{disable},
909              'enable=s'        => \$opt->{enable},
910              'setorder=s'      => \$opt->{setorder},
911
912              'days=i'          => \$days,
913              'offset=i'        => \$opt->{offset},
914              'show-channels'   => \$opt->{show_channels},
915              'output=s'        => \$opt->{output},
916              'check'           => \$opt->{check}
917            );
918}
919
920
921# -----------------------------------------
922# Subs: Configuration
923# -----------------------------------------
924
925sub configure
926{
927    my $REGIONS = {
928        "ACT" => 126,
929        "NSW: Sydney" => 73,
930        "NSW: Newcastle" => 184,
931        "NSW: Central Coast" => 66,
932        "NSW: Griffith" => 67,
933        "NSW: Broken Hill" => 63,
934        "NSW: Northern NSW" => 69,
935        "NSW: Southern NSW" => 71,
936        "NSW: Remote and Central" => 106,
937        "NT: Darwin" => 74,
938        "NT: Remote & Central" => 108,
939        "QLD: Brisbane" => 75,
940        "QLD: Gold Coast" => 78,
941        "QLD: Regional" => 79,
942        "QLD: Remote & Central" => 114,
943        "SA: Adelaide" => 81,
944        "SA: Renmark" => 82,
945        "SA: Riverland" => 83,
946        "SA: South East SA" => 85,
947        "SA: Spencer Gulf" => 86,
948        "SA: Remote & Central" => 107,
949        "Tasmania" => 88,
950        "VIC: Melbourne" => 94,
951        "VIC: Geelong" => 93,
952        "VIC: Eastern Victoria" => 90,
953        "VIC: Mildura/Sunraysia" => 95,
954        "VIC: Western Victoria" => 98,
955        "WA: Perth" => 101,
956        "WA: Regional" => 102
957    };
958
959    print "\nConfiguring.\n\n" .
960          "Select your region:\n";
961    foreach (sort keys %$REGIONS)
962    {
963        printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
964    }
965    $region = ask_choice("Enter region code:", "94", values %$REGIONS);
966
967    print "\nFetching channel information... ";
968
969    my @channellist = get_channels();
970
971    print "done.\n\n" .
972          "For each channel you want guide data for, enter an XMLTV id\n" .
973          "of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
974          "guide data for this channel, just press Enter.\n\n" .
975          "Please don't subscribe to unneeded channels.\n\nChannels:\n";
976    $channels = {};
977    my $line;
978    foreach (@channellist)
979    {
980        $line = ask(" \"$_\"? ");
981        $channels->{$_} = $line if ($line);
982    }
983
984
985    print "\nRandomly selecting grabber order.\n\n";
986    set_order(0);
987
988    show_channels();
989    unless(ask_boolean("\nCreate configuration file?"))
990    {
991        print "Aborting configuration.\n";
992        exit 0;
993    }
994
995    write_config_file();
996    write_channels_file();
997
998    print "Finished configuring.\n\n" .
999          "Shepherd is installed into $CWD.\n\n";
1000   
1001    if ($invoked ne "$CWD/$progname" and $invoked =~ /$progname/)
1002    {
1003        print "Warning: you invoked this program as $invoked.\n" .
1004            "In the future, it should be run as $CWD/$progname,\n" .
1005            "to avoid constantly re-downloading the latest version.\n\n" .
1006            "MythTV users may wish to create the following symlink, by " .
1007            "doing this (as root):\n" .
1008            "\"ln -s $CWD/$progname /usr/bin/tv_grab_au\".\n\n" .
1009            "You may safely delete $invoked.\n\n";
1010    }
1011
1012    status();
1013
1014    unless (ask_boolean("\nGrab data now?"))
1015    {
1016        exit 0;
1017    }
1018}
1019
1020sub get_channels
1021{
1022    my @date = localtime;
1023    my $page = LWP::Simple::get(
1024        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1025        ($date[5] + 1900) . "-$date[4]-$date[3]");
1026    my @channellist;
1027    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
1028    {
1029        push @channellist, $1;
1030    }
1031    return @channellist;
1032}
1033
1034# -----------------------------------------
1035# Subs: Status & Help
1036# -----------------------------------------
1037
1038sub show_config
1039{
1040    print "\nConfiguration\n".
1041          "-------------\n" .
1042          "Config file: $config_file\n" .
1043          "Debug mode : " . is_set($debug) . "\n" .
1044          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1045          "Region ID  : $region\n";
1046  show_channels();
1047  print "\n";
1048  status();
1049  print "\n";
1050}
1051
1052sub show_channels
1053{
1054  print "Subscribed channels:\n";
1055  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
1056}
1057
1058sub is_set
1059{
1060    my $arg = shift;
1061    return $arg ? "Yes" : "No";
1062}
1063
1064sub status
1065{
1066    print " Grabber           Version Enabled Ready Last Run   Status\n" .
1067          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1068    foreach (sort { $grabbers->{$a}->{order} <=> $grabbers->{$b}->{order} } keys %$grabbers) {
1069        my $h = $grabbers->{$_};
1070        printf  " %-16s %8s %4s %6s  %11s %s\n",
1071                "$h->{order}. $_",
1072                ($h->{ver} ? $h->{ver} : "unknown"),
1073                $h->{disabled} ? '' : 'Y',
1074                $h->{ready} ? 'Y' : '',
1075                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1076                $h->{laststatus} ? $h->{laststatus} : '';
1077    }
1078    printf "Grabbers shown in order of preference.\n\n";
1079
1080    print " Postprocessor     Version Enabled Ready Last Run   Status\n" .
1081          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1082    foreach (sort { $postprocessors->{$a} <=> $postprocessors->{$b} } keys %$postprocessors) {
1083        my $h = $postprocessors->{$_};
1084        printf  " %-16s %8s %4s %6s  %11s %s\n",
1085                $_,
1086                ($h->{ver} ? $h->{ver} : "unknown"),
1087                $h->{disabled} ? '' : 'Y',
1088                $h->{ready} ? 'Y' : '',
1089                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1090                $h->{laststatus} ? $h->{laststatus} : '';
1091    }
1092    printf "Postprocessors shown in order of execution.\n\n";
1093}
1094
1095sub help
1096{
1097    print q{
1098Command-line options:
1099    --help                Print this message
1100
1101    --status              Print a list of grabbers maintained
1102    --list                Print a detailed list of grabbers
1103
1104    --configure           Setup
1105    --show-config         Print setup details
1106
1107    --setorder <s>        Set order of grabbers to <s> (comma-seperated list of grabbers)
1108
1109    --disable <s>         Don't ever use grabber/postprocessor <s>
1110    --enable <s>          Okay, maybe use it again then
1111    --uninstall <s>       Remove a disabled grabber/postprocessor
1112
1113    --noupdate            Do not attempt to update before running
1114    --update              Update only; do not grab data
1115
1116    --check               Check status of all grabbers and postprocessors
1117};
1118    exit 0;
1119}
1120
1121# -----------------------------------------
1122# Subs: override handlers for standard perl.
1123# -----------------------------------------
1124
1125# ugly hack. please don't try this at home kids!
1126sub my_die {
1127    my ($arg,@rest) = @_;
1128    my ($pack,$file,$line,$sub) = caller(1);
1129
1130    # check if we are in an eval()
1131    if ($^S) {
1132        printf STDERR "  shepherd caught a die() within eval{} from file $file line $line\n";
1133    } else {
1134        if (!ref($arg)) {
1135            CORE::die((sprintf "DIE at line %d in file %s: %s\n",$line,$file,(join("",($arg,@rest)))));
1136        } else {
1137            CORE::die($arg,@rest);
1138        }
1139    }
1140}
Note: See TracBrowser for help on using the browser.