root/applications/shepherd @ 394

Revision 394, 88.4 kB (checked in by max, 6 years ago)

Added undocumented option --grabwith to temporarily specify grabber order
  • Property svn:executable set to *
Line 
1#!/usr/bin/perl -w
2
3my $progname = 'shepherd';
4my $version = '0.4.22';
5
6# tv_grab_au
7# "Shepherd"
8# A wrapper for various Aussie TV guide data grabbers
9#
10# Use --help for command-line options.
11#
12# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
13# make one cohesive reliable data set. It works by calling a series of
14# scripts that grab data from a large variety of sources, and then
15# analysing the resulting XML data sets and determining which of the many
16# is the most reliable.
17
18# Shepherd runs in 5 stages:
19#  stage 1: Checks that all components are up-to-date, auto-updates if not.
20#  stage 2: calls grabbers to fill in missing data
21#  stage 3: calls reconciler to reconcile overlapping data and normalize
22#           programme titles to our preferred title
23#  stage 4: calls postprocessors to postprocess data
24#           (e.g. flag HDTV programmes, augment with IMDb etc.)
25#  stage 5: write final XMLTV out
26
27# Changelog:
28# 0.2.31  : split tv_grab_au (install/test/upgrade/enable/disable) from
29#           shepherd (grab/reconcile/postprocess). Previous changelog history
30#           is in shepherd
31# 0.3.0   : This split deserves a real version bump, Linc! :)
32# 0.3.1   : honour $option_ready
33# 0.3.10  : split out into apps directory, renamed back to 'shepherd' with
34#           an auto symlink to tv_grab_au
35#           logging to logs/ directory
36# 0.4.1   : revert split - dog and shepherd are back as one
37
38BEGIN { *CORE::GLOBAL::die = \&my_die; }
39
40use strict;
41no strict 'refs';
42
43# ---------------------------------------------------------------------------
44# --- required perl modules
45# ---------------------------------------------------------------------------
46
47&require_module("Cwd", qw(realpath));
48&require_module("LWP::UserAgent");
49&require_module("Getopt::Long");
50&require_module("Data::Dumper");
51&require_module("XMLTV");
52&require_module("XMLTV::Ask");
53&require_module("POSIX", qw(strftime mktime getcwd));
54&require_module("Compress::Zlib");
55&require_module("Date::Manip");
56&require_module("Algorithm::Diff");
57&require_module("List::Compare");
58&require_module("Digest::SHA1");
59
60# ---------------------------------------------------------------------------
61# --- Global Variables
62# ---------------------------------------------------------------------------
63
64my $HOME = 'http://www.whuffy.com';
65
66my $CWD = &find_home;
67-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
68chdir($CWD);
69
70my $ARCHIVE_DIR = "$CWD/archive";
71my $LOG_DIR = "$CWD/log";
72
73my @options;
74my $opt = {};
75my $pref_title_source;
76my $mirror_site;
77my $debug = 0;
78my $components = { };
79my $components_pending_install = { };
80my $region;
81my $channels;
82my $opt_channels;
83my $config_file =   "$CWD/$progname.conf";
84my $channels_file = "$CWD/channels.conf";
85my $log_file = "$progname.log";
86my $sysid = time.".".$$;
87my $pending_messages = { };
88my $starttime = time;
89
90my $invoked = get_full_path($0);
91
92# grabbing
93my $gscore;
94my $days = 7;
95my $missing;
96my $timeslice;
97my $grabbed;
98my $gmt_offset;
99my $grabber_found_all_data;
100my $writer;
101my $components_used = $progname."(v".$version.")";
102
103# postprocessing
104my $langs = [ 'en' ];
105my $plugin_data = { };
106my $channel_data = { };
107my $reconciler_found_all_data;
108my $input_postprocess_file = "";
109
110# ---------------------------------------------------------------------------
111# --- Policies
112# ---------------------------------------------------------------------------
113# the following thresholds are used to control whether we keep calling grabbers or
114# not.
115
116my %policy;
117$policy{timeslot_size} = (5 * 60);      # 5 minute slots
118$policy{timeslot_debug} = 0;            # don't debug timeslot policy by default
119
120# PEAK timeslots -
121#  between 4.30pm and 10.30pm every day, only allow a maximum of
122#  15 minutes "programming data" missing
123#  if there is more than this, we will continue asking grabbers for more
124#  programming on this channel
125$policy{peak_max_missing} = 15*60;              # up to 15 mins max allowed missing
126$policy{peak_start} = (16*(60*60))+(30*60);     # 4.30pm
127$policy{peak_stop} = (22*(60*60))+(30*60);      # 10.30pm
128
129# NON-PEAK timeslots -
130#  between midnight and 7.15am every day, only allow up to 6 hours missing
131#  if there is more than this, we will continue asking grabbers for more
132#  programming on this channel
133$policy{nonpeak_max_missing} = 7*(60*60);       # up to 6 hours can be missing
134$policy{nonpeak_start} = 0;                     # midnight
135$policy{nonpeak_stop} = (7*(60*60))+(15*60);    # 7.15am
136
137# all other timeslots - (7.15am-4.30pm, 10.30pm-midnight)
138#  allow up to 60 minutes maximum missing programming
139$policy{other_max_missing} = 3*60*60;           # up to 3 hrs max allowed missing
140
141# don't accept programmes that last for longer than 8 hours.
142$policy{max_programme_length} = (8 * 60 * 60);  # 8 hours
143
144
145# ---------------------------------------------------------------------------
146# --- Setup
147# ---------------------------------------------------------------------------
148
149&get_command_line_options;
150
151&capabilities if ($opt->{capabilities});
152&description if ($opt->{description});
153
154$| = 1; 
155print "$progname v$version\n\n";
156
157exit if ($opt->{version});
158&help if ($opt->{help});
159
160&check_user;
161
162&read_config_file;
163&read_channels_file;
164
165&process_setup_commands;
166
167&open_logfile unless ($opt->{nolog});
168
169# ---------------------------------------------------------------------------
170# --- Update
171# ---------------------------------------------------------------------------
172
173unless ($opt->{noupdate})
174{
175    if (&update()) 
176    {
177        &write_config_file;
178    }
179}
180
181if ($opt->{configure})
182{
183    &configure;
184}
185
186# ---------------------------------------------------------------------------
187# --- Go!
188# ---------------------------------------------------------------------------
189
190# If the previous run failed to complete, we'll have some pending stats:
191# deliver these.
192if (&report_stats)
193{
194    &write_config_file;
195}
196
197unless ($opt->{update})
198{
199    &calc_gmt_offset;
200    &commence_stats;
201    &calc_date_range;
202    &start_tor;
203    &grab_data;
204    &reconcile_data;
205    &postprocess_data;
206    &output_data;
207    &finalize_stats;
208    &report_stats;
209    &write_config_file;
210    &stop_tor;
211}
212
213&log("Done.\n");
214&close_logfile() unless $opt->{nolog};
215
216# ---------------------------------------------------------------------------
217# --- Subroutines
218# ---------------------------------------------------------------------------
219
220# -----------------------------------------
221# Subs: Updates & Installations
222# -----------------------------------------
223
224sub update
225{
226    my $made_changes = 0;
227    my $wanted_prog = get_full_path(query_filename('shepherd','application'));
228    if (($invoked ne $wanted_prog) && (!$opt->{configure}))
229    {
230        if (-e $wanted_prog)
231        {
232            &log("\n*** Restarting ($invoked invoked, $wanted_prog wanted)  ***\n\n");
233            &close_logfile unless $opt->{nolog};
234            exec("$wanted_prog @options");
235            # This exits.
236            exit(0);
237        }
238
239        &log("\nWARNING: you should really be running ".ucfirst($progname)."\n".
240           "    as '".query_filename('shepherd','application')."'\n".
241           "    rather than '$invoked'!\n".
242           "    Auto-update has been disabled until you fix this!\n\n");
243        &countdown();
244        &log("\nSkipped auto-update.\n\n");
245        return 0;
246    }
247
248    &log("\nChecking for updates:\n\n");
249    my $data = fetch_shepherd_file("shepherd/status.csum");
250
251    return 0 unless ($data);
252
253    my %clist = %$components;
254
255    while ($data =~ /(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/g)
256    {
257        my ($progtype, $proggy, $latestversion, $csum1, $csum2) = ($1,$2,$3,$4,$5);
258        if (update_component($proggy, $latestversion, $progtype, $csum1, $csum2))
259        {
260            $made_changes = 1;
261        }
262        delete $clist{$proggy};
263    }
264
265    # work out what components disappeared (if any)
266    foreach (keys %clist) {
267        unless ($components->{$_}->{disabled}) {
268            &log("\nDeleted component: $_.\n");
269            disable($_, 2);
270            $made_changes = 1;
271        }
272    }
273    $made_changes;
274}
275
276sub update_component
277{
278    my ($proggy, $latestversion, $progtype, $csum1, $csum2) = @_;
279
280    my $ver = 0;
281    $ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e query_filename($proggy,$progtype));
282
283    my ($result, $action);
284
285    if ($progtype eq 'application'
286        or $progtype eq 'engine'
287        or $progtype eq 'reconciler')
288    {
289        $result = &majorversioncmp($ver, $latestversion);
290
291        # Ignore major versions that are lower. This lets us maintain branches
292        # of Shepherd; i.e. release a bugfix for a previous version while continuing
293        # development of a newer version with new dependencies.
294        return 0 if ($result == 1);
295       
296        if ($result == -1 and !$opt->{'update-version'})
297        {
298            &log(ucfirst($progtype) . " $proggy has new major version available: " .
299                 "v$latestversion.\nNot auto-updating. To update, run: $progname " .
300                 "--update-version\n");
301            $result = 0;
302            $action = 'IGNORING';
303        }
304    }
305    elsif ($components->{$proggy}->{disabled} and $components->{$proggy}->{disabled} == 1)
306    {
307        $action = 'DISABLED BY USER';
308    }
309
310    unless ($action)
311    {
312        $result = &versioncmp($ver, $latestversion);
313        $action =    $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
314                     $result ==  1 ? "DOWNGRADING" :
315                                     "up to date";
316    }
317    &log(sprintf    "* %-55s%16s\n",
318                    ucfirst($progtype) . " $proggy" .
319                        ($ver ? " v$ver" : '') . "...",
320                    $action);
321    return 0 unless ($result);
322    install($proggy, $latestversion, $progtype, $ver, $csum1, $csum2);
323    return 1;
324}
325
326sub install
327{
328    my ($proggy, $latestversion, $progtype, $oldver, $csum1, $csum2) = @_;
329    my $config;
330
331    my $rdir = "";
332    my $basedir = $CWD."/".$progtype."s";
333    my $ldir = query_ldir($proggy, $progtype);
334   
335    -d $basedir or mkdir $basedir or die "Cannot create directory $basedir: $!\n";
336    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!\n";
337    my $newfile = "$ldir/$proggy-$latestversion";
338
339    $rdir = $progtype . 's';
340    my $rfile = "shepherd/$rdir/$proggy";
341
342    # have we previously downloaded it but haven't been able to install it
343    # (due to a failed test or failed dependencies or something like that)?
344    if ((-e "$newfile") && (-s "$newfile") && (defined $components_pending_install->{$proggy})) {
345        &log("Appear to have previously downloaded $proggy v$latestversion.\n");
346        $config = Data::Dumper->Dump([$components_pending_install->{$proggy}->{config}], ["config"]);
347    } else {
348        &log("Downloading $proggy v$latestversion.\n");
349        return unless (fetch_shepherd_file($rfile, $newfile, undef, $csum2));
350
351        # Make component executable
352        chmod 0755,$newfile;
353    }
354
355    $rfile .= ".conf";
356    $config = fetch_shepherd_file($rfile, undef, undef, $csum1) if (!defined $config);
357
358    return unless ($config); # everyone MUST have config files
359
360    eval $config;
361    if ($@) {
362        &log("Config file $rfile was invalid, not updating this component: $@\n");
363        return;
364    }
365
366    # test that the component works BEFORE we install it
367    my $ready_test = test_proggy("$proggy", $progtype, $latestversion);
368    if (!$ready_test) {
369        &log("$proggy v$latestversion failed ready test - marking as a pending update.\n");
370        $components_pending_install->{$proggy}->{config} = $config;
371        $components_pending_install->{$proggy}->{updated} = time;
372
373        if (defined $components->{$proggy}) {
374            $components->{$proggy}->{admin_status} = sprintf "update to version %s pending: %s",
375                $latestversion, $components_pending_install->{$proggy}->{admin_status};
376        }
377
378        return;
379    }
380
381    $components->{$proggy}->{ready} = $ready_test;
382
383    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!\n";
384
385    rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$oldver") if (-e "$ldir/$proggy");
386    rename($newfile, "$ldir/$proggy");
387   
388    &log("Installed $proggy v$latestversion.\n") if ($debug);
389
390    $components->{$proggy}->{type} = $progtype;
391    $components->{$proggy}->{ver} = $latestversion;
392    $components->{$proggy}->{config} = $config;
393    $components->{$proggy}->{updated} = time;
394    $components->{$proggy}->{admin_status} = sprintf "updated from %s to %s", $oldver, $latestversion;
395    delete $components_pending_install->{$proggy} if (defined $components_pending_install->{$proggy});
396
397    # if the update was for the main app, restart it
398    if ($proggy eq $progname) {
399        &write_config_file;
400
401        # special case for main app - we create a symlink also
402        unlink("$CWD/tv_grab_au","$CWD/shepherd");
403        eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/tv_grab_au"); 1 };
404        eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/shepherd"); 1 };
405
406        &log("\n*** Restarting ***\n\n");
407        &close_logfile unless $opt->{nolog};
408        exec("$ldir/$proggy @options"); # this exits
409        exit(0);
410    }
411
412    # If this component was disabled automatically, re-enable it.
413    # But if it was disabled manually, leave it off.
414    my $d = $components->{$proggy}->{disabled};
415    if ($d and $d == 2)
416    {
417        enable($proggy);
418    }
419}
420
421sub fetch_shepherd_file
422{
423    my ($fn, $store, $postvars, $csum) = @_;
424
425    my $sites = "";
426    $sites = "$mirror_site," if ($mirror_site);
427    $sites .= $HOME;
428
429    my $ret;
430    foreach my $site (split(/,/,$sites)) 
431    {
432        $ret = fetch_file("$site/$fn", $store, 1, $postvars, $csum);
433        return $ret if ($ret);
434    }
435    return undef;
436}
437
438sub test_proggy
439{
440    my ($proggy, $progtype, $specific_version) = @_;
441
442    &log("Testing $proggy...\n");
443
444    my $ldir = query_ldir($proggy, $progtype);
445    my $progname = query_filename($proggy, $progtype);
446    $progname .= "-".$specific_version if ((defined $specific_version) && ($specific_version ne ""));
447
448    my $opt_ready = query_config($proggy, 'option_ready');
449    $opt_ready ||= '--version';
450   
451    chdir($ldir);
452    my ($result,$test_output) = call_prog($proggy, $progname . " $opt_ready" . " 2>&1",1);
453    chdir ($CWD);
454
455    &log("Return value: $result\n") if ($debug);
456
457    my $statusmsg;
458
459    if ($result)
460    {
461        &log(ucfirst($progtype) . " $proggy did not exit cleanly!\n" .
462             "It may require configuration.\n");
463
464        # set proggy status accordingly
465        $statusmsg = sprintf "FAILED (return code %d) on %s", $result, POSIX::strftime("%a%d%b%y", localtime(time));
466
467        # can we give any more details on why it failed?
468        if ($test_output and $test_output =~ /Can't locate (.*) in \@INC/) {
469            my $modname = $1;
470            $modname =~ s#/#::#g;       # turn / into ::
471            $modname =~ s#\.pm##g;      # remove .pm suffix
472            $statusmsg .= ": missing '".$modname."' module.";
473
474            &log("Probably failed due to dependency on missing module '".$modname."'\n");
475        }
476
477        &log("\n");
478    }
479    else
480    {
481        &log("OK.\n");
482
483        # mark as successful but only if previously unsuccessful
484        # (we only mark it if it was previously unsuccessful otherwise a --check
485        # will result in clearing out all of the admin_status fields)
486        $statusmsg = sprintf "tested successfully on %s", POSIX::strftime("%a%d%b%y", localtime(time))
487          if ((defined $components->{$proggy}->{ready}) && (!$components->{$proggy}->{ready}));
488    }
489
490    # update status message
491    if ((defined $statusmsg) && ($statusmsg ne "")) {
492        if ((defined $specific_version) && ($specific_version ne "")) {
493            $components_pending_install->{$proggy}->{admin_status} = $statusmsg;
494        } else {
495            $components->{$proggy}->{admin_status} = $statusmsg;
496        }
497    }
498
499    return !$result;
500}
501
502sub enable
503{
504    my $proggy = shift;
505
506    # confirm it exists first
507    if (!$components->{$proggy}) {
508        &log("No such component: \"$proggy\".\n");
509        return;
510    }
511
512    &log("Enabling $proggy.\n");
513
514    delete $components->{$proggy}->{disabled};
515    $components->{$proggy}->{admin_status} = sprintf "enabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
516}
517
518sub disable
519{
520    my ($proggy, $n) = @_;
521
522    # confirm it exists first
523    if (!$components->{$proggy}) {
524        &log("No such component: \"$proggy\".\n");
525        return;
526    }
527
528    if ($components->{$proggy}->{type} eq "application") {
529        &log("Can't disable component: \"$proggy\".\n");
530        return;
531    }
532
533    &log("Disabling $proggy.\n");
534   
535    $n ||= 1;
536    $components->{$proggy}->{disabled} = $n;
537    $components->{$proggy}->{admin_status} = sprintf "manually disabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
538}
539
540sub check
541{
542    my $result;
543
544    foreach my $proggy (keys %$components) {
545        my $progtype = $components->{$proggy}->{type};
546        my $try_count = 0;
547
548RETRY:
549        $try_count++;
550        $result = test_proggy($proggy, $components->{$proggy}->{type});
551        $components->{$proggy}->{ready} = $result;
552
553        if ((!$result) && ($try_count < 2) && (query_config($proggy, 'option_config'))) {
554            &log("Trying to configure '$proggy'\n");
555
556            chdir(query_ldir($proggy, $progtype));
557            system(query_filename($proggy, $progtype) . " ". query_config($proggy, 'option_config') . " 2>&1");
558            chdir ($CWD);
559
560            goto RETRY;
561        }
562    }
563}
564
565sub pending
566{
567    return unless ($components_pending_install);
568
569    my @pending;
570    foreach (keys %$components_pending_install)
571    {
572        push @pending, $_;
573    }
574    unless (@pending)
575    {
576        &log("\nNo components are pending install.\n");
577        return;
578    }
579    &log("\nThe following components are pending install: " .
580        join(', ', @pending) . ".\n\n" .
581        "You may have missing Perl dependencies. To see errors,\n".
582        "run: $progname --update or $progname --check\n");
583
584    # Exit with non-zero status so this sub can be used to
585    # notify an external program (to email the owner, perhaps)
586    # about pending installs.
587    exit 1;
588}
589
590# Set this to a failure message as a default; if we complete successfully we'll change it.
591sub commence_stats
592{
593    &add_pending_message($progname, 'FAIL', $sysid, $starttime, 0, $region, 'incomplete');
594}
595
596sub finalize_stats
597{
598    delete $pending_messages->{$progname};
599    &add_pending_message($progname, "SUCCESS", $sysid, $starttime, (time-$starttime), $region, $components_used);
600}
601
602# Report any pending stats to main server.
603sub report_stats
604{
605    my $postvars = build_stats();
606    return unless $postvars;
607   
608    if ($opt->{nonotify})
609    {
610        &log("Not posting usage statistics due to --nonotify option.\n");
611        return;
612    }
613    &log("Posting anonymous usage statistics.\n");
614
615    return 0 unless (fetch_shepherd_file("report.cgi", undef, $postvars));
616
617    # successful post, clear out our pending messages
618    foreach my $component (sort keys %$pending_messages) 
619    {
620        delete $pending_messages->{$component};
621    }
622    return 1; # made changes
623}
624
625# gather pending messages
626sub build_stats
627{
628    return unless (keys %$pending_messages);
629
630    my $postvars = "";
631    my %postmsgs;
632
633    foreach my $component (keys %$pending_messages) {
634        foreach my $msgtype (sort keys %{($pending_messages->{$component})}) {
635            $postmsgs{$component} .= urlify("\n".$component."\t") if (defined $postmsgs{$component});
636            $postmsgs{$component} .= urlify($msgtype."\t".$pending_messages->{$component}->{$msgtype});
637        }
638    }
639
640    # shepherd first
641    $postvars = "$progname=$postmsgs{$progname}";
642
643    # the rest
644    foreach my $component (sort keys %postmsgs) {
645        next if ($component eq $progname);
646        $postvars .= sprintf "%s%s=%s",
647                             (length($postvars) > 0 ? "&" : ""),
648                             $component, $postmsgs{$component};
649    }
650
651    return $postvars;
652}
653
654# -----------------------------------------
655# Subs: Utilities
656# -----------------------------------------
657
658# versioncmp from Sort::Versions by Kenneth J. Albanowski
659sub versioncmp( $$ ) {
660    my @A = ($_[0] =~ /([-.]|\d+|[^-.\d]+)/g);
661    my @B = ($_[1] =~ /([-.]|\d+|[^-.\d]+)/g);
662
663    my ($A, $B);
664    while (@A and @B) {
665        $A = shift @A;
666        $B = shift @B;
667        if ($A eq '-' and $B eq '-') {
668            next;
669        } elsif ( $A eq '-' ) {
670            return -1;
671        } elsif ( $B eq '-') {
672            return 1;
673        } elsif ($A eq '.' and $B eq '.') {
674            next;
675        } elsif ( $A eq '.' ) {
676            return -1;
677        } elsif ( $B eq '.' ) {
678            return 1;
679        } elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
680            if ($A =~ /^0/ || $B =~ /^0/) {
681                return $A cmp $B if $A cmp $B;
682            } else {
683                return $A <=> $B if $A <=> $B;
684            }
685        } else {
686            $A = uc $A;
687            $B = uc $B;
688            return $A cmp $B if $A cmp $B;
689        }       
690    }
691    @A <=> @B;
692}
693
694sub majorversioncmp
695{
696    my ($v1, $v2) = @_;
697
698    $v1 =~ /^(\d+)\./ and $v1 = $1;
699    $v2 =~ /^(\d+)\./ and $v2 = $1;
700
701    $v1 <=> $v2;
702}
703
704sub get_full_path
705{
706    my $path = shift;
707    my $real = realpath($path);
708    return $path if (!$real);
709    return $real;
710}
711
712sub require_module
713{
714    my ($mod, @imports) = @_;
715
716    my $modname = $mod.".pm";
717    $modname =~ s/::/\//g;
718
719    eval { require $modname; };
720    if ($@) {
721        &log("\nERROR:\nMandatory module '$mod' not found.\n\n" .
722             "Please see the Wiki at http://svn.whuffy.com/index.cgi/wiki/Installation\n" .
723             "for details on how to install this module.\n", 1);
724        exit(1);
725    }
726
727    import $mod @imports;
728}
729
730# check that user isn't root, warn them if they are!
731sub check_user
732{
733    if ($< == 0) {
734        &log("WARNING:\n You are running ".ucfirst($progname).
735            " as 'root' super-user.\n".
736            " It is HIGHLY RECOMMENDED that you set your system to run ".
737            ucfirst($progname)."\n from within a normal user account!\n\n", 1);
738        &countdown(10, 1);
739    }
740}
741
742sub query_grabbers
743{
744    my ($conf, $val) = @_;
745    return query_component_type('grabber',$conf,$val);
746}
747
748sub query_reconcilers
749{
750    return query_component_type('reconciler');
751}
752
753sub query_postprocessors
754{
755    return query_component_type('postprocessor');
756}
757
758sub query_component_type
759{
760    my ($progtype,$conf,$val) = @_;
761
762    my @ret = ();
763    foreach (keys %$components)
764    {
765        if ($components->{$_}->{type} eq $progtype) {
766            if (defined $conf) {
767                push (@ret, $_) if (query_config($_,$conf) eq $val);
768            } else {
769                push (@ret, $_);
770            }
771        }
772    }
773    return @ret;
774}
775
776sub query_name
777{
778    my $str = shift;
779    if ($str =~ /(.*) \[cache\]/)
780    {
781        return $1;
782    }
783    return $str;
784}
785
786sub query_filename
787{
788    my ($proggy, $progtype) = @_;
789    return query_ldir($proggy,$progtype).'/'.$proggy;
790}
791
792sub query_ldir
793{
794    my ($proggy, $progtype) = @_;
795    return $CWD.'/'.$progtype.'s/'.$proggy;
796}
797
798sub query_config
799{
800    my ($grabber, $key) = @_;
801
802    $grabber = query_name($grabber);
803    return undef unless ($components->{$grabber});
804    return $components->{$grabber}->{config}->{$key};
805}
806
807sub countdown
808{
809    my ($n, $stderr) = @_;
810
811    $n ||= 10;
812    &log("You may wish to CTRL-C and fix this.\n\nContinuing anyway in:", $stderr);
813    foreach (1 .. $n)
814    {
815        &log(" " . ($n + 1 - $_), $stderr);
816        sleep 1;
817    }
818    &log("\n", $stderr);
819}
820
821sub rotate_logfiles
822{
823    # keep last 10 log files
824    my $num;
825    for ($num = 10; $num > 0; $num--) {
826        my $f1 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num;
827        my $f2 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num+1;
828        unlink($f2);
829        rename($f1,$f2);
830    }
831
832    my $f1 = sprintf "%s/%s",$LOG_DIR,$log_file;
833    my $f2 = sprintf "%s/%s.1",$LOG_DIR,$log_file;
834    rename($f1,$f2);
835}
836
837sub compress_file
838{
839    my $infile = shift;
840    my $outfile = sprintf "%s.gz",$infile;
841    my $gz;
842
843    if (!(open(INFILE,"<$infile"))) {
844        warn "could not open file $infile for reading: $!\n";
845        return;
846    }
847
848    if (!($gz = gzopen($outfile,"wb"))) {
849        warn "could not open file $outfile for writing: $!\n";
850        return;
851    }
852
853    while (<INFILE>) {
854        my $byteswritten = $gz->gzwrite($_);
855        warn "error writing to compressed file: error $gz->gzerror"
856          if ($byteswritten == 0);
857    }
858    close(INFILE);
859    $gz->gzclose();
860    unlink($infile);
861}
862
863sub open_logfile
864{
865    -d $LOG_DIR or mkdir $LOG_DIR or die "Cannot create directory $LOG_DIR: $!";
866
867    &rotate_logfiles;
868    print "Logging to $log_file.\n" if ($debug);
869    open(LOG_FILE,">>$LOG_DIR/$log_file") || die "can't open log file $LOG_DIR/$log_file for writing: $!\n";
870
871    my $now = localtime(time);
872    printf LOG_FILE "$progname v$version started at $now\n";
873    printf LOG_FILE "Invoked as: $invoked ".join(" ",@options)."\n\n";
874
875    my $old_log_file = $LOG_DIR."/".$log_file.".1";
876    compress_file($old_log_file) if (-f $old_log_file);
877}
878
879sub close_logfile
880{
881    close(LOG_FILE);
882}
883
884sub log
885{
886    my ($entry, $stderr) = @_;
887
888    if ($stderr)
889    {
890        print STDERR $entry;
891    }
892    else
893    {
894        print $entry unless ($opt->{quiet});
895    }
896    print LOG_FILE $entry if (fileno(*LOG_FILE) and !$opt->{nolog});
897}
898
899sub call_prog
900{
901    my ($component,$prog,$want_output,$timeout) = @_;
902    $timeout = 0 if (!defined $timeout);
903    $want_output = 0 if (!defined $want_output);
904
905    my $prog_output = "";
906
907    if (!(open(PROG,"$prog|"))) {
908        &log("warning: couldn't exec $component as \"$prog\": $!\n");
909        return -1;
910    }
911
912    &log("\n>>>> Output from $component >>>>>\n");
913
914    eval {
915        local $SIG{ALRM};
916        if ($timeout > 0) {
917            $SIG{ALRM} = sub { die "alarm\n" };
918            alarm $timeout; # set alarm
919        }
920        while(<PROG>) {
921            &log($_);
922            $prog_output .= $_ if ($want_output);
923            &add_pending_message($component, 'stats', $1) if ($_ =~ /^STATS: (.*)/);
924        }
925        alarm(0) if ($timeout > 0); # cancel alarm
926        close(PROG);
927    };
928
929    &log("<<<<< End output from $component <<<<<\n\n");
930
931    if ($@) {
932        die unless $@ eq "alarm\n";   # propagate unexpected errors
933
934        # timeout
935        &log(ucfirst($component) . " ran for $timeout seconds, stopping it.\n");
936        close(PROG);
937    }
938
939    if ($? == -1) {
940        &log("Failed to execute $component: $!\n");
941        return -1;
942    } elsif ($? & 127) {
943        &log((sprintf "%s died with signal %d, %s coredump\n",
944          ucfirst($component), ($? & 127),  (($? & 128) ? "with" : "without")));
945        return $?;
946    } elsif ($debug) {
947        &log((sprintf "%s exited with value %d\n", ucfirst($component), ($? >> 8)));
948    }
949    return ($? >> 8);
950}
951
952sub fetch_file
953{
954    my ($url, $store, $id_self, $postvars, $csum) = @_;
955    my $request;
956
957    &log("Fetching $url.\n") if ($debug);
958   
959    my $ua = LWP::UserAgent->new();
960    if ($id_self)
961    {
962        $ua->agent(ucfirst("$progname/$version"));
963    }
964    else
965    {
966        $ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322')
967    }
968
969    if (defined $postvars) {
970        $request = HTTP::Request->new(POST => $url);
971        $request->add_content($postvars);
972    } else {
973        $request = HTTP::Request->new(GET => $url);
974    }
975    $request->header('Accept-Encoding' => 'gzip');
976
977    my $response = $ua->request($request);
978    if ($response->is_success())
979    {
980        if ($response->header('Content-Encoding') &&
981            $response->header('Content-Encoding') eq 'gzip') {
982            $response->content(Compress::Zlib::memGunzip($response->content));
983        }
984
985        # check the checksum
986        if (defined $csum) {
987            my $sha1 = Digest::SHA1->new();
988            $sha1->add($response->content);
989            if ($sha1->hexdigest ne $csum) {
990                &log("$url corrupt: expected checksum $csum but got ".$sha1->hexdigest."\n");
991                return undef;
992            }
993        }
994
995        if ($store)
996        {
997            open (FILE, ">$store") 
998                or (&log("ERROR: Unable to open $store for writing.\n") and return undef);
999            print FILE $response->content();
1000            close FILE;
1001            return 1;
1002        }
1003        else 
1004        {
1005            return $response->content();
1006        } 
1007    }
1008    &log("Failed to retrieve $url!\n" . $response->status_line() . "\n");
1009    return undef;
1010}
1011
1012sub add_pending_message
1013{
1014    my ($component, $field, @rest) = @_;
1015
1016    # Don't compile stats if running with these options
1017    return if ($opt->{nonotify} or $opt->{dontcallgrabbers});
1018
1019    $pending_messages->{$component}->{$field} = join("\t",@rest);
1020}
1021
1022sub urlify
1023{
1024    my $str = shift;
1025    $str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
1026    return $str;
1027}
1028
1029# Try to find a sensible place to put Shepherd files. Default is ~/.shepherd/
1030sub find_home
1031{
1032    my $home = $ENV{HOME};
1033    $home = undef if ($home eq '/' or $home eq '');
1034    if (!$home and $ENV{USER})
1035    {
1036        foreach ( "/home/$ENV{USER}", "/usr/home/$ENV{USER}", "/$ENV{USER}" )
1037        {
1038            if (-o $_ and -d $_)
1039            {
1040                $home = $_;
1041                last;
1042            }
1043        }
1044    }
1045    if ($home)
1046    {
1047        $home =~ s'/$'';
1048        return "$home/.$progname";
1049    }
1050    return "/opt/$progname";
1051}
1052
1053# -----------------------------------------
1054# Subs: Setup
1055# -----------------------------------------
1056
1057sub read_config_file
1058{
1059    read_file($config_file, 'configuration');
1060}
1061
1062sub read_channels_file
1063{
1064    read_file($channels_file, 'channels');
1065}
1066
1067sub read_file
1068{
1069    my $fn = shift;
1070    my $name = shift;
1071
1072    print "Reading $name file: $fn\n";
1073    unless (-r $fn)
1074    {
1075        unless ($opt->{configure})
1076        {
1077            print "\nNo $name file found.\n" .
1078                  ucfirst($progname) . " must be configured: " .
1079                  "configuring now.\n\n";
1080            $opt->{'configure'} = 1;
1081            $opt->{'nolog'} = 1;
1082        }
1083        return;
1084    }
1085    local (@ARGV, $/) = ($fn);
1086    no warnings 'all';
1087    eval <>;
1088    if ($@ and !$opt->{configure})
1089    {
1090        warn "\nERROR in $name file! Details:\n$@";
1091        &countdown();
1092    }
1093}
1094
1095sub write_config_file
1096{
1097    write_file($config_file, 'configuration',
1098        [$region,  $pref_title_source,  $sysid,  $mirror_site,  $components,  $components_pending_install,  $pending_messages ],
1099        ["region", "pref_title_source", "sysid", "mirror_site", "components", "components_pending_install", "pending_messages" ]);
1100}
1101
1102sub write_channels_file
1103{
1104    write_file($channels_file, 'channels',
1105        [ $channels,  $opt_channels ],
1106        [ 'channels', 'opt_channels' ]);
1107}
1108
1109sub write_file
1110{
1111    my ($fn, $name, $vars, $varnames) = @_;
1112    open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
1113    print FN Data::Dumper->Dump($vars, $varnames);
1114    close FN;
1115    &log("Wrote $name file $fn.\n") if ($debug);
1116}
1117
1118sub get_command_line_options
1119{
1120  # Record so we can pass the unmodified args to components later
1121  @options = @ARGV;     # Record so we can pass the unmodified args to components later
1122  push (@options,"") if ($#options == -1); # silence warnings if none
1123
1124  # filter what options we don't pass on ..
1125  foreach (0..$#options) {
1126    next if (!$options[$_]);
1127
1128    splice(@options,$_,2) if ($options[$_] =~ /^--config-file/);        # don't pass on "--config-file (file)"
1129    splice(@options,$_,1) if ($options[$_] =~ /^--quiet/);              # never be quiet
1130  }
1131
1132  Getopt::Long::Configure(qw/pass_through/);
1133
1134  GetOptions($opt, qw(  config-file=s
1135                        help
1136                        configure
1137                        setmirror=s
1138                        setpreftitle=s
1139                        clearpreftitle
1140                        capabilities
1141                        description
1142                        quiet
1143                        version
1144                        debug
1145                        status
1146                        desc
1147                        show-config
1148                        show-channels
1149                        update
1150                        noupdate
1151                        disable=s
1152                        enable=s
1153                        nolog
1154                        nonotify
1155                        check
1156                        update-version
1157                        reset
1158                        dontcallgrabbers
1159                        days=i
1160                        offset=i
1161                        output=s
1162                        randomize
1163                        pending
1164                        grabwith=s
1165                     ));
1166  $debug = $opt->{debug};
1167  $days = $opt->{days} if ($opt->{days});
1168  $opt->{update} = 1 if ($opt->{'update-version'});
1169}
1170
1171
1172# Here we can specify which command-line options should call
1173# subroutines of the same name. The field following each sub
1174# name is a string that can contain a key for what action should
1175# be performed following the sub:
1176#   W : write config file
1177#   S : print --status output
1178# Shepherd will exit if at least one of these routines was
1179# called.
1180sub process_setup_commands
1181{
1182    my %routines = (    enable => 'WS',
1183                        disable => 'WS',
1184                        setorder => 'WS',
1185                        check => 'WS',
1186                        setpreftitle => 'W',
1187                        clearpreftitle => 'W',
1188                        setmirror => 'W',
1189                        'reset' => 'W',
1190                        status => '',
1191                        desc => '',
1192                        'show-config' => '',
1193                        'show-channels' => '',
1194                        'pending' => ''
1195                    );
1196
1197    my @run;
1198    foreach (keys %routines)
1199    {
1200        if ($opt->{$_})
1201        {
1202            push @run, $_;
1203            my $sub = $_;
1204            $sub =~ s/-/_/g;
1205            &$sub($opt->{$_});
1206        }
1207    }
1208    return unless (@run);
1209    foreach (@run)
1210    {
1211        &write_config_file if ($routines{$_} =~ /W/);
1212        &status if ($routines{$_} =~ /S/);
1213    }
1214    exit;
1215}
1216
1217# if a preferred title source has been specified, add it to our config
1218sub setpreftitle
1219{
1220    my $arg = shift;
1221    $pref_title_source = $arg;
1222    &log("Added preferred title source: $pref_title_source\n");
1223    1;
1224}
1225
1226# if requesting to clear preferred title and we have one, remove it
1227sub clearpreftitle
1228{
1229    $pref_title_source = undef;
1230    &log("Removed preferred title source $pref_title_source\n");
1231    1;
1232}
1233
1234# if a mirror has been specified, add it into our config
1235sub setmirror
1236{
1237    my $arg = shift;
1238    $mirror_site = $arg;
1239    &log("Setting mirror site(s): $mirror_site\n");
1240}
1241
1242sub reset
1243{
1244    &log( "\nWARNING! The --reset argument will remove your established\n" .
1245          "title translation data. This may cause Shepherd to lose the\n" .
1246          "ability to keep show titles consistent with what you have seen\n" .
1247          "in the past!\n\n");
1248    &countdown(20);
1249    my @r = query_component_type('reconciler');
1250    foreach (@r)        # Not that there should be more than one...
1251    {
1252        my $fn = query_ldir($_, 'reconciler') . '/' . $_ . '.config';
1253        &log("Removing $fn.\n");
1254        unlink($fn) or &log("Failed to remove file! $!\n");
1255    }
1256
1257    if ($pref_title_source)
1258    {
1259        my @prefs = split(/,/, $pref_title_source);
1260        foreach my $grabber (@prefs)
1261        {
1262            if ($components->{$grabber}->{lastdata})
1263            {
1264                &log( "Clearing lastdata for '$grabber' to trigger it to be called.\n");
1265                delete $components->{$grabber}->{lastdata};
1266            }
1267        }
1268    }
1269}
1270
1271# -----------------------------------------
1272# Subs: Configuration
1273# -----------------------------------------
1274
1275sub configure
1276{
1277    my $REGIONS = {
1278        "ACT" => 126,
1279        "NSW: Sydney" => 73,
1280        "NSW: Newcastle" => 184,
1281        "NSW: Central Coast" => 66,
1282        "NSW: Griffith" => 67,
1283        "NSW: Broken Hill" => 63,
1284        "NSW: Northern NSW" => 69,
1285        "NSW: Southern NSW" => 71,
1286        "NSW: Remote and Central" => 106,
1287        "NT: Darwin" => 74,
1288        "NT: Remote & Central" => 108,
1289        "QLD: Brisbane" => 75,
1290        "QLD: Gold Coast" => 78,
1291        "QLD: Regional" => 79,
1292        "QLD: Remote & Central" => 114,
1293        "SA: Adelaide" => 81,
1294        "SA: Renmark" => 82,
1295        "SA: Riverland" => 83,
1296        "SA: South East SA" => 85,
1297        "SA: Spencer Gulf" => 86,
1298        "SA: Remote & Central" => 107,
1299        "Tasmania" => 88,
1300        "VIC: Melbourne" => 94,
1301        "VIC: Geelong" => 93,
1302        "VIC: Eastern Victoria" => 90,
1303        "VIC: Mildura/Sunraysia" => 95,
1304        "VIC: Western Victoria" => 98,
1305        "WA: Perth" => 101,
1306        "WA: Regional" => 102
1307    };
1308
1309    print "\nConfiguring.\n\n" .
1310          "Select your region:\n";
1311    foreach (sort keys %$REGIONS)
1312    {
1313        printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
1314    }
1315    $region = ask_choice("Enter region code:", "94", values %$REGIONS);
1316
1317    print "\nFetching channel information... ";
1318
1319    my @channellist = get_channels();
1320
1321    print "done.\n\n" .
1322          "For each channel you want guide data for, enter an XMLTV id\n" .
1323          "of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
1324          "guide data for this channel, just press Enter.\n\n" .
1325          "Please don't subscribe to unneeded channels.\n\nChannels:\n";
1326    $channels = {};
1327    my $line;
1328    foreach (@channellist)
1329    {
1330        $line = ask(" \"$_\"? ");
1331        $channels->{$_} = $line if ($line);
1332    }
1333
1334    print "\nHigh Definition TV (HDTV)\n".
1335          "Most Australian TV networks broadcast at least some\n".
1336          "programmes in HDTV each week, but for the most part\n".
1337          "either upsample SD to HD or play a rolling demonstration\n".
1338          "HD clip when they don't have the programme in HD format.\n\n".
1339          "If you have a HDTV capable system and are interested in\n".
1340          "having Shepherd's postprocessors populate HDTV content\n".
1341          "then Shepherd will need to know the XMLTV IDs for the HD\n".
1342          "channels also.\n";
1343    if (ask_boolean("\nDo you wish to include HDTV channels?")) {
1344        print "\nFor each channel you want guide data for, enter an XMLTV id\n" .
1345              "of your choice (e.g. \"sevenhd.free.au\"). If you don't need\n" .
1346              "guide data for this channel, just press Enter.\n\n";
1347
1348        $opt_channels = {};
1349        foreach (@channellist)
1350        {
1351            next if (($_ =~ /ABC2/i) || ($_ =~ /SBS News/i) || ($_ =~ /31/));
1352            $_ .= "HD";
1353            $line = ask(" \"$_\"? ");
1354            $opt_channels->{$_} = $line if ($line);
1355        }
1356    }
1357
1358
1359    print "\nWould you like to transition seamlessly from your current grabber?\n\n".
1360          "Different data sources can have different names for the same show. For\n".
1361          "example, one grabber might call a show \"Spicks & Specks\" while another\n".
1362          "calls it \"Spicks and Specks\". These differences can make MythTV think\n".
1363          "they're actually different shows.\n\n".
1364          ucfirst($progname) . " is able to merge these differences so that it always\n".
1365          "presents shows with a consistent name, no matter where it actually sourced\n".
1366          "show data from. If you'd like, it can also rename shows so they're consistent\n".
1367          "with whichever grabber you've been using until now.\n\n".
1368          "The advantage of this is that you should get a smoother transition to\n".
1369          ucfirst($progname) . ", with no shows changing names and no need to re-create\n".
1370          "any recording rules. The main disadvantage is that if your previous grabber\n".
1371          "used an inferior data source -- i.e. it sometimes has typos or less\n".
1372          "informative program names -- then you'll continue to see these.\n\n".
1373          "If you were using one of the following grabbers previously AND you want\n".
1374          ucfirst($progname) . " to use that grabber's program names, select it here.\n\n";
1375
1376    my $def = "Do not transition; just use best quality titles";
1377    my %transition = (  "ltd (aka tv_grab_au, versions 1,30, 1.40 or 1.41)" => "yahoo7widget,abc2_website",
1378                        "OzTivo" => 'oztivo',
1379                        "Rex" => 'rex',
1380                        "JRobbo" => 'jrobbo' );
1381    my $pref = ask_choice("Transition from grabber?", $def,
1382                $def, keys %transition);
1383    $pref_title_source = $transition{$pref};
1384   
1385    print "\n";
1386    show_channels();
1387    unless(ask_boolean("\nCreate configuration file?"))
1388    {
1389        print "Aborting configuration.\n";
1390        exit 0;
1391    }
1392
1393    write_config_file();
1394    write_channels_file();
1395
1396    print "Checking if any components require configuration.\n\n";
1397    &check;
1398
1399    print "Finished configuring.\n\n";
1400
1401    status();
1402
1403    print "\nShepherd is installed into $CWD.\n\n" .
1404          "Run it as: $CWD/shepherd\n\n".
1405          "MythTV users may wish to create the following symlink, by " .
1406          "doing this (as root):\n" .
1407          "  \"ln -s $CWD/$progname /usr/bin/tv_grab_au\".\n\n";
1408
1409    # if ($invoked ne get_full_path(query_filename('shepherd','application')))
1410    # {
1411    #   print "You may safely delete $invoked.\n\n";
1412    # }
1413
1414    unless (ask_boolean("\nGrab data now?"))
1415    {
1416        exit 0;
1417    }
1418}
1419
1420sub get_channels
1421{
1422    my @date = localtime;
1423    my $page = fetch_file(
1424        "http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1425        ($date[5] + 1900) . "-$date[4]-$date[3]");
1426    my @channellist;
1427    while ($page =~ /<tr class=rtb><td class=rth><a .*?>(.*?)<\/a>/g)
1428    {
1429        push @channellist, $1;
1430    }
1431    return @channellist;
1432}
1433
1434# -----------------------------------------
1435# Subs: Status & Help
1436# -----------------------------------------
1437
1438sub show_config
1439{
1440    &log("\nConfiguration\n".
1441         "-------------\n" .
1442         "Config file: $config_file\n" .
1443         "Debug mode : " . is_set($debug) . "\n" .
1444         "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1445         "Region ID  : $region\n");
1446    show_channels();
1447    &log("\n");
1448    status();
1449    &log("\n");
1450}
1451
1452sub show_channels
1453{
1454    &log("Subscribed channels:\n");
1455    &log("    $_ -> $channels->{$_}\n") for sort keys %$channels;
1456    &log("Optional (HDTV) channels:\n");
1457    &log("    $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
1458}
1459
1460sub is_set
1461{
1462    my $arg = shift;
1463    return $arg ? "Yes" : "No";
1464}
1465
1466sub pretty_print
1467{
1468    my ($p, $len) = @_;
1469    my $spaces = ' ' x (79-$len);
1470    my $ret = "";
1471
1472    while (length($p) > 0) {
1473        if (length($p) <= $len) {
1474            $ret .= $p;
1475            $p = "";
1476        } else {
1477            # find a space to the left of cutoff
1478            my $len2 = $len;
1479            while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
1480                $len2--;
1481            }
1482            if ($len2 == 0) {
1483                # no space - just print it with cutoff
1484                $ret .= substr($p,0,$len);
1485                $p = substr($p,$len,(length($p)-$len));
1486            } else {
1487                # print up to space
1488                $ret .= substr($p,0,$len2);
1489                $p = substr($p,($len2+1),(length($p)-$len2+1));
1490            }
1491            # print whitespace
1492            $ret .= "\n".$spaces;
1493        }
1494    }
1495    return $ret;
1496}
1497
1498sub pretty_date
1499{
1500    my $t = shift;
1501
1502    return "-    " unless $t;
1503
1504    my @lt = localtime($t);
1505    my @ltnow = localtime();
1506    if (time - $t > 15768000)   # 6 months or older
1507    {
1508        return POSIX::strftime("%d-%b-%y", @lt);    # eg 18-Mar-05
1509    }
1510    if (time - $t < 43200       # less than 12 hours ago
1511            or
1512        ($lt[4] == $ltnow[4] and $lt[3] == $ltnow[3]))  # today
1513    {
1514        return POSIX::strftime("%l:%M%P ", @lt);    # eg 10:45pm
1515    }
1516    return POSIX::strftime("%a %d-%b", @lt);        # eg Mon 25-Dec
1517}
1518
1519sub desc
1520{
1521    my $lasttype = '';
1522    my %qual_table = ( 3 => "Excellent", 2 => "Good", 1 => "Poor" );
1523
1524    foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) 
1525    {
1526        if ($lasttype ne $components->{$_}->{type})
1527        {
1528            $lasttype = $components->{$_}->{type};
1529            &log("\n*** " . uc($lasttype) . "S ***\n");
1530        }
1531        &log("\n$_ v$components->{$_}->{ver}" .
1532             "\n* " . pretty_print(query_config($_, 'desc'), 77) . "\n");
1533        if ($lasttype eq 'grabber')
1534        {
1535            &log("* Data Quality: " . $qual_table{query_config($_, 'quality')} . "\n");
1536            &log("* Speed: " . (query_config($_, 'category') == 1 ? "Slow" : "Fast") . "\n");
1537            my $ch = query_config($_, 'channels');
1538            $ch = "All" if ($ch eq '');
1539            $ch = "All except $1" if ($ch =~ /^\-(.*)/);
1540            &log("* Channels: $ch\n");
1541            my $d1 = query_config($_, 'max_days');
1542            my $d2 = query_config($_, 'max_reliable_days');
1543            &log("* Days: " . ($d1 == $d2 ? $d1 : "$d2 to $d1") . "\n");
1544        }
1545    }
1546}
1547
1548sub status
1549{
1550    foreach my $ctype ('grabber', 'reconciler', 'postprocessor')
1551    {
1552        &log("\n " . 
1553             ($ctype eq 'grabber' ?
1554                "                         Enabled/\n".
1555                sprintf(" %-17s Version Ready  Last Run  Status", ucfirst($ctype)) 
1556                : ucfirst($ctype)) .
1557             "\n -------------- ---------- ----- ---------- -----------------------------------\n");
1558         foreach (sort (query_component_type($ctype)))
1559         {
1560             my $h = $components->{$_};
1561             &log(sprintf  " %-15s%10s  %1s/%1s %11s %s\n",
1562                  length($_) > 15 ? substr($_,0,13).".." : $_,
1563                  $h->{ver},
1564                  $h->{disabled} ? 'N' : 'Y',
1565                  $h->{ready} ? 'Y' : 'N',
1566                  pretty_date($h->{lastdata}),
1567                  $h->{laststatus} ? pretty_print($h->{laststatus},35) : '');
1568         }
1569     }
1570    &log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
1571}
1572
1573sub capabilities
1574{
1575    print "baseline\nmanualconfig\n";
1576    exit 0;
1577}
1578
1579sub description
1580{
1581    print "Australia\n";
1582    exit 0;
1583}
1584
1585sub help
1586{
1587    print q{Command-line options:
1588    --help                Display this message
1589    --version             Display version
1590    --status              Display status of various components
1591    --desc                Display detailed status of components
1592
1593    --configure           Setup
1594    --show-config         Display setup details
1595    --show-channels       Display subscribed channels
1596
1597    --disable <s>         Don't ever use grabber/postprocessor <s>
1598    --enable <s>          Okay, use it again then
1599    --uninstall <s>       Remove a disabled grabber/postprocessor
1600
1601    --noupdate            Don't update; just grab data
1602    --update              Update only; don't grab data
1603
1604    --update-version      Update major version
1605
1606    --check               Check status of all components, configure if necessary
1607    --pending             List pending installs, if any
1608
1609    --nonotify            Block reporting of anonymous usage statistics
1610
1611    --debug               Print lots of debugging messages
1612    --quiet               Don't print anything except errors
1613    --nolog               Don't write a logfile
1614
1615    --setmirror <s>       Set URL <s> as primary location to check for updates
1616    --setpreftitle <s>    Set preferred 'title' source as grabber <s>
1617    --clearpreftitle      Clear preferred 'title' source
1618    --reset               Remove all previous title translation data
1619};
1620    exit 0;
1621}
1622
1623
1624# -----------------------------------------
1625# Subs: override handlers for standard perl.
1626# -----------------------------------------
1627
1628# ugly hack. please don't try this at home kids!
1629sub my_die {
1630    my ($arg,@rest) = @_;
1631    my ($pack,$file,$line,$sub) = caller(0);
1632
1633    # check if we are in an eval()
1634    if ($^S) {
1635        printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
1636    } else {
1637            printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
1638            if ($arg) {
1639                CORE::die($arg,@rest);
1640            } else {
1641                CORE::die(join("",@rest));
1642            }
1643    }
1644}
1645
1646
1647# -----------------------------------------
1648# Subs: Grabbing
1649# -----------------------------------------
1650
1651sub grab_data
1652{
1653    my $used_grabbers = 0;
1654    &log("\nGrabber stage.\n");
1655
1656    &analyze_plugin_data("",1);   
1657
1658    while (my $grabber = choose_grabber())
1659    {
1660        $grabber_found_all_data = 0;
1661        $used_grabbers++;
1662
1663        &log("\nSHEPHERD: Using grabber: ($used_grabbers) $grabber\n");
1664
1665        my $output = "$CWD/grabbers/$grabber/output.xmltv";
1666
1667        my $comm = "$CWD/grabbers/$grabber/$grabber " .
1668                   "--region $region " .
1669                   "--output $output";
1670
1671        # Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
1672        # that we need. Category 2 grabbers are requested to get everything, since there's
1673        # very little cost in grabbing that extra data, and we can use it in the reconciler
1674        # to verify that everything looks OK.
1675        if (query_config($grabber, 'category') == 1)
1676        {
1677            &log("$grabber is Category 1: grabbing timeslice.\n") if ($debug);
1678
1679            record_requested_chandays($grabber, $timeslice);
1680
1681            if ($timeslice->{start} != 0)
1682            {
1683                $comm .= " " . 
1684                         query_config($grabber, 'option_days_offset') .
1685                         " " .
1686                         $timeslice->{start};
1687            }
1688
1689            my $n = $timeslice->{stop} + 1;
1690            if ($timeslice->{start} != 0 
1691                    and 
1692                !query_config($grabber, 'option_offset_eats_days'))
1693            {
1694                $n -= $timeslice->{start};
1695            }
1696            $comm .= " " .
1697                     query_config($grabber, 'option_days') .
1698                     " " . 
1699                     $n;
1700           
1701            # Write a temporary channels file specifying only the channels we want
1702            my $tmpchans;
1703            foreach (@{$timeslice->{chans}})
1704            {
1705                $tmpchans->{$_} = $channels->{$_};
1706            }
1707            my $tmpcf = "$CWD/channels.conf.tmp";
1708            write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
1709            $comm .= " --channels_file $tmpcf";
1710        }
1711        else
1712        {
1713            &log("$grabber is category 2: grabbing everything.\n") if ($debug);
1714            $comm .= " --days $days" if ($days);
1715            $comm .= " --offset $opt->{offset}" if ($opt->{offset});
1716            $comm .= " --channels_file $channels_file";
1717        }
1718
1719        if ((defined $plugin_data->{tor_pid}) &&
1720            (query_config($grabber, 'option_anon_socks'))) {
1721            $comm .= " ".query_config($grabber, 'option_anon_socks')." ".$plugin_data->{tor_address};
1722        }
1723
1724        $comm .= " --debug" if ($debug);
1725        $comm .= " @ARGV" if (@ARGV);
1726
1727        my $retval = 0;
1728        my $component_start = time;
1729        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
1730            &log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
1731            &log("SHEPHERD: would have called: $comm\n") if ($debug);
1732        } else {
1733            &log("SHEPHERD: Excuting command: $comm\n");
1734            chdir "$CWD/grabbers/$grabber/";
1735            $retval = call_prog($grabber,$comm,0,(query_config($grabber,'max_runtime')*60));
1736            chdir $CWD;
1737        }
1738        my $component_duration = time - $component_start;
1739
1740        if ($retval != 0) {
1741            &log("grabber returned with non-zero return code $retval: assuming it failed.\n");
1742            $components->{$grabber}->{laststatus} = "failed with return code $retval";
1743            $components->{$grabber}->{consecutive_failures}++;
1744            &add_pending_message($grabber,"FAIL", $retval, $component_start, $component_duration, 
1745                $components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
1746            next;
1747        }
1748
1749        # soak up the data we just collected
1750        &soak_up_data($grabber, $output, "grabber");
1751        $components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
1752
1753        if ($plugin_data->{$grabber}->{valid}) {
1754            $components->{$grabber}->{lastdata} = time;
1755            delete $components->{$grabber}->{consecutive_failures}
1756              if (defined $components->{$grabber}->{consecutive_failures});
1757            &add_pending_message($grabber,"SUCCESS", $retval, $component_start, $component_duration, 
1758                $components->{$grabber}->{ver});
1759        } else {
1760            $components->{$grabber}->{laststatus} = "failed (invalid XMLTV)";
1761            $components->{$grabber}->{consecutive_failures}++;
1762            &add_pending_message($grabber,"FAIL", 0, $component_start, $component_duration,
1763                $components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
1764        }
1765       
1766        # check to see if we have all the data we want
1767        $grabber_found_all_data = &analyze_plugin_data("analysis of all grabbers so far");
1768
1769        # Record what we grabbed from cacheable C1 grabbers
1770        if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
1771        {
1772            my $missing_before = convert_dayhash_to_list($missing);
1773            my $missing_after = convert_dayhash_to_list(detect_missing_data());
1774            my $list = List::Compare->new($missing_before, $missing_after);
1775            my @grabbed = $list->get_symmetric_difference();
1776            &log("Grabbed: " . join (', ', @grabbed) . ".\n") if ($debug);
1777            record_cached($grabber, @grabbed);
1778            write_config_file();
1779        }
1780
1781        last if ($grabber_found_all_data);
1782    }
1783
1784
1785    if ($used_grabbers == 0)
1786    {
1787        &log("No valid grabbers installed/enabled!\n");
1788        return;
1789    }
1790
1791    unless ($grabber_found_all_data)
1792    {
1793        &log("SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n");
1794        return;
1795    }
1796}
1797
1798# -----------------------------------------
1799# Subs: Intelli-random grabber selection
1800# -----------------------------------------
1801
1802sub choose_grabber
1803{
1804    if (defined $gscore)        # Reset score hash
1805    {
1806        foreach (keys %$gscore)
1807        {
1808            $gscore->{$_} = 0;
1809        }
1810    }
1811    else                        # Create score hash
1812    {
1813        foreach (query_grabbers())
1814        {
1815            unless ($components->{$_}->{disabled})
1816            {
1817                $gscore->{$_} = 0;
1818                if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
1819                {
1820                    $gscore->{$_ . ' [cache]'} = 0;
1821                }
1822            }
1823        }
1824    }
1825
1826    $missing = detect_missing_data();
1827    $timeslice = find_best_timeslice();
1828
1829    if ($debug)
1830    {
1831        &log((sprintf "Best timeslice: day%s of channels %s (%d chandays).\n",
1832                    ($timeslice->{start} == $timeslice->{stop} ?
1833                        " $timeslice->{start}" :
1834                        "s $timeslice->{start} - $timeslice->{stop}"),
1835                    join(', ', @{$timeslice->{chans}}),
1836                    $timeslice->{chandays}));
1837    }
1838
1839    my $total = score_grabbers();
1840 
1841    if ($debug)
1842    {
1843        &log("Grabber selection:\n");
1844        foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
1845        {
1846            next if ($_ =~ /\[cache\]/);
1847
1848            my $score  = $gscore->{$_};
1849            my $cscore = $gscore->{"$_ [cache]"};
1850            my $cstr   = $cscore ? "(inc. $cscore cache pts)" : "";
1851
1852            if ($opt->{randomize})
1853            {
1854                &log((sprintf "%15s %6.1f%% %9s %s\n", 
1855                        $_, 
1856                        ($total ? 100* $score / $total : 0), 
1857                        "$score pts",
1858                        $cstr));
1859            }
1860            else
1861            {
1862                &log(sprintf("%15s %4s pts %s\n", 
1863                        $_, 
1864                        $score,
1865                        $cstr));
1866            }
1867        }
1868    }
1869
1870    if ($opt->{grabwith})
1871    {
1872        my @a = split(/,/, $opt->{grabwith});
1873        my $g;
1874        while ($g = shift @a)
1875        {
1876            $opt->{grabwith} = (@a ? join(',', @a) : undef);
1877            &log("\nObeying --grabwith option: selecting grabber \"$g\".\n");
1878            if ($components->{$g} and $components->{$g}->{type} eq 'grabber')
1879            {
1880                return select_grabber($g, $gscore);
1881            }
1882            &log("Not a grabber: \"$g\".\n");
1883        }
1884    }
1885
1886    return undef unless ($total);
1887
1888    # If the user has specified a pref_title_source -- i.e. he is
1889    # transitioning from a known grabber -- then we make sure it
1890    # has run at least once, to build the list of title translations.
1891    if ($pref_title_source)
1892    {
1893        my @prefs = split(/,/, $pref_title_source);
1894        foreach my $grabber (@prefs)
1895        {
1896            unless ($components->{$grabber}->{lastdata})
1897            {
1898                &log("Need to build title translation list for transitional grabber $grabber.\n");
1899                return select_grabber($grabber, $gscore) if ($gscore->{$grabber});
1900                &log("WARNING: Can't run $grabber to build title translation list!\n");
1901            }
1902        }
1903    }
1904
1905    # If run with --randomize, then rather than always selecting the highest-scoring
1906    # grabber first we'll make a weighted random selection.
1907    if ($opt->{randomize})
1908    {
1909        my $r = int(rand($total));
1910        my $c = 0;
1911        foreach my $grabber (keys %$gscore)
1912        {
1913            next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
1914            if ($r >= $c and $r < ($c + $gscore->{$grabber}))
1915            {
1916                return select_grabber($grabber, $gscore);
1917            }
1918            $c += $gscore->{$grabber};
1919        }
1920        die "ERROR: failed to choose grabber.";
1921    }
1922
1923    # Choose grabber with best score. If there are multiple grabbers with the
1924    # best score, randomly select one of them.
1925    my @sorted = sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore;
1926    my @candidates = ( $sorted[0] );
1927    my $c = 1;
1928    while ($gscore->{$sorted[$c]} == $gscore->{$sorted[0]})
1929    {
1930        push @candidates, $sorted[$c] unless ($sorted[$c] =~ /\[cache\]/);
1931        $c++;
1932    }
1933    return select_grabber($candidates[0], $gscore) unless (@candidates > 1);
1934
1935    print "Multiple grabbers with best score: @candidates.\n" if ($debug);
1936    return select_grabber($candidates[int(rand(scalar(@candidates)))], $gscore);
1937}
1938
1939sub select_grabber
1940{
1941    my ($grabber, $gscore) = @_;
1942
1943    &log("Selected $grabber.\n") if ($debug);
1944    if (query_config($grabber, 'category') == 2)
1945    {
1946        # We might want to run C1 grabbers multiple times
1947        # to grab various timeslices, but not C2 grabbers,
1948        # which should get everything at once.
1949        delete $gscore->{$grabber};
1950    }
1951    return $grabber;
1952}
1953
1954# Grabbers earn 1 point for each slot or chanday they can fill.
1955# This score is multiplied if the grabber:
1956# * is a category 2 grabber (i.e. fast/cheap)
1957# * is a category 1 grabber that has the data we want in a cache
1958# * can supply high-quality data
1959# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
1960sub score_grabbers
1961{
1962    my ($score, $total, $day, $catbonus, $dqbonus, $mult, $key);
1963
1964    my $bestdq = 0;
1965
1966    # Compare C2 grabbers against the raw missing file, because we'll get
1967    # everything. But compare C1 grabbers against the timeslice, because we'll
1968    # only ask them for a slice. This goes for the [cache] and regular C1s.
1969    foreach my $grabber (keys %$gscore)
1970    {
1971        # for each slot, say whether we can fill it or not -- that is,
1972        # whether we support this channel and this day #.
1973
1974        my $hits = 0;
1975        my $cat = query_config($grabber, 'category');
1976        my $dq = query_config($grabber, 'quality');
1977
1978        if ($cat == 1)
1979        {
1980            $key = cut_down_missing($grabber);
1981            # &log("Grabber $grabber is Category 1: comparing capability to best timeslice.\n") if ($debug);
1982        }
1983        else
1984        {
1985            $key = $missing;
1986            # &log("Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n") if ($debug);
1987        }
1988
1989        if ($grabber =~ /\[cache\]/)
1990        {
1991            $hits = find_cache_hits($grabber, $key);
1992        }
1993        else
1994        {
1995            foreach my $day (sort keys %$key)
1996            {
1997                my $val = supports_day($grabber, $day);
1998                next unless ($val);
1999                # &log("Day $day:") if ($debug);
2000                foreach my $ch (@{$key->{$day}})
2001                {
2002                    if (supports_channel($grabber, $ch, $day))
2003                    {
2004                        # &log(" $ch") if ($debug);
2005                        $hits += $val;
2006                    }
2007                }
2008                # &log("\n") if $debug;
2009                $hits = 1 if ($hits > 0 and $hits < 1);
2010            }
2011        }
2012
2013        my $catbonus = 1;
2014        $catbonus = 3 if ($cat == 2);
2015        if ($grabber =~ /\[cache\]/)
2016        {
2017            # Bonus is on a sliding scale between 1 and 2 depending on
2018            # % of required data in cache
2019            $catbonus += $hits / $timeslice->{chandays};
2020        }
2021
2022        my $dqbonus = 2 ** ($dq-1);
2023
2024        my $mult = $dq ** $catbonus;
2025
2026        my $score = int($hits * $mult);
2027
2028        if ($debug)
2029        {
2030            my $str = sprintf "Grabber %s can supply %d chandays",
2031                                $grabber, $hits;
2032            if ($hits)
2033            {
2034                $str .= sprintf " at x%.1f (cat: %d, DQ: %d): %d pts",
2035                            $mult,
2036                            $cat,
2037                            $dq,
2038                            $score;
2039            }
2040            &log("$str.\n");
2041        }
2042
2043        if ($score and query_config($grabber, 'option_anon_socks') and !defined $plugin_data->{tor_pid}) 
2044        {
2045            &log("Grabber $grabber needs Tor to run efficiently: reducing score.\n") if ($debug);
2046            $score = int($score/10)+1;
2047        }
2048
2049        $gscore->{$grabber} += $score;
2050        $total += $score;
2051        if ($grabber =~ /\[cache\]/)
2052        {
2053            $gscore->{query_name($grabber)} += $score;
2054        }
2055
2056        if ($score and $dq > $bestdq)
2057        {
2058            $bestdq = $dq;
2059        }
2060    }
2061   
2062    # Eliminate grabbers of data quality 1 if there are any better-quality
2063    # alternatives. (Only need to do this with 'randomize' option, since otherwise
2064    # we will always pick the highest score.)
2065    if ($opt->{randomize})
2066    {
2067        foreach (keys %$gscore)
2068        {
2069            if (query_config($_, 'quality') == 1 and $bestdq > 1)
2070            {
2071                $total -= $gscore->{$_};
2072                $gscore->{$_} = 0;
2073                &log("Zeroing grabber $_ due to low data quality.\n") if ($debug);
2074            }
2075        }
2076    }
2077
2078    return $total;
2079}
2080
2081# Return 1 if the grabber can provide data for this channel, else 0.
2082sub supports_channel
2083{
2084    my ($grabber, $ch, $day) = @_;
2085
2086    my $mdpc = query_config($grabber, 'max_days_per_chan');
2087    if ($mdpc)
2088    {
2089        if ($mdpc->{$ch})
2090        {
2091            return ($mdpc->{$ch} > $day);
2092        }
2093    }
2094
2095    my $channels_supported = query_config($grabber, 'channels');
2096    unless (defined $channels_supported)
2097    {
2098        &log("WARNING: Grabber $grabber has no channel support " .
2099              "specified in config.\n");
2100        $channels_supported = '';
2101    }
2102
2103    return 1 unless ($channels_supported); # Empty string means we support all
2104   
2105    $ch =~ s/ /_/g;
2106    my $match = ($channels_supported =~ /\b$ch\b/);
2107    my $exceptions = ($channels_supported =~/^-/);
2108    return ($match != $exceptions);
2109}
2110
2111# Return 0 if the grabber can't provide data for this day,
2112# 1 if it can reliably, and 0.5 if it can unreliably.
2113#
2114# Note that a max_days of 7 means the grabber can retrieve data for
2115# today plus 6 days.
2116sub supports_day
2117{
2118    my ($grabber, $day) = @_;
2119
2120    return 0 unless ($day < query_config($grabber, 'max_days'));
2121    return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
2122    return 1;
2123}
2124
2125sub find_cache_hits
2126{
2127    my ($grabber, $key) = @_;
2128
2129    $grabber = query_name($grabber);
2130
2131    return 0 unless ($components->{$grabber}->{cached});
2132
2133    my $hits = 0;
2134
2135    foreach my $day (keys %$key)
2136    {
2137        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2138        foreach my $ch (@{$key->{$day}})
2139        {
2140            $hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
2141        }
2142    }
2143    return $hits;
2144}
2145
2146# Build a dayhash of what channel/day data we're currently missing.
2147# I think granularity of one day is good for now; could possibly be
2148# made more fine-grained if we think grabbers will support that.
2149sub detect_missing_data
2150{
2151    my $m = { };
2152
2153    my $chandays = 0;
2154    foreach my $ch (keys %$channels)
2155    {
2156        # is this channel missing too much data?
2157        unless ($channel_data->{$ch}->{analysis}->{data_ok}) {
2158            # not ok - record which days are bad
2159            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) {
2160                push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
2161            }
2162        }
2163    }
2164
2165    foreach my $day (keys %$m)
2166    {
2167        $m->{$day} = [ sort @{$m->{$day}} ];
2168        $chandays += scalar(@{$m->{$day}}) if ($debug);
2169    }
2170
2171    if ($debug)
2172    {
2173        &log("Need data for days " . join(", ", sort keys %$m) . 
2174             " ($chandays chandays).\n");
2175    }
2176    return $m;
2177}
2178
2179# Find the largest timeslice in the current $missing dayhash; i.e.
2180# something like "Days 4 - 6 of ABC and SBS." This works by iterating
2181# through the days and looking for overlaps where consecutive days
2182# want the same channels.
2183sub find_best_timeslice
2184{
2185    my ($overlap, $a);
2186    my $slice = { 'chandays' => 0 };
2187
2188    foreach my $day (0 .. $days-1)
2189    {
2190        consider_slice($slice, $day, $day, @{$missing->{$day}});
2191        $overlap = $missing->{$day};
2192        foreach my $nextday (($day + 1) .. $days-1)
2193        {
2194            last unless ($missing->{$nextday});
2195            $a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
2196            last unless ($a and @{$a});
2197            consider_slice($slice, $day, $nextday, @{$a});
2198            $overlap = $a;
2199        }
2200    }
2201    return $slice;
2202}
2203
2204sub consider_slice
2205{
2206    my ($slice, $startday, $stopday, @chans) = @_;
2207
2208    my $challenger = ($stopday - $startday + 1) * scalar(@chans);
2209    return unless ($challenger > $slice->{chandays});
2210
2211    # We have a winner!
2212    $slice->{start} = $startday;
2213    $slice->{stop} = $stopday;
2214    $slice->{chans} = [ @chans ];
2215    $slice->{chandays} = $challenger;
2216}
2217
2218# Record what a cacheable C1 grabber has just retrieved for us,
2219# so we know next time that this data can be grabbed quickly.
2220sub record_cached
2221{
2222    my ($grabber, @grabbed) = @_;
2223
2224    &log("Recording cache for grabber $grabber.\n") if ($debug);
2225
2226    my $gcache = $components->{$grabber}->{cached};
2227    $gcache = [ ] unless ($gcache);
2228    my @newcache;
2229    my $today = strftime("%Y%m%d", localtime);
2230
2231    # remove old chandays
2232    foreach my $chanday (@$gcache)
2233    {
2234        $chanday =~ /(\d+):(.*)/;
2235        if ($1 >= $today)
2236        {
2237            push (@newcache, $chanday);
2238        }
2239    }
2240
2241    # record new chandays
2242    foreach my $chanday (@grabbed)
2243    {
2244        push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
2245    }
2246    $components->{$grabber}->{cached} = [ @newcache ];
2247}
2248
2249# Takes a dayhash and returns it as a list like this:
2250# ( "20061018:ABC", "20061018:Seven", ... )
2251sub convert_dayhash_to_list
2252{
2253    my $h = shift;
2254
2255    my @ret;
2256    foreach my $day (keys %$h)
2257    {
2258        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2259        foreach my $ch (@{$h->{$day}})
2260        {
2261            push (@ret, "$date:$ch");
2262        }
2263    }
2264    @ret = sort @ret;
2265    return \@ret;
2266}
2267
2268# If we're about to re-try a grabber, make sure that we're not asking
2269# it for the same data. That is, prevent a broken C1 grabber causing
2270# an infinite loop.
2271sub record_requested_chandays
2272{
2273    my ($grabber, $slice) = @_;
2274
2275    &log("Recording timeslice request; will not request these chandays " .
2276         "from $grabber again.\n") if ($debug);
2277
2278    my @requested;
2279    for my $day ($slice->{start} .. $slice->{stop})
2280    {
2281        foreach my $ch (@{$slice->{chans}})
2282        {
2283            push @requested, "$day:$ch";
2284        }
2285    }
2286    if ($grabbed->{$grabber})
2287    {
2288        push @{$grabbed->{$grabber}}, @requested;
2289    }
2290    else
2291    {
2292        $grabbed->{$grabber} = [ @requested ];
2293    }
2294}
2295
2296# If this grabber has been called previously, remove those chandays
2297# from the current request -- we don't want to ask it over and over
2298# for a timeslice that it has already failed to provide.
2299sub cut_down_missing
2300{
2301    my $grabber = shift;
2302
2303    $grabber = query_name($grabber);
2304    my $dayhash = {};
2305
2306    # Take the timeslice and expand it to a dayhash, while pruning
2307    # any chandays that have previously been requested from this
2308    # grabber.
2309    foreach my $day ($timeslice->{start} .. $timeslice->{stop})
2310    {
2311        my @chans;
2312        foreach my $ch (@{$timeslice->{chans}})
2313        {
2314            unless ($grabbed->{$grabber} and grep(/$day:$ch/, @{$grabbed->{$grabber}}))
2315            {
2316                push (@chans, $ch)
2317            }
2318        }
2319        $dayhash->{$day} = [ @chans ] if (@chans);
2320    }
2321
2322    return $dayhash;
2323}
2324
2325# -----------------------------------------
2326# Subs: Analyzing data
2327# -----------------------------------------
2328
2329# interpret xmltv data from this grabber/postprocessor
2330sub soak_up_data
2331{
2332    my ($plugin, $output, $plugintype) = @_;
2333
2334    if (! -r $output) {
2335        &log("SHEPHERD: Warning: plugin '$plugin' output file '$output' does not exist\n");
2336        return;
2337    }
2338
2339    my $this_plugin = $plugin_data->{$plugin};
2340    &log("SHEPHERD: Started parsing XMLTV from '$plugin' in '$output' .. any errors below are from parser:\n");
2341    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
2342    &log("SHEPHERD: Completed XMLTV parsing from '$plugin'\n");
2343
2344    if (!($this_plugin->{xmltv})) {
2345        &log("WARNING: Plugin $plugin didn't seem to return any valid XMLTV!\n");
2346        return;
2347    }
2348
2349    $this_plugin->{valid} = 1;
2350    $this_plugin->{output_filename} = $output;
2351    $components_used .= " + ".$plugin."(v".$components->{$plugin}->{ver}.")";
2352
2353    my $xmltv = $this_plugin->{xmltv};
2354    my ($encoding, $credits, $chan, $progs) = @$xmltv;
2355    $this_plugin->{total_duration} = 0;
2356    $this_plugin->{programmes} = 0;
2357    $this_plugin->{progs_with_invalid_date} = 0;        # explicitly track unparsable dates
2358    $this_plugin->{progs_too_long} = 0;                 # explicitly track exxcessive programme durations
2359    $this_plugin->{progs_with_unknown_channel} = 0;     # explicitly track unknown channels
2360
2361    my $seen_channels_with_data = 0;
2362
2363    #
2364    # first iterate through all programmes and see if there are any channels we don't know about
2365    #
2366    my %chan_xml_list;
2367    foreach my $ch (sort keys %{$channels}) {
2368        $chan_xml_list{($channels->{$ch})} = 1;
2369    }
2370    foreach my $prog (@$progs) {
2371        if (!defined $chan_xml_list{($prog->{channel})}) {
2372            $this_plugin->{progs_with_unknown_channel}++;
2373            &log((sprintf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel}));
2374            $chan_xml_list{($prog->{channel})} = 1;     # so we warn only once
2375        }
2376    }
2377       
2378    # iterate thru channels
2379    foreach my $ch (sort keys %{$channels}) {
2380        my $seen_progs_on_this_channel = 0;
2381
2382        # iterate thru programmes per channel
2383        foreach my $prog (@$progs) {
2384            next if ($prog->{channel} ne $channels->{$ch});
2385
2386            my $t1 = &parse_xmltv_date($prog->{start});
2387            my $t2 = &parse_xmltv_date($prog->{stop});
2388
2389            if (!$t1 || !$t2) {
2390                &log((sprintf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
2391                    $plugin,(!$t1 ? $prog->{start} : $prog->{stop}))) if (!$this_plugin->{progs_with_invalid_date});
2392                $this_plugin->{progs_with_invalid_date}++;
2393                next;
2394            }
2395
2396            my $this_duration = $t2 - $t1;
2397            if ($this_duration > $policy{max_programme_length}) {
2398                &log((sprintf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
2399                    $plugin, int($policy{max_programme_length} / 3600),
2400                    int(($policy{max_programme_length} % 3600) / 60)))
2401                    if (!$this_plugin->{progs_too_long});
2402                $this_plugin->{progs_too_long}++;
2403                next;
2404            }
2405
2406            # store plugin-specific stats
2407            $this_plugin->{programmes}++;
2408            $this_plugin->{total_duration} += $this_duration;
2409            $seen_progs_on_this_channel++;
2410            $this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
2411            $this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
2412            $this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
2413            $this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
2414
2415            # store channel-specific stats
2416            $channel_data->{$ch}->{programmes}++;
2417            $channel_data->{$ch}->{total_duration} += $this_duration;
2418
2419            # programme is outside the timeslots we are interested in.
2420            next if ($t1 > $policy{endtime});
2421            next if ($t2 < $policy{starttime});
2422
2423            # store timeslot info
2424            my $start_slotnum = 0;
2425            $start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
2426                if ($t1 >= $policy{starttime});
2427
2428            my $end_slotnum = ($policy{num_timeslots}-1);
2429            $end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
2430                if ($t2 < $policy{endtime});
2431
2432            &log((sprintf "DEBUG: ch '%s' prog start '%s' stop '%s' storing into timeslots %d-%d (%s-%s)\n",
2433                $ch, $prog->{start}, $prog->{stop}, $start_slotnum, $end_slotnum,
2434                POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($start_slotnum * $policy{timeslot_size}))),
2435                POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($end_slotnum * $policy{timeslot_size})))))
2436                if $policy{timeslot_debug};
2437
2438            # add this programme into the global timeslots table for this channel
2439            foreach my $slotnum ($start_slotnum..$end_slotnum) {
2440                $channel_data->{$ch}->{timeslots}[$slotnum]++;
2441            }
2442        }
2443
2444        $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
2445    }
2446
2447    # print some stats about what we saw!
2448    &log((sprintf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
2449        ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
2450        int($this_plugin->{total_duration} / 86400),            # days
2451        int(($this_plugin->{total_duration} % 86400) / 3600),   # hours
2452        int(($this_plugin->{total_duration} % 3600) / 60),      # mins
2453        int($this_plugin->{total_duration} % 60),               # sec
2454        (defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
2455        (defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '')));
2456
2457    $this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
2458        $seen_channels_with_data, $this_plugin->{programmes},
2459        int($this_plugin->{total_duration} / 3600),
2460        (defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
2461        (defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
2462
2463    $plugin_data->{$plugin} = $this_plugin;
2464}
2465
2466
2467# analyze grabber data - do we have all the data we want?
2468sub analyze_plugin_data
2469{
2470    my ($analysistype,$quiet) = @_;
2471    &log("SHEPHERD: $analysistype:\n") unless $quiet;
2472
2473    my $total_channels = 0;
2474
2475    my $overall_data_ok = 1; # until proven otherwise
2476
2477    # iterate across each channel
2478    foreach my $ch (sort keys %{$channels}) {
2479        $total_channels++;
2480
2481        my $data;
2482        my $lastpol = "";
2483        $data->{data_ok} = 1; # unless proven otherwise
2484        $data->{have} = 0;
2485        $data->{missing} = 0;
2486
2487        for my $slotnum (0..($policy{num_timeslots}-1)) {
2488            my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
2489
2490            # work out day number of when this bucket is.
2491            # number from 0 onwards.  (i.e. today=0).
2492            # for a typical 7 day grabber this will actually mean 8 days of data (0-7)
2493            # with days 0 and 7 truncated to half-days
2494            my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
2495
2496            if (!defined $data->{day}->[$day]) {
2497                $data->{day}->[$day]->{num} = $day;
2498                $data->{day}->[$day]->{have} = 0;
2499                $data->{day}->[$day]->{missing} = 0;
2500                $data->{day}->[$day]->{missing_peak} = 0;
2501                $data->{day}->[$day]->{missing_nonpeak} = 0;
2502                $data->{day}->[$day]->{missing_other} = 0;
2503
2504                $data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
2505
2506                # day changed, dump any 'already_missing' data
2507                &dump_already_missing($data);
2508            }
2509
2510            # we have programming data for this bucket.  great!  process next bucket
2511            if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
2512                ($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) {
2513
2514                # if we have missing data queued up, push it now
2515                &dump_already_missing($data);
2516
2517                &dump_already_missing_period($data->{day}->[$day],$lastpol)
2518                  if ($lastpol ne "");
2519
2520                $data->{day}->[$day]->{have} += $policy{timeslot_size};
2521                $data->{have} += $policy{timeslot_size};
2522                next;
2523            }
2524
2525            # we don't have programming for this channel for this bucket
2526            &log((sprintf "DEBUG: missing timeslot data for ch '%s' bucket %d (%s)\n",
2527                $ch, $slotnum, POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($slotnum * $policy{timeslot_size})))))
2528                if $policy{timeslot_debug};
2529
2530            # some grabbers take HOURS to run. if this bucket (missing data) is for
2531            # a time period now in the past, then don't include it
2532            next if (($bucket_start_offset + $policy{starttime}) < time);
2533
2534            # work out the localtime of when this bucket is
2535            my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
2536
2537            # store details of where we are missing data
2538            if (!defined $data->{already_missing}) {
2539                $data->{already_missing} = sprintf "#%d/%02d:%02d",
2540                  $day,
2541                  int($bucket_seconds_offset / 3600),
2542                  int(($bucket_seconds_offset % 3600) / 60);
2543            }
2544            $data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
2545
2546            $data->{day}->[$day]->{missing} += $policy{timeslot_size};
2547            $data->{missing} += $policy{timeslot_size};
2548
2549            # work out what policy missing data for this bucket fits into
2550            my $pol;
2551            if (($bucket_seconds_offset >= $policy{peak_start}) &&
2552                (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
2553                $pol = "peak";
2554            } elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
2555                     (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
2556                $pol = "nonpeak";
2557            } else {
2558                $pol = "other";
2559            }
2560
2561            &dump_already_missing_period($data->{day}->[$day],$lastpol)
2562              if (($lastpol ne $pol) && ($lastpol ne ""));
2563
2564            $lastpol = $pol;
2565
2566            $data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
2567
2568            $data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
2569              if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
2570            $data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
2571
2572            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
2573            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
2574            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
2575            $data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
2576            $overall_data_ok = 0 if ($data->{data_ok} == 0);
2577        }
2578
2579        # finished all timeslots in this channel.
2580        # if we have missing data queued up, push it now
2581        &dump_already_missing($data);
2582
2583        # fill in any last missing period data
2584        foreach my $day (@{($data->{day})}) {
2585            &dump_already_missing_period($day,"peak");
2586            &dump_already_missing_period($day,"nonpeak");
2587            &dump_already_missing_period($day,"other");
2588        }
2589
2590        my $statusstring = sprintf " > ch %s: %s programming: %s\n", 
2591          $ch, pretty_duration($data->{have}),
2592          $data->{data_ok} ? "PASS (within thresholds)" : "FAIL, missing data over policy threshold:";
2593
2594        # display per-day missing data statistics
2595        foreach my $day (@{($data->{day})}) {
2596            unless ($day->{day_ok}) {
2597                $statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": ";
2598
2599                # do we have any data for this day?
2600                $statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
2601                  if (($day->{missing_peak}) && ($day->{missing_peak} > $policy{peak_max_missing}));
2602
2603                $statusstring .= sprintf "%snon-peak %s",
2604                  ($day->{missing_peak} ? " / " : ""),
2605                  join(", ",(@{($day->{missing_nonpeak_table})}))
2606                  if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak} > $policy{nonpeak_max_missing}));
2607
2608                $statusstring .= sprintf "%sother %s",
2609                  (($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
2610                  join(", ",(@{($day->{missing_other_table})}))
2611                  if (($day->{missing_other}) && ($day->{missing_other} > $policy{other_max_missing}));
2612
2613                $statusstring .= "\n";
2614            }
2615        }
2616        &log($statusstring) unless $quiet;
2617
2618        delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
2619        $channel_data->{$ch}->{analysis} = $data;
2620    }
2621
2622    &log((sprintf " > OVERALL: %s\n", ($overall_data_ok ? "PASS" : "FAIL"))) unless $quiet;
2623
2624    return $overall_data_ok; # return 1 for good, 0 for need more
2625}
2626
2627# helper routine for filling in 'missing_all' array
2628sub dump_already_missing
2629{
2630    my $d = shift;
2631    if (defined $d->{already_missing}) {
2632        $d->{already_missing} .= sprintf "-%02d:%02d",
2633          int($d->{already_missing_last} / 3600),
2634          int(($d->{already_missing_last} % 3600) / 60)
2635          if (defined $d->{already_missing_last});
2636        push(@{($d->{missing_all})}, $d->{already_missing});
2637        delete $d->{already_missing};
2638        delete $d->{already_missing_last};
2639    }
2640}
2641
2642# helper routine for filling in per-day missing data
2643# specific to peak/nonpeak/other
2644sub dump_already_missing_period
2645{
2646    my ($d,$p) = @_;
2647    my $startvar = "already_missing_".$p."_start";
2648    my $stopvar = "already_missing_".$p."_stop";
2649
2650    if (defined $d->{$startvar}) {
2651        push(@{($d->{"missing_".$p."_table"})},
2652          sprintf "%02d:%02d-%02d:%02d",
2653            int($d->{$startvar} / 3600),
2654            int(($d->{$startvar} % 3600) / 60),
2655            int($d->{$stopvar} / 3600),
2656            int(($d->{$stopvar} % 3600) / 60));
2657        delete $d->{$startvar};
2658        delete $d->{$stopvar};
2659    }
2660}
2661
2662# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
2663# and indication of whether the duration is over its threshold or not
2664sub pretty_duration
2665{
2666    my ($d,$crit) = @_;
2667    my $s = "";
2668    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
2669    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if (($d % (60*60*24)) >= (60*60));
2670    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if (($d % (60*60)) >= 60);
2671    $s .= "no" if ($s eq "");
2672
2673    if (defined $crit) {
2674        $s .= "[!]" if ($d > $crit);
2675    }
2676    return $s;
2677}
2678
2679# work out date range we are expecting data to be in
2680sub calc_date_range
2681{
2682
2683    $policy{starttime} = time;
2684
2685    # set endtime as per $days less 1 day + hours left today
2686    $policy{endtime} = $policy{starttime} + ((60*60*24)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
2687
2688    # normalize starttime to beginning of next bucket
2689    $policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
2690
2691    # work out how many seconds into a day our first bucket starts
2692    $policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
2693
2694    # normalize endtime to end of previous bucket
2695    $policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
2696
2697    # if we are working with an --offset, apply it now.
2698    $policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
2699
2700    # work out number of buckets
2701    $policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
2702
2703    &log((sprintf "DEBUG: policy settings: starttime=%d, endtime=%d, first_bucket_offset=%d, gmt_offset=%d, strftime_tz=%s\n",
2704        $policy{starttime}, $policy{endtime}, $policy{first_bucket_offset}, $gmt_offset,
2705        (strftime("%z", localtime(time)))))
2706        if ($policy{timeslot_debug});
2707}
2708
2709sub calc_gmt_offset
2710{
2711    # work out GMT offset - we only do this once
2712    if (!$gmt_offset) {
2713        # work out our gmt offset
2714        my $tzstring = strftime("%z", localtime(time));
2715
2716        $gmt_offset = (60*60) * int(substr($tzstring,1,2));     # hr
2717        $gmt_offset += (60 * int(substr($tzstring,3,2)));       # min
2718        $gmt_offset *= -1 if (substr($tzstring,0,1) eq "-");    # +/-
2719    }
2720}
2721
2722# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
2723# rather than the various other perl implementation which treat it as being in UTC/GMT
2724sub parse_xmltv_date
2725{
2726    my $datestring = shift;
2727    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
2728    my $tz_offset = 0;
2729
2730    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
2731        ($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);
2732        ($t[6],$t[7],$t[8]) = (-1,-1,-1);
2733
2734        # if input data has a timezone offset, then offset by that
2735        if ($datestring =~ /\+(\d{2})(\d{2})/) {
2736            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
2737        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
2738            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
2739        }
2740
2741        my $e = mktime(@t);
2742        return ($e+$tz_offset) if ($e > 1);
2743    }
2744    return undef;
2745}
2746
2747# -----------------------------------------
2748# Subs: Reconciling data
2749# -----------------------------------------
2750
2751# for all the data we have, try to pick the best bits!
2752sub reconcile_data
2753{
2754    &log("\nReconciling data:\n\n");
2755
2756    my $num_grabbers = 0;
2757    my $input_files = "";
2758    my @input_file_list;
2759
2760    # when reconciling & postprocessing, increase the thresholds of how much
2761    # missing data we permit.
2762    # generally, if a postprocessor or reconciler breaks, it'll return
2763    # no data rather than 'most' data.
2764    $policy{peak_max_missing} *= 3;
2765    $policy{nonpeak_max_missing} *= 1.5;
2766    $policy{other_max_missing} *= 3;
2767
2768    &log("Preferred title preferences from '$pref_title_source'\n")
2769        if ((defined $pref_title_source) &&
2770            ($plugin_data->{$pref_title_source}) &&
2771            ($plugin_data->{$pref_title_source}->{valid}));
2772
2773    &log("Preference for whose data we prefer as follows:\n");
2774    foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
2775        if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
2776            $num_grabbers++;
2777            &log((sprintf "  %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename}));
2778
2779            $input_files .= $plugin_data->{$proggy}->{output_filename}." ";
2780            push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
2781        }
2782    }
2783
2784    if ($num_grabbers == 0) {
2785        &log("ERROR! Nothing to reconcile! No valid grabber data!\n");
2786        return;
2787    }
2788
2789    foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
2790        next if ($components->{$reconciler}->{disabled});
2791        next if (!$components->{$reconciler}->{ready});
2792
2793        $reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
2794
2795        if ((!$reconciler_found_all_data) && ($grabber_found_all_data)) {
2796            # urgh.  this reconciler did a bad bad thing ...
2797            &log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
2798        } else {
2799            &log("SHEPHERD: Data from reconciler $reconciler looks good\n");
2800            $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
2801        }
2802
2803        last if ($input_postprocess_file ne "");
2804    }
2805
2806    if ($input_postprocess_file eq "") {
2807        # no reconcilers worked!!
2808        &log("SHEPHERD: WARNING: No reconcilers seemed to work!  Falling back to concatenating the data together!\n");
2809
2810        my %w_args = ();
2811        $input_postprocess_file = "$CWD/input_preprocess.xmltv";
2812        my $fh = new IO::File ">$input_postprocess_file" || die "could not open $input_postprocess_file for writing: $!\n";
2813        %w_args = (OUTPUT => $fh);
2814        XMLTV::catfiles(\%w_args, @input_file_list);
2815    }
2816}
2817
2818
2819# -----------------------------------------
2820# Subs: Postprocessing
2821# -----------------------------------------
2822
2823sub postprocess_data
2824{
2825    # for our first postprocessor, we feed it ALL of the XMLTV files we have
2826    # as each postprocessor runs, we feed in the output from the previous one
2827    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
2828    # reverts back to the previous postprocessor if it was shown to be bad
2829
2830    # first time around: feed in reconciled data ($input_postprocess_file)
2831
2832    &log("\nPostprocessing stage:\n");
2833
2834    foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
2835        next if ($components->{$postprocessor}->{disabled});
2836        next if (!$components->{$postprocessor}->{ready});
2837
2838        my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
2839
2840        if ($found_all_data) {
2841            # accept what this postprocessor did to our output ...
2842            &log("SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n");
2843            $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
2844            delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
2845            next;
2846        }
2847
2848        # urgh.  this postprocessor did a bad bad thing ...
2849        &log("SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n");
2850
2851        if (defined $components->{$postprocessor}->{conescutive_failures}) {
2852            $components->{$postprocessor}->{conescutive_failures}++;
2853        } else {
2854            $components->{$postprocessor}->{conescutive_failures} = 1;
2855        }
2856    }
2857}
2858
2859
2860# -----------------------------------------
2861# Subs: Postprocessing/Reconciler helpers
2862# -----------------------------------------
2863
2864sub call_data_processor
2865{
2866    my ($data_processor_type, $data_processor_name, $input_files) = @_;
2867
2868    &log("\nSHEPHERD: Using $data_processor_type: $data_processor_name\n");
2869
2870    my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
2871    my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
2872    $comm .= " --region $region" .
2873             " --channels_file $channels_file" .
2874             " --output $output";
2875    $comm .= " --days $days" if ($days);
2876    $comm .= " --offset $opt->{offset}" if ($opt->{offset});
2877    $comm .= " --debug" if ($debug);
2878    $comm .= " @ARGV" if (@ARGV);
2879
2880    $comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
2881      if (($data_processor_type eq "reconciler") &&
2882          (defined $pref_title_source) &&
2883          ($plugin_data->{$pref_title_source}) &&
2884          ($plugin_data->{$pref_title_source}->{valid}));
2885
2886    $comm .= " $input_files";
2887    &log("SHEPHERD: Excuting command: $comm\n");
2888
2889    my $component_start = time;
2890    my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
2891    chdir $dir;
2892    my $retval = call_prog($data_processor_name,$comm,0,(query_config($data_processor_name,'max_runtime')*60));
2893    chdir $CWD;
2894    my $component_duration = time - $component_start;
2895
2896    if ($retval != 0) {
2897        &log("$data_processor_type returned with non-zero return code $retval: assuming it failed.\n");
2898        $components->{$data_processor_name}->{laststatus} = "failed with return code $retval";
2899        $components->{$data_processor_name}->{consecutive_failures}++;
2900        &add_pending_message($data_processor_name,"FAIL", $retval, $component_start, $component_duration,
2901            $components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
2902        return 0;
2903    }
2904
2905    #
2906    # soak up the data we just collected and check it
2907    # YES - these are the SAME routines we used in the previous 'grabber' phase
2908    # but the difference here is that we clear out our 'channel_data' beforehand
2909    # so we can independently analyze the impact of this postprocessor.
2910    # if it clearly returns bad data, don't use that data (go back one step) and
2911    # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
2912    #
2913
2914    # clear out channel_data
2915    foreach my $ch (keys %{$channels}) {
2916        delete $channel_data->{$ch};
2917    }
2918
2919    # process and analyze it!
2920    &soak_up_data($data_processor_name, $output, $data_processor_type);
2921    my $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name");
2922
2923    if ($have_all_data) {
2924        $components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
2925        $components->{$data_processor_name}->{lastdata} = time;
2926        delete $components->{$data_processor_name}->{consecutive_failures}
2927          if (defined $components->{$data_processor_name}->{consecutive_failures});
2928        &add_pending_message($data_processor_name,"SUCCESS", $retval, $component_start, $component_duration,
2929            $components->{$data_processor_name}->{ver});
2930    } else {
2931        $components->{$data_processor_name}->{laststatus} = "missing data: ".$plugin_data->{$data_processor_name}->{laststatus};
2932        $components->{$data_processor_name}->{consecutive_failures}++;
2933        &add_pending_message($data_processor_name,"FAIL", $retval, $component_start, $component_duration,
2934            $components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
2935    }
2936
2937    return $have_all_data;
2938}
2939
2940
2941sub output_data
2942{
2943    # $input_postprocess_file contains our final output
2944    # send it to whereever --output told us to!
2945
2946    my $output_filename = "$CWD/output.xmltv";
2947    $output_filename = $opt->{output} if ($opt->{output});
2948
2949    my %writer_args = ( encoding => 'ISO-8859-1' );
2950    my $fh = new IO::File(">$output_filename") ||
2951      die "can't open $output_filename for writing: $!";
2952    $writer_args{OUTPUT} = $fh;
2953
2954    $writer = new XMLTV::Writer(%writer_args);
2955    $writer->start( {
2956        'source-info-name' => "$progname v".$components->{$progname}->{ver},
2957        'generator-info-name' => $components_used } );
2958
2959    XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb, 
2960        \&output_data_programme_cb, $input_postprocess_file);
2961    $writer->end();
2962
2963    &log("Final output stored in $output_filename.\n");
2964}
2965
2966sub output_data_channel_cb
2967{
2968    my $c = shift;
2969    $writer->write_channel($c);
2970}
2971
2972sub output_data_programme_cb
2973{
2974    my $prog=shift;
2975    $writer->write_programme($prog);
2976}
2977
2978# -----------------------------------------
2979# Subs: Tor support
2980# -----------------------------------------
2981
2982sub start_tor
2983{
2984    # do we have any components requesting the use of tor?
2985    my $want_tor = 0;
2986    foreach (query_grabbers()) {
2987        unless ($components->{$_}->{disabled}) {
2988            $want_tor++ if (query_config($_, 'option_anon_socks'));
2989        }
2990    }
2991
2992    return if ($want_tor == 0);
2993
2994    # try to find tor
2995    my $searchpath = ".:/usr/sbin:".$ENV{PATH};
2996    my $found_tor;
2997    foreach my $dir (split(/:/,$searchpath)) {
2998        if ((-x "$dir/tor") && (-f "$dir/tor")) {
2999            $found_tor = "$dir/tor";
3000            last;
3001        }
3002    }
3003
3004    if (!defined $found_tor) {
3005        &log("\nWARNING: $want_tor components wanted to use Tor but could not find it.\n");
3006        &log("This may cause data collection to run slower than it otherwise would.\n");
3007        return;
3008    }
3009
3010    # we'll run our own local copy of Tor exclusively for shepherd
3011    my $tordir = $CWD."/tor";
3012    if (!-d $tordir) {
3013        if (!mkdir $tordir) {
3014            &log("\nWARNING: Could not create $tordir, Tor not started!\n");
3015            &log("This may cause data collection to run slower than it otherwise would.\n");
3016            return;
3017        }
3018    }
3019
3020    &log("\nStarting Tor ($found_tor) in the background (wanted by $want_tor components).\n");
3021    my $pid = fork;
3022    if (!defined $pid) {
3023        # failed
3024        &log("Failed to start $found_tor: $!\n");
3025        return;
3026    } elsif ($pid > 0) {
3027        # parent
3028        sleep 2; # wait a few seconds for Tor to start
3029
3030        # test that it is running
3031        if (!kill 0, $pid) {
3032            &log("Tor doesn't seem to be running on pid $pid anymore, ignoring Tor option.\n");
3033        } else {
3034            &log("Tor appears to have successfully started (pid $pid).\n");
3035            $plugin_data->{tor_address} = "127.0.0.1:9051";
3036            $plugin_data->{tor_pid} = $pid;
3037        }
3038    } else {
3039        # child
3040        exec $found_tor "DataDirectory $tordir MaxCircuitDirtiness 30 SocksListenAddress 127.0.0.1:9051";
3041        exit(1); # we won't reach this
3042    }
3043}
3044
3045
3046sub stop_tor
3047{
3048    if (defined $plugin_data->{tor_pid}) {
3049        # INTR sig stops tor
3050        kill 2,$plugin_data->{tor_pid};
3051    }
3052}
Note: See TracBrowser for help on using the browser.