root/shepherd @ 29

Revision 29, 37.0 kB (checked in by max, 7 years ago)

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