root/shepherd @ 207

Revision 207, 48.1 kB (checked in by lincoln, 7 years ago)

fill in output xmltv with details of what we used to generate the data
Line 
1#!/usr/bin/perl -w
2
3my $version = '0.2.36';
4
5# "Shepherd"
6# A wrapper for various Aussie TV guide data grabbers
7#
8# Use --help for command-line options.
9#
10# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
11# make one cohesive reliable data set. It works by calling a series of
12# scripts that grab data from a large variety of sources, and then
13# analysing the resulting XML data sets and determining which of the many
14# is the most reliable.
15
16# Shepherd runs in 4 passes:
17#  pass 1: (tv_grab_au)  Checks that all components are up-to-date, auto-
18#                        updates if not.
19#                        Passes control onto shepherd
20#  pass 2: (shepherd)    calls grabbers to fill in missing data
21#  pass 3: (shepherd)    calls reconciler to reconcile overlapping data
22#                        and normalize programme titles to our preferred title
23#  pass 4: (shepherd)    calls postprocessors to postprocess data
24#                        (e.g. flag HDTV programmes, augment with IMDb etc.)
25
26# Changelog:
27# 0.1.0   : Basic self-updating and grabber management
28# 0.2.0   : --configure
29# 0.2.1   : Has a home in ~/.shepherd/
30# 0.2.2   : --check
31# 0.2.3   : Bugfix: archives correctly
32# 0.2.5   : Multi-grabber (potentially with partial data)
33# 0.2.6   : Postprocessor support
34# 0.2.7   : Changed online file structure
35# 0.2.8   : Integrated reconciler
36# 0.2.9   : Grabber config support
37# 0.2.10  : Bugfix: don't call postprocessors that aren't ready,
38#           rework accept-data-or-not postprocessor logic
39# 0.2.11  : Dedicated external reconciler support
40# 0.2.13  : revert 'alawys run' added in 0.2.12, --setorder bugfix
41# 0.2.14  : Changed online status file format
42# 0.2.15  : Intelli-random grabber ordering now kinda works
43# 0.2.16  : config logic for HD channels
44# 0.2.17  : bugfix timezone bogosities
45# 0.2.18  : care less about missing data in early-morning/overnight
46#           care more about missing data in evening/night
47# 0.2.22  : remove ->{order}, order is now set by quality
48#           explicitly tell reconciler the preferred _title_ source
49# 0.2.24  : logging and log files
50# 0.2.25  : use open-with-pipe rather than system() and look at
51#           return codes from called programmes
52# 0.2.27  : Identify self in useragent when fetching shepherd files
53# 0.2.28  : Changing status file format again
54# 0.2.30  : Run transitional grabber(s) as a once-off to establish preferred
55#           title translations.
56# 0.2.31  : split tv_grab_au (install/test/upgrade/enable/disable) from
57#           shepherd (grab/reconcile/postprocess)
58# 0.2.33  : remove logging (tv_grab_au does it for us)
59
60BEGIN { *CORE::GLOBAL::die = \&my_die; }
61
62use strict;
63no strict 'refs';
64
65use LWP::UserAgent;
66use Getopt::Long;
67use Data::Dumper;
68use XMLTV;
69use POSIX qw(strftime mktime);
70use Date::Manip;
71use Algorithm::Diff;
72use List::Compare;
73
74# ---------------------------------------------------------------------------
75# --- Global Variables
76# ---------------------------------------------------------------------------
77
78my $progname = 'shepherd';
79
80my @options = @ARGV;
81
82# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
83# it will try /opt/shepherd/ instead.
84my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
85-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
86chdir($CWD);
87
88#### analyzer settings ####
89# the following thresholds are used to control whether we keep calling grabbers or
90# not.
91
92my %policy;
93$policy{timeslot_size} = (5 * 60);      # 5 minute slots
94
95# PEAK timeslots -
96#  between 4.30pm and 11.30pm every day, only allow a maximum of
97#  15 minutes "programming data" missing
98#  if there is more than this, we will continue asking grabbers for more
99#  programming on this channel
100$policy{peak_max_missing} = 15*60;              # up to 15 mins max allowed missing
101$policy{peak_start} = (16*(60*60))+(30*60);     # 4.30pm
102$policy{peak_stop} = (23*(60*60))+(30*60);      # 11.30pm
103
104# NON-PEAK timeslots -
105#  between midnight and 6.15am every day, only allow up to 6 hours missing
106#  if there is more than this, we will continue asking grabbers for more
107#  programming on this channel
108$policy{nonpeak_max_missing} = 6*(60*60);       # up to 6 hours can be missing
109$policy{nonpeak_start} = 0;                     # midnight
110$policy{nonpeak_stop} = (6*(60*60))+(15*60);    # 6.15am
111
112# all other timeslots - (6.15am-4.30pm, 11.30pm-midnight)
113#  allow up to 60 minutes maximum missing programming
114$policy{other_max_missing} = 60*60;             # up to 60 mins max allowed missing
115
116# if a postprocessor failed 5 times in a row, automatically disable it
117$policy{postprocessor_disable_failure_threshold} = 5;
118
119#### end analyzer section ####
120
121my $opt = { };
122my $pref_title_source;
123my $mirror_site;
124my $debug = 0;
125my $components = { };
126my $gscore;
127my $region;
128my $channels;
129my $opt_channels;
130my $config_file =   "$CWD/$progname.conf";
131my $channels_file = "$CWD/channels.conf";
132my $days = 7;
133my $missing;
134my $timeslice;
135my $grabbed;
136my $gmt_offset;
137my $grabber_found_all_data;
138my $writer;
139my $components_used = "";
140
141# postprocessing
142my $langs = [ 'en' ];
143my $plugin_data = { };
144my $channel_data = { };
145my $reconciler_found_all_data;
146my $input_postprocess_file = "";
147
148# OBSOLETE: will be removed
149my $preferred;
150my $title_translation_table;
151my $pref_order;
152
153# ---------------------------------------------------------------------------
154# --- Setup
155# ---------------------------------------------------------------------------
156
157# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
158Getopt::Long::Configure(qw/pass_through/);
159&get_command_line_options;
160
161if ($opt->{version}) { print "$version\n"; exit 0; }  # This is horrible
162$| = 1; 
163print ucfirst($progname) . " v$version\n\n";
164
165exit 0 if ($opt->{version});
166die "run tv_grab_au --help for details.\n" if ($opt->{help});
167
168&read_config_file;
169&read_channels_file;
170
171# ---------------------------------------------------------------------------
172# --- Go!
173# ---------------------------------------------------------------------------
174
175&calc_date_range;
176&grab_data;
177&reconcile_data;
178&postprocess_data;
179&output_data;
180&write_config_file;
181
182# ---------------------------------------------------------------------------
183# --- Subroutines
184# ---------------------------------------------------------------------------
185
186# -----------------------------------------
187# Subs: Grabbing
188# -----------------------------------------
189
190sub grab_data
191{
192    my $used_grabbers = 0;
193
194    printf "\nGrabber stage.\n";
195
196    &analyze_plugin_data("",1);   
197
198    while (my $grabber = choose_grabber())
199    {
200        $grabber_found_all_data = 0;
201        $used_grabbers++;
202
203        $components->{$grabber}->{laststatus} = "unknown";
204
205        printf "\nSHEPHERD: Using grabber: (%d) %s\n", $used_grabbers, $grabber;
206
207        my $output = "$CWD/grabbers/$grabber/output.xmltv";
208
209        my $comm = "$CWD/grabbers/$grabber/$grabber " .
210                   "--region $region " .
211                   "--output $output";
212
213        # Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
214        # that we need. Category 2 grabbers are requested to get everything, since there's
215        # very little cost in grabbing that extra data, and we can use it in the reconciler
216        # to verify that everything looks OK.
217        if (query_config($grabber, 'category') == 1)
218        {
219            printf "$grabber is Category 1: grabbing timeslice.\n" if ($debug);
220
221            record_requested_chandays($grabber, $timeslice);
222
223            if ($timeslice->{start} != 0)
224            {
225                $comm .= " " . 
226                         query_config($grabber, 'option_days_offset') .
227                         " " .
228                         $timeslice->{start};
229            }
230
231            my $n = $timeslice->{stop} + 1;
232            if ($timeslice->{start} != 0 
233                    and 
234                !query_config($grabber, 'option_offset_eats_days'))
235            {
236                $n -= $timeslice->{start};
237            }
238            $comm .= " " .
239                     query_config($grabber, 'option_days') .
240                     " " . 
241                     $n;
242           
243            # Write a temporary channels file specifying only the channels we want
244            my $tmpchans;
245            foreach (@{$timeslice->{chans}})
246            {
247                $tmpchans->{$_} = $channels->{$_};
248            }
249            my $tmpcf = "$CWD/channels.conf.tmp";
250            write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
251            $comm .= " --channels_file $tmpcf";
252        }
253        else
254        {
255            printf "$grabber is category 2: grabbing everything.\n" if ($debug);
256            $comm .= " --days $days" if ($days);
257            $comm .= " --offset $opt->{offset}" if ($opt->{offset});
258            $comm .= " --channels_file $channels_file";
259        }
260        $comm .= " --debug" if ($debug);
261        $comm .= " @ARGV" if (@ARGV);
262
263        my $retval = 0;
264        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
265            printf "SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n";
266            printf "SHEPHERD: would have called: $comm\n" if ($debug);
267        } else {
268            printf "SHEPHERD: Excuting command: $comm\n";
269            chdir "$CWD/grabbers/$grabber/";
270            $retval = call_prog($comm);
271            chdir $CWD;
272        }
273
274        if ($retval != 0) {
275            printf "grabber returned with non-zero return code $retval: assuming it failed.\n";
276            next;
277        }
278
279        # soak up the data we just collected
280        &soak_up_data($grabber, $output, "grabber");
281        $components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
282        $components->{$grabber}->{lastdata} = time if ($plugin_data->{$grabber}->{valid});
283
284        # check to see if we have all the data we want
285        $grabber_found_all_data = &analyze_plugin_data("analysis of all grabbers so far");
286
287        # Record what we grabbed from cacheable C1 grabbers
288        if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
289        {
290            my $missing_before = convert_dayhash_to_list($missing);
291            my $missing_after = convert_dayhash_to_list(detect_missing_data());
292            my $list = List::Compare->new($missing_before, $missing_after);
293            my @grabbed = $list->get_symmetric_difference();
294            printf "Grabbed: " . join (', ', @grabbed) . ".\n" if ($debug);
295            record_cached($grabber, @grabbed);
296            write_config_file();
297        }
298
299        last if ($grabber_found_all_data);
300    }
301
302
303    if ($used_grabbers == 0)
304    {
305        printf "No valid grabbers installed/enabled!\n";
306        return;
307    }
308
309    unless ($grabber_found_all_data)
310    {
311        printf "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
312        return;
313    }
314}
315
316# -----------------------------------------
317# Subs: Intelli-random grabber selection
318# -----------------------------------------
319
320sub choose_grabber
321{
322    if (defined $gscore)        # Reset score hash
323    {
324        foreach (keys %$gscore)
325        {
326            $gscore->{$_} = 0;
327        }
328    }
329    else                        # Create score hash
330    {
331        foreach (query_grabbers())
332        {
333            unless ($components->{$_}->{disabled})
334            {
335                $gscore->{$_} = 0;
336                if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
337                {
338                    $gscore->{$_ . ' [cache]'} = 0;
339                }
340            }
341        }
342    }
343
344    $missing = detect_missing_data();
345    $timeslice = find_best_timeslice();
346
347    if ($debug)
348    {
349        printf "Best timeslice: day%s of channels %s (%d chandays).\n",
350                    ($timeslice->{start} == $timeslice->{stop} ?
351                        " $timeslice->{start}" :
352                        "s $timeslice->{start} - $timeslice->{stop}"),
353                    join(', ', @{$timeslice->{chans}}),
354                    $timeslice->{chandays};
355    }
356
357    my $total = score_grabbers();
358 
359    if ($debug)
360    {
361        printf "Grabber selection:\n";
362        foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
363        {
364            next if ($_ =~ /\[cache\]/);
365
366            my $score  = $gscore->{$_};
367            my $cscore = $gscore->{"$_ [cache]"};
368            my $cstr   = $cscore ? "(inc. $cscore cache pts)" : "";
369
370            if ($opt->{randomize})
371            {
372                printf "%15s %6.1f%% %9s %s\n", 
373                        $_, 
374                        ($total ? 100* $score / $total : 0), 
375                        "$score pts",
376                        $cstr;
377            }
378            else
379            {
380                printf "%15s %4s pts %s\n", 
381                        $_, 
382                        $score,
383                        $cstr;
384            }
385        }
386    }
387
388    return undef unless ($total);
389
390    # Select a grabber
391
392    # If the user has specified a pref_title_source -- i.e. he is
393    # transitioning from a known grabber -- then we make sure it
394    # has run at least once, to build the list of title translations.
395    if ($pref_title_source)
396    {
397        my @prefs = split(/,/, $pref_title_source);
398        foreach my $grabber (@prefs)
399        {
400            unless ($components->{$grabber}->{lastdata})
401            {
402                printf "Need to build title translation list for transitional grabber $grabber.\n";
403                return select_grabber($grabber, $gscore) if ($gscore->{$grabber});
404                printf "WARNING: Can't run $grabber to build title translation list!\n";
405            }
406        }
407    }
408
409    # Either do it randomly based on scores, or just return the
410    # highest-scoring grabber, depending on whether --randomize has
411    # been used.
412
413    my $r = int(rand($total));
414    my $c = 0;
415    my $best;
416
417    foreach my $grabber (keys %$gscore)
418    {
419        next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
420        if ($opt->{randomize})
421        {
422            if ($r >= $c and $r < ($c + $gscore->{$grabber}))
423            {
424                return select_grabber($grabber, $gscore);
425            }
426            $c += $gscore->{$grabber};
427        }
428        else
429        {
430            if (!$best or $gscore->{$grabber} > $gscore->{$best})
431            {
432                $best = $grabber;
433            }
434        }
435    }
436
437    if ($opt->{randomize} or !$best)
438    {
439        die "ERROR: failed to choose grabber.";
440    }
441    return select_grabber($best, $gscore);
442}
443
444sub select_grabber
445{
446    my ($grabber, $gscore) = @_;
447
448    printf "Selected $grabber.\n" if ($debug);
449    if (query_config($grabber, 'category') == 2)
450    {
451        # We might want to run C1 grabbers multiple times
452        # to grab various timeslices, but not C2 grabbers,
453        # which should get everything at once.
454        delete $gscore->{$grabber};
455    }
456    return $grabber;
457}
458
459# Grabbers earn 1 point for each slot or chanday they can fill.
460# This score is multiplied if the grabber:
461# * is a category 2 grabber (i.e. fast/cheap)
462# * is a category 1 grabber that has the data we want in a cache
463# * can supply high-quality data
464# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
465sub score_grabbers
466{
467    my ($score, $total, $day, $catbonus, $dqbonus, $mult, $key);
468
469    my $bestdq = 0;
470
471    # Compare C2 grabbers against the raw missing file, because we'll get
472    # everything. But compare C1 grabbers against the timeslice, because we'll
473    # only ask them for a slice. This goes for the [cache] and regular C1s.
474    foreach my $grabber (keys %$gscore)
475    {
476        # for each slot, say whether we can fill it or not -- that is,
477        # whether we support this channel and this day #.
478
479        my $hits = 0;
480        my $cat = query_config($grabber, 'category');
481        my $dq = query_config($grabber, 'quality');
482
483        if ($cat == 1)
484        {
485            $key = cut_down_missing($grabber);
486            # printf "Grabber $grabber is Category 1: comparing capability to best timeslice.\n" if ($debug);
487        }
488        else
489        {
490            $key = $missing;
491            # printf "Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n" if ($debug);
492        }
493
494        if ($grabber =~ /\[cache\]/)
495        {
496            $hits = find_cache_hits($grabber, $key);
497        }
498        else
499        {
500            foreach my $day (sort keys %$key)
501            {
502                my $val = supports_day($grabber, $day);
503                next unless ($val);
504                # printf "Day $day:" if ($debug);
505                foreach my $ch (@{$key->{$day}})
506                {
507                    if (supports_channel($grabber, $ch, $day))
508                    {
509                        # printf " $ch" if ($debug);
510                        $hits += $val;
511                    }
512                }
513                # printf "\n" if $debug;
514                $hits = 1 if ($hits > 0 and $hits < 1);
515            }
516        }
517
518        my $catbonus = 1;
519        $catbonus = 3 if ($cat == 2);
520        if ($grabber =~ /\[cache\]/)
521        {
522            # Bonus is on a sliding scale between 1 and 2 depending on
523            # % of required data in cache
524            $catbonus += $hits / $timeslice->{chandays};
525        }
526
527        my $dqbonus = 2 ** ($dq-1);
528
529        my $mult = $dq ** $catbonus;
530
531        my $score = int($hits * $mult);
532
533        if ($debug)
534        {
535            my $str = sprintf "Grabber %s can supply %d chandays",
536                                $grabber, $hits;
537            if ($hits)
538            {
539                $str .= sprintf " at x%.1f (cat: %d, DQ: %d): %d pts",
540                            $mult,
541                            $cat,
542                            $dq,
543                            $score;
544            }
545            printf "$str.\n";
546        }
547
548        $gscore->{$grabber} += $score;
549        $total += $score;
550        if ($grabber =~ /\[cache\]/)
551        {
552            $gscore->{query_name($grabber)} += $score;
553        }
554
555        if ($score and $dq > $bestdq)
556        {
557            $bestdq = $dq;
558        }
559    }
560
561    # Eliminate grabbers of data quality 1 if there are any better-quality
562    # alternatives when using randomize.
563    if ($opt->{randomize})
564    {
565        foreach (keys %$gscore)
566        {
567            if ($gscore->{$_}
568                    and
569                query_config($_, 'quality') == 1
570                    and
571                $bestdq > 1)
572            {
573                $total -= $gscore->{$_};
574                $gscore->{$_} = 0;
575                printf "Zeroing grabber $_ due to low data quality.\n" if ($debug);
576            }
577        }
578    }
579
580    return $total;
581}
582
583# Return 1 if the grabber can provide data for this channel, else 0.
584sub supports_channel
585{
586    my ($grabber, $ch, $day) = @_;
587
588    my $mdpc = query_config($grabber, 'max_days_per_chan');
589    if ($mdpc)
590    {
591        if ($mdpc->{$ch})
592        {
593            return ($mdpc->{$ch} > $day);
594        }
595    }
596
597    my $channels_supported = query_config($grabber, 'channels');
598    unless (defined $channels_supported)
599    {
600        printf "WARNING: Grabber $grabber has no channel support " .
601              "specified in config.\n";
602        $channels_supported = '';
603    }
604
605    return 1 unless ($channels_supported); # Empty string means we support all
606   
607    $ch =~ s/ /_/g;
608    my $match = ($channels_supported =~ /\b$ch\b/);
609    my $exceptions = ($channels_supported =~/^-/);
610    return ($match != $exceptions);
611}
612
613# Return 0 if the grabber can't provide data for this day,
614# 1 if it can reliably, and 0.5 if it can unreliably.
615#
616# Note that a max_days of 7 means the grabber can retrieve data for
617# today plus 6 days.
618sub supports_day
619{
620    my ($grabber, $day) = @_;
621
622    return 0 unless ($day < query_config($grabber, 'max_days'));
623    return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
624    return 1;
625}
626
627sub find_cache_hits
628{
629    my ($grabber, $key) = @_;
630
631    $grabber = query_name($grabber);
632
633    return 0 unless ($components->{$grabber}->{cached});
634
635    my $hits = 0;
636
637    foreach my $day (keys %$key)
638    {
639        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
640        foreach my $ch (@{$key->{$day}})
641        {
642            $hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
643        }
644    }
645    return $hits;
646}
647
648# Build a dayhash of what channel/day data we're currently missing.
649# I think granularity of one day is good for now; could possibly be
650# made more fine-grained if we think grabbers will support that.
651sub detect_missing_data
652{
653    my $m = { };
654
655    my $chandays = 0;
656    foreach my $ch (keys %$channels)
657    {
658        # is this channel missing too much data?
659        unless ($channel_data->{$ch}->{analysis}->{data_ok}) {
660            # not ok - record which days are bad
661            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) {
662                push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
663            }
664        }
665    }
666
667    foreach my $day (keys %$m)
668    {
669        $m->{$day} = [ sort @{$m->{$day}} ];
670        $chandays += scalar(@{$m->{$day}}) if ($debug);
671    }
672
673    if ($debug)
674    {
675        printf "Need data for days " . join(", ", sort keys %$m) . 
676             " ($chandays chandays).\n";
677    }
678    return $m;
679}
680
681# Find the largest timeslice in the current $missing dayhash; i.e.
682# something like "Days 4 - 6 of ABC and SBS." This works by iterating
683# through the days and looking for overlaps where consecutive days
684# want the same channels.
685sub find_best_timeslice
686{
687    my ($overlap, $a);
688    my $slice = { 'chandays' => 0 };
689
690    foreach my $day (0 .. $days-1)
691    {
692        consider_slice($slice, $day, $day, @{$missing->{$day}});
693        $overlap = $missing->{$day};
694        foreach my $nextday (($day + 1) .. $days-1)
695        {
696            last unless ($missing->{$nextday});
697            $a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
698            last unless ($a and @{$a});
699            consider_slice($slice, $day, $nextday, @{$a});
700            $overlap = $a;
701        }
702    }
703    return $slice;
704}
705
706sub consider_slice
707{
708    my ($slice, $startday, $stopday, @chans) = @_;
709
710    my $challenger = ($stopday - $startday + 1) * scalar(@chans);
711    return unless ($challenger > $slice->{chandays});
712
713    # We have a winner!
714    $slice->{start} = $startday;
715    $slice->{stop} = $stopday;
716    $slice->{chans} = [ @chans ];
717    $slice->{chandays} = $challenger;
718}
719
720# Record what a cacheable C1 grabber has just retrieved for us,
721# so we know next time that this data can be grabbed quickly.
722sub record_cached
723{
724    my ($grabber, @grabbed) = @_;
725
726    printf "Recording cache for grabber $grabber.\n" if ($debug);
727
728    my $gcache = $components->{$grabber}->{cached};
729    $gcache = [ ] unless ($gcache);
730    my @newcache;
731    my $today = strftime("%Y%m%d", localtime);
732
733    # remove old chandays
734    foreach my $chanday (@$gcache)
735    {
736        $chanday =~ /(\d+):(.*)/;
737        if ($1 >= $today)
738        {
739            push (@newcache, $chanday);
740        }
741    }
742
743    # record new chandays
744    foreach my $chanday (@grabbed)
745    {
746        push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
747    }
748    $components->{$grabber}->{cached} = [ @newcache ];
749}
750
751# Takes a dayhash and returns it as a list like this:
752# ( "20061018:ABC", "20061018:Seven", ... )
753sub convert_dayhash_to_list
754{
755    my $h = shift;
756
757    my @ret;
758    foreach my $day (keys %$h)
759    {
760        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
761        foreach my $ch (@{$h->{$day}})
762        {
763            push (@ret, "$date:$ch");
764        }
765    }
766    @ret = sort @ret;
767    return \@ret;
768}
769
770# If we're about to re-try a grabber, make sure that we're not asking
771# it for the same data. That is, prevent a broken C1 grabber causing
772# an infinite loop.
773sub record_requested_chandays
774{
775    my ($grabber, $slice) = @_;
776
777    printf "Recording timeslice request; will not request these chandays " .
778         "from $grabber again.\n" if ($debug);
779
780    my @requested;
781    for my $day ($slice->{start} .. $slice->{stop})
782    {
783        foreach my $ch (@{$slice->{chans}})
784        {
785            push @requested, "$day:$ch";
786        }
787    }
788    if ($grabbed->{$grabber})
789    {
790        push @{$grabbed->{$grabber}}, @requested;
791    }
792    else
793    {
794        $grabbed->{$grabber} = [ @requested ];
795    }
796}
797
798# If this grabber has been called previously, remove those chandays
799# from the current request -- we don't want to ask it over and over
800# for a timeslice that it has already failed to provide.
801sub cut_down_missing
802{
803    my $grabber = shift;
804
805    $grabber = query_name($grabber);
806    my $dayhash = {};
807
808    # Take the timeslice and expand it to a dayhash, while pruning
809    # any chandays that have previously been requested from this
810    # grabber.
811    foreach my $day ($timeslice->{start} .. $timeslice->{stop})
812    {
813        my @chans;
814        foreach my $ch (@{$timeslice->{chans}})
815        {
816            unless ($grabbed->{$grabber} and grep(/$day:$ch/, @{$grabbed->{$grabber}}))
817            {
818                push (@chans, $ch)
819            }
820        }
821        $dayhash->{$day} = [ @chans ] if (@chans);
822    }
823
824    return $dayhash;
825}
826
827# -----------------------------------------
828# Subs: Analyzing data
829# -----------------------------------------
830
831# interpret xmltv data from this grabber/postprocessor
832sub soak_up_data
833{
834    my ($plugin, $output, $plugintype) = @_;
835
836    if (! -r $output) {
837        printf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output;
838        return;
839    }
840
841    my $this_plugin = $plugin_data->{$plugin};
842    printf "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output;
843    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
844    printf "SHEPHERD: Completed XMLTV parsing from '%s'\n",$plugin;
845
846    if (!($this_plugin->{xmltv})) {
847        printf "WARNING: Plugin $plugin didn't seem to return any valid XMLTV!\n";
848        return;
849    }
850
851    $this_plugin->{valid} = 1;
852    $this_plugin->{output_filename} = $output;
853    $components_used .= " + ".$plugin."(".$components->{$plugin}->{ver}.")";
854
855    my $xmltv = $this_plugin->{xmltv};
856    my ($encoding, $credits, $chan, $progs) = @$xmltv;
857    $this_plugin->{total_duration} = 0;
858    $this_plugin->{programmes} = 0;
859    $this_plugin->{progs_with_invalid_date} = 0;        # explicitly track unparsable dates
860    $this_plugin->{progs_with_unknown_channel} = 0;     # explicitly track unknown channels
861
862    my $seen_channels_with_data = 0;
863
864    #
865    # first iterate through all programmes and see if there are any channels we don't know about
866    #
867    my %chan_xml_list;
868    foreach my $ch (sort keys %{$channels}) {
869        $chan_xml_list{($channels->{$ch})} = 1;
870    }
871    foreach my $prog (@$progs) {
872        if (!defined $chan_xml_list{($prog->{channel})}) {
873            $this_plugin->{progs_with_unknown_channel}++;
874            printf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel};
875            $chan_xml_list{($prog->{channel})} = 1;     # so we warn only once
876        }
877    }
878       
879    # iterate thru channels
880    foreach my $ch (sort keys %{$channels}) {
881        my $seen_progs_on_this_channel = 0;
882
883        # iterate thru programmes per channel
884        foreach my $prog (@$progs) {
885            next if ($prog->{channel} ne $channels->{$ch});
886
887            my $t1 = &parse_xmltv_date($prog->{start});
888            my $t2 = &parse_xmltv_date($prog->{stop});
889
890            if (!$t1 || !$t2) {
891                printf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
892                    $plugin,(!$t1 ? $prog->{start} : $prog->{stop}) if (!$this_plugin->{progs_with_invalid_date});
893                $this_plugin->{progs_with_invalid_date}++;
894                next;
895            }
896
897            # store plugin-specific stats
898            $this_plugin->{programmes}++;
899            $this_plugin->{total_duration} += ($t2 - $t1);
900            $seen_progs_on_this_channel++;
901            $this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
902            $this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
903            $this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
904            $this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
905
906            # store channel-specific stats
907            $channel_data->{$ch}->{programmes}++;
908            $channel_data->{$ch}->{total_duration} += ($t2 - $t1);
909
910            # programme is outside the timeslots we are interested in.
911            next if ($t1 > $policy{endtime});
912            next if ($t2 < $policy{starttime});
913
914            # store timeslot info
915            my $start_slotnum = 0;
916            $start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
917                if ($t1 >= $policy{starttime});
918
919            my $end_slotnum = ($policy{num_timeslots}-1);
920            $end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
921                if ($t2 < $policy{endtime});
922
923            # add this programme into the global timeslots table for this channel
924            foreach my $slotnum ($start_slotnum..$end_slotnum) {
925                $channel_data->{$ch}->{timeslots}[$slotnum]++;
926            }
927        }
928
929        $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
930    }
931
932    # print some stats about what we saw!
933    printf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
934        ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
935        int($this_plugin->{total_duration} / 86400),            # days
936        int(($this_plugin->{total_duration} % 86400) / 3600),   # hours
937        int(($this_plugin->{total_duration} % 3600) / 60),      # mins
938        int($this_plugin->{total_duration} % 60),               # sec
939        (defined $this_plugin->{earliest_data_seen} ? (strftime "%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
940        (defined $this_plugin->{latest_data_seen} ? (strftime "%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '');
941
942    $this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
943        $seen_channels_with_data, $this_plugin->{programmes},
944        int($this_plugin->{total_duration} / 3600),
945        (defined $this_plugin->{earliest_data_seen} ? (strftime "%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
946        (defined $this_plugin->{latest_data_seen} ? (strftime "%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
947
948    $plugin_data->{$plugin} = $this_plugin;
949}
950
951
952# analyze grabber data - do we have all the data we want?
953sub analyze_plugin_data
954{
955    my ($analysistype,$quiet) = @_;
956    printf "SHEPHERD: $analysistype:\n" unless $quiet;
957
958    my $total_channels = 0;
959
960    my $overall_data_ok = 1; # until proven otherwise
961
962    # iterate across each channel
963    foreach my $ch (sort keys %{$channels}) {
964        $total_channels++;
965
966        my $data;
967        my $lastpol = "";
968        $data->{data_ok} = 1; # unless proven otherwise
969        $data->{have} = 0;
970        $data->{missing} = 0;
971
972        for my $slotnum (0..($policy{num_timeslots}-1)) {
973            my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
974
975            # work out day number of when this bucket is.
976            # number from 0 onwards.  (i.e. today=0).
977            # for a typical 7 day grabber this will actually mean 8 days of data (0-7)
978            # with days 0 and 7 truncated to half-days
979            my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
980
981            if (!defined $data->{day}->[$day]) {
982                $data->{day}->[$day]->{num} = $day;
983                $data->{day}->[$day]->{have} = 0;
984                $data->{day}->[$day]->{missing} = 0;
985                $data->{day}->[$day]->{missing_peak} = 0;
986                $data->{day}->[$day]->{missing_nonpeak} = 0;
987                $data->{day}->[$day]->{missing_other} = 0;
988
989                $data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
990
991                # day changed, dump any 'already_missing' data
992                &dump_already_missing($data);
993            }
994
995            # we have programming data for this bucket.  great!  process next bucket
996            if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
997                ($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) {
998
999                # if we have missing data queued up, push it now
1000                &dump_already_missing($data);
1001
1002                &dump_already_missing_period($data->{day}->[$day],$lastpol)
1003                  if ($lastpol ne "");
1004
1005                $data->{day}->[$day]->{have} += $policy{timeslot_size};
1006                $data->{have} += $policy{timeslot_size};
1007                next;
1008            }
1009
1010            # we don't have programming for this channel for this bucket
1011
1012            # some grabbers take HOURS to run. if this bucket (missing data) is for
1013            # a time period now in the past, then don't include it
1014            next if (($bucket_start_offset + $policy{starttime}) < time);
1015
1016            # work out the localtime of when this bucket is
1017            my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
1018
1019            # store details of where we are missing data
1020            if (!defined $data->{already_missing}) {
1021                $data->{already_missing} = sprintf "#%d/%02d:%02d",
1022                  $day,
1023                  int($bucket_seconds_offset / 3600),
1024                  int(($bucket_seconds_offset % 3600) / 60);
1025            }
1026            $data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
1027
1028            $data->{day}->[$day]->{missing} += $policy{timeslot_size};
1029            $data->{missing} += $policy{timeslot_size};
1030
1031            # work out what policy missing data for this bucket fits into
1032            my $pol;
1033            if (($bucket_seconds_offset >= $policy{peak_start}) &&
1034                (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
1035                $pol = "peak";
1036            } elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
1037                     (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
1038                $pol = "nonpeak";
1039            } else {
1040                $pol = "other";
1041            }
1042
1043            &dump_already_missing_period($data->{day}->[$day],$lastpol)
1044              if (($lastpol ne $pol) && ($lastpol ne ""));
1045
1046            $lastpol = $pol;
1047
1048            $data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
1049
1050            $data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
1051              if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
1052            $data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
1053
1054            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
1055            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
1056            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
1057            $data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
1058            $overall_data_ok = 0 if ($data->{data_ok} == 0);
1059        }
1060
1061        # finished all timeslots in this channel.
1062        # if we have missing data queued up, push it now
1063        &dump_already_missing($data);
1064
1065        # fill in any last missing period data
1066        foreach my $day (@{($data->{day})}) {
1067            &dump_already_missing_period($day,"peak");
1068            &dump_already_missing_period($day,"nonpeak");
1069            &dump_already_missing_period($day,"other");
1070        }
1071
1072        my $statusstring = sprintf " > ch %s: %s programming: %s\n", 
1073          $ch, pretty_duration($data->{have}),
1074          $data->{data_ok} ? "PASS (within thresholds)" : "FAIL, missing data over policy threshold:";
1075
1076        # display per-day missing data statistics
1077        foreach my $day (@{($data->{day})}) {
1078            unless ($day->{day_ok}) {
1079                $statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": ";
1080
1081                # do we have any data for this day?
1082                $statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
1083                  if (($day->{missing_peak}) && ($day->{missing_peak} > $policy{peak_max_missing}));
1084
1085                $statusstring .= sprintf "%snon-peak %s",
1086                  ($day->{missing_peak} ? " / " : ""),
1087                  join(", ",(@{($day->{missing_nonpeak_table})}))
1088                  if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak} > $policy{nonpeak_max_missing}));
1089
1090                $statusstring .= sprintf "%sother %s",
1091                  (($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
1092                  join(", ",(@{($day->{missing_other_table})}))
1093                  if (($day->{missing_other}) && ($day->{missing_other} > $policy{other_max_missing}));
1094
1095                $statusstring .= "\n";
1096            }
1097        }
1098        printf $statusstring unless $quiet;
1099
1100        delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
1101        $channel_data->{$ch}->{analysis} = $data;
1102    }
1103
1104    printf " > OVERALL: %s\n", ($overall_data_ok ? "PASS" : "FAIL") unless $quiet;
1105
1106    return $overall_data_ok; # return 1 for good, 0 for need more
1107}
1108
1109# helper routine for filling in 'missing_all' array
1110sub dump_already_missing
1111{
1112    my $d = shift;
1113    if (defined $d->{already_missing}) {
1114        $d->{already_missing} .= sprintf "-%02d:%02d",
1115          int($d->{already_missing_last} / 3600),
1116          int(($d->{already_missing_last} % 3600) / 60)
1117          if (defined $d->{already_missing_last});
1118        push(@{($d->{missing_all})}, $d->{already_missing});
1119        delete $d->{already_missing};
1120        delete $d->{already_missing_last};
1121    }
1122}
1123
1124# helper routine for filling in per-day missing data
1125# specific to peak/nonpeak/other
1126sub dump_already_missing_period
1127{
1128    my ($d,$p) = @_;
1129    my $startvar = "already_missing_".$p."_start";
1130    my $stopvar = "already_missing_".$p."_stop";
1131
1132    if (defined $d->{$startvar}) {
1133        push(@{($d->{"missing_".$p."_table"})},
1134          sprintf "%02d:%02d-%02d:%02d",
1135            int($d->{$startvar} / 3600),
1136            int(($d->{$startvar} % 3600) / 60),
1137            int($d->{$stopvar} / 3600),
1138            int(($d->{$stopvar} % 3600) / 60));
1139        delete $d->{$startvar};
1140        delete $d->{$stopvar};
1141    }
1142}
1143
1144# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
1145# and indication of whether the duration is over its threshold or not
1146sub pretty_duration
1147{
1148    my ($d,$crit) = @_;
1149    my $s = "";
1150    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
1151    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if (($d % (60*60*24)) >= (60*60));
1152    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if (($d % (60*60)) >= 60);
1153    $s .= "no" if ($s eq "");
1154
1155    if (defined $crit) {
1156        $s .= "[!]" if ($d > $crit);
1157    }
1158    return $s;
1159}
1160
1161# work out date range we are expecting data to be in
1162sub calc_date_range
1163{
1164    # work out GMT offset - we only do this once
1165    if (!$gmt_offset) {
1166        # work out our gmt offset
1167        my @l = localtime(43200), my @g = gmtime(43200);
1168        $gmt_offset = (($l[2] - $g[2])*(60*60)) + (($l[1] - $g[1])*60);
1169    }
1170
1171    $policy{starttime} = time;
1172
1173    # set endtime as per $days less 1 day + hours left today
1174    $policy{endtime} = $policy{starttime} + ((60*60*24)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
1175
1176    # normalize starttime to beginning of next bucket
1177    $policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
1178
1179    # work out how many seconds into a day our first bucket starts
1180    $policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
1181
1182    # normalize endtime to end of previous bucket
1183    $policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
1184
1185    # if we are working with an --offset, apply it now.
1186    $policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
1187
1188    # work out number of buckets
1189    $policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
1190}
1191
1192
1193# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
1194# rather than the various other perl implementation which treat it as being in UTC/GMT
1195sub parse_xmltv_date
1196{
1197    my $datestring = shift;
1198    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
1199    my $tz_offset = 0;
1200
1201    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
1202        ($t[5],$t[4],$t[3],$t[2],$t[1],$t[0]) = (int($1)-1900,int($2)-1,int($3),int($4),int($5),0);
1203        ($t[6],$t[7],$t[8]) = (-1,-1,-1);
1204
1205        # if input data has a timezone offset, then offset by that
1206        if ($datestring =~ /\+(\d{2})(\d{2})/) {
1207            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
1208        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
1209            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
1210        }
1211
1212        my $e = mktime(@t);
1213        return ($e+$tz_offset) if ($e > 1);
1214    }
1215    return undef;
1216}
1217
1218# -----------------------------------------
1219# Subs: Reconciling data
1220# -----------------------------------------
1221
1222# for all the data we have, try to pick the best bits!
1223sub reconcile_data
1224{
1225    printf "\nReconciling data:\n\n";
1226
1227    my $num_grabbers = 0;
1228    my $input_files = "";
1229    my @input_file_list;
1230
1231    printf "Preferred title preferences from '$pref_title_source'\n"
1232        if ((defined $pref_title_source) &&
1233            ($plugin_data->{$pref_title_source}) &&
1234            ($plugin_data->{$pref_title_source}->{valid}));
1235
1236    printf "Preference for whose data we prefer as follows:\n";
1237    foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
1238        if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
1239            $num_grabbers++;
1240            printf "  %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename};
1241
1242            $input_files .= $plugin_data->{$proggy}->{output_filename}." ";
1243            push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
1244        }
1245    }
1246
1247    if ($num_grabbers == 0) {
1248        die "Nothing to reconcile!  There is no valid grabber data!\n";
1249    }
1250
1251    foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
1252        next if ($components->{$reconciler}->{disabled});
1253        next if (!$components->{$reconciler}->{ready});
1254
1255        $reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
1256
1257        if ((!$reconciler_found_all_data) && ($grabber_found_all_data)) {
1258            # urgh.  this reconciler did a bad bad thing ...
1259            printf "SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n";
1260        } else {
1261            printf "SHEPHERD: Data from reconciler $reconciler looks good\n";
1262            $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
1263        }
1264
1265        last if ($input_postprocess_file ne "");
1266    }
1267
1268    if ($input_postprocess_file eq "") {
1269        # no reconcilers worked!!
1270        printf "SHEPHERD: WARNING: No reconcilers seemed to work!  Falling back to concatenating the data together!\n";
1271
1272        my %w_args = ();
1273        $input_postprocess_file = "$CWD/input_preprocess.xmltv";
1274        my $fh = new IO::File ">$input_postprocess_file" || die "could not open $input_postprocess_file for writing: $!\n";
1275        %w_args = (OUTPUT => $fh);
1276        XMLTV::catfiles(\%w_args, @input_file_list);
1277    }
1278}
1279
1280
1281# -----------------------------------------
1282# Subs: Postprocessing
1283# -----------------------------------------
1284
1285sub postprocess_data
1286{
1287    # for our first postprocessor, we feed it ALL of the XMLTV files we have
1288    # as each postprocessor runs, we feed in the output from the previous one
1289    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
1290    # reverts back to the previous postprocessor if it was shown to be bad
1291
1292    # first time around: feed in reconciled data ($input_postprocess_file)
1293
1294    printf "\nPostprocessing stage:\n";
1295
1296    foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
1297        next if ($components->{$postprocessor}->{disabled});
1298        next if (!$components->{$postprocessor}->{ready});
1299
1300        my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
1301
1302        if ($found_all_data) {
1303            # accept what this postprocessor did to our output ...
1304            printf "SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n";
1305            $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
1306            delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
1307            next;
1308        }
1309
1310        # urgh.  this postprocessor did a bad bad thing ...
1311        printf "SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n";
1312
1313        if (defined $components->{$postprocessor}->{conescutive_failures}) {
1314            $components->{$postprocessor}->{conescutive_failures}++;
1315        } else {
1316            $components->{$postprocessor}->{conescutive_failures} = 1;
1317        }
1318        printf "SHEPHERD: Postprocessor \"%s\" has now failed %d times in a row.  %d more and it will be automatically disabled.\n",
1319            $postprocessor,
1320            $components->{$postprocessor}->{conescutive_failures},
1321            ($policy{postprocessor_disable_failure_threshold} - $components->{$postprocessor}->{conescutive_failures});
1322
1323        if ($components->{$postprocessor}->{conescutive_failures} >= $policy{postprocessor_disable_failure_threshold}) {
1324            printf "SHEPHERD: Disabling Postprocessor \"$postprocessor\".\n";
1325            $components->{$postprocessor}->{disabled} = 1;
1326        }
1327    }
1328}
1329
1330
1331# -----------------------------------------
1332# Subs: Postprocessing/Reconciler helpers
1333# -----------------------------------------
1334
1335sub call_data_processor
1336{
1337    my ($data_processor_type, $data_processor_name, $input_files) = @_;
1338
1339    $components->{$data_processor_name}->{lastdata} = time;
1340    $components->{$data_processor_name}->{laststatus} = "unknown";
1341
1342    printf "\nSHEPHERD: Using %s: %s\n",$data_processor_type,$data_processor_name;
1343
1344    my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
1345    my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
1346    $comm .= " --region $region" .
1347             " --channels_file $channels_file" .
1348             " --output $output";
1349    $comm .= " --days $days" if ($days);
1350    $comm .= " --offset $opt->{offset}" if ($opt->{offset});
1351    $comm .= " --debug" if ($debug);
1352    $comm .= " @ARGV" if (@ARGV);
1353
1354    $comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
1355      if (($data_processor_type eq "reconciler") &&
1356          (defined $pref_title_source) &&
1357          ($plugin_data->{$pref_title_source}) &&
1358          ($plugin_data->{$pref_title_source}->{valid}));
1359
1360    $comm .= " $input_files";
1361    printf "SHEPHERD: Excuting command: $comm\n";
1362
1363    my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
1364    chdir $dir;
1365    my $retval = call_prog($comm);
1366    chdir $CWD;
1367
1368    if ($retval != 0) {
1369        printf "$data_processor_type returned with non-zero return code $retval: assuming it failed.\n";
1370        return 0;
1371    }
1372
1373    #
1374    # soak up the data we just collected and check it
1375    # YES - these are the SAME routines we used in the previous 'grabber' phase
1376    # but the difference here is that we clear out our 'channel_data' beforehand
1377    # so we can independently analyze the impact of this postprocessor.
1378    # if it clearly returns bad data, don't use that data (go back one step) and
1379    # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
1380    #
1381
1382    # clear out channel_data
1383    foreach my $ch (keys %{$channels}) {
1384        delete $channel_data->{$ch};
1385    }
1386
1387    # process and analyze it!
1388    &soak_up_data($data_processor_name, $output, $data_processor_type);
1389    my $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name");
1390
1391    $components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
1392
1393    return $have_all_data;
1394}
1395
1396
1397sub output_data
1398{
1399    # $input_postprocess_file contains our final output
1400    # send it to whereever --output told us to!
1401
1402    my $output_filename = "$CWD/output.xmltv";
1403    $output_filename = $opt->{output} if ($opt->{output});
1404
1405    my %writer_args = ( encoding => 'ISO-8859-1' );
1406    my $fh = new IO::File(">$output_filename") ||
1407      die "can't open $output_filename for writing: $!";
1408    $writer_args{OUTPUT} = $fh;
1409
1410    $writer = new XMLTV::Writer(%writer_args);
1411    $writer->start( {
1412        'source-info-name' => "$progname $version",
1413        'generator-info-name' => "$progname($version)".$components_used} );
1414
1415    XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb, 
1416        \&output_data_programme_cb, $input_postprocess_file);
1417    $writer->end();
1418
1419    printf "Final output stored in $output_filename.\n";
1420}
1421
1422sub output_data_channel_cb
1423{
1424    my $c = shift;
1425    $writer->write_channel($c);
1426}
1427
1428sub output_data_programme_cb
1429{
1430    my $prog=shift;
1431    $writer->write_programme($prog);
1432}
1433
1434# -----------------------------------------
1435# Subs: Utilities
1436# -----------------------------------------
1437#
1438
1439sub query_grabbers
1440{
1441    my ($conf, $val) = @_;
1442    return query_component_type('grabber',$conf,$val);
1443}
1444
1445sub query_reconcilers
1446{
1447    return query_component_type('reconciler');
1448}
1449
1450sub query_postprocessors
1451{
1452    return query_component_type('postprocessor');
1453}
1454
1455sub query_component_type
1456{
1457    my ($progtype,$conf,$val) = @_;
1458
1459    my @ret = ();
1460    foreach (keys %$components)
1461    {
1462        if ($components->{$_}->{type} eq $progtype) {
1463            if (defined $conf) {
1464                push (@ret, $_) if (query_config($_,$conf) eq $val);
1465            } else {
1466                push (@ret, $_);
1467            }
1468        }
1469    }
1470    return @ret;
1471}
1472
1473sub query_name
1474{
1475    my $str = shift;
1476    if ($str =~ /(.*) \[cache\]/)
1477    {
1478        return $1;
1479    }
1480    return $str;
1481}
1482
1483sub query_config
1484{
1485    my ($grabber, $key) = @_;
1486
1487    $grabber = query_name($grabber);
1488    return undef unless ($components->{$grabber});
1489    return $components->{$grabber}->{config}->{$key};
1490}
1491
1492sub call_prog
1493{
1494    my $prog = shift;
1495    if (!(open(PROG,"$prog|"))) {
1496        printf "warning: couldn't exec \"$prog\": $!\n";
1497        return -1;
1498    }
1499    while(<PROG>) {
1500        print $_;
1501    }
1502    close(PROG);
1503
1504    if ($? == -1) {
1505        printf "Failed to execute prog: $!\n";
1506        return -1;
1507    } elsif ($? & 127) {
1508        printf "prog died with signal %d, %s coredump\n",
1509          ($? & 127),  (($? & 128) ? "with" : "without");
1510        return $?;
1511    } else {
1512        printf "prog exited with value %d\n", ($? >> 8) if ($debug or $?);
1513        return ($? >> 8);
1514    }
1515}
1516
1517# -----------------------------------------
1518# Subs: Setup
1519# -----------------------------------------
1520
1521sub read_config_file
1522{
1523    read_file($config_file, 'configuration');
1524}
1525
1526sub read_channels_file
1527{
1528    read_file($channels_file, 'channels');
1529}
1530
1531sub read_file
1532{
1533    my $fn = shift;
1534    my $name = shift;
1535
1536    print "Reading $name file: $fn\n";
1537    unless (-r $fn)
1538    {
1539        unless ($opt->{configure})
1540        {
1541            print "\nNo $name file found.\n" .
1542                  ucfirst($progname) . " must be configured: " .
1543                  "configuring now.\n\n";
1544            $opt->{'configure'} = 1;
1545        }
1546        return;
1547    }
1548    local (@ARGV, $/) = ($fn);
1549    no warnings 'all';
1550    eval <>;
1551    if ($@ and !$opt->{configure})
1552    {
1553        warn "\nERROR in $name file! Details:\n$@";
1554        print "You may wish to CTRL-C and fix this.\n\nContinuing anyway in:";
1555        foreach (1 .. 5)
1556        {
1557            print " " . (6 - $_);
1558            sleep 1;
1559        }
1560        print "\n";
1561    }
1562}
1563
1564sub write_config_file
1565{
1566    write_file($config_file, 'configuration', 
1567        [$region,  $pref_title_source,  $mirror_site,  $components ],
1568        ["region", "pref_title_source", "mirror_site", "components" ]);
1569}
1570
1571sub write_channels_file
1572{
1573    write_file($channels_file, 'channels',
1574        [ $channels,  $opt_channels ],
1575        [ 'channels', 'opt_channels' ]);
1576}
1577
1578sub write_file
1579{
1580    my ($fn, $name, $vars, $varnames) = @_;
1581    open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
1582    print FN Data::Dumper->Dump($vars, $varnames);
1583    close FN;
1584    print "Wrote $name file $fn.\n" if ($debug);
1585}
1586
1587sub get_command_line_options
1588{
1589  GetOptions($opt, qw(  help
1590                        dontcallgrabbers
1591                        version
1592                        debug
1593                        days=i
1594                        offset=i
1595                        output=s
1596                        randomize
1597                    ));
1598    $debug = $opt->{debug};
1599    $days = $opt->{days} if ($opt->{days});
1600}
1601
1602# -----------------------------------------
1603# Subs: override handlers for standard perl.
1604# -----------------------------------------
1605
1606# ugly hack. please don't try this at home kids!
1607sub my_die {
1608    my ($arg,@rest) = @_;
1609    my ($pack,$file,$line,$sub) = caller(0);
1610
1611    # check if we are in an eval()
1612    if ($^S) {
1613        printf "  shepherd caught a die() within eval{} from file $file line $line\n";
1614    } else {
1615            printf "\nDIE: line %d in file %s\n",$line,$file;
1616            if ($arg) {
1617                CORE::die($arg,@rest);
1618            } else {
1619                CORE::die(join("",@rest));
1620            }
1621    }
1622}
Note: See TracBrowser for help on using the browser.