root/shepherd @ 51

Revision 51, 62.6 kB (checked in by max, 7 years ago)

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