root/shepherd @ 19

Revision 19, 36.0 kB (checked in by max, 7 years ago)

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