root/shepherd @ 10

Revision 10, 34.6 kB (checked in by lincoln, 7 years ago)

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