root/shepherd @ 77

Revision 77, 45.0 kB (checked in by lincoln, 7 years ago)

shepherd update was failing because of no shepherd.conf on whuffy. skip .conf file download for shepherd
Line 
1#!/usr/bin/perl -w
2
3# "Shepherd"
4
5my $version = '0.2.12';
6
7# A wrapper for various Aussie TV guide data grabbers
8#
9# Use --help for command-line options.
10# See shepherd.txt for details.
11#
12#  A current version of this script, plus a README file, might be here:
13#  http://www.whuffy.com/tv_grab_au/
14#
15# Changelog:
16# 0.1.0   : Basic self-updating and grabber management
17# 0.2.0   : --configure
18# 0.2.1   : Has a home in ~/.shepherd/
19# 0.2.2   : --check
20# 0.2.3   : Bugfix: archives correctly
21# 0.2.5   : Multi-grabber (potentially with partial data)
22# 0.2.6   : Postprocessor support
23# 0.2.7   : Changed online file structure
24# 0.2.8   : Integrated reconciler
25# 0.2.9   : Grabber config support
26# 0.2.10  : Bugfix: don't call postprocessors that aren't ready,
27#           rework accept-data-or-not postprocessor logic
28# 0.2.11  : Dedicated external reconciler support
29# 0.2.12  : add concept of 'always run this grabber'; useful for prepaid
30#           data sources like IceTV
31
32BEGIN { *CORE::GLOBAL::die = \&my_die; }
33
34use strict;
35
36use LWP::Simple;
37use Sort::Versions;
38use Cwd;
39use Getopt::Long;
40use Data::Dumper;
41use XMLTV;
42use XMLTV::Ask;
43use DateTime::Format::Strptime;
44use POSIX qw(strftime);
45use Time::HiRes qw(gettimeofday tv_interval);
46
47# ---------------------------------------------------------------------------
48# --- Global Variables
49# ---------------------------------------------------------------------------
50
51my $progname = 'shepherd';
52
53my $HOME = 'http://www.whuffy.com/shepherd';
54
55my $invoked = Cwd::realpath($0);
56
57# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
58# it will try /opt/shepherd/ instead.
59my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
60-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
61chdir($CWD);
62
63my $ARCHIVE_DIR = "$CWD/archive";
64
65
66#### analyzer settings ####
67
68my $timeslot_size = (15 * 60);                  # 15 minute slots
69my $channel_ok_threshold_percent = 90;          # 90% these may need to be
70                                                # tweaked but look ok for now
71my $postprocessor_ok_threshold_percent = 80;    # 80% these may need to be
72                                                # tweaked but look ok for now
73my $postprocessor_disable_failure_threshold = 5;# number of times a
74                                                # postprocessor has to fail
75                                                # in a row before it is
76                                                # automatically disabled
77
78my $opt;
79my $pref_order;
80my $mirror_site;
81my $made_changes = 0;
82my $debug = 0;
83my $recdebug = 0;
84my $components = { };
85my $gscore;
86my $region;
87my $channels;
88my $config_file =   "$CWD/$progname.conf";
89my $channels_file = "$CWD/channels.conf";
90my $days = 7;
91
92# postprocessing
93my $title_translation_table = { };
94my $langs = [ 'en' ];
95my $num_timeslots;
96my $plugin_data = { };
97my $channel_data = { };
98my $starttime, my $endtime;
99my $input_postprocess_file = "";
100my $grabber_data_percent = 0;
101my $reconciler_data_percent = 0;
102
103# OBSOLETE: will be removed
104my $grabbers;
105my $postprocessors;
106my $preferred;
107
108# ---------------------------------------------------------------------------
109# --- Setup
110# ---------------------------------------------------------------------------
111
112print ucfirst($progname) . " v$version\n\n";
113#print "Cwd: $CWD.\n";
114
115# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
116Getopt::Long::Configure(qw/pass_through/);
117
118get_initial_command_line_options();
119
120help() if ($opt->{help});
121
122unless ($opt->{configure})
123{
124    read_config_file();
125    read_channels_file();
126}
127
128get_remaining_command_line_options();
129
130if ($opt->{status})
131{
132    status();
133    exit;
134}
135
136if ($opt->{show_config})
137{
138    show_config();
139    exit;
140}
141
142if ($opt->{enable})
143{
144    enable($opt->{enable});
145}
146
147if ($opt->{disable})
148{
149    disable($opt->{disable});
150}
151
152if ($opt->{setorder})
153{
154    set_order(0, $opt->{setorder}); 
155}
156
157if ($opt->{check})
158{
159    check();
160}
161
162if ($opt->{enable} or
163    $opt->{disable} or
164    $opt->{setorder} or
165    $opt->{check} or
166    $opt->{mirror})
167{
168    set_order(1) if $made_changes;
169    write_config_file() if $made_changes;
170    status();
171    exit;
172}
173
174# ---------------------------------------------------------------------------
175# --- Update
176# ---------------------------------------------------------------------------
177
178unless ($opt->{noupdate})
179{
180    update($progname, $version);
181    set_order(1) if $made_changes;
182    write_config_file() if (($made_changes) && (! $opt->{configure}))
183}
184
185if ($opt->{configure})
186{
187    configure();
188}
189
190# ---------------------------------------------------------------------------
191# --- Go!
192# ---------------------------------------------------------------------------
193
194unless ($opt->{update})
195{
196    calc_date_range();
197    grab_data();
198    reconcile_data();
199    postprocess_data();
200    output_data();
201}
202
203print "Done.\n";
204
205status();
206write_config_file();
207
208# ---------------------------------------------------------------------------
209# --- Subroutines
210# ---------------------------------------------------------------------------
211
212# -----------------------------------------
213# Subs: Grabbing
214# -----------------------------------------
215
216sub grab_data
217{
218    my $used_grabbers = 0;
219    my $found_data_percent = 0;
220
221    print "\nGrabber stage:\n";
222
223    my $grabber;
224   
225    while ($grabber = choose_grabber())
226    {
227        $used_grabbers++;
228
229        $components->{$grabber}->{lastdata} = time;
230        $components->{$grabber}->{laststatus} = "unknown";
231
232        printf "\nSHEPHERD: Using grabber: (%d) %s\n", $used_grabbers, $grabber;
233
234        my $output = "$CWD/grabbers/$grabber/output.xmltv";
235
236        my $comm = "$CWD/grabbers/$grabber/$grabber " .
237                   "--region $region " .
238                   "--channels_file $channels_file " .
239                   "--output $output";
240
241        # NOTE: ideally a grabber could be instructed to fetch partial data through --channel, --starttime & --endtime
242        # we don't have that for now so instead whenever there is missing data, ALL 7 days for all channels will be collected
243        # FIXME FUTURE: call grabbers just with what we want...
244        $comm .= " --days $days" if ($days);
245        $comm .= " --offset $opt->{offset}" if ($opt->{offset});
246        $comm .= " --debug" if ($debug);
247        $comm .= " @ARGV" if (@ARGV);
248
249        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
250            printf "SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n";
251        } else {
252            print "SHEPHERD: Excuting command: $comm\n";
253            chdir "$CWD/grabbers/$grabber/";
254            system($comm);
255            chdir $CWD;
256        }
257
258        # soak up the data we just collected
259        &soak_up_data($grabber, $output, "grabber");
260        $components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
261
262        # check to see if we have all the data we want
263        $found_data_percent = &analyze_plugin_data($channel_ok_threshold_percent, "AGGREGATE GRABBER");
264
265        last if ($found_data_percent >= $channel_ok_threshold_percent);
266    }
267
268
269    if ($used_grabbers == 0)
270    {
271        print "No valid grabbers installed/enabled!\n";
272        return;
273    }
274
275    if ($found_data_percent < $channel_ok_threshold_percent)
276    {
277        print "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
278        $grabber_data_percent = $found_data_percent;
279        return;
280    }
281}
282
283sub choose_grabber
284{
285    unless (defined $gscore)
286    {
287        foreach (query_grabbers())
288        {
289            unless ($components->{$_}->{disabled})
290            {
291                $gscore->{$_} = 0;
292            }
293        }
294    }
295
296    # run any 'always_run' grabbers that are listed
297    foreach (keys %$gscore)
298    {
299        if (defined $components->{$_}->{config}->{always_run}) {
300            delete $gscore->{$_};
301            print "Selected $_ (always run)\n" if ($debug);
302            return $_;
303        }
304    }
305
306    # score grabbers
307    my $total = score_grabbers();
308
309    return undef unless ($total);
310
311    if ($debug)
312    {
313        print "Grabber selection probabilities:\n";
314        foreach (keys %$gscore)
315        {
316            printf "%15s %6.1f%% %12s\n", 
317                   $_, 100 * $gscore->{$_} / $total, "($gscore->{$_} pts)";
318        }
319    }
320
321    return undef unless (scalar keys %$gscore);
322
323    my $r = int(rand($total));
324
325    my $c = 0;
326    foreach (keys %$gscore)
327    {
328        next if (!$gscore->{$_});
329        if ($r >= $c and $r < ($c + $gscore->{$_}))
330        {
331            delete $gscore->{$_};
332            print "Selected $_.\n" if ($debug);
333            return $_;
334        }
335        $c += $gscore->{$_};
336    }
337    die "ERROR: failed to choose grabber.";
338}
339
340sub score_grabbers
341{
342    my ($score, $total, $niceness, $granularity, $m);
343
344    my $missing = detect_missing_data();
345
346    foreach my $grabber (keys %$gscore)
347    {
348        # for each slot, say whether we can fill it or not -- that is,
349        # whether we support this channel and this day #.
350       
351        my $hits = 0;
352        foreach (@$missing)
353        {
354            my ($ch, $day) = split(/:/);
355            my $result = (can_support_channel($grabber, $ch)
356                          and
357                          can_support_day($grabber, $day));
358            $hits += $result;
359#           print "$grabber vs $ch:$day: " . ($result ? "OK" : "no") . "\n";
360        }
361        $niceness = $components->{$grabber}->{config}->{niceness};
362        unless ($niceness)
363        {
364            print "WARNING: Grabber $grabber has no niceness support " .
365                  "specified in config.\n";
366            $niceness = 5;
367        }
368        $granularity = $components->{$grabber}->{config}->{granularity};
369        unless (defined $granularity)
370        {
371            print "WARNING: Grabber $grabber has no granularity support " .
372                "specified in config.\n";
373            $granularity = '';
374        }
375        # TODO: use granularity more intelligently ('c' vs 'd') -- Max.
376        $granularity = length ($granularity);
377        my $total_channeldays = $days * scalar (keys %$channels);
378        $granularity *= int((($total_channeldays - 1 ) / scalar(@$missing))/2);
379
380        $score = $hits * ($niceness + $granularity);
381        print "Grabber $grabber can fill $hits empty slots with $niceness niceness and $granularity granularity: scoring $score pts.\n";
382        $gscore->{$grabber} = $score;
383        $total += $score;
384    }
385    return $total;
386}
387
388sub can_support_channel
389{
390    my ($grabber, $ch) = @_;
391
392    my $channels_supported = $components->{$grabber}->{config}->{channels};
393    unless (defined $channels_supported)
394    {
395        print "WARNING: Grabber $grabber has no channel support " .
396              "specified in config.\n";
397        $channels_supported = '';
398    }
399
400    return 1 unless ($channels_supported); # Empty string means we support all
401   
402    my $match = ($channels_supported =~ /\b$ch\b/);
403    my $exceptions = ($channels_supported =~/^-/);
404    return ($match != $exceptions);
405}
406
407sub can_support_day
408{
409    my ($grabber, $day) = @_;
410
411    my $days_supported = $components->{$grabber}->{config}->{max_days};
412    unless ($days_supported)
413    {
414        print "WARNING: Grabber $grabber has no max_days support " .
415              "specified in config.\n";
416        $days_supported = 2;
417    }
418    return $day <= $days_supported;
419}
420
421#
422# Build a little hash of what channel/day data we're currently missing.
423# I think granularity of one day is good for now; could possibly be
424# made more fine-grained if we think grabbers will support that.
425#
426sub detect_missing_data
427{
428    my @missing;
429
430    my $timeslots_per_day = (24 * 60 * 60) / $timeslot_size;
431
432    foreach my $ch (keys %$channels)
433    {
434        if (defined $channel_data->{$ch})
435        {
436            my $slotnum;
437            for ($slotnum = 0; $slotnum < $num_timeslots-1; $slotnum++) 
438            {
439                if (!@{$channel_data->{$ch}->{timeslots}}[$slotnum])
440                {
441                    my $day = int($slotnum / $timeslots_per_day) + 1;
442                    push @missing, "$ch:$day";
443                    $slotnum += $timeslots_per_day -
444                                ($slotnum % $timeslots_per_day);
445
446                }
447            }
448        }
449        else
450        {
451            for my $i (1 .. $days)
452            {
453                push (@missing, "$ch:$i");
454            }
455        }
456
457    }
458
459    print "Need data for @missing.\n" if ($debug);
460    return \@missing;
461}
462
463
464# interpret xmltv data from this grabber/postprocessor
465sub soak_up_data
466{
467    my ($plugin, $output, $plugintype) = @_;
468
469    if (! -r $output) {
470        printf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output;
471        return;
472    }
473
474    my $parse_start_time = [gettimeofday];
475    my $this_plugin = $plugin_data->{$plugin};
476    printf STDERR "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output;
477    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
478    printf STDERR "SHEPHERD: Completed XMLTV parsing from '%s' in %0.2f seconds\n",$plugin,tv_interval($parse_start_time);
479
480    if (!($this_plugin->{xmltv})) {
481        printf "WARNING: Plugin %s didn't seem to return any valid XMLTV!\n",$plugin;
482        return;
483    }
484
485    $this_plugin->{valid} = 1;
486    $this_plugin->{output_filename} = $output;
487
488    my $xmltv = $this_plugin->{xmltv};
489    my ($encoding, $credits, $chan, $progs) = @$xmltv;
490    $this_plugin->{total_duration} = 0;
491    $this_plugin->{programmes} = 0;
492    $this_plugin->{progs_with_invalid_date} = 0;        # explicitly track unparsable dates
493    $this_plugin->{progs_with_unknown_channel} = 0;     # explicitly track unknown channels
494
495    my $strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M %z");
496    my $alt_strptime = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M"); # alternate format 1: oztivo doesn't seem to output timezone
497    my $seen_channels_with_data = 0;
498
499    #
500    # first iterate through all programmes and see if there are any channels we don't know about
501    #
502    my %chan_xml_list;
503    foreach my $ch (sort keys %{$channels}) {
504        $chan_xml_list{($channels->{$ch})} = 1;
505    }
506    foreach my $prog (@$progs) {
507        if (!defined $chan_xml_list{($prog->{channel})}) {
508            $this_plugin->{progs_with_unknown_channel}++;
509            printf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel};
510            $chan_xml_list{($prog->{channel})} = 1;     # so we warn only once
511        }
512    }
513       
514    # iterate thru channels
515    foreach my $ch (sort keys %{$channels}) {
516        my $seen_progs_on_this_channel = 0;
517
518        # iterate thru programmes per channel
519        foreach my $prog (@$progs) {
520            next if ($prog->{channel} ne $channels->{$ch});
521
522            my $t1 = $strptime->parse_datetime($prog->{start});
523            my $t2 = $strptime->parse_datetime($prog->{stop});
524            $t1 = $alt_strptime->parse_datetime($prog->{start}) if (!$t1);
525            $t2 = $alt_strptime->parse_datetime($prog->{stop}) if (!$t2);
526
527            if (!$t1 || !$t2) {
528                printf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
529                    $plugin,(!$t1 ? $prog->{start} : $prog->{stop}) if (!$this_plugin->{progs_with_invalid_date});
530                $this_plugin->{progs_with_invalid_date}++;
531                next;
532            }
533
534            # store t1 and t2 times in the xmltv data for later on (shh.. ton't tell anyone..)
535            $prog->{start_epoch} = $t1->epoch;
536            $prog->{stop_epoch} = $t2->epoch;
537
538            # store plugin-specific stats
539            $this_plugin->{programmes}++;
540            $this_plugin->{total_duration} += ($t2->epoch - $t1->epoch);
541            $seen_progs_on_this_channel++;
542            $this_plugin->{earliest_data_seen} = $t1->epoch if (!defined $this_plugin->{earliest_data_seen});
543            $this_plugin->{earliest_data_seen} = $t1->epoch if ($t1->epoch < $this_plugin->{earliest_data_seen});
544            $this_plugin->{latest_data_seen} = $t2->epoch if (!defined $this_plugin->{latest_data_seen});
545            $this_plugin->{latest_data_seen} = $t2->epoch if ($t2->epoch > $this_plugin->{latest_data_seen});
546
547            # store channel-specific stats
548            $channel_data->{$ch}->{programmes}++;
549            $channel_data->{$ch}->{total_duration} += ($t2->epoch - $t1->epoch);
550
551            # store timeslot info
552            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!
553            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!
554            my $start_slotnum;
555            if ($t1->epoch >= $starttime) {
556                $start_slotnum = int(($t1->epoch - $starttime) / $timeslot_size);
557            } else {
558                $start_slotnum = 0;
559            }
560            my $end_slotnum;
561            if ($t2->epoch < $endtime) {
562                $end_slotnum = int(($t2->epoch - $starttime) / $timeslot_size);
563            } else {
564                $end_slotnum = ($num_timeslots-1);
565            }
566
567            # add this programme into the global timeslots table for this channel
568            foreach my $slotnum ($start_slotnum..$end_slotnum) {
569                $channel_data->{$ch}->{timeslots}[$slotnum]++;
570            }
571        }
572
573        $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
574    }
575
576    # print some stats about what we saw!
577    printf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
578        ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
579        int($this_plugin->{total_duration} / 86400),            # days
580        int(($this_plugin->{total_duration} % 86400) / 3600),   # hours
581        int(($this_plugin->{total_duration} % 3600) / 60),      # mins
582        int($this_plugin->{total_duration} % 60),               # sec
583        (defined $this_plugin->{earliest_data_seen} ? (strftime "%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
584        (defined $this_plugin->{latest_data_seen} ? (strftime "%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '');
585    $this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
586        $seen_channels_with_data, $this_plugin->{programmes},
587        int($this_plugin->{total_duration} / 3600),
588        (defined $this_plugin->{earliest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($this_plugin->{earliest_data_seen})) : 'no'),
589        (defined $this_plugin->{latest_data_seen} ? (strftime "%a%d%b%H:%M", localtime($this_plugin->{latest_data_seen})) : 'data');
590
591    $plugin_data->{$plugin} = $this_plugin;
592}
593
594
595# analyze grabber data - do we have all the data we want?
596# returns percent of data found
597sub analyze_plugin_data
598{
599    my ($threshold,$analysistype) = @_;
600    my $total_data_percent = 0, my $total_channels = 0;
601    my $statusstring = "";
602
603    # iterate across each channel
604    foreach my $ch (sort keys %{$channels}) {
605        $total_channels++;
606        if (defined $channel_data->{$ch}) {
607            my $data_in_channel = 0;
608            for my $slotnum (0..($num_timeslots-1)) {
609                $data_in_channel++ if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) && ($channel_data->{$ch}->{timeslots}[$slotnum] > 0));
610            }
611
612            # do we have enough data for this channel?
613            my $data_in_channel_percent = $data_in_channel / ($num_timeslots-1) * 100;
614            if ($data_in_channel_percent >= $threshold) {
615                $statusstring .= sprintf "%s: %0.1f%% [complete], ",$ch,$data_in_channel_percent;
616            } else {
617                $statusstring .= sprintf "%s: %0.1f%% [hungry], ",$ch,$data_in_channel_percent;
618            }
619            $total_data_percent += $data_in_channel_percent;
620        } else {
621            $statusstring .= sprintf "%s: 0%% [starving], ",$ch;
622        }
623    }
624
625    if ($total_channels > 0) {
626        $total_data_percent = $total_data_percent / $total_channels;
627    } else {
628        $total_data_percent = 0;
629    }
630
631    # print some stats about what our analysis says!
632    printf "SHEPHERD: %s ANALYSIS: %sTOTAL %0.2f%% %s %0.2f%%: %s\n",
633        uc($analysistype), $statusstring, $total_data_percent,
634        ($total_data_percent >= $channel_ok_threshold_percent ? ">" : "<"), $channel_ok_threshold_percent,
635        (($total_data_percent < $channel_ok_threshold_percent) ? "WANT MORE DATA" : "COMPLETE");
636    return $total_data_percent;
637}
638
639
640# work out date range we are expecting data to be in
641sub calc_date_range
642{
643    # normalize starttime to beginning of hour
644    my $now = time;
645    my ($sec,$min,@rest) = localtime($now);
646
647    $starttime = $now - ((60 * $min) + $sec);
648
649    if ($days) {
650        $endtime = $starttime + ($days * 86400);
651    } else {
652        $endtime = $starttime + (7*86400);
653    }
654    $starttime += (86400 * $opt->{offset}) if ($opt->{offset});
655
656    $num_timeslots = ($endtime - $starttime) / $timeslot_size;
657}
658
659# -----------------------------------------
660# Subs: Reconciling data
661# -----------------------------------------
662
663# for all the data we have, try to pick the best bits!
664sub reconcile_data
665{
666    printf "\nReconciling data:\n\n";
667
668    my $num_grabbers = 0;
669    my $input_files = "";
670    my @input_file_list;
671
672    printf "Preference for whose data we prefer as follows:\n";
673    foreach my $proggy (sort { $components->{$a}->{order} <=> $components->{$b}->{order} } query_grabbers()) {
674        if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
675            $num_grabbers++;
676            printf "  %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename};
677
678            $input_files .= $plugin_data->{$proggy}->{output_filename}." ";
679            push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
680        }
681    }
682
683    if ($num_grabbers == 0) {
684        die "Nothing to reconcile!  There is no valid grabber data!\n";
685    }
686
687    foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
688        next if ($components->{$reconciler}->{disabled});
689        next if (!$components->{$reconciler}->{ready});
690
691        $reconciler_data_percent = &call_data_processor("reconciler",$reconciler,$input_files);
692
693        if ($reconciler_data_percent < $postprocessor_ok_threshold_percent) {
694            # how bad is the data?  is it significantly different to that of what the grabber run finished with?
695            # allow at most 15% of the data to go away
696            if ($grabber_data_percent > ($reconciler_data_percent + 15)) {
697                # urgh.  this reconciler did a bad bad thing ...
698                printf "SHEPHERD: XML data from reconciler %s appears bogus, will try to use another reconciler\n",$reconciler;
699            } else {
700                printf "SHEPHERD: Allowing marginal data from reconciler %s (was %d%%, really wanted at least %d%%)\n",
701                  $reconciler,$reconciler_data_percent,$postprocessor_ok_threshold_percent;
702                $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
703            }
704        } else {
705            printf "SHEPHERD: Data from reconciler %s looks good (got %d%%, wanted at least %d%%)\n",
706              $reconciler,$reconciler_data_percent,$postprocessor_ok_threshold_percent;
707            $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
708        }
709
710        last if ($input_postprocess_file ne "");
711    }
712
713    if ($input_postprocess_file eq "") {
714        # no reconcilers worked!!
715        printf "SHEPHERD: WARNING: No reconcilers seemed to work!  Falling back to concatenating the data together!\n";
716
717        my %w_args = ();
718        $input_postprocess_file = "$CWD/input_preprocess.xmltv";
719        my $fh = new IO::File ">$input_postprocess_file" || die "could not open $input_postprocess_file for writing: $!\n";
720        %w_args = (OUTPUT => $fh);
721        XMLTV::catfiles(\%w_args, @input_file_list);
722    }
723}
724
725
726# -----------------------------------------
727# Subs: Postprocessing
728# -----------------------------------------
729
730sub postprocess_data
731{
732    # for our first postprocessor, we feed it ALL of the XMLTV files we have
733    # as each postprocessor runs, we feed in the output from the previous one
734    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
735    # reverts back to the previous postprocessor if it was shown to be bad
736
737    # first time around: feed in reconciled data ($input_postprocess_file)
738
739    printf "\nPostprocessing stage:\n";
740
741    foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
742        next if ($components->{$postprocessor}->{disabled});
743        next if (!$components->{$postprocessor}->{ready});
744
745        my $found_data_percent;
746        $found_data_percent = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
747
748        if ($found_data_percent < $postprocessor_ok_threshold_percent) {
749            # how bad is the data?  is it significantly different to that of what the grabber run finished with?
750            # allow at most 15% of the data to go away
751            if ($grabber_data_percent > ($found_data_percent + 15)) {
752                # urgh.  this postprocessor did a bad bad thing ...
753                printf "SHEPHERD: XML data from postprocessor %s rejected, using XML from previous stage\n",$postprocessor;
754
755                if (defined $components->{$postprocessor}->{conescutive_failures}) {
756                    $components->{$postprocessor}->{conescutive_failures}++;
757                } else {
758                    $components->{$postprocessor}->{conescutive_failures} = 1;
759                }
760                printf "SHEPHERD: Postprocessor \"%s\" has now failed %d times in a row.  %d more and it will be automatically disabled.\n",
761                    $postprocessor,
762                    $components->{$postprocessor}->{conescutive_failures},
763                    ($postprocessor_disable_failure_threshold - $components->{$postprocessor}->{conescutive_failures});
764
765                if ($components->{$postprocessor}->{conescutive_failures} >= $postprocessor_disable_failure_threshold) {
766                    printf "SHEPHERD: Disabling Postprocessor \"%s\".\n",$postprocessor;
767                    $components->{$postprocessor}->{disabled} = 1;
768                }
769            } else {
770                # accept what this postprocessor did to our output ...
771                printf "SHEPHERD: accepting output from postprocessor %s, feeding it into next stage\n",$postprocessor;
772                $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
773                delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
774            }
775        } else {
776            # accept what this postprocessor did to our output ...
777            printf "SHEPHERD: accepting output from postprocessor %s, feeding it into next stage\n",$postprocessor;
778            $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
779            delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
780        }
781    }
782}
783
784
785# -----------------------------------------
786# Subs: Postprocessing/Reconciler helpers
787# -----------------------------------------
788
789sub call_data_processor
790{
791    my ($data_processor_type, $data_processor_name, $input_files) = @_;
792
793    $components->{$data_processor_name}->{lastdata} = time;
794    $components->{$data_processor_name}->{laststatus} = "unknown";
795
796    printf "\nSHEPHERD: Using %s: %s\n",$data_processor_type,$data_processor_name;
797
798    my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
799    my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
800    $comm .= " --region $region" .
801             " --channels_file $channels_file" .
802             " --output $output";
803    $comm .= " --days $days" if ($days);
804    $comm .= " --offset $opt->{offset}" if ($opt->{offset});
805    $comm .= " --debug" if ($debug);
806    $comm .= " @ARGV" if (@ARGV);
807    $comm .= " $input_files";
808    print "SHEPHERD: Excuting command: $comm\n";
809
810    my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
811    chdir $dir;
812    system($comm);
813    chdir $CWD;
814
815    #
816    # soak up the data we just collected and check it
817    # YES - these are the SAME routines we used in the previous 'grabber' phase
818    # but the difference here is that we clear out our 'channel_data' beforehand
819    # so we can independently analyze the impact of this postprocessor.
820    # if it clearly returns bad data, don't use that data (go back one step) and
821    # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
822    #
823
824    # clear out channel_data
825    foreach my $ch (keys %{$channels}) {
826        delete $channel_data->{$ch};
827    }
828
829    # process and analyze it!
830    &soak_up_data($data_processor_name, $output, $data_processor_type);
831    my $found_data_percent = &analyze_plugin_data($postprocessor_ok_threshold_percent, "POSTPROCESSOR");
832
833    $components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
834
835    return $found_data_percent;
836}
837
838
839sub output_data
840{
841    # $input_postprocess_file contains our final output
842    # send it to whereever --output told us to!
843
844    my $output_filename = "$CWD/output.xmltv";
845    $output_filename = $opt->{output} if ($opt->{output});
846
847    open(OUTFILE,">$output_filename") || die "could not open output file $output_filename for writing: $!\n";
848
849    if (!(open(INFILE,"<$input_postprocess_file"))) {
850        printf "WARNING: could not open input file \"%s\": %s\n", $input_postprocess_file, $!;
851        printf "Output XMLTV data may be damanged as a result!\n";
852    } else {
853        while (<INFILE>) {
854            print OUTFILE $_;
855        }
856        close(INFILE);
857        close(OUTFILE);
858    }
859
860    printf "Final output stored in $output_filename.\n";
861}
862
863# -----------------------------------------
864# Subs: Updates & Installations
865# -----------------------------------------
866
867sub update
868{
869    printf "\nChecking for updates:\n\n";
870
871    my $data = fetch_file("status");
872
873    return unless ($data);
874
875    my %clist = %$components;
876    while ($data =~ /(.*):(.*):(.*)/g)
877    {
878        my ($proggy, $latestversion, $progtype) = ($1,$2,$3);
879        update_component($proggy, $latestversion, $progtype);
880        delete $clist{$proggy};
881    }
882
883    # work out what components disappeared (if any)
884    foreach (keys %clist) {
885        unless ($components->{$_}->{disabled}) {
886            print "\nDeleted component: $_.\n";
887            disable($_);
888            $made_changes = 1;
889        }
890    }
891
892}
893
894sub update_component
895{
896    my ($proggy, $latestversion, $progtype) = @_;
897
898    # handle new installs..
899    if ($progtype eq "shepherd") {
900        if(! -e "$CWD/$progname") {
901            print "Missing: $CWD/$progname\n";
902            install($progname, $latestversion, $progtype);
903            return;
904        }
905    } else {
906        if (!defined $components->{$proggy} or ! -e ($progtype . "s/$proggy/$proggy")) {
907            print "New $progtype: $proggy.\n";
908            install($proggy, $latestversion, $progtype);
909            return;
910        }
911        if ($components->{$proggy}->{disabled}) {
912            print "Warning: grabber $proggy disabled by config file.\n";
913        }
914    }
915
916    # upgrade/downgrades
917    my $ver;
918    if ($progtype eq "shepherd") {
919        $ver = $version;
920    }
921    else {
922        $ver = $components->{$proggy}->{ver};
923    } 
924
925    my $result = versioncmp($ver, $latestversion);
926    if ($result == -1) {
927        print "UPGRADING $proggy from v$ver to v$latestversion.\n";
928    } elsif ($result == 1) {
929        print "DOWNGRADING $proggy from v$ver to v$latestversion.\n";
930    } else {
931        print "Already have latest version of $proggy: v$ver.\n";
932        return;
933    }
934    install($proggy, $latestversion, $progtype);
935}
936
937sub install
938{
939    my ($proggy, $latestversion, $progtype) = @_;
940    my $config;
941
942    print "Downloading $proggy v$latestversion.\n";
943
944    my $rdir = "";
945    my $ldir = $CWD;
946    my $ver = "unknown";
947
948    if ($progtype eq "shepherd") {
949        $ver = $version;
950    } else {
951        $rdir = $progtype . "s";
952        $ldir = "$CWD/$progtype" . "s/$proggy";
953        $ver = $components->{$proggy}->{ver} if ((defined $components->{$proggy}) && $components->{$proggy}->{ver});
954        -d ("$CWD/$progtype" . "s") or mkdir ("$CWD/$progtype" . "s") or die "Cannot create directory $CWD/$progtype" . "s: $!";
955    }
956    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!";
957
958    my $newfile = "$ldir/$proggy-$latestversion";
959    my $rfile = "$rdir/$proggy";
960
961    return unless (fetch_file($rfile, $newfile));
962
963    if ($progtype ne "shepherd") {   
964        # Fetch grabber config file
965        $rfile .= ".conf";
966        $config = fetch_file($rfile);
967        return unless ($config);
968
969        eval $config;
970    }
971
972    # Make component executable
973    system('chmod u+x ' . $newfile);
974
975    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!";
976
977    if (-e "$ldir/$proggy")
978    {
979        rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$ver");
980    }
981    rename($newfile, "$ldir/$proggy");
982   
983    print "Installed $proggy v$latestversion.\n" if ($debug);
984
985    # if the update was for shepherd itself, restart it
986    if ($progtype eq "shepherd") {
987        print "\n*** Restarting ***\n\n";
988        exec("$ldir/$proggy");
989        # This exits.
990    }
991
992    print "Testing $proggy...\n" if ($debug);
993    my $result = test_proggy($ldir,"$ldir/$proggy");
994
995    $components->{$proggy}->{type} = $progtype;
996    $components->{$proggy}->{ver} = $latestversion;
997    $components->{$proggy}->{ready} = $result;
998    $components->{$proggy}->{config} = $config;
999    $components->{$proggy}->{laststatus} = sprintf "updated to %s on %s", $latestversion, (strftime "%a%d%b%y",localtime(time));
1000
1001    $made_changes = 1;
1002}
1003
1004sub fetch_file
1005{
1006    my ($fn, $store) = @_;
1007
1008    my $sites = "";
1009    $sites = "$mirror_site," if ($mirror_site);
1010    $sites .= $HOME;
1011
1012    my $ret;
1013    foreach my $site (split(/,/,$sites)) 
1014    {
1015        printf "Fetching $site/$fn.\n";
1016        if ($store)
1017        {
1018            $ret = LWP::Simple::getstore("$site/$fn", $store);
1019            return 1 if (is_success($ret));
1020        }
1021        else
1022        {
1023            $ret = LWP::Simple::get("$site/$fn");
1024            return $ret if ($ret);
1025        }
1026        print "Failed to retrieve $site/$fn.\n";
1027    }
1028    return undef;
1029}
1030
1031sub test_proggy
1032{
1033    my ($testdir,$proggyexec) = @_;
1034
1035    chdir($testdir);
1036    system("$proggyexec --ready");
1037    chdir ($CWD);
1038
1039    my $result = $?;
1040    print "Return value: $result\n" if ($debug);
1041
1042    print "\nComponent $proggyexec did not exit cleanly!\n" .
1043         "It may require configuration.\n\n" if ($result);
1044    return !$result;
1045}
1046
1047sub enable
1048{
1049    my $proggy = shift;
1050
1051    # confirm it exists first
1052    if (!$components->{$proggy}) {
1053        printf "No such component: \"%s\".\n",$proggy;
1054        return;
1055    }
1056    print "Enabling $proggy.\n";
1057
1058    delete $components->{$proggy}->{disabled};
1059    $components->{$proggy}->{laststatus} = sprintf "enabled on %s, not run yet",(strftime "%a%d%b%y", localtime(time));
1060    $made_changes = 1;
1061}
1062
1063sub disable
1064{
1065    my $proggy = shift;
1066
1067    # confirm it exists first
1068    if (!$components->{$proggy}) {
1069        printf "No such component: \"%s\".\n",$proggy;
1070        return;
1071    }
1072    print "Disabling $proggy.\n";
1073
1074    $components->{$proggy}->{disabled} = 1;
1075    $components->{$proggy}->{laststatus} = sprintf "manually disabled on %s",(strftime "%a%d%b%y", localtime(time));
1076    $made_changes = 1;
1077}
1078
1079sub set_order
1080{
1081    my ($quiet,$order) = @_;
1082    $pref_order = $order if ($order);
1083
1084    # reset current order to zero
1085    foreach my $proggy (query_grabbers()) {
1086        $components->{$proggy}->{order} = 0;
1087    }
1088
1089    # and now set order
1090    my $order_num = 1;
1091    if ($pref_order) {
1092        foreach my $proggy (split(/,/,$pref_order)) {
1093            if (defined $components->{$proggy} and $components->{$proggy}->{type} eq 'grabber') {
1094                $components->{$proggy}->{order} = $order_num;
1095                $order_num++;
1096            }
1097        }
1098    }
1099
1100    # set order of any grabbers not specified in a random manner
1101    foreach my $proggy (sort query_grabbers()) {
1102        if ((!defined $components->{$proggy}->{order}) || ($components->{$proggy}->{order} == 0)) {
1103            $components->{$proggy}->{order} = $order_num+int(rand(1000));
1104        }
1105    }
1106
1107    # .. and finally normalize the order (& show the user the order we chose)
1108    print "Grabber order set as follows:\n" unless $quiet;
1109    $order_num = 0;
1110    foreach my $proggy (sort { $components->{$a}->{order} <=> $components->{$b}->{order} } query_grabbers()) {
1111        $order_num++;
1112        $components->{$proggy}->{order} = $order_num;
1113        printf " #%d. %s%s\n",$components->{$proggy}->{order},$proggy,($components->{$proggy}->{disabled} ? " [disabled]" : "") unless $quiet;
1114    }
1115
1116    $made_changes = 1;
1117}
1118
1119sub check
1120{
1121    my $result;
1122    foreach my $proggy (keys %$components) {
1123        my $progtype = $components->{$proggy}->{type};
1124        $result = test_proggy("$CWD/$progtype" . "s/$proggy", "$CWD/$progtype" . "s/$proggy/$proggy");
1125        printf "%s %s: %s\n",ucfirst($progtype), $proggy,($result ? "OK" : "Failed");
1126        if (!$result ne !$components->{$proggy}->{ready}) {
1127            $components->{$proggy}->{ready} = $result;
1128            $made_changes = 1;
1129        }
1130    }
1131}
1132# -----------------------------------------
1133# Subs: Utilities
1134# -----------------------------------------
1135#
1136
1137sub query_grabbers
1138{
1139    return query_component_type('grabber');
1140}
1141
1142sub query_reconcilers
1143{
1144    return query_component_type('reconciler');
1145}
1146
1147sub query_postprocessors
1148{
1149    return query_component_type('postprocessor');
1150}
1151
1152sub query_component_type
1153{
1154    my $progtype = shift;
1155
1156    my @ret = ();
1157    foreach (keys %$components)
1158    {
1159        push (@ret, $_) if ($components->{$_}->{type} eq $progtype);
1160    }
1161    return @ret;
1162}
1163
1164# -----------------------------------------
1165# Subs: Setup
1166# -----------------------------------------
1167
1168sub read_config_file
1169{
1170    read_file($config_file, 'configuration');
1171
1172    # TEMPORARY! Convert old $grabbers/$postprocessors config file to
1173    # new $components format.
1174    if (defined $grabbers or defined $postprocessors)
1175    {
1176        foreach (keys %$grabbers) {
1177            $grabbers->{$_}->{type} = 'grabber';
1178        }
1179        foreach (keys %$postprocessors) {
1180            $postprocessors->{$_}->{type} = 'postprocessor';
1181        }
1182        $components = { %$grabbers, %$postprocessors };
1183        $grabbers = undef;
1184        $postprocessors = undef;
1185    }
1186
1187
1188    # if we are updating from a previous rev of shepherd.conf we may not
1189    # have any 'order' fields set .. check here
1190    my $found_order = 1;
1191    foreach (query_grabbers())
1192    {
1193        $found_order = 0 if (!defined $components->{$_}->{order});
1194    }
1195    if (($found_order == 0) && (!$opt->{setorder}))
1196    {
1197        # at least one 'order' was missing .. we need to put it in!
1198        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";
1199        &set_order(1);
1200    }
1201
1202    # if a mirror has been specified, add it into our config
1203    if ($opt->{mirror}) {
1204        $mirror_site = $opt->{mirror};
1205        $made_changes = 1;
1206        print "Adding mirror: $mirror_site\n";
1207    }
1208}
1209
1210sub read_channels_file
1211{
1212    read_file($channels_file, 'channels');
1213}
1214
1215sub read_file
1216{
1217    my $fn = shift;
1218    my $name = shift;
1219
1220    print "Reading $name file: $fn\n";
1221    unless (-r $fn)
1222    {
1223        unless ($opt->{configure})
1224        {
1225            print "\nNo $name file found.\n" .
1226                  ucfirst($progname) . " must be configured: " .
1227                  "configuring now.\n\n";
1228            $opt->{'configure'} = 1;
1229        }
1230        return;
1231    }
1232    local (@ARGV, $/) = ($fn);
1233    no warnings 'all';
1234    eval <>;
1235    if ($@ and !$opt->{configure})
1236    {
1237        die "\nError in $name file!\nDetails:\n$@";
1238    }
1239}
1240
1241sub write_config_file
1242{
1243    open(CONF, ">$config_file") or die "cannot write to $config_file: $!";
1244    print CONF Data::Dumper->Dump(
1245        [$region,  $pref_order,  $mirror_site,  $components, $title_translation_table  ],
1246        ["region", "pref_order", "mirror_site", "components", "title_translation_table" ]);
1247    close CONF;
1248    print "\nUpdated configuration file $config_file.\n" if ($debug);
1249}
1250
1251sub write_channels_file
1252{
1253    open(CHAN, ">$channels_file") or die "cannot write to $channels_file: $!";
1254    print CHAN Data::Dumper->Dump([$channels], ["channels"]);
1255    close CHAN;
1256    print "Updated channels file $channels_file.\n" if ($debug);
1257}
1258
1259sub get_initial_command_line_options
1260{
1261  GetOptions( 'config-file=s'   => \$opt->{configfile},
1262              'help'            => \$opt->{help},
1263              'configure'       => \$opt->{configure},
1264              'mirror=s'        => \$opt->{mirror},
1265              'dontcallgrabbers' => \$opt->{dontcallgrabbers},
1266              'debug'           => \$debug);
1267}
1268
1269sub get_remaining_command_line_options
1270{
1271    GetOptions(
1272              'version'         => \$opt->{status},
1273              'status'          => \$opt->{status},
1274              'list'            => \$opt->{list},
1275              'show-config'     => \$opt->{show_config},
1276
1277              'update'          => \$opt->{update},
1278              'noupdate'        => \$opt->{noupdate},
1279
1280              'disable=s'       => \$opt->{disable},
1281              'enable=s'        => \$opt->{enable},
1282              'setorder=s'      => \$opt->{setorder},
1283
1284              'days=i'          => \$days,
1285              'offset=i'        => \$opt->{offset},
1286              'show-channels'   => \$opt->{show_channels},
1287              'output=s'        => \$opt->{output},
1288              'check'           => \$opt->{check}
1289            );
1290}
1291
1292
1293# -----------------------------------------
1294# Subs: Configuration
1295# -----------------------------------------
1296
1297sub configure
1298{
1299    my $REGIONS = {
1300        "ACT" => 126,
1301        "NSW: Sydney" => 73,
1302        "NSW: Newcastle" => 184,
1303        "NSW: Central Coast" => 66,
1304        "NSW: Griffith" => 67,
1305        "NSW: Broken Hill" => 63,
1306        "NSW: Northern NSW" => 69,
1307        "NSW: Southern NSW" => 71,
1308        "NSW: Remote and Central" => 106,
1309        "NT: Darwin" => 74,
1310        "NT: Remote & Central" => 108,
1311        "QLD: Brisbane" => 75,
1312        "QLD: Gold Coast" => 78,
1313        "QLD: Regional" => 79,
1314        "QLD: Remote & Central" => 114,
1315        "SA: Adelaide" => 81,
1316        "SA: Renmark" => 82,
1317        "SA: Riverland" => 83,
1318        "SA: South East SA" => 85,
1319        "SA: Spencer Gulf" => 86,
1320        "SA: Remote & Central" => 107,
1321        "Tasmania" => 88,
1322        "VIC: Melbourne" => 94,
1323        "VIC: Geelong" => 93,
1324        "VIC: Eastern Victoria" => 90,
1325        "VIC: Mildura/Sunraysia" => 95,
1326        "VIC: Western Victoria" => 98,
1327        "WA: Perth" => 101,
1328        "WA: Regional" => 102
1329    };
1330
1331    print "\nConfiguring.\n\n" .
1332          "Select your region:\n";
1333    foreach (sort keys %$REGIONS)
1334    {
1335        printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
1336    }
1337    $region = ask_choice("Enter region code:", "94", values %$REGIONS);
1338
1339    print "\nFetching channel information... ";
1340
1341    my @channellist = get_channels();
1342
1343    print "done.\n\n" .
1344          "For each channel you want guide data for, enter an XMLTV id\n" .
1345          "of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
1346          "guide data for this channel, just press Enter.\n\n" .
1347          "Please don't subscribe to unneeded channels.\n\nChannels:\n";
1348    $channels = {};
1349    my $line;
1350    foreach (@channellist)
1351    {
1352        $line = ask(" \"$_\"? ");
1353        $channels->{$_} = $line if ($line);
1354    }
1355
1356
1357    print "\nRandomly selecting grabber order.\n\n";
1358    set_order(0);
1359
1360    show_channels();
1361    unless(ask_boolean("\nCreate configuration file?"))
1362    {
1363        print "Aborting configuration.\n";
1364        exit 0;
1365    }
1366
1367    write_config_file();
1368    write_channels_file();
1369
1370    print "Finished configuring.\n\n" .
1371          "Shepherd is installed into $CWD.\n\n";
1372   
1373    if ($invoked ne "$CWD/$progname" and $invoked =~ /$progname/)
1374    {
1375        print "Warning: you invoked this program as $invoked.\n" .
1376            "In the future, it should be run as $CWD/$progname,\n" .
1377            "to avoid constantly re-downloading the latest version.\n\n" .
1378            "MythTV users may wish to create the following symlink, by " .
1379            "doing this (as root):\n" .
1380            "\"ln -s $CWD/$progname /usr/bin/tv_grab_au\".\n\n" .
1381            "You may safely delete $invoked.\n\n";
1382    }
1383
1384    status();
1385
1386    unless (ask_boolean("\nGrab data now?"))
1387    {
1388        exit 0;
1389    }
1390}
1391
1392sub get_channels
1393{
1394    my @date = localtime;
1395    my $page = LWP::Simple::get(
1396        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1397        ($date[5] + 1900) . "-$date[4]-$date[3]");
1398    my @channellist;
1399    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
1400    {
1401        push @channellist, $1;
1402    }
1403    return @channellist;
1404}
1405
1406# -----------------------------------------
1407# Subs: Status & Help
1408# -----------------------------------------
1409
1410sub show_config
1411{
1412    print "\nConfiguration\n".
1413          "-------------\n" .
1414          "Config file: $config_file\n" .
1415          "Debug mode : " . is_set($debug) . "\n" .
1416          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1417          "Region ID  : $region\n";
1418  show_channels();
1419  print "\n";
1420  status();
1421  print "\n";
1422}
1423
1424sub show_channels
1425{
1426  print "Subscribed channels:\n";
1427  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
1428}
1429
1430sub is_set
1431{
1432    my $arg = shift;
1433    return $arg ? "Yes" : "No";
1434}
1435
1436sub status
1437{
1438    print " Grabber           Version Enabled Ready Last Run   Status\n" .
1439          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1440    foreach (sort { $components->{$a}->{order} <=> $components->{$b}->{order} } query_grabbers()) {
1441        my $h = $components->{$_};
1442        printf  " %-16s %8s %4s %6s  %11s %s\n",
1443                "$h->{order}. $_",
1444                ($h->{ver} ? $h->{ver} : "unknown"),
1445                $h->{disabled} ? '' : 'Y',
1446                $h->{ready} ? 'Y' : '',
1447                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1448                $h->{laststatus} ? $h->{laststatus} : '';
1449    }
1450    printf "Grabbers shown in order of preference.\n\n";
1451
1452    print " Reconciler        Version Enabled Ready Last Run   Status\n" .
1453          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1454    foreach (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
1455        my $h = $components->{$_};
1456        printf  " %-16s %8s %4s %6s  %11s %s\n",
1457                $_,
1458                ($h->{ver} ? $h->{ver} : "unknown"),
1459                $h->{disabled} ? '' : 'Y',
1460                $h->{ready} ? 'Y' : '',
1461                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1462                $h->{laststatus} ? $h->{laststatus} : '';
1463    }
1464
1465    print " Postprocessor     Version Enabled Ready Last Run   Status\n" .
1466          " ----------------- ------- ------- ----- ---------- ---------------------------\n";
1467    foreach (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
1468        my $h = $components->{$_};
1469        printf  " %-16s %8s %4s %6s  %11s %s\n",
1470                $_,
1471                ($h->{ver} ? $h->{ver} : "unknown"),
1472                $h->{disabled} ? '' : 'Y',
1473                $h->{ready} ? 'Y' : '',
1474                $h->{lastdata} ? (strftime "%a%d%b%y", localtime($h->{lastdata})) : 'never',
1475                $h->{laststatus} ? $h->{laststatus} : '';
1476    }
1477    printf "Reconcilers and Postprocessors shown in order of execution.\n\n";
1478}
1479
1480sub help
1481{
1482    print q{
1483Command-line options:
1484    --help                Print this message
1485
1486    --status              Print a list of grabbers maintained
1487    --list                Print a detailed list of grabbers
1488    --mirror <s>          Set URL <s> as primary location to check for updates
1489
1490    --configure           Setup
1491    --show-config         Print setup details
1492
1493    --setorder <s>        Set order of grabbers to <s> (comma-seperated list of grabbers)
1494
1495    --disable <s>         Don't ever use grabber/postprocessor <s>
1496    --enable <s>          Okay, maybe use it again then
1497    --uninstall <s>       Remove a disabled grabber/postprocessor
1498
1499    --noupdate            Do not attempt to update before running
1500    --update              Update only; do not grab data
1501
1502    --check               Check status of all grabbers and postprocessors
1503};
1504    exit 0;
1505}
1506
1507# -----------------------------------------
1508# Subs: override handlers for standard perl.
1509# -----------------------------------------
1510
1511# ugly hack. please don't try this at home kids!
1512sub my_die {
1513    my ($arg,@rest) = @_;
1514    my ($pack,$file,$line,$sub) = caller(1);
1515
1516    # check if we are in an eval()
1517    if ($^S) {
1518        printf STDERR "  shepherd caught a die() within eval{} from file $file line $line\n";
1519    } else {
1520        if (!ref($arg)) {
1521            printf STDERR "DIE at line %d in file %s\n",$line,$file;
1522            CORE::die(join("",@rest));
1523        } else {
1524            CORE::die($arg,@rest);
1525        }
1526    }
1527}
Note: See TracBrowser for help on using the browser.