root/shepherd @ 52

Revision 52, 62.8 kB (checked in by max, 7 years ago)

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