root/shepherd @ 35

Revision 35, 61.0 kB (checked in by lincoln, 7 years ago)

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