root/shepherd @ 17

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

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