root/shepherd @ 16

Revision 16, 36.2 kB (checked in by lincoln, 7 years ago)

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