root/shepherd @ 80

Revision 80, 45.1 kB (checked in by max, 7 years ago)

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