source: trunk/applications/shepherd @ 1471

Last change on this file since 1471 was 1471, checked in by mbarry, 5 years ago

shepherd: Even more help text during &require_module()

  • Property svn:executable set to *
File size: 153.3 KB
Line 
1#!/usr/bin/env perl
2
3our $progname = 'shepherd';
4my $version = '1.8.8';
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
27BEGIN { *CORE::GLOBAL::die = \&my_die; }
28
29use strict;
30no strict 'refs';
31use warnings;
32use lib 'references';
33
34# ---------------------------------------------------------------------------
35# --- required perl modules
36# ---------------------------------------------------------------------------
37
38our $wiki = 'http://svn.whuffy.com/wiki';
39
40&require_module("Cwd", qw(realpath));
41&require_module("LWP::UserAgent");
42&require_module("Getopt::Long");
43&require_module("Data::Dumper");
44&require_module("XMLTV");
45&require_module("XMLTV::Ask");
46&require_module("POSIX", qw(strftime mktime getcwd));
47&require_module("Compress::Zlib");
48&require_module("Date::Manip");
49&require_module("Algorithm::Diff");
50&require_module("List::Compare");
51&require_module("Digest::SHA");
52&require_module("Fcntl");
53our $have_Sort_Versions = &soft_require_module("Sort::Versions");
54
55# ---------------------------------------------------------------------------
56# --- Global Variables
57# ---------------------------------------------------------------------------
58#
59# Shared with libraries:
60#
61
62our $CWD = &find_home;
63-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
64chdir($CWD);
65
66our $opt = {};
67our $debug = 0;
68our $region;
69our $channels;
70our $opt_channels;
71our $components = { };
72our $want_paytv_channels;
73our $pref_title_source;
74my $last_successful_run;
75our $hd_to_sds;
76
77#
78# Not shared with libraries:
79#
80my $ARCHIVE_DIR = "$CWD/archive";
81my $LOG_DIR = "$CWD/log";
82
83my @options;
84my $mirror_site;    # obsolete
85my $sources;
86my $last_successful_run_data;
87my $last_successful_runs;
88my $components_pending_install = { };
89my $config_file =   "$CWD/$progname.conf";
90my $channels_file = "$CWD/channels.conf";
91my $log_file = "$progname.log";
92my $output_filename = "$CWD/output.xmltv";
93my $sysid = time.".".$$;
94my $pending_messages = { };
95my $starttime = time;
96my $any_data;
97my $lock;
98my $MAX_DAYS_HISTORY = 30;
99
100my $invoked = get_full_path($0);
101
102@{$hd_to_sds->{"ABC HD"}} = ("ABC1");
103@{$hd_to_sds->{"7HD"}} = ("Seven","Southern Cross","SCTV Central","Central GTS/BKN","Golden West");
104@{$hd_to_sds->{"Prime HD"}} = ("Prime");
105@{$hd_to_sds->{"Nine HD"}} = ("Nine","WIN","NBN","Imparja");
106@{$hd_to_sds->{"One HD"}} = ("One Digital");
107@{$hd_to_sds->{"SBS HD"}} = ("SBS ONE");
108
109
110# grabbing
111my $gscore;
112my $days = 8;
113my $missing;
114my $missing_unfillable;
115my $timeslice;
116my $grabbed;
117my $gmt_offset;
118my $data_found_all;
119my $data_satisfies_policy;
120my $find_microgaps;
121my $writer;
122my $components_used = $^O." ".$progname."(v".$version.")";
123
124# postprocessing
125my $langs = [ 'en' ];
126my $plugin_data = { };
127my $channel_data = { };
128my $reconciler_found_all_data;
129my $input_postprocess_file = "";
130
131# ---------------------------------------------------------------------------
132# --- Policies
133# ---------------------------------------------------------------------------
134# the following thresholds are used to control whether we keep calling grabbers or
135# not.
136
137my %policy;
138$policy{timeslot_size} = (2 * 60);      # 2 minute slots
139$policy{timeslot_debug} = 0;            # don't debug timeslot policy by default
140
141# PEAK timeslots -
142#  between 4.30pm and 10.30pm every day, only allow a maximum of
143#  15 minutes "programming data" missing
144#  if there is more than this, we will continue asking grabbers for more
145#  programming on this channel
146$policy{peak_max_missing} = 15*60;              # up to 15 mins max allowed missing
147$policy{peak_start} = (16*(60*60))+(30*60);     # 4.30pm
148$policy{peak_stop} = (22*(60*60))+(30*60);      # 10.30pm
149
150# NON-PEAK timeslots -
151#  between midnight and 7.15am every day, only allow up to 6 hours missing
152#  if there is more than this, we will continue asking grabbers for more
153#  programming on this channel
154$policy{nonpeak_max_missing} = 7*(60*60);       # up to 7 hours can be missing
155$policy{nonpeak_start} = 0;                     # midnight
156$policy{nonpeak_stop} = (7*(60*60))+(15*60);    # 7.15am
157
158# all other timeslots - (7.15am-4.30pm, 10.30pm-midnight)
159#  allow up to 60 minutes maximum missing programming
160$policy{other_max_missing} = 3*60*60;           # up to 3 hrs max allowed missing
161
162# don't accept programmes that last for longer than 12 hours.
163$policy{max_programme_length} = (12 * 60 * 60);  # 12 hours
164$policy{max_programme_length_opt_channels} = (18 * 60 * 60); # 18 hours
165
166
167# ---------------------------------------------------------------------------
168# --- Setup
169# ---------------------------------------------------------------------------
170
171&get_command_line_options(1);
172
173&capabilities if ($opt->{capabilities});
174&preferredmethod if ($opt->{preferredmethod});
175&description if ($opt->{description});
176
177$| = 1; 
178print STDERR "$progname v$version ($^O)\n\n" unless ($opt->{quiet});
179
180exit if ($opt->{version});
181&help if ($opt->{help});
182&dev_help if ($opt->{'dev-help'});
183
184&check_user;
185&invoke_correctly;
186&read_config_file;
187&check_region;
188&read_channels_file;
189&check_channels unless ($opt->{configure});
190&check_lock;
191&process_setup_commands;
192
193unless ($lock)
194{
195    print STDERR "ERROR: Another instance of Shepherd is already running. Exiting.\n";
196    exit 33;
197}
198
199&get_command_line_options(0) if (defined $components->{$progname}->{default_cmdline});
200
201&open_logfile unless ($opt->{nolog} or $opt->{update} or $opt->{configure});
202
203# ---------------------------------------------------------------------------
204# --- Update
205# ---------------------------------------------------------------------------
206
207if (!$opt->{skipupdate} and &update())
208{
209    &write_config_file;
210}
211
212if ($opt->{configure})
213{
214    &configure;
215}
216
217# ---------------------------------------------------------------------------
218# --- Go!
219# ---------------------------------------------------------------------------
220
221# If the previous run failed to complete, we'll have some pending stats:
222# deliver these.
223if (&report_stats)
224{
225    &write_config_file;
226}
227
228&test_output_file;
229
230unless ($opt->{update})
231{
232    if (defined $opt->{reoutput}) 
233    {
234        &log(2, "\nReturning cached output due to '--reoutput' flag.\n");
235        &output_data(1);
236        exit(0);
237    }
238
239    if (defined $opt->{'refill-mythtv'})
240    {
241        &refill_mythtv;
242        exit(0);
243    }
244
245    if (defined $opt->{'reoutput-mythtv'})
246    {
247        &refill_mythtv(undef, 1);
248        exit(0);
249    }
250
251    &check_last_run;
252    &calc_gmt_offset;
253    &commence_stats;
254    &calc_date_range;
255    &start_tor;
256
257    &grab_data("standard");
258
259    &grab_data("paytv") if (defined $want_paytv_channels);
260
261    &grab_data("expanded");     # Use C2 grabbers to fill missing sub-titles
262
263    $any_data = &reconcile_data;
264    if ($any_data)
265    {
266        &postprocess_data unless ($opt->{skippost});
267        &output_data;
268        &finalize_stats;
269        &report_stats;
270        &describe_components_used;
271    }
272    else
273    {
274        &no_data;
275    }
276    &write_config_file;
277    &stop_tor;
278
279    if (defined $opt->{'refresh-mythtv'})
280    {
281        &refill_mythtv(1);
282    }
283}
284
285&log("Done.\n");
286&close_logfile() unless $opt->{nolog};
287
288exit (!$any_data);
289
290# ---------------------------------------------------------------------------
291# --- Subroutines
292# ---------------------------------------------------------------------------
293
294# -----------------------------------------
295# Subs: Updates & Installations
296# -----------------------------------------
297
298sub update
299{
300    my $made_changes = 0;
301
302    &log("\nChecking for updates:\n");
303
304    # Sources
305    #
306    # Sources are where Shepherd looks for updates. Users can specify
307    # new sources as mirrors in case Shepherd's default source becomes
308    # unavailable, or for additional, unofficial functionality.
309
310    my (%datalist, %network_errors);
311    my $count = 0;
312    foreach my $site (@$sources)
313    {
314        $count++;
315        &log("Source #$count: $site\n");
316        my $data = fetch_file($site . 'status.csum?', undef, 1);
317        if ((!$data) || (!($data =~ /\nEND\n/)))
318        {
319            &log(0, "Locking components owned by source $site due to network error.\n");
320            $network_errors{$site} = 1;
321            next;
322        }
323        my @source_components;
324        while ($data =~ /(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/g)
325        {
326            my ($progtype, $proggy, $latestversion, $csum1, $csum2) = ($1,$2,$3,$4,$5);
327            if ($datalist{$proggy})
328            {
329                &log(1, "Preferring previous source for $progtype $proggy\n");
330            }
331            else
332            {
333                $datalist{$proggy} = { progtype => $progtype, 
334                                       latestversion => $latestversion,
335                                       csum1 => $csum1,
336                                       csum2 => $csum2,
337                                       source => $site
338                                   };
339                push @source_components, $proggy;
340            }
341
342        }
343        &log(1, "Source #$count has " . scalar(@source_components) . " components (" .
344                join(', ', @source_components) . ")\n");
345    }
346
347    unless (keys %datalist)
348    {
349        &log("Skipping update.\n");
350        return 0;
351    }
352
353    &log("\n");
354
355    my %clist = %$components;
356
357    foreach my $stage (qw( application reference grabber reconciler postprocessor ))
358    {
359        foreach my $c (keys %datalist)
360        {
361            my $proggy = $datalist{$c};
362            next unless ($proggy->{progtype} eq $stage);
363            if ($components->{$c} and $components->{$c}->{source} and $components->{$c}->{source} ne $proggy->{source} and $network_errors{$components->{$c}->{source}} and 1) # /* the unavailable source is preferred */)
364            {
365                $proggy->{source} = $components->{$c}->{source};
366                $proggy->{csum1} = 'locked';
367            }
368            if (update_component($c, $proggy->{source}, $proggy->{latestversion}, $stage, $proggy->{csum1}, $proggy->{csum2}))
369            {
370                $made_changes++;
371            }
372            delete $clist{$c};
373        }
374    }
375
376    # if user has set system to not update, then simply tell them if there are updates
377    if ((defined $opt->{noupdate}) && ($made_changes)) {
378        &log(2,"\n$made_changes components with pending updates, but --noupdate specified.\n".
379               "It is recommended that you manually run --update at your earliest convenience,\n".
380                "as these updates may be for critical bugfixes!\n\n");
381        &countdown(20);
382        return 0;
383    }
384
385    # work out what components disappeared (if any)
386    foreach (keys %clist) {
387        unless ($components->{$_}->{disabled} or $network_errors{$components->{$_}->{source}}) {
388            &log("\nDeleted component: $_.\n");
389            disable($_, 2);
390            $made_changes++;
391        }
392    }
393    $made_changes;
394}
395
396sub update_component
397{
398    my ($proggy, $source, $latestversion, $progtype, $csum1, $csum2) = @_;
399
400    my $ver = 0;
401    $ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e query_filename($proggy,$progtype));
402
403    my ($result, $action, $component_csum);
404
405    if ($components->{$proggy} and $components->{$proggy}->{disabled} and $components->{$proggy}->{disabled} == 1)
406    {
407        $action = 'DISABLED BY USER';
408    }
409    elsif ($csum1 eq 'locked')
410    {
411        $action = 'SOURCE LOCKED';
412    }
413
414    unless ($action)
415    {
416        $result = &versioncmp($ver, $latestversion);
417
418        if (!defined $opt->{noupdate}) {
419            $action =  $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
420                       $result ==  1 ? "DOWNGRADING" :
421                                       "up to date";
422        } else {
423            $action =  $result == -1 ? ($ver ? "UPDATE AVAILABLE" : "NEW COMPONENT") :
424                       $result ==  1 ? "DOWNGRADE ADVISED" :
425                                       "up to date";
426        }
427    }
428
429    # if component is up-to-date, check it still works and isn't tainted (modified)
430    if (defined $result and $result == 0)
431    {
432        # check it still works
433        my $test_result = 1;
434        unless ($progtype eq 'application' 
435                or
436                ($progtype eq 'reference' and $proggy !~ /^Shepherd\/.*\.pm$/)) 
437        {
438            $test_result = test_proggy($proggy, $progtype, undef, 1);
439        }
440
441        if (!$test_result) 
442        {
443            # broken
444            $action = 'FAILED';
445            $plugin_data->{$proggy}->{failed_test} = 1;
446        } 
447        else 
448        {
449            # verify the component isn't tainted
450            $component_csum = csum_file(query_ldir($proggy, $progtype)."/".$proggy);
451            if ($component_csum ne $csum2) 
452            {
453                # tainted
454                $action = 'TAINTED';
455            }
456        }
457    }
458
459    &log(sprintf  "* %-54s%17s\n",
460                    ucfirst($progtype) . " $proggy" .
461                        ($ver ? " v$ver" : '') . 
462                        ($opt->{debug} ? ' [' . &shortsource($source) . ']' : '') .
463                        "...",
464                    $action);
465
466    if ($action eq 'FAILED')
467    {
468        &log(2,"  For details, run Shepherd with --check option.\n");
469    }
470    if ($action eq 'TAINTED')
471    {
472        &log(2,"\nWARNING: Component '$proggy' ($progtype) has been modified/tainted\n".
473               " -  expected checksum: $csum2\n".
474               " -  actual checksum:   $component_csum\n\n");
475
476        # are we running a manual update?
477        if ($opt->{update}) {
478            # yes - manually force the tainted module to be reinstalled
479            $result = -1;
480            &log("Forcing reinstall of $proggy due to existing component modified/tainted.\n".
481                 "If you DON'T wish this to happen CTRL-C now...\n");
482             &countdown(15);
483         } else {
484             # no - whinge about the tainted module
485             $plugin_data->{$proggy}->{tainted} = 1;
486             $plugin_data->{tainted} = 1;
487             $components_used .= "[tainted]" if ($proggy eq $progname);
488
489             &log(2,"Modifying Shepherd or its components is not recommended.  If you have added\n".
490                    "functionality in some way, why not contribute it back?  See the wiki at\n".
491                    "$wiki for details.\n\n".
492                    "If you wish to revert $proggy back to the standard module, run ".ucfirst($progname)."\n".
493                    "with --update manually.\n\n");
494             &countdown(10);
495             &log(2,"\n\n");
496         }
497     }
498
499    return $result if (defined $opt->{noupdate});
500
501    my $was_reenabled = 0;
502    # If this component was centrally disabled, re-enable it.
503    if ($components->{$proggy}->{'disabled'} and $components->{$proggy}->{'disabled'} == 2)
504    {
505        &log("Centrally disabled component \"$proggy\" is now available again.\n");
506        &enable($proggy, 2);
507        $was_reenabled = 1;
508    }
509
510    return $was_reenabled unless ($result);
511    install($proggy, $source, $latestversion, $progtype, $ver, $csum1, $csum2);
512    return 1;
513}
514
515sub csum_file
516{
517    my $file = shift;
518    my $sha1 = Digest::SHA->new();
519
520    open(F,"<$file") || return -1;
521    $sha1->addfile(*F);
522    close(F);
523    return $sha1->hexdigest;
524}
525
526sub shortsource
527{
528    my $source = shift;
529    ($source =~ /(.*):\/+w*\.*(.*?)\//) ? $2 : $source;
530}
531
532sub install
533{
534    my ($proggy, $source, $latestversion, $progtype, $oldver, $csum1, $csum2) = @_;
535
536    my $config;
537    my $rdir = "";
538    my $basedir = $CWD."/".$progtype."s";
539    my $ldir = query_ldir($proggy, $progtype);
540   
541    -d $basedir or mkdir $basedir or die "Cannot create directory $basedir: $!\n";
542    -d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!\n";
543    if ($proggy =~ m"(.*)/")
544    {
545        -d "$ldir/$1" or mkdir "$ldir/$1" or die "Cannot create directory $ldir/$1: $!\n";
546    }
547    my $newfile = "$ldir/$proggy-$latestversion";
548
549    $rdir = $progtype . 's';
550    my $rfile = $source . "$rdir/$proggy";
551
552    # have we previously downloaded it but haven't been able to install it
553    # (due to a failed test or failed dependencies or something like that)?
554    if ((-e "$newfile") && (-s "$newfile") && (defined $components_pending_install->{$proggy})) {
555        &log("Appear to have previously downloaded $proggy v$latestversion.\n");
556        $config = Data::Dumper->Dump([$components_pending_install->{$proggy}->{config}], ["config"]);
557    } else {
558        &log("Downloading $proggy v$latestversion.\n");
559        return unless (fetch_file($rfile.'?', $newfile, 1, undef, $csum2));
560
561        # Make component executable
562        chmod 0755,$newfile unless ($progtype eq 'reference');
563    }
564
565    # Fetch config file
566    $rfile .= ".conf";
567    $config = fetch_file($rfile.'?', undef, 1, undef, $csum1) if (!defined $config);
568
569    return unless ($config); # everyone MUST have config files
570
571    eval $config;
572    if ($@) {
573        &log("Config file $rfile was invalid, not updating this component: $@\n");
574        return;
575    }
576
577    if ($progtype eq 'reference' and $proggy !~ /^Shepherd\/.*\.pm$/)
578    {
579        $components->{$proggy}->{ready} = 1;
580    }
581    else
582    {
583        # test that the component works BEFORE we install it
584        my $ready_test = test_proggy("$proggy", $progtype, $latestversion);
585        if (!$ready_test) {
586            &log("$proggy v$latestversion failed ready test - marking as a pending update.\n");
587            $components_pending_install->{$proggy}->{config} = $config;
588            $components_pending_install->{$proggy}->{updated} = time;
589
590            if (defined $components->{$proggy}) {
591                $components->{$proggy}->{admin_status} = sprintf "update to version %s pending: %s",
592                    $latestversion, $components_pending_install->{$proggy}->{admin_status};
593            }
594
595            return;
596        }
597        $components->{$proggy}->{ready} = $ready_test;
598    }
599
600    -d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!\n";
601
602    rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy") if (-e "$ldir/$proggy");
603    rename($newfile, "$ldir/$proggy");
604   
605    &log(1, "Installed $proggy v$latestversion.\n");
606
607    $components->{$proggy}->{type} = $progtype;
608    $components->{$proggy}->{ver} = $latestversion;
609    $components->{$proggy}->{config} = $config;
610    $components->{$proggy}->{source} = $source;
611    $components->{$proggy}->{updated} = time;
612    $components->{$proggy}->{admin_status} = sprintf "updated from v%s to v%s", ($oldver or 0), $latestversion;
613    delete $components_pending_install->{$proggy} if (defined $components_pending_install->{$proggy});
614
615    # if the update was for the main app, restart it
616    if ($proggy eq $progname) {
617        &write_config_file;
618
619        # special case for main app - we create a symlink also
620        unlink("$CWD/tv_grab_au","$CWD/shepherd");
621        eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/tv_grab_au"); 1 };
622        eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/shepherd"); 1 };
623
624        &log("\n*** Restarting ***\n\n");
625        &close_logfile unless $opt->{nolog};
626        push(@options,"--quiet") if $opt->{quiet};
627        exec("$ldir/$proggy @options"); # this exits
628        exit(0);
629    }
630
631    # If the update was for the channel_list reference, re-check
632    # the validity of channels (and migrate if necessary). Otherwise we won't
633    # use the new data until next run.
634    &check_channels if ($proggy eq 'channel_list');
635}
636
637sub test_proggy
638{
639    my ($proggy, $progtype, $specific_version, $quiet) = @_;
640
641    &log("Testing $progtype $proggy ... ") unless ($quiet);
642
643    my $progname = query_filename($proggy, $progtype);
644    $progname .= "-".$specific_version if ((defined $specific_version) && ($specific_version ne ""));
645
646    my $exec;
647    if ($progtype eq 'reference')
648    {
649        $exec = "perl -e 'require \"$progname\";'";
650    }   
651    else
652    {
653        $exec = $progname . ' ' . (&query_config($proggy, 'option_ready') or '--version');
654    }
655 
656    &log(1, "\nExecuting: $exec\n") unless ($quiet);
657
658    my ($result,$resultmsg,$test_output) = call_prog($proggy, $exec,1,1,0, $progtype);
659    &log(1, "Return value: $result\n") unless ($quiet);
660
661    my $statusmsg;
662
663    if ($result)
664    {
665        unless ($quiet)
666        {
667            &log("FAIL.\n\n".ucfirst($progtype) . " $proggy did not exit cleanly!\n");
668
669            # can we give any more details on why it failed?
670            if ($test_output and $test_output =~ /Can't locate (.*) in \@INC/) 
671            {
672                my $modname = $1;
673                $modname =~ s#/#::#g;       # turn / into ::
674                $modname =~ s#\.pm##g;      # remove .pm suffix
675                $statusmsg = "Missing module \"$modname\"";
676
677                &log("Probably failed due to dependency on missing module '".$modname."'\n");
678            }
679            else
680            {
681                &log("It may require configuration.\n");
682            }
683
684            &log(sprintf("\n<<<<<< output from $proggy was as follows:\n%s>>>>>> end output from $proggy\n\n",$test_output));
685        }
686        # set proggy status accordingly
687        unless ($statusmsg)
688        {
689            $statusmsg = sprintf "return code %d%s", $result, ($resultmsg eq "" ? "" : ", '$resultmsg'");
690        }
691        $statusmsg = sprintf "FAILED (%s) on %s",
692                         $statusmsg,
693                         POSIX::strftime("%a%d%b%y", localtime(time));
694    }
695    else
696    {
697        &log("OK.\n") unless ($quiet);
698
699        # mark as successful but only if previously unsuccessful
700        # (we only mark it if it was previously unsuccessful otherwise a --check
701        # will result in clearing out all of the admin_status fields)
702        $statusmsg = sprintf "tested successfully on %s", POSIX::strftime("%a%d%b%y", localtime(time))
703          if ((defined $components->{$proggy}->{ready}) && (!$components->{$proggy}->{ready}));
704    }
705
706    # update status message
707    if ($statusmsg) {
708        if ($specific_version) {
709            $components_pending_install->{$proggy}->{admin_status} = $statusmsg;
710        } elsif (defined $components->{$proggy}) {
711            $components->{$proggy}->{admin_status} = $statusmsg;
712        }
713    }
714
715    return !$result;
716}
717
718sub enable
719{
720    return &enable_or_disable('enable', @_);
721}
722
723sub disable
724{
725    return &enable_or_disable('disable', @_);
726}
727
728sub enable_or_disable
729{
730    my ($which, $proggy, $n) = @_;
731
732    if ($proggy =~ /,/)
733    {
734        foreach (split(/,/, $proggy))
735        {
736            &enable_or_disable($which, $_, $n);
737        }
738        return;
739    }
740
741    if ($proggy eq 'all')
742    {
743        foreach (keys %$components)
744        {
745            next if ($_ eq $progname);
746            &enable_or_disable($which, $_, $n);
747        }
748        return;
749    }
750   
751    return unless ($which eq 'enable' or $which eq 'disable');
752
753    unless ($components->{$proggy}) 
754    {
755        &log("No such component: \"$proggy\".\n");
756        return;
757    }
758
759    if ($components->{$proggy}->{type} eq "application") 
760    {
761        &log("Can't $which component: \"$proggy\".\n");
762        return;
763    }
764
765    if (($which eq 'enable') == !$components->{$proggy}->{disabled})
766    {
767        &log("Already " . $which . "d: $proggy.\n");
768        return;
769    }
770    &log(ucfirst($which) . "d $proggy.\n");
771    if ($which eq 'enable')
772    {
773        delete $components->{$proggy}->{disabled};
774    }
775    else
776    {
777        $n ||= 1;
778        $components->{$proggy}->{disabled} = $n;
779    }
780    $components->{$proggy}->{admin_status} = sprintf "%s %s on %s", 
781                        (($n and $n == 2) ? 'centrally' : 'manually'),
782                        $which . 'd', 
783                        POSIX::strftime("%a%d%b%y", localtime(time));
784}
785
786sub check
787{
788    my $result;
789
790    &log("\nTesting all components...\n\n");
791
792    foreach my $proggy (sort keys %$components) {
793        my $progtype = $components->{$proggy}->{type};
794        if (!$progtype)
795        {
796            my $reason = $components->{$proggy}->{admin_status} || '';
797            printf "\n!!! %s: NOT INSTALLED! %s\n\n", $proggy, $reason;
798            next;
799        }
800        next if ($progtype eq 'application');
801        next if ($progtype eq 'reference' and $proggy !~ /^Shepherd\/.*\.pm$/);
802        next unless (defined $components->{$proggy}->{'type'});
803
804        my $try_count = 0;
805
806RETRY:
807        $try_count++;
808        $result = test_proggy($proggy, $components->{$proggy}->{type});
809        $components->{$proggy}->{ready} = $result;
810
811        if ((!$result) && ($try_count < 2) && (query_config($proggy, 'option_config'))) {
812            &log("Trying to configure '$proggy'\n");
813
814            call_prog($proggy, query_filename($proggy, $progtype) . " ". query_config($proggy, 'option_config'));
815
816            goto RETRY;
817        }
818    }
819
820    unless ($have_Sort_Versions)
821    {
822        &log("\n! Missing optional recommended module: Sort::Versions\n");
823        &log("! This may be required for full integration with MythTV.\n");
824    }
825
826    &test_tor;
827}
828
829sub pending
830{
831    return unless ($components_pending_install);
832
833    my @pending;
834    foreach (keys %$components_pending_install)
835    {
836        push @pending, $_;
837    }
838    unless (@pending)
839    {
840        &log("\nNo components are pending install.\n");
841        return;
842    }
843    &log("\nThe following components are pending install: " .
844        join(', ', @pending) . ".\n\n" .
845        "You may have missing Perl dependencies. To see errors,\n".
846        "run: $progname --update or $progname --check\n");
847
848    # Exit with non-zero status so this sub can be used to
849    # notify an external program (to email the owner, perhaps)
850    # about pending installs.
851    exit 1;
852}
853
854# Set this to a failure message as a default; if we complete successfully we'll change it.
855sub commence_stats
856{
857    &add_pending_message($progname, 'FAIL', $sysid, $starttime, 0, $region, 'incomplete');
858}
859
860sub finalize_stats
861{
862    delete $pending_messages->{$progname}->{FAIL};
863    &add_pending_message($progname, "SUCCESS", $sysid, $starttime, (time-$starttime), $region, $components_used);
864   
865    # Remove any MISSING_DATA from Shepherd we don't bother reporting.
866    if ($pending_messages->{$progname}->{MISSING_DATA})
867    {
868        # We don't care about Day 6 or later
869        my $stats_limit = $policy{starttime} - $policy{first_bucket_offset} + (6 * 86400);
870        &log(1, "SHEPHERD: Not reporting Shepherd missing data later than " . localtime($stats_limit) . ".\n");
871
872        $pending_messages->{$progname}->{MISSING_DATA} =~ s/(\d+)-(\d+)/$1 >= $stats_limit ? '' : "$1-$2"/eg;
873
874        # Clean up: drop duplicate commas, empty channel text
875        $pending_messages->{$progname}->{MISSING_DATA} =~ s/(?<!\d),+|,+(?!\d)//g;
876        $pending_messages->{$progname}->{MISSING_DATA} =~ s/[ \w]+:\t?(?!\d)//g;
877
878        # Anything left?
879        unless ($pending_messages->{$progname}->{MISSING_DATA} =~ /\d{6,}/)
880        {
881            delete $pending_messages->{$progname}->{MISSING_DATA};
882        }
883    }
884
885    unless ($opt->{dontcallgrabbers})
886    {
887        $last_successful_run = time;
888        my $total_wanted = $plugin_data->{$progname}->{total_duration} + $plugin_data->{$progname}->{total_missing};
889        $last_successful_run_data = ($total_wanted ? 100* $plugin_data->{$progname}->{total_duration} / $total_wanted : 0);
890
891        $last_successful_runs->{$last_successful_run} = $last_successful_run_data;
892    }
893}
894
895# If no grabbers returned data, don't report individual component failures but rather
896# an overall Shepherd failure.
897sub no_data
898{
899    $pending_messages = undef;
900    &add_pending_message($progname, 'FAIL', $sysid, $starttime, (time-$starttime), ($region or 0), 'no data');
901}
902
903# Report any pending stats to main server.
904sub report_stats
905{
906    my $postvars = build_stats();
907    return unless $postvars;
908
909    if ($opt->{nonotify} or $opt->{dontcallgrabbers})
910    {
911        &log("Not posting usage statistics due to --" . ($opt->{nonotify} ? 'nonotify' : 'dontcallgrabbers' ) . " option.\n");
912        &log("Would have posted: ".Dumper($pending_messages)) if ($debug);
913    }
914    else
915    {
916        &log("Posting anonymous usage statistics.\n");
917        return 0 unless (fetch_file("http://www.whuffy.com/report.cgi", undef, 1, $postvars));
918    }
919
920    # successful post, clear out our pending messages
921    $pending_messages = undef;
922
923    return 1; # made changes
924}
925
926# gather pending messages
927sub build_stats
928{
929    return unless (keys %$pending_messages);
930
931    my $postvars = "";
932    my %postmsgs;
933
934    # If Shepherd failed last run, just report that, not MISSING_DATA as well
935    # (since the fact that we're missing data is almost certainly due to the
936    # fact that we failed).
937    if ($pending_messages->{$progname}
938            and $pending_messages->{$progname}->{FAIL}
939            and $pending_messages->{$progname}->{MISSING_DATA})
940    {
941        delete $pending_messages->{$progname}->{MISSING_DATA};
942    }
943
944    foreach my $component (keys %$pending_messages) {
945        foreach my $msgtype ( 'SUCCESS', 'FAIL', 'stats', 'MISSING_DATA') {
946            if ($pending_messages->{$component}->{$msgtype}) {
947                $postmsgs{$component} .= urlify("\n".$component."\t") if (defined $postmsgs{$component});
948                $postmsgs{$component} .= urlify($msgtype."\t".$pending_messages->{$component}->{$msgtype});
949            }
950        }
951    }
952
953    # shepherd first
954    $postvars = "$progname=$postmsgs{$progname}";
955
956    # the rest
957    foreach my $component (sort keys %postmsgs) {
958        next if ($component eq $progname);
959        $postvars .= sprintf "%s%s=%s",
960                             (length($postvars) > 0 ? "&" : ""),
961                             $component, $postmsgs{$component};
962    }
963
964    return $postvars;
965}
966
967sub describe_components_used
968{
969    &log("\nComponent summary: $components_used\n\n");
970}
971
972# -----------------------------------------
973# Subs: Utilities
974# -----------------------------------------
975
976# versioncmp from Sort::Versions by Kenneth J. Albanowski
977#
978# We should really use the proper module, but we'll leave
979# the old copied code here for people who don't have it.
980#
981sub versioncmp( $$ )
982{
983    if ($have_Sort_Versions)
984    {
985        return &Sort::Versions::versioncmp(@_);
986    }
987
988    return -1 unless (@_ == 2 and $_[0] and $_[1]);
989
990    my @A = ($_[0] =~ /([-.]|\d+|[^-.\d]+)/g);
991    my @B = ($_[1] =~ /([-.]|\d+|[^-.\d]+)/g);
992
993    my ($A, $B);
994    while (@A and @B) {
995        $A = shift @A;
996        $B = shift @B;
997        if ($A eq '-' and $B eq '-') {
998            next;
999        } elsif ( $A eq '-' ) {
1000            return -1;
1001        } elsif ( $B eq '-') {
1002            return 1;
1003        } elsif ($A eq '.' and $B eq '.') {
1004            next;
1005        } elsif ( $A eq '.' ) {
1006            return -1;
1007        } elsif ( $B eq '.' ) {
1008            return 1;
1009        } elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
1010            if ($A =~ /^0/ || $B =~ /^0/) {
1011                return $A cmp $B if $A cmp $B;
1012            } else {
1013                return $A <=> $B if $A <=> $B;
1014            }
1015        } else {
1016            $A = uc $A;
1017            $B = uc $B;
1018            return $A cmp $B if $A cmp $B;
1019        }       
1020    }
1021    @A <=> @B;
1022}
1023
1024sub get_full_path
1025{
1026    my $path = shift;
1027    my $real = realpath($path);
1028    return $path if (!$real);
1029    return $real;
1030}
1031
1032sub require_module
1033{
1034    my ($mod, @imports) = @_;
1035
1036    my $modname = $mod.".pm";
1037    $modname =~ s/::/\//g;
1038
1039    eval { require $modname; };
1040    if ($@) {
1041        my $ubuntu_package_name = lc $mod;
1042        $ubuntu_package_name =~ s/::/-/g;
1043        &log("\n!!! ERROR: Mandatory module '$mod' not found.\n\n" .
1044             "    On Ubuntu distributions, you may be able to install\n" .
1045             "    this with the command:\n\n" .
1046             "    sudo apt-get install lib" . $ubuntu_package_name . "-perl\n\n" .
1047             "    Otherwise, try:\n" .
1048             "    sudo cpan " . $mod . "\n\n" .
1049             "For more help, see the Wiki at ".$wiki."/Installation\n", 1);
1050        exit(1);
1051    }
1052
1053    import $mod @imports;
1054}
1055
1056sub soft_require_module
1057{
1058    my ($mod, $flag_ref) = @_;
1059
1060    my $modname = $mod . ".pm";
1061    $modname =~ s/::/\//g;
1062
1063    eval { require $modname; };
1064    return 0 if ($@);   # Failed
1065    return 1;
1066}
1067
1068# check that user isn't root, warn them if they are!
1069sub check_user
1070{
1071    if ($< == 0) {
1072        &log(2, "WARNING:\n You are running ".ucfirst($progname).
1073                " as 'root' super-user.\n".
1074                " It is HIGHLY RECOMMENDED that you set your system to run ".
1075                ucfirst($progname)."\n from within a normal user account!\n\n", 1);
1076        &countdown(10);
1077    }
1078}
1079
1080sub invoke_correctly
1081{
1082    &log(1, "Home: $CWD\n");
1083    my $wanted_prog = get_full_path(query_filename('shepherd','application'));
1084    if (($invoked ne $wanted_prog) && (!$opt->{configure}))
1085    {
1086        if (-e $wanted_prog)
1087        {
1088            &log("\n*** Application/user mismatch ***\n".
1089                   "    You invoked: $invoked\n".
1090                   "    Instead of : $wanted_prog\n" .
1091                 "\n*** Restarting ***\n\n");
1092            &close_logfile unless $opt->{nolog};
1093            exec("$wanted_prog @options");
1094            # This exits.
1095            exit(0);
1096        }
1097
1098        &log("\n*** Installing Shepherd into $CWD ***\n\n" .
1099             "If this is not what you intend, CTRL-C now.\n");
1100        &countdown();
1101    }
1102}
1103
1104# if last run was successful and was less than 22 hours ago, refuse to run.
1105# there's really no point calling shepherd more frequently than this.
1106sub check_last_run
1107{
1108    return if (!defined $last_successful_run);
1109    my $last_ran_secs_ago = time - $last_successful_run;
1110
1111    &log(0,"\n".ucfirst($progname)." last ran successfully ".pretty_duration($last_ran_secs_ago)." ago.\n");
1112
1113    return if ($last_ran_secs_ago > (22*60*60));
1114    return if ($opt->{dontcallgrabbers});
1115
1116    # enforce hard limit
1117    my $num_runs = 0;
1118    my $earliest_run = time;
1119    foreach my $when (sort {$b <=> $a} keys %{$last_successful_runs}) {
1120        if (($when + (86400 * $MAX_DAYS_HISTORY)) < time) {
1121            delete $last_successful_runs->{$when}; # age out old entries
1122            next;
1123        }
1124
1125        if ($when >= (time - (86400*7))) {
1126            $num_runs++;
1127            $earliest_run = $when if ($num_runs == 30);
1128        }
1129    }
1130    if ($num_runs >= 30) {
1131        &log(2, "\n*** ERROR: EXTREME OVERUSE ***\n\n".
1132            "Shepherd has run to completion more than 30 times in the last 7 days!\n".
1133            "To avoid overloading datasources, Shepherd will now exit.\n\n".
1134            "PLEASE NOTE: There is usually NO BENEFIT in running Shepherd more than once\n".
1135            "per day. Overuse can lead to datasources becoming unavailable for all users.\n\n".
1136            "TO AVOID THIS ERROR: Please do not run Shepherd more than once or twice per\n".
1137            "day. Shepherd is now in a locked state. To unlock Shepherd, wait \n".
1138            pretty_duration((7*86400)-(time-$earliest_run)).
1139            ". Alternately, you may reinstall Shepherd.\n\n".
1140            "Please do not abuse Shepherd. All users depend on your courtesy.\n\n");
1141
1142        exit(10);
1143    }
1144
1145    if (defined $opt->{notimetest}) {
1146        &log(2, "\n** SPECIAL OPERATION **\n" .
1147                "Shepherd thinks it doesn't need to compile new data, as it\n" .
1148                "recently completed a successful run. Running anyway due to\n" .
1149                "--notimetest option. Please do NOT make a habit of this, as\n" .
1150                "it risks straining resources needed by all Shepherd users.\n\n");
1151        &countdown(10);
1152        return;
1153    }
1154
1155    &log("!! Shepherd has successfully completed a run less than 22 hours ago.\n" .
1156         "!! Exiting to avoid wasting time and bandwidth.\n\n");
1157
1158    if (defined $opt->{'refresh-mythtv'})
1159    {
1160        &log("Please try 'tv_grab_au --refill-mythtv' instead, to use cached data.\n");
1161    }
1162    else
1163    {
1164        &log("If you wish Shepherd to re-output the data it gathered last run,\n" .
1165         "use the --reoutput option (e.g. 'tv_grab_au --reoutput'). To do this\n" .
1166         "via mythfilldatabase, use 'mythfilldatabase -- --reoutput'. (Or,\n".
1167         "for older versions, 'mythfilldatabase --graboptions --reoutput'.)\n\n" .
1168         "If you wish to force Shepherd to re-compile guide data from scratch,\n" .
1169         "even though you seem to already have fresh data, use the --notimetest\n" .
1170         "option (e.g. 'tv_grab_au --notimetest'). However, this should ONLY be\n".
1171         "used for testing. If you call Shepherd too often with --notimetest,\n" .
1172         "it will lock down and refuse to run, to prevent straining resources\n" .
1173         "needed by all Shepherd users.\n");
1174    }
1175    exit(0);
1176}
1177
1178# Somehow some users are ending up with no region
1179sub check_region
1180{
1181    unless ($opt->{configure} or ($region and $region =~ /^\d+$/))
1182    {
1183        &log(2, "No or invalid region set! " . ucfirst($progname) . " must be configured.\n");
1184        $opt->{configure} = 1;
1185        $region = undef;
1186    }
1187}
1188
1189# Make sure the user hasn't edited the config file to try to support
1190# additional channels. This seems to happen reasonably often, and
1191# (a) makes Shepherd waste time and bandwith looking for unsupported channels,
1192# and (b) confuses our stats.
1193sub check_channels
1194{
1195    my @supported_channels = &read_official_channels($region);
1196    unless (@supported_channels)
1197    {
1198        &log("Skipping channel check.\n");
1199        return;
1200    }
1201    my $checked_migration;
1202    foreach my $ch (keys %$channels)
1203    {
1204        unless (grep($_ eq $ch, @supported_channels))
1205        {
1206            # check this isn't the result of a channel migration
1207            unless ($checked_migration)
1208            {
1209                &migrate_channels;
1210                $checked_migration = 1;
1211                redo;
1212            }
1213           
1214            # We may have removed it via migration
1215            next unless ($channels->{$ch});
1216
1217            &log("Ignoring unsupported channel for region $region: \"$ch\"\n");
1218            delete $channels->{$ch};
1219            if ($opt_channels->{$ch.'HD'})
1220            {
1221                &log("Ignoring related HD channel: \"$ch" . "HD\"\n");
1222                delete $opt_channels->{$ch.'HD'};
1223            }
1224        }
1225    }
1226
1227    if (defined $want_paytv_channels) {
1228        my @supported_paytv_channels = &read_official_channels($want_paytv_channels);
1229        unless (@supported_paytv_channels)
1230        {
1231            &log("Skipping paytv channel check.\n");
1232            return;
1233        }
1234        my $checked_migration;
1235        foreach my $ch (keys %$opt_channels)
1236        {
1237            unless (grep($_ eq $ch, @supported_paytv_channels) || grep($_.'HD' eq $ch, @supported_channels))
1238            {
1239                # check this isn't the result of a channel migration
1240                unless ($checked_migration)
1241                {
1242                    &migrate_paytv_channels;
1243                    $checked_migration = 1;
1244                    redo;
1245                }
1246
1247                # We may have removed it via migration
1248                next unless ($opt_channels->{$ch});
1249
1250                &log("Ignoring unsupported channel for $want_paytv_channels: \"$ch\"\n");
1251                delete $opt_channels->{$ch};
1252            }
1253        }
1254    }
1255
1256    &migrate_hd_channels;
1257
1258    &check_channel_xmltvids;
1259}
1260
1261sub read_official_channels
1262{
1263    my $reg = shift;
1264    return unless ($reg);
1265
1266    my $fn = 'references/channel_list/channel_list';
1267    unless (open (FN, $fn))
1268    {
1269        &log("ERROR: Unable to open $fn!\n");
1270        return;
1271    }
1272    while (my $line = <FN>)
1273    {
1274        return split(/,/, $1) if ($line =~ /^$reg:(.*)/);
1275    }
1276    &log("ERROR: Unable to find region \"$reg\" in $fn\n");
1277}
1278
1279# This is called when we download a new channels_file reference.
1280# We check the migration info in that file and rename any channels
1281# as appropriate.
1282sub migrate_channels
1283{
1284    &log("Checking for channel migrations...\n");
1285
1286    my $fn = 'references/channel_list/channel_list';
1287    unless (open (FN, $fn))
1288    {
1289        &log("ERROR: Unable to open $fn!\n");
1290        return;
1291    }
1292
1293    my $write_config = 0;
1294    my $mflag = 0;
1295    while (my $line = <FN>)
1296    {
1297        $mflag = 1 if ($line =~ /---migrate---/);
1298        next unless ($mflag);
1299
1300        # Look for our region number before the first colon.
1301        # EG These all match region 126:
1302        # 126:TEN->SC10
1303        # 126,254,255:TEN->SC10
1304        # *:TEN->SC10
1305        next unless ($line =~ /^[^:]*\b$region\b.*?:(.*)/ or $line =~ /^\*:(.*)/);
1306
1307        my $migrations = $1;
1308        if ($migrations =~ /(.*?):(.*?):(.*)/) {
1309                my $to_region = $1;
1310                my $need_channel = $2;
1311                $migrations = $3;
1312
1313                if (($need_channel =~ /^!(.*)$/ && !defined($channels->{$1})) ||
1314                                defined $channels->{$need_channel}) {
1315                        &log("Migrating region \"$region\" to \"$to_region\".\n");
1316                        $region = $to_region;
1317                        $write_config = 1;
1318                } else {
1319                        next;
1320                }
1321        }
1322        my @migrations = split(/,/, $migrations);
1323        foreach (@migrations)
1324        {
1325            my ($from, $to) = split /->/;
1326            if ($channels->{$from})
1327            {
1328                &log("Migrating channel \"$from\" to \"$to\".\n");
1329                $channels->{$to} = $channels->{$from};
1330                delete $channels->{$from};
1331                $mflag = 2;
1332                if ($opt_channels->{$from.'HD'})
1333                {
1334                    $from .= 'HD';
1335                    $to .= 'HD';
1336                    &log("Migrating HD channel \"$from\" to \"$to\".\n");
1337                    $opt_channels->{$to} = $opt_channels->{$from};
1338                    delete $opt_channels->{$from};
1339                }
1340            }
1341        }
1342    }
1343    if ($mflag == 2)
1344    {
1345        &log("Updating channels file.\n");
1346        &write_channels_file;
1347    }
1348        if ($write_config) {
1349                &log("Updating config file.\n");
1350                &write_config_file;
1351        }
1352}
1353
1354sub migrate_paytv_channels
1355{
1356    &log("Checking for paytv channel migrations...\n");
1357
1358    my $fn = 'references/channel_list/channel_list';
1359    unless (open (FN, $fn))
1360    {
1361        &log("ERROR: Unable to open $fn!\n");
1362        return;
1363    }
1364
1365    my $mflag = 0;
1366    while (my $line = <FN>)
1367    {
1368        $mflag = 1 if ($line =~ /---migrate---/);
1369        next unless ($mflag);
1370        next unless ($line =~ /^$want_paytv_channels:(.*)/);
1371        my @migrations = split(/,/, $1);
1372        foreach (@migrations)
1373        {
1374            my ($from, $to) = split /->/;
1375            if ($opt_channels->{$from})
1376            {
1377                &log("Migrating channel \"$from\" to \"$to\".\n");
1378                $opt_channels->{$to} = $opt_channels->{$from};
1379                delete $opt_channels->{$from};
1380                $mflag = 2;
1381            }
1382        }
1383    }
1384    if ($mflag == 2)
1385    {
1386        &log("Updating channels file.\n");
1387        &write_channels_file;
1388    }
1389}
1390
1391sub migrate_hd_channels
1392{
1393    my $write = 0;
1394
1395    # migrate to high definition channels
1396    foreach my $hdchannel (keys %$hd_to_sds) {
1397        if (!exists $channels->{$hdchannel}) { # annoyingly if they don't want 7HD this loops everytime
1398                foreach my $sdchannel (@{$hd_to_sds->{$hdchannel}}) {
1399                        if (exists $opt_channels->{$sdchannel.'HD'}) {
1400                                # there can be only one 7HD channel
1401                                $channels->{$hdchannel} = $opt_channels->{$sdchannel.'HD'};
1402                                delete $opt_channels->{$sdchannel.'HD'};
1403                                &log("Migrating channel \"${sdchannel}HD\" to \"$hdchannel\".\n");
1404                                $write = 1;
1405                                last;
1406                        }
1407                }
1408        }
1409    }
1410
1411    if ($write == 1) {
1412        &log("Updating channels file.\n");
1413        &write_channels_file;
1414    }
1415}
1416
1417# Ensure that every channel has a unique XMLTV ID
1418sub check_channel_xmltvids
1419{
1420    my $xmltvids = { };
1421    &check_channel_xmltvids_loop($channels, $xmltvids);
1422    &check_channel_xmltvids_loop($opt_channels, $xmltvids);
1423}
1424
1425sub check_channel_xmltvids_loop
1426{
1427    my ($cref, $xmltvids) = @_;
1428
1429    foreach my $ch (keys %$cref)
1430    {
1431        if ($xmltvids->{$cref->{$ch}})
1432        {
1433            &log(sprintf "WARNING: dropping channel %s: XMLTV ID of \"%s\" conflicts with %s\n",
1434                         $ch, $cref->{$ch}, $xmltvids->{$cref->{$ch}});
1435            delete $cref->{$ch};
1436        }
1437        else
1438        {
1439            $xmltvids->{$cref->{$ch}} = $ch;
1440        }
1441    }
1442}
1443
1444sub query_grabbers
1445{
1446    my ($conf, $val) = @_;
1447    return query_component_type('grabber',$conf,$val);
1448}
1449
1450sub query_reconcilers
1451{
1452    return query_component_type('reconciler');
1453}
1454
1455sub query_postprocessors
1456{
1457    return query_component_type('postprocessor');
1458}
1459
1460sub query_component_type
1461{
1462    my ($progtype,$conf,$val) = @_;
1463
1464    my @ret = ();
1465    foreach (keys %$components)
1466    {
1467        if ($components->{$_}->{type} and $components->{$_}->{type} eq $progtype) {
1468            if (defined $conf) {
1469                push (@ret, $_) if (query_config($_,$conf) eq $val);
1470            } else {
1471                push (@ret, $_);
1472            }
1473        }
1474    }
1475    return @ret;
1476}
1477
1478sub query_name
1479{
1480    my $str = shift;
1481    if ($str =~ /(.*) \[cache\]/)
1482    {
1483        return $1;
1484    }
1485    return $str;
1486}
1487
1488sub query_filename
1489{
1490    my ($proggy, $progtype) = @_;
1491    return query_ldir($proggy,$progtype).'/'.$proggy;
1492}
1493
1494sub query_ldir
1495{
1496    my ($proggy, $progtype) = @_;
1497    return $CWD.'/'.$progtype.'s' if ($proggy =~ /\.pm$/);
1498    return $CWD.'/'.$progtype.'s/'.$proggy;
1499}
1500
1501sub query_config
1502{
1503    my ($grabber, $key) = @_;
1504
1505    $grabber = query_name($grabber);
1506    return undef unless ($components->{$grabber});
1507    return $components->{$grabber}->{config}->{$key};
1508}
1509
1510sub countdown
1511{
1512    my ($n, $contstring) = @_;
1513
1514    $n ||= 10;
1515    $contstring ||= "Continuing";
1516
1517    &log(2, "You may wish to CTRL-C and fix this.\n\n$contstring anyway in:");
1518    foreach (1 .. $n)
1519    {
1520        &log(2, " " . ($n + 1 - $_));
1521        sleep 1;
1522    }
1523    &log(2, "\n");
1524}
1525
1526sub rotate_logfiles
1527{
1528    # keep last 30 log files
1529    my $num;
1530    for ($num = 30; $num > 0; $num--) {
1531        my $f1 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num;
1532        my $f2 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num+1;
1533        unlink($f2);
1534        rename($f1,$f2);
1535    }
1536
1537    my $f1 = sprintf "%s/%s",$LOG_DIR,$log_file;
1538    my $f2 = sprintf "%s/%s.1",$LOG_DIR,$log_file;
1539    rename($f1,$f2);
1540}
1541
1542sub compress_file
1543{
1544    my $infile = shift;
1545    my $outfile = sprintf "%s.gz",$infile;
1546    my $gz;
1547
1548    if (!(open(INFILE,"<$infile"))) {
1549        warn "could not open file $infile for reading: $!\n";
1550        return;
1551    }
1552
1553    if (!($gz = gzopen($outfile,"wb"))) {
1554        warn "could not open file $outfile for writing: $!\n";
1555        return;
1556    }
1557
1558    while (<INFILE>) {
1559        my $byteswritten = $gz->gzwrite($_);
1560        warn "error writing to compressed file: error $gz->gzerror"
1561          if ($byteswritten == 0);
1562    }
1563    close(INFILE);
1564    $gz->gzclose();
1565    unlink($infile);
1566}
1567
1568sub open_logfile
1569{
1570    unless (-d $LOG_DIR or mkdir $LOG_DIR)
1571    {
1572        print "Cannot create directory $LOG_DIR: $!";
1573        return;
1574    }
1575
1576    &rotate_logfiles;
1577    &log(1, "Logging to: $log_file\n");
1578    unless (open(LOG_FILE,">>$LOG_DIR/$log_file"))
1579    {
1580        print "Can't open log file $LOG_DIR/$log_file for writing: $!\n";
1581        return;
1582    }
1583
1584    my $now = localtime(time);
1585    printf LOG_FILE "$progname v$version started at $now\n";
1586    printf LOG_FILE "Invoked as: $invoked ".join(" ",@options)."\n";
1587    printf LOG_FILE "System ID: $sysid ($^O)\n\n";
1588
1589    my $old_log_file = $LOG_DIR."/".$log_file.".1";
1590    compress_file($old_log_file) if (-f $old_log_file);
1591}
1592
1593sub close_logfile
1594{
1595    close(LOG_FILE);
1596}
1597
1598# Optionally sent a loglevel as first arg:
1599#  0: print to STDERR unless sent --quiet (default)
1600#  1: print to STDERR if sent --debug, unless sent --quiet
1601#  2: print to STDERR
1602# In all cases, output will be printed to the logfile. To stop this,
1603# use --nolog.
1604sub log
1605{
1606    my $loglevel = shift;
1607
1608    my $entry;
1609    if ($loglevel =~ /^\d$/)
1610    {
1611        $entry = shift;
1612    }
1613    else
1614    {
1615        $entry = $loglevel;
1616        $loglevel = 0;
1617    }
1618    if ($loglevel == 2 or (!$opt->{'quiet'} and ($loglevel == 0 or $debug)))
1619    {
1620        print STDERR $entry;
1621    }
1622    print LOG_FILE $entry if (fileno(*LOG_FILE) and !$opt->{nolog});
1623}
1624
1625sub call_prog
1626{
1627    my ($component,$prog,$want_output,$timeout,$display_output,$progtype) = @_;
1628
1629    $timeout = 0 if (!defined $timeout);
1630    $want_output = 0 if (!defined $want_output);
1631    $display_output = 1 if (!defined $display_output);
1632    $progtype = $components->{$component}->{type} unless ($progtype);
1633    if ($components->{$component}->{default_cmdline})
1634    {
1635        my $parameters = $components->{$component}->{default_cmdline};
1636        $parameters =~ s/:/ /g;
1637        $prog .= " $parameters";
1638    }
1639
1640    my $prog_output = "";
1641
1642    chdir (query_ldir($component, $progtype));
1643
1644    my $exec = sprintf "PERL5LIB=\"%s/references\" %s 2>&1|", $CWD, $prog;
1645    unless (open(PROG,$exec)) {
1646        &log("warning: couldn't exec $component as \"$prog\": $!\n");
1647        chdir $CWD;
1648        return(-1,"open failed",$prog_output);
1649    }
1650
1651    &log("\n:::::: Output from $component\n") if ($display_output);
1652
1653    my $msg;
1654    eval {
1655        local $SIG{ALRM};
1656        if ($timeout > 0) {
1657            $timeout = 20 if ($timeout < 20);
1658            $SIG{ALRM} = sub { die "alarm\n"; };
1659            alarm $timeout; # set alarm
1660        }
1661        while(<PROG>) {
1662            $msg = $_;
1663            &log(": $msg") if ($display_output);
1664            $prog_output .= $msg if ($want_output);
1665            &add_pending_message($component, 'stats', $1) if ($msg =~ /^STATS: (.*)/);
1666
1667        }
1668        alarm(0) if ($timeout > 0); # cancel alarm
1669        close(PROG);
1670    };
1671
1672    chdir $CWD;
1673
1674    &log(":::::: End output from $component\n\n") if ($display_output);
1675
1676    if ($@) {
1677        die unless $@ eq "alarm\n";   # propagate unexpected errors
1678
1679        # timeout
1680        &log(ucfirst($component) . " ran for $timeout seconds, stopping it.\n");
1681        close(PROG);
1682    }
1683
1684    if ($? == -1) {
1685        &log("Failed to execute $component: $!\n");
1686        return (-1,"Failed to execute",$prog_output);
1687    }
1688    if ($msg)
1689    {
1690        chomp $msg;
1691        $msg =~ s/(.*) at .*\/(.*)/$1 at $2/g;
1692    }
1693    if ($? & 127) {
1694        &log((sprintf "%s died with signal %d, %s coredump\n",
1695             ucfirst($component), ($? & 127),  (($? & 128) ? "with" : "without")));
1696        return (($? & 127), "Died:$msg", $prog_output);
1697    } 
1698
1699    return (0,"",$prog_output) unless ($? >> 8);
1700    return (($? >> 8), $msg, $prog_output);
1701}
1702
1703sub fetch_file
1704{
1705    my ($url, $store, $id_self, $postvars, $csum) = @_;
1706    my $request;
1707
1708    # Need to drop cache-defeating final '?' if looking for local file
1709    $url = $1 if ($url =~ /^(file:\/\/\/.*)\?$/);
1710
1711    &log(1, "Fetching $url.\n");
1712   
1713    my $ua = LWP::UserAgent->new();
1714    $ua->env_proxy;
1715    if ($id_self)
1716    {
1717        $ua->agent(ucfirst("$progname/$version"));
1718    }
1719    else
1720    {
1721        $ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322');
1722    }
1723
1724    if (defined $postvars) {
1725        $request = HTTP::Request->new(POST => $url);
1726        $request->add_content($postvars);
1727    } else {
1728        $request = HTTP::Request->new(GET => $url);
1729    }
1730    $request->header('Accept-Encoding' => 'gzip');
1731
1732    my $response = $ua->request($request);
1733    if ($response->is_success())
1734    {
1735        if ($response->header('Content-Encoding') &&
1736            $response->header('Content-Encoding') eq 'gzip') {
1737            $response->content(Compress::Zlib::memGunzip($response->content));
1738        }
1739
1740        # check the checksum
1741        if (defined $csum) {
1742            my $sha = Digest::SHA->new();
1743            $sha->add($response->content);
1744            my $rcsum = $sha->hexdigest;
1745            if ($rcsum ne $csum) {
1746                &log("$url corrupt: expected checksum $csum but got ".$rcsum."\n");
1747                return undef;
1748            }
1749        }
1750
1751        if ($store)
1752        {
1753            open (FILE, ">$store") 
1754                or (&log("ERROR: Unable to open $store for writing: $!.\n") and return undef);
1755            print FILE $response->content();
1756            close FILE;
1757
1758            # re-check checksum of saved file if we have a checksum to compare against
1759            if (defined $csum) {
1760                my $rcsum = &csum_file($store);
1761                if ($rcsum ne $csum) {
1762                    &log("ERROR: file $store corrupt: expected checksum $csum but got ".$rcsum.".\n".
1763                         "       Maybe the filesystem is full? I/O error code was $!.\n");
1764                    return undef;
1765                }
1766            }
1767
1768            return 1;
1769        }
1770        else 
1771        {
1772            return $response->content();
1773        } 
1774    }
1775    &log("Failed to retrieve $url: " . $response->status_line() . "\n");
1776    return undef;
1777}
1778
1779sub add_pending_message
1780{
1781    my ($component, $field, @rest) = @_;
1782
1783    &log("SHEPHERD: Set pending message: $component $field @rest\n") if ($debug);
1784    my $iteration = 0;
1785    my $componentname = $component;
1786    if ($component ne $progname)
1787    {
1788        while (defined $pending_messages->{"$component-$iteration"}->{SUCCESS}
1789                or
1790               defined $pending_messages->{"$component-$iteration"}->{FAIL})
1791        {
1792            $iteration++;
1793            last if ($iteration > 19); # just in case
1794        }
1795        $componentname = "$component-$iteration";
1796    }
1797    $pending_messages->{$componentname}->{$field} = join("\t",@rest);
1798}
1799
1800sub urlify
1801{
1802    my $str = shift;
1803    $str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
1804    return $str;
1805}
1806
1807# Try to find a sensible place to put Shepherd files. Default is ~/.shepherd/
1808sub find_home
1809{
1810    my $home = $ENV{HOME};
1811    $home = undef if ($home eq '/' or $home eq '');
1812    if (!$home and $ENV{USER})
1813    {
1814        foreach ( "/home/$ENV{USER}", "/usr/home/$ENV{USER}", "/$ENV{USER}" )
1815        {
1816            if (-o $_ and -d $_)
1817            {
1818                $home = $_;
1819                last;
1820            }
1821        }
1822    }
1823    if ($home)
1824    {
1825        $home =~ s'/$'';
1826        return "$home/.$progname";
1827    }
1828    return "/opt/$progname";
1829}
1830
1831# -----------------------------------------
1832# Subs: Setup
1833# -----------------------------------------
1834
1835sub read_config_file
1836{
1837    read_file($config_file, 'configuration');
1838    &log(1,"System ID: $sysid\n");
1839
1840    # shepherd.conf bug fixes
1841    # 04/08/07 - added selectv_website
1842    $want_paytv_channels = 'Foxtel' if (defined $want_paytv_channels && $want_paytv_channels eq 1);
1843    # 29/08/07 - removed abc2_website as a preferred title source
1844    $pref_title_source = 'yahoo7widget'
1845            if (defined $pref_title_source && $pref_title_source eq 'yahoo7widget,abc2_website');
1846    delete $components->{'abc2_website'} if (defined $components &&
1847            defined $components->{'abc2_website'} && !defined $components->{'abc2_website'}->{'ver'});
1848    # 27/06/08 - removed jrobbo as a preferred title source
1849    $pref_title_source = undef
1850            if (defined $pref_title_source && $pref_title_source eq 'jrobbo');
1851    delete $components->{'jrobbo'} if (defined $components &&
1852            defined $components->{'jrobbo'} && !defined $components->{'jrobbo'}->{'ver'});
1853
1854    # Migrate from 'mirror_site' to new 'sources'
1855    unless ($sources)
1856    {
1857        &log("Defining default source.\n");
1858        &reset_sources;
1859        # Components with no source are assigned to whuffy
1860        foreach (keys %$components)
1861        {
1862            $components->{$_}->{source} ||= 'http://www.whuffy.com/shepherd/';
1863        }
1864    }
1865       
1866    if ($mirror_site)
1867    {
1868        print "Migrating mirrors to sources.\n";
1869        foreach my $site (split (/,/, $mirror_site))
1870        {
1871            $site = "$site/" unless ($site =~ /\/$/);
1872            push(@$sources, $site);
1873        }
1874        $mirror_site = undef;
1875    }
1876}
1877
1878sub read_channels_file
1879{
1880    read_file($channels_file, 'channels');
1881}
1882
1883sub read_file
1884{
1885    my $fn = shift;
1886    my $name = shift;
1887
1888    print STDERR "Reading $name file: $fn\n" unless ($opt->{quiet});
1889    unless (-r $fn)
1890    {
1891        unless ($opt->{configure})
1892        {
1893            print "\nNo $name file found.\n" .
1894                  ucfirst($progname) . " must be configured: " .
1895                  "configuring now.\n\n";
1896            $opt->{'configure'} = 1;
1897            $opt->{'nolog'} = 1;
1898        }
1899        return;
1900    }
1901    local (@ARGV, $/) = ($fn);
1902    no warnings 'all';
1903    eval <>;
1904    if ($@ and !$opt->{configure})
1905    {
1906        warn "\nERROR in $name file! Details:\n$@";
1907        &countdown();
1908    }
1909}
1910
1911sub write_config_file
1912{
1913    write_file($config_file, 'configuration',
1914        [$region,  $pref_title_source,  $want_paytv_channels,  $sysid,  $last_successful_run, $last_successful_run_data, $last_successful_runs, $sources, $components,  $components_pending_install,  $pending_messages ],
1915        ["region", "pref_title_source", "want_paytv_channels", "sysid", "last_successful_run", "last_successful_run_data", "last_successful_runs", 'sources', "components", "components_pending_install", "pending_messages" ]);
1916}
1917
1918sub write_channels_file
1919{
1920    write_file($channels_file, 'channels',
1921        [ $channels,  $opt_channels ],
1922        [ 'channels', 'opt_channels' ]);
1923}
1924
1925sub write_file
1926{
1927    my ($fn, $name, $vars, $varnames) = @_;
1928    open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
1929    print FN Data::Dumper->Dump($vars, $varnames);
1930    close FN;
1931    &log(1, "SHEPHERD: Wrote $name file $fn.\n");
1932}
1933
1934sub get_command_line_options
1935{
1936  my $use_argv = shift;
1937
1938  if ($use_argv) {
1939    # Record so we can pass the unmodified args to components later
1940    @options = @ARGV;   # Record so we can pass the unmodified args to components later
1941    push (@options,"") if ($#options == -1); # silence warnings if none
1942
1943    # filter what options we don't pass on ..
1944    foreach (0..$#options) {
1945        next if (!$options[$_]);
1946
1947        splice(@options,$_,2) if ($options[$_] =~ /^--config-file/);    # don't pass on "--config-file (file)"
1948        next if (!$options[$_]);
1949        splice(@options,$_,1) if ($options[$_] =~ /^--quiet/);          # never be quiet
1950    }
1951  } else {
1952    push(@ARGV,split(/:/,$components->{$progname}->{default_cmdline}));
1953  }
1954
1955  Getopt::Long::Configure(qw/pass_through/);
1956
1957  GetOptions($opt, qw(  config-file=s
1958                        help
1959                        dev-help
1960                        configure:s
1961                        setpreftitle=s
1962                        clearpreftitle
1963                        capabilities
1964                        preferredmethod
1965                        description
1966                        quiet
1967                        notquiet
1968                        version
1969                        debug
1970                        status
1971                        desc
1972                        show-config
1973                        show-channels
1974                        update
1975                        noupdate
1976                        skipupdate
1977                        skippost
1978                        disable=s
1979                        enable=s
1980                        component-set=s
1981                        delete=s
1982                        nolog
1983                        nonotify
1984                        notimetest
1985                        check
1986                        reset
1987                        dontcallgrabbers
1988                        days=i
1989                        offset=i
1990                        output=s
1991                        nooutput
1992                        randomize
1993                        pending
1994                        grabwith=s
1995                        list-chan-names
1996                        set-icons
1997                        configure-mythtv
1998                        refill-mythtv
1999                        refresh-mythtv
2000                        ancestry=s
2001                        history
2002                        sources
2003                        addsource=s
2004                        delsource=s
2005                        mode=s
2006                        daily
2007                        reoutput
2008                        reoutput-mythtv
2009                     ));
2010  $debug = $opt->{debug};
2011  $days = $opt->{days} if ($opt->{days});
2012  $opt->{configure} = 1 if (defined $opt->{configure} and !$opt->{configure});
2013  $output_filename = $opt->{output} if ($opt->{output});
2014  delete $opt->{quiet} if (defined $opt->{notquiet});
2015}
2016
2017sub check_lock
2018{
2019    $lock = (flock DATA, &Fcntl::LOCK_EX | &Fcntl::LOCK_NB);
2020    &log("Lock failed.\n") unless ($lock);
2021}
2022
2023sub check_other_instance
2024{
2025    if (!$lock)
2026    {
2027        &log("\n*** IN PROGRESS ***\nAnother instance of Shepherd is currently running.\n");
2028    }
2029}
2030
2031# Here we can specify which command-line options should call
2032# subroutines of the same name. The field following each sub
2033# name is a string that can contain a key for what action should
2034# be performed following the sub:
2035#   W : write config file
2036#   S : print --status output
2037# Shepherd will exit if at least one of these routines was
2038# called.
2039sub process_setup_commands
2040{
2041    my %routines = (    enable => 'WS',
2042                        disable => 'WS',
2043                        'delete' => 'WS',
2044                        setorder => 'WS',
2045                        check => 'WS',
2046                        setpreftitle => 'W',
2047                        clearpreftitle => 'W',
2048                        'reset' => 'W',
2049                        'component-set' => 'W',
2050                        addsource => 'W',
2051                        delsource => 'W',
2052                        status => '',
2053                        history => '',
2054                        desc => '',
2055                        'show-config' => '',
2056                        'show-channels' => '',
2057                        'list-chan-names' => '',
2058                        'set-icons' => '',
2059                        'configure-mythtv' => '',
2060                        'pending' => '',
2061                        ancestry => '',
2062                        sources => ''
2063                    );
2064
2065    my ($run, $write_flag, $status_flag);
2066    foreach my $func (keys %routines)
2067    {
2068        if ($opt->{$func})
2069        {
2070            $run = 1;
2071            my $sub = $func;
2072            $sub =~ s/-/_/g;
2073            if (!$lock and $routines{$func} =~ /W/)
2074            {
2075                print "\nERROR: Cannot --$func while another instance of Shepherd is running.\n".
2076                      "Please try again later.\n";
2077            }
2078            else
2079            {
2080                &$sub($opt->{$func});
2081                $write_flag = 1 if ($routines{$func} =~ /W/);
2082                $status_flag = 1 if ($routines{$func} =~ /S/);
2083            }
2084        }
2085    }
2086    return unless ($run);
2087    &write_config_file if ($write_flag);
2088    &status if ($status_flag);
2089    exit;
2090}
2091
2092# if a preferred title source has been specified, add it to our config
2093sub setpreftitle
2094{
2095    my $arg = shift;
2096    $pref_title_source = $arg;
2097    &log("Added preferred title source: $pref_title_source\n");
2098    1;
2099}
2100
2101# if requesting to clear preferred title and we have one, remove it
2102sub clearpreftitle
2103{
2104    &log("Removed preferred title source: $pref_title_source\n");
2105    $pref_title_source = undef;
2106    1;
2107}
2108
2109sub reset
2110{
2111    &log(2, "\nWARNING! The --reset argument will remove your established\n" .
2112            "title translation data. This may cause Shepherd to lose the\n" .
2113            "ability to keep show titles consistent with what you have seen\n" .
2114            "in the past!\n\n");
2115    &countdown(20);
2116    my @r = query_component_type('reconciler');
2117    foreach (@r)        # Not that there should be more than one...
2118    {
2119        my $fn = query_ldir($_, 'reconciler') . '/' . $_ . '.storable.config';
2120        &log("Removing $fn.\n");
2121        unlink($fn) or &log("Failed to remove file! $!\n");
2122    }
2123
2124    if ($pref_title_source)
2125    {
2126        my @prefs = split(/,/, $pref_title_source);
2127        foreach my $grabber (@prefs)
2128        {
2129            if ($components->{$grabber}->{lastdata})
2130            {
2131                &log( "Clearing lastdata for '$grabber' to trigger it to be called.\n");
2132                delete $components->{$grabber}->{lastdata};
2133            }
2134        }
2135    }
2136}
2137
2138sub delete
2139{
2140    my $proggy = shift;
2141
2142    delete $components->{$proggy};
2143    &log("\nDeleted component \"$proggy\".");
2144}
2145
2146# used to call a component in a manner so it can set some tunable parameter
2147sub component_set
2148{
2149    my $compset = shift;
2150
2151    my $helpstr = "Format: --component-set <component>:<argument>[:<argument2>...]\n".
2152                  "  e.g.: --component-set oztivo:region=101\n".
2153                  "        --component-set oztivo:region=101:debug:config=default.conf\n\n";
2154
2155    my ($component, @args) = split(/:/,$compset);
2156    if (!defined $components->{$component}) {
2157        &log("\nError: No component called '$component'!\n$helpstr");
2158        return;
2159    }
2160    my $arg = join(":",@args);
2161
2162    if ((!defined $arg) || ($arg eq "")) {
2163        delete $components->{$component}->{default_cmdline};
2164        &log("\n*** Cleared default options for $component. ***\n\n".
2165             "If you wish to set new options:\n$helpstr");
2166    } else {
2167        $components->{$component}->{default_cmdline} = "--".join(":--",@args);
2168        &log("\nSet default options for $component to: --".join(" --",@args)."\n");
2169    }
2170}
2171
2172sub sources
2173{
2174    my $arg = shift;
2175
2176    if ($arg and $arg eq 'reset')
2177    {
2178        print "Resetting sources.\n";
2179        &reset_sources;
2180    }
2181    print "Sources:\n".
2182          "  # Source                                        Can Update\n".
2183          "-------------------------------------------------------------------\n";
2184
2185    my $count = 1;
2186    foreach my $site (@$sources)
2187    {
2188        printf " %2d %-50s\n",
2189               $count,
2190               $site;
2191        $count++;
2192    }
2193}
2194
2195sub addsource
2196{
2197    my $source = shift;
2198
2199    my ($site, $priority, @rest) = split(/,/, $source);
2200
2201    if (@rest)
2202    {
2203        print "Warning: Ignoring unknown options: @rest\n";
2204    }
2205
2206    $site = "$site/" unless ($site =~ /\/$/);
2207
2208    &delsource($site, 1);
2209
2210    if (!$priority or $priority < 1 or $priority > @$sources)
2211    {
2212        $priority = @$sources;
2213    }
2214    else
2215    {
2216        $priority--;
2217    }
2218    splice (@$sources, $priority, 0, $site);
2219    &log("\nAdded source $site\n");
2220    if (&fetch_file($site . 'status.csum?', undef, 1))
2221    {
2222        &log("Source appears valid.\n");
2223    }
2224    else
2225    {
2226        &log("\n*** WARNING: Source unreachable! ***\n\n");
2227    }
2228    &sources;
2229    &log("\n*** PLEASE READ CAREFULLY! ***\n".
2230         "Adding a source allows the remote host to install and execute\n".
2231         "software on your system. Each time Shepherd runs (except when\n".
2232         "invoked with --noupdate), it will ask this host for updates.\n".
2233         "This is a serious security risk, and we STRONGLY RECOMMEND that\n".
2234         "you take steps to limit the damage a malicious source could do\n".
2235         "to your system. For more information, see:\n".
2236         "   $wiki/Security\n" .
2237         "To remove a source, use \"--delsource <source>\".\n");
2238}
2239
2240sub delsource 
2241{
2242    my ($source, $quietcheck) = @_;
2243
2244    if ($source eq 'all')
2245    {
2246        print "Resetting sources.\n";
2247        &reset_sources;
2248        return &sources;
2249    }
2250    $source = "$source/" unless ($source =~ /\/$/);
2251    for (my $i = 0; $i < @$sources; $i++)
2252    {
2253        my $site = $sources->[$i];
2254        if ($source eq $site)
2255        {
2256            splice (@$sources, $i, 1);
2257            &reset_sources if (@$sources < 1);
2258            return if ($quietcheck);
2259            print "\nDeleted source: $source\n";
2260            return &sources;
2261        }
2262    }
2263    unless ($quietcheck)
2264    {
2265        print "\nError: No such source: \"$source\"\n";
2266        exit;
2267    }
2268}
2269
2270sub reset_sources
2271{
2272    $sources = [ 'http://www.whuffy.com/shepherd/' ];
2273}
2274
2275sub list_chan_names
2276{
2277    require Shepherd::Configure;
2278    &Shepherd::Configure::list_chan_names;
2279}
2280
2281sub set_icons
2282{
2283    require Shepherd::Configure;
2284    &Shepherd::Configure::set_icons;
2285}
2286
2287sub configure_mythtv
2288{
2289    require Shepherd::Configure;
2290    &Shepherd::Configure::configure_mythtv;
2291}
2292
2293sub refill_mythtv
2294{
2295    my ($refresh, $reoutput) = @_;
2296
2297    my $t = time;
2298    if (!$refresh and (!$last_successful_run or $t - $last_successful_run > (24 * 3600)))
2299    {
2300        if ($last_successful_run)
2301        {
2302            &log("\nWARNING: Last successful run was " . 
2303                &pretty_duration($t - $last_successful_run) .
2304                " ago, which is a pretty long time.\n");
2305        }
2306        else
2307        {
2308            &log("\nWARNING: Shepherd doesn't seem to have ever run successfully,\n" .
2309                 "so we may have no guide data to feed to MythTV.\n");
2310        }
2311        &log("You may want to run 'tv_grab_au --refresh-mythtv' instead, to generate\n" .
2312             "fresh guide data.\n");
2313        &countdown(10);
2314    }
2315    my $mythtv_version;
2316    &log("\nAttempting to figure out your version of mythfilldatabase...\n");
2317    my $result = `mythfilldatabase --version`;
2318    if ($result =~ /MythTV Version.*?v([\.0-9]+)/)
2319    {
2320        $mythtv_version = $1;
2321        &log("MythTV version seems to be $mythtv_version\n");
2322    }
2323    else
2324    {
2325        &log("Couldn't understand the response from 'mythfilldatabase --version'.\n" .
2326                "Assuming a version prior to 0.25.\n");
2327        $mythtv_version = '0.24';
2328    }
2329    $result = &versioncmp('0.25', $mythtv_version);
2330    my ($mythfilldatabase_exec, $mythfilldatabase_exec2);
2331    if ($result <= 0)
2332    {
2333        if ($reoutput)
2334        {
2335            $mythfilldatabase_exec = 'mythfilldatabase -- --reoutput';
2336        }
2337        else
2338        {
2339            $mythfilldatabase_exec = "mythfilldatabase --update --file --sourceid 1 --xmlfile $output_filename";
2340        }
2341    }
2342    else
2343    {
2344        if ($reoutput)
2345        {
2346            $mythfilldatabase_exec2 = "mythfilldatabase --graboptions '--reoutput'";
2347        }
2348        else
2349        {
2350            $mythfilldatabase_exec = "mythfilldatabase --update --file 1 $output_filename";
2351        }
2352    }
2353    &log("Trying now...\nExecuting: $mythfilldatabase_exec\n\n".
2354        "-------------------mythfilldatabase output---------------------\n");
2355    sleep 1;
2356    $result = system("$mythfilldatabase_exec");
2357    &log("-----------------end mythfilldatabase output-------------------\n\n");
2358    if ($result)
2359    {
2360        &log("Hmm, that didn't seem to work (got a non-zero exit value!).\n");
2361        if ($reoutput)
2362        {
2363            &log("Consider trying 'tv_grab_au --refill-mythtv', which does the same\n" .
2364                "thing, only using mythfilldatabase's --file option.\n\n");
2365        }
2366        else
2367        {
2368            &log("Consider trying 'tv_grab_au --reoutput-mythtv', which does the same\n" .
2369                "thing, only by feeding output directly to MythTV. This requires\n" .
2370                "that MythTV be already configured to use Shepherd as its default\n" .
2371                "grabber, however.\n\n");
2372        }
2373    }
2374    &log("Shepherd: Hopefully your guide data has now been loaded into MythTV.\n" .
2375        "          If not, please report it to the Shepherd mailing list.\n");
2376}
2377
2378sub ancestry
2379{
2380    # Since this subroutine is optional and manually invoked, we won't
2381    # require users have the File::Find dependency until they need it.
2382    # It's probably a little annoying to suddenly realize you need
2383    # another module when you thought everything was installed, but
2384    # that's better than requiring all users have this dependency even
2385    # if they don't really need it.
2386    &require_module("File::Find::Rule");
2387
2388    # Step 1: figure out start and stop dates
2389
2390    my $t = time;
2391    $opt->{'ancestry-zone'} = POSIX::strftime("%z", localtime($t));
2392    print "Assuming local time zone is $opt->{'ancestry-zone'}.\n";
2393    my ($start, $stop);
2394    if ($opt->{ancestry} =~ /(.*)\+(\d+):?(.*)/)
2395    {
2396        $opt->{'ancestry-start'} = Date::Manip::UnixDate("$1 $opt->{'ancestry-zone'}","%s");
2397        $opt->{'ancestry-stop'} = $opt->{'ancestry-start'} + (60 * $2);
2398        $opt->{'ancestry-title'} = $3 if ($3);
2399    }
2400    unless ($opt->{'ancestry-start'} and $opt->{'ancestry-stop'})
2401    {
2402        &log("\nSorry, I don't understand the argument sent to --ancestry.\n".
2403             "Format: --ancestry \"<timestamp>+<minutes>[:title]\"\n".
2404             "Timestamp can be any of a variety of formats. Some examples:\n".
2405             "  --ancestry 200706210800+30             (June 21 2007 8am-8:30am)\n".
2406             "  --ancestry \"today 9pm+10\"            (today 9pm-9:10pm)\n".
2407             "  --ancestry \"midnight tomorrow+60\"    (12am-1am tomorrow)\n".
2408             "  --ancestry \"tuesday 8:28pm+10:news\"  (also only shows with \"news\" in title)\n");
2409        return;
2410    }
2411
2412    my $dformat = "%A %e %B %Y %I:%M %p %z";
2413    printf "Examining ancestry of data from %s to %s.\n",
2414        POSIX::strftime($dformat, localtime($opt->{'ancestry-start'})),
2415        POSIX::strftime($dformat, localtime($opt->{'ancestry-stop'}));
2416    print "Only looking for shows with \"$opt->{'ancestry-title'}\" in title.\n" if ($opt->{'ancestry-title'});
2417
2418    # Step 2: Figure out dates of interest of output files
2419    #
2420    # A little tricky because we only store the timestamp of when Shepherd's
2421    # last run finished, not when it started.
2422
2423    print "Last successful run was " . pretty_duration($t - $last_successful_run) ." ago.\n" if ($last_successful_run);
2424    my $previous_run = (reverse sort keys %$last_successful_runs)[1] if (ref $last_successful_runs and keys %$last_successful_runs > 1);
2425
2426    if ($previous_run)
2427    {
2428        print "Second-last successful run was " . pretty_duration($t - $previous_run)." ago.\n";
2429    }
2430    else
2431    {
2432        $previous_run = $t - (24*60*60);
2433        print "No data on second-last successful run.\n";
2434    }
2435    if ($last_successful_run and $last_successful_run - $previous_run > (6*60*60))
2436    {
2437        $previous_run = $last_successful_run - (6 * 60 * 60);
2438        print "Setting cut-off point to 6 hours before end of last successful run.\n";
2439    }
2440    print "Looking for output files more recent than " . pretty_duration($t - $previous_run) . " ago.\n";
2441
2442    # Step 3: gather files
2443
2444    my @f = File::Find::Rule->file()
2445                            ->name('output*.xmltv')
2446                            ->mtime(">$previous_run")
2447                            ->nonempty
2448                            ->in('grabbers', 'reconcilers', 'postprocessors');
2449    push @f, "output.xmltv" if (-e 'output.xmltv' and (stat 'output.xmltv')[9] > $previous_run);
2450
2451    # Step 4: Process files via XMLTV callback
2452
2453    foreach my $f (@f) 
2454    { 
2455        my $str;
2456        if ($f =~ /.*?\/(.*?)\/(.*)/)
2457        {
2458            $str = "$1: $2";
2459        }
2460        else
2461        {
2462            $str = "Shepherd Final Output: $f";
2463        }
2464        print  "********************************************************************************\n";
2465        printf "%*s\n", int((80 - length($str)) / 2) + length ($str), $str;
2466        XMLTV::parsefiles_callback(undef, undef, undef, \&ancestry_cb, $f);
2467    }
2468}
2469
2470sub ancestry_cb
2471{
2472    my $s = shift;
2473
2474    my ($start, $stop) = ($s->{start}, $s->{stop});
2475    $start .= " $opt->{'ancestry-zone'}" unless ($start =~ /\+\d{4}/);
2476    $stop  .= " $opt->{'ancestry-zone'}" unless ($stop =~ /\+\d{4}/);
2477
2478    $start = Date::Manip::UnixDate($start, "%s");
2479    $stop = Date::Manip::UnixDate($stop, "%s");
2480   
2481    return unless ($stop > $opt->{'ancestry-start'} and $start < $opt->{'ancestry-stop'});
2482
2483    my $title = (ref $s->{title} ? $s->{title}[0][0] : $s->{title});
2484    return if ($opt->{'ancestry-title'} and $title !~ /$opt->{'ancestry-title'}/i);
2485    my $channame;
2486    foreach (keys %$channels)
2487    {
2488        if ($channels->{$_} eq $s->{channel})
2489        {
2490            $channame = $_;
2491            $channame =~ s/\(.*?\)//g;
2492            last;
2493        }
2494    }
2495    $channame = $s->{channel} unless ($channame);
2496    my $subtitle = (ref $s->{'sub-title'} ? $s->{'sub-title'}[0][0] : $s->{'sub-title'});
2497    printf "+ %-50s%s\n",
2498        "$title [$channame]",
2499        POSIX::strftime("%a %d/%m %I:%M%p", localtime($start)) . ' - ' . POSIX::strftime("%I:%M%p", localtime($stop));
2500    print "     \"$subtitle\"\n" if ($subtitle);
2501    print "     $s->{start}  -  $s->{stop}\n";
2502}
2503
2504# -----------------------------------------
2505# Subs: Configuration
2506# -----------------------------------------
2507
2508sub configure
2509{
2510    eval
2511    {
2512        require Shepherd::Configure;
2513
2514        return &Shepherd::Configure::configure;
2515    };
2516    if ($@)
2517    {
2518        &log("Error from Shepherd::Configure:\n-> $@\n");
2519        return undef;
2520    }
2521}
2522
2523# -----------------------------------------
2524# Subs: Status & Help
2525# -----------------------------------------
2526
2527sub show_config
2528{
2529    &log("\nConfiguration\n".
2530         "-------------\n" .
2531         "Config file: $config_file\n" .
2532         "Debug mode : " . is_set($debug) . "\n" .
2533         "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
2534         "Region ID  : $region\n");
2535    show_channels();
2536    &log("\n");
2537    status();
2538    &log("\n");
2539}
2540
2541sub show_channels
2542{
2543    my $mchans = &retrieve_mythtv_channels;
2544    if ($mchans) {
2545        &show_mythtv_mappings($debug, $mchans);
2546    } else {
2547        &log(sprintf "\nYou have subscribed to %d standard channels and %d HDTV/PayTV channels.\n",
2548                        scalar(keys %$channels), scalar(keys %$opt_channels));
2549        &log("\nShepherd XMLTV IDs:\n");
2550        &log(" Standard channels (priority):\n");
2551        &log("    $_ -> $channels->{$_}\n") for sort keys %$channels;
2552        &log(" HDTV and PayTV channels (best-effort):\n");
2553        &log("    $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
2554    }
2555}
2556
2557sub is_set
2558{
2559    my $arg = shift;
2560    return $arg ? "Yes" : "No";
2561}
2562
2563sub pretty_print
2564{
2565    my ($p, $len) = @_;
2566    my $spaces = ' ' x (79-$len);
2567    my $ret = "";
2568
2569    while (length($p) > 0) {
2570        if (length($p) <= $len) {
2571            $ret .= $p;
2572            $p = "";
2573        } else {
2574            # find a space to the left of cutoff
2575            my $len2 = $len;
2576            while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
2577                $len2--;
2578            }
2579            if ($len2 == 0) {
2580                # no space - just print it with cutoff
2581                $ret .= substr($p,0,$len);
2582                $p = substr($p,$len,(length($p)-$len));
2583            } else {
2584                # print up to space
2585                $ret .= substr($p,0,$len2);
2586                $p = substr($p,($len2+1),(length($p)-$len2+1));
2587            }
2588            # print whitespace
2589            $ret .= "\n".$spaces;
2590        }
2591    }
2592    return $ret;
2593}
2594
2595sub pretty_date
2596{
2597    my $t = shift;
2598
2599    return "-    " unless $t;
2600
2601    my @lt = localtime($t);
2602    my @ltnow = localtime();
2603    if (time - $t > 15768000)   # 6 months or older
2604    {
2605        return POSIX::strftime("%d-%b-%y", @lt);    # eg 18-Mar-05
2606    }
2607    if (time - $t < 43200       # less than 12 hours ago
2608            or
2609        ($lt[4] == $ltnow[4] and $lt[3] == $ltnow[3]))  # today
2610    {
2611        return POSIX::strftime("%l:%M%P ", @lt);    # eg 10:45pm
2612    }
2613    return POSIX::strftime("%a %d-%b", @lt);        # eg Mon 25-Dec
2614}
2615
2616sub retrieve_mythtv_channels
2617{
2618    print "\nAttempting Mysql connection to MythTV database mythconverg.\n";
2619
2620    my $mchans;
2621    eval
2622    {
2623        require Shepherd::MythTV;
2624
2625        my $dbh = &Shepherd::MythTV::open_connection();
2626        return unless ($dbh); # end eval
2627        $mchans = $dbh->selectall_arrayref("SELECT name,callsign,channum,xmltvid FROM channel;", { Slice => {} } );
2628        &Shepherd::MythTV::close_connection;
2629    };
2630    if ($@)
2631    {
2632        &log("Error trying to access MythTV database: $@\n");
2633        return undef;
2634    }
2635    return $mchans;
2636}
2637
2638sub show_mythtv_mappings
2639{
2640    my ($show_xmltvids, $mchans) = @_;
2641
2642    &log(sprintf "\nRegion %d. %d MythTV channels. %d Shepherd channels.\n\n",
2643        $region, scalar(@$mchans), scalar(keys %$channels) + scalar(keys %$opt_channels));
2644    if ($show_xmltvids)
2645    {
2646        &log("   #  MythTV Channel                 XMLTV ID             Shepherd Guide Data\n".
2647             " -----------------------------------------------------------------------------\n");
2648    }
2649    else
2650    {
2651        &log("   #  MythTV Channel                 Shepherd Guide Data\n".
2652             " --------------------------------------------------------\n");
2653    }
2654    my %xmltvids;
2655    map { $xmltvids{$channels->{$_}} = $_ } keys %$channels;
2656    map { $xmltvids{$opt_channels->{$_}} = $_ } keys %$opt_channels;
2657    my %unmapped = %xmltvids;
2658    foreach my $chan (@$mchans)
2659    {
2660        my $mapped_to = $chan->{'xmltvid'} ? $xmltvids{$chan->{'xmltvid'}} || '-' : '-';
2661        delete $unmapped{$chan->{'xmltvid'}} if ($mapped_to ne '-');
2662
2663        my $longname = $chan->{'name'};
2664        $longname .= " ($chan->{callsign})" if ($chan->{'callsign'} and lc($chan->{'callsign'}) ne lc($chan->{'name'}));
2665        my $channum = $chan->{'channum'};
2666        if ($show_xmltvids)
2667        {
2668            &log(sprintf "%4s  %-30s %-20s <- %s\n",
2669                         $channum,
2670                         $longname,
2671                         $chan->{'xmltvid'} || '-',
2672                         $mapped_to
2673                        );
2674        }
2675        else
2676        {
2677            &log(sprintf "%4s  %-30s <- %s\n",
2678                    $channum,
2679                    $longname,
2680                    $mapped_to);
2681        }
2682    }
2683    if (keys %unmapped)
2684    {
2685        &log("\nWARNING! Unmapped guide data: " . join(', ', values %unmapped) . ".\n".
2686             "         Shepherd is set to download guide data that no MythTV channel wants.\n".
2687             "         Either map these to a MythTV channel, or do not subscribe to them!\n\n");
2688    }
2689}
2690
2691sub desc
2692{
2693    my $lasttype = '';
2694    my %qual_table = ( 3 => "Excellent", 2 => "Good", 1 => "Poor" );
2695
2696    foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) 
2697    {
2698        if ($lasttype ne $components->{$_}->{type})
2699        {
2700            $lasttype = $components->{$_}->{type};
2701            &log("\n*** " . uc($lasttype) . "S ***\n");
2702        }
2703        &log("\n$_ v$components->{$_}->{ver}" .
2704             "\n* " . pretty_print(query_config($_, 'desc'), 77) . "\n".
2705             "* Component source: " . $components->{$_}->{source} . "\n");
2706        if ($lasttype eq 'grabber')
2707        {
2708            &log("* Data Quality: " . $qual_table{int(query_config($_, 'quality'))} . "\n");
2709            &log("* Speed: " . (query_config($_, 'category') == 1 ? "Slow" : "Fast") . "\n");
2710            my $ch = query_config($_, 'channels');
2711            $ch = "All" if ($ch eq '');
2712            $ch = "All except $1" if ($ch =~ /^\-(.*)/);
2713            &log("* Channels: $ch\n");
2714            my $d1 = query_config($_, 'max_days');
2715            my $d2 = query_config($_, 'max_reliable_days');
2716            &log("* Days: " . ($d1 == $d2 ? $d1 : "$d2 to $d1") . "\n");
2717        }
2718    }
2719}
2720
2721sub status
2722{
2723    foreach my $ctype ('grabber', 'reconciler', 'postprocessor')
2724    {
2725        &log("\n " . 
2726             ($ctype eq 'grabber' ?
2727                "                        Enabled/\n".
2728                sprintf(" %-15s Version Ready  Last Run  Status", ucfirst($ctype)) 
2729                : ucfirst($ctype)) .
2730             "\n --------------- ------- ----- ---------- -------------------------------------\n");
2731        foreach (sort { ($components->{$b}->{lastdata} or 0) <=> ($components->{$a}->{lastdata} or 0) } query_component_type($ctype))
2732        {
2733            my $h = $components->{$_};
2734            &log(sprintf  " %-16s%7s %1s/%1s%1s %11s %s\n",
2735                 length($_) > 16 ? substr($_,0,14).".." : $_,
2736                 $h->{ver},
2737                 $h->{disabled} ? 'N' : 'Y',
2738                 $h->{ready} ? 'Y' : 'N',
2739                 (defined $plugin_data->{$_}->{tainted} ? "!" : ""),
2740                 pretty_date($h->{lastdata}),
2741                 ((defined $h->{disabled} && $h->{disabled} == 2) ? "centrally disabled" :
2742                     ($h->{laststatus} ? pretty_print($h->{laststatus},37) : '')));
2743        }
2744    }
2745    if (defined $last_successful_run)
2746    {
2747        my $str = sprintf "Shepherd last ran successfully %s ago", 
2748                          pretty_duration(time - $last_successful_run);
2749        if (defined $last_successful_run_data)
2750        {
2751            $str .= sprintf " and acquired %2.2f%% of data",
2752                            $last_successful_run_data;
2753        }
2754        &log("\n$str.\n");
2755    }
2756    &log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
2757    &log("\nWARNING: [!] against components above indicate TAINTED components.\n\n")
2758      if (defined $plugin_data->{tainted});
2759    &check_other_instance;
2760}
2761
2762sub history
2763{
2764    my @all_runs = (sort {$a <=> $b} keys %{$last_successful_runs});
2765    if (scalar @all_runs == 0) {
2766        &log("\nNo runs recorded yet.\n\n");
2767        return;
2768    }
2769
2770    &log(sprintf "\nShepherd has run successfully %d times in the last %d days.\n\n",
2771                 scalar(keys %$last_successful_runs),
2772                 int((time - $all_runs[0]) / 86400));
2773    my $str;
2774    foreach my $when (sort {$b <=> $a} keys (%{$last_successful_runs})) 
2775    {
2776        $str = ($str ? "$str," : 'History:');
2777        my $append = sprintf " %s ago (%2.2f%%)", 
2778                     &pretty_duration(time - $when),
2779                     $last_successful_runs->{$when};
2780        if (length($str.$append) > 79) 
2781        {
2782            &log("$str\n");
2783            $str = '        ';
2784        }
2785        $str .= $append;
2786    }
2787    &log("$str.\n");
2788    &check_other_instance;
2789}
2790
2791sub capabilities
2792{
2793    print "baseline\nmanualconfig\npreferredmethod\n";
2794    exit 0;
2795}
2796
2797sub preferredmethod
2798{
2799    print "allatonce\n";
2800    exit 0;
2801}
2802
2803sub description
2804{
2805    print "Australia\n";
2806    exit 0;
2807}
2808
2809sub help
2810{
2811    print q{Info options:
2812    --help                Display this message
2813    --dev-help            Display advanced options
2814    --version             Display version
2815    --status              Display status of various components
2816    --desc                Display detailed status of components
2817    --history             Display usage history
2818    --check               Display check of all components
2819
2820    --show-config         Show setup details
2821    --show-channels       Show subscribed channels
2822    --pending             Show any pending component installs
2823    --ancestry <s>        Show origin of recent guide data
2824                          (See "--ancestry help")
2825
2826Session options:
2827    --output <s>          Create file <s> (default: ~/.shepherd/output.xmltv)
2828    --days <n>            Retrieve <n> days of guide data
2829    --offset <n>          Skip first <n> days
2830
2831    --reoutput            Don't grab fresh data; just return cache
2832    --reoutput-mythtv     Don't grab fresh data; feed cache to MythTV
2833    --refill-mythtv       Don't grab fresh data; feed cache to MythTV via --file
2834    --refresh-mythtv      Grab fresh data, then feed to MythTV via --file
2835
2836    --noupdate            Don't update Shepherd; just grab data
2837    --update              Don't grab data; just update Shepherd
2838    --skipupdate          Skip update of Shepherd
2839    --skippost            Skip postprocessing of data
2840
2841    --mode <s>            Quality (default), Efficiency or Speed
2842    --grabwith <s>        Grab with grabber <s> before trying other grabbers
2843                          (e.g. --grabwith sbsweb,abc_website)
2844
2845    --debug               Print debugging messages
2846    --quiet               Don't print anything except errors
2847    --notquiet            Don't be --quiet
2848    --nolog               Don't write a logfile
2849    --nonotify            Don't report anonymous usage statistics
2850
2851Configuration options:
2852    --configure           Setup
2853    --configure-mythtv    Create symlink & cron job to feed data to MythTV
2854
2855    --disable <s>         Set component <s> (or "all") as not to be used
2856    --enable <s>          Set component <s> (or "all") as available for use
2857
2858    --component-set <s:s> Set default argument for component
2859    --configure <s>       Configure component <s>
2860
2861    --set-icons           Download channel icons and update MythTV to use them
2862    --setpreftitle <s>    Set preferred 'title' source as grabber <s>
2863    --clearpreftitle      Clear preferred 'title' source
2864    --reset               Remove all previous title translation data
2865};
2866    exit 0;
2867}
2868
2869sub dev_help
2870{
2871    print q{Developer options:
2872
2873    These options are probably never useful to regular users.
2874
2875    --dontcallgrabbers    Don't call the grabbers, just process cached data
2876    --list-chan-names     List official channel names
2877    --delete <s>          Delete a Shepherd component
2878    --randomize           Use weighted random method of grabber selection
2879
2880    --sources             List Shepherd sources
2881    --addsource <s>[,p]   Add a Shepherd source (optional: priority #)
2882    --delsource <s>       Delete a Shepherd source (or 'all')
2883   };
2884    exit 0;
2885}
2886
2887
2888# -----------------------------------------
2889# Subs: override handlers for standard perl.
2890# -----------------------------------------
2891
2892# ugly hack. please don't try this at home kids!
2893sub my_die {
2894    my ($arg,@rest) = @_;
2895    my ($pack,$file,$line,$sub) = caller(0);
2896
2897    # check if we are in an eval()
2898    if ($^S) {
2899        printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
2900    } else {
2901            printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
2902            if ($arg) {
2903                CORE::die($arg,@rest);
2904            } else {
2905                CORE::die(join("",@rest));
2906            }
2907    }
2908}
2909
2910
2911# -----------------------------------------
2912# Subs: Grabbing
2913# -----------------------------------------
2914
2915sub grab_data
2916{
2917    my $grab_policy = shift;
2918    $grab_policy = "standard" if (!defined $grab_policy);
2919
2920    $find_microgaps = 0;
2921    $missing_unfillable = undef;
2922
2923    my $used_grabbers = 0;
2924    &log("\nSHEPHERD: Grabber stage ($grab_policy).\n");
2925    &log("SHEPHERD: Seeking supplementary data for episode names ('sub-titles').\n") if ($grab_policy eq 'expanded');
2926    &log("SHEPHERD: " .
2927         (($opt->{mode} and grep($_ eq lc($opt->{mode}), qw(efficiency speed))) ?
2928             ucfirst(lc($opt->{mode})) : 'Quality') . 
2929             " mode.\n");
2930
2931    &analyze_plugin_data("",1,$progname);   
2932
2933    my ($grabber, $reason_chosen);
2934    while (my ($grabber, $reason_chosen) = choose_grabber($grab_policy))
2935    {
2936        last if (!defined $grabber);
2937
2938        $data_satisfies_policy = 0;
2939        $data_found_all = 0;
2940        $used_grabbers++;
2941
2942        &log("\nSHEPHERD: Using grabber: ($used_grabbers) $grabber ($reason_chosen)\n");
2943
2944        my $iteration = query_iteration($grabber);
2945
2946        my $output = sprintf "%s/grabbers/%s/output-%d.xmltv", 
2947                             $CWD, $grabber, $iteration;
2948
2949        my $comm = "$CWD/grabbers/$grabber/$grabber " .
2950                   "--region $region " .
2951                   "--output $output";
2952
2953        if (query_config($grabber, 'option_grabber_settings')) {
2954                $comm .= " " . query_config($grabber, 'option_grabber_settings');
2955        }
2956
2957        # Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
2958        # that we need. Category 2 grabbers are requested to get everything, since there's
2959        # very little cost in grabbing that extra data, and we can use it in the reconciler
2960        # to verify that everything looks OK.
2961        if (query_config($grabber, 'category') == 1)
2962        {
2963            &log("SHEPHERD: Asking $grabber for " . 
2964                 ($find_microgaps ? 'microgaps within ' : '') .
2965                 display_best_timeslice());
2966
2967            # Shepherd internally considers Today == Day 0, but
2968            # grabbers expect Today == Day 1, so add 1.
2969            my $n = $timeslice->{stop} + 1;
2970
2971            # Don't ask the grabber for more than it can provide. This is not
2972            # prevented earlier because we only checked whether the grabber can
2973            # return SOME data within the desired window.
2974            if ($n > query_config($grabber, 'max_days'))
2975            {
2976                $n = query_config($grabber, 'max_days');
2977            }
2978
2979            # Can we use --offset?
2980            if ($timeslice->{start} != 0 and query_config($grabber, 'option_days_offset'))
2981            {
2982                # We want to skip the first X days. We calculate X by taking the
2983                # start day that we want, which is $timeslice->{start}, adding 1
2984                # to convert from Shepherd's "today is day 0" system, then deducting
2985                # 1 because we want to skip until the day before this. So:
2986                my $offset = $timeslice->{start};
2987
2988                $comm .= " " . 
2989                         query_config($grabber, 'option_days_offset') .
2990                         " " .
2991                         $offset;
2992
2993                # 'option_days_offset' / 'option_offset_eats_days'
2994                #
2995                # Grabbers that can skip the first X days of data have the
2996                # 'option_days_offset' flag set in their .conf files.
2997                #
2998                # Of those grabbers that support --offset, there are two
2999                # slightly different interpretations:
3000                #
3001                # --offset 2 --days 3
3002                # Interpretation 1: Grab data for day 3 only.
3003                # Interpretation 2: Grab data for days 3-6 (i.e. skip 2 days,
3004                #                   then grab 3 more).
3005                #
3006                # Most grabbers follow interpretation 1, and they have
3007                # 'option_offset_eats_days' set to indicate this.
3008               
3009                if (!query_config($grabber, 'option_offset_eats_days'))
3010                {
3011                    $n -= $offset;
3012                }
3013            }
3014
3015            $comm .= " " .
3016                     query_config($grabber, 'option_days') .
3017                     " " . 
3018                     $n;
3019           
3020            # Write a temporary channels file specifying only the channels we want
3021            my $tmpchans;
3022            foreach (@{$timeslice->{chans}})
3023            {
3024                $tmpchans->{$_} = $channels->{$_};
3025            }
3026            my $tmpcf = "$CWD/channels.conf.tmp";
3027            write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
3028            $comm .= " --channels_file $tmpcf";
3029
3030            # Create gaps_file if we want less than (roughly) the full day
3031            if ($find_microgaps)
3032            {
3033                my $tmpgf = "$CWD/gaps.tmp";
3034                my $gapstr = record_requested_gaps($tmpgf, $timeslice, $grabber);
3035                $comm .= " --gaps_file $tmpgf";
3036                &log(1, "SHEPHERD: Asking $grabber to fill gaps: $gapstr\n");
3037            }
3038        }
3039        else
3040        {
3041            &log("SHEPHERD: Asking $grabber for days " . 
3042                 ($opt->{offset} ? $opt->{offset} : 0) . 
3043                 " - " . ($days-1). " of all channels\n");
3044            $comm .= " --days $days" if ($days);
3045            $comm .= " --offset $opt->{offset}" if ($opt->{offset});
3046            $comm .= " --channels_file $channels_file";
3047        }
3048
3049        &record_requested_chandays($grabber, $timeslice);
3050
3051        if ((defined $plugin_data->{tor_pid}) &&
3052            (query_config($grabber, 'option_anon_socks'))) {
3053            $comm .= " ".query_config($grabber, 'option_anon_socks')." ".$plugin_data->{tor_address};
3054        }
3055
3056        $comm .= " --debug" if ($debug);
3057        $comm .= " @ARGV" if (@ARGV);
3058
3059        my $retval = 0;
3060        my $msg;
3061        my $component_start = time;
3062        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
3063            &log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
3064            &log(1, "SHEPHERD: would have called: $comm\n");
3065        } else {
3066            &log("SHEPHERD: Executing command: $comm\n");
3067            if (-e $output) {
3068                &log(1, "SHEPHERD: Removing old output file: $output\n");
3069                unlink($output) or &log("SHEPHERD: Failed to remove old output file: $output\n$!\n");
3070            }
3071            ($retval,$msg) = call_prog($grabber,$comm,0,(query_config($grabber,'max_runtime')*60));
3072        }
3073        my $component_duration = time - $component_start;
3074
3075        if ($retval) {
3076            &log("Grabber exited with non-zero code $retval: assuming it failed.\n" .
3077                 "Last message: \"$msg\"\n");
3078            $components->{$grabber}->{laststatus} = "Failed (code $retval)";
3079            $components->{$grabber}->{consecutive_failures}++;
3080            &add_pending_message($grabber,"FAIL", $retval.":".$msg, $component_start, $component_duration, 
3081                $components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
3082            next;
3083        }
3084
3085        # soak up the data we just collected
3086        &soak_up_data($grabber, $output, "grabber", $grab_policy);
3087        $components->{$grabber}->{laststatus} = $plugin_data->{"$grabber-$iteration"}->{laststatus};
3088
3089        # analyze the data that this grabber returned
3090        # (useful to detect individual components going bad and report them upstream)
3091        &analyze_plugin_data("grabber $grabber", 1, $grabber, $iteration);
3092
3093        if ($plugin_data->{"$grabber-$iteration"}->{valid}) {
3094            $components->{$grabber}->{lastdata} = time;
3095            delete $components->{$grabber}->{consecutive_failures}
3096              if (defined $components->{$grabber}->{consecutive_failures});
3097            &add_pending_message($grabber,"SUCCESS", $retval, $component_start, $component_duration, 
3098                $components->{$grabber}->{ver}, ($plugin_data->{"$grabber-$iteration"}->{total_duration}/60) );
3099        } else {
3100            $components->{$grabber}->{laststatus} = sprintf "Failed (%s)", $plugin_data->{"$grabber-$iteration"}->{failure_reason};
3101            $components->{$grabber}->{consecutive_failures}++;
3102            &add_pending_message($grabber,"FAIL", '0:'.$plugin_data->{"$grabber-$iteration"}->{failure_reason},
3103                $component_start, $component_duration, $components->{$grabber}->{ver}, 
3104                $components->{$grabber}->{consecutive_failures});
3105            # Don't report MISSING_DATA if the component failed
3106            delete $pending_messages->{"$grabber-$iteration"}->{MISSING_DATA};
3107        }
3108
3109        # check to see if we have all the data we want
3110        $data_satisfies_policy = &analyze_plugin_data("analysis of all grabbers so far",0,$progname);
3111
3112        my $missing_before = convert_dayhash_to_list($missing);
3113        my $missing_after = convert_dayhash_to_list(detect_missing_data($grab_policy, 1));
3114        my $list = List::Compare->new($missing_before, $missing_after);
3115        my @grabbed = $list->get_symmetric_difference();
3116        &log("SHEPHERD: Filled " . scalar(@grabbed) . " channel-days with new data from $grabber.\n");
3117        &log(1, "SHEPHERD: Channel-days acquired: " . join (', ', @grabbed) . ".\n");
3118
3119        # Record what we grabbed from cacheable C1 grabbers
3120        if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
3121        {
3122            record_cached($grabber, @grabbed);
3123            write_config_file();
3124        }
3125
3126        # Force paytv to exit because analysis is only for freetv (could maybe move this higher)
3127        if ($grab_policy eq "paytv") {
3128                $data_satisfies_policy = 1;
3129                $data_found_all = 1;
3130                last;
3131        }
3132
3133        last if ($data_found_all);
3134        if ($data_satisfies_policy and $grab_policy ne 'expanded')
3135        {
3136            $find_microgaps = 1;
3137        }
3138    }
3139
3140    if ($used_grabbers == 0)
3141    {
3142        &log("SHEPHERD: No valid grabbers available for $grab_policy stage.\n");
3143    }
3144    elsif (!$data_satisfies_policy)
3145    {
3146        &log("SHEPHERD: Ran through all grabbers but still have policy-violating gaps in data. :(\n");
3147    }
3148    elsif (!$data_found_all)
3149    {
3150        &log("SHEPHERD: Unfillable micro-gaps exist in data.\n");
3151    }
3152}
3153
3154sub query_iteration
3155{
3156    my $grabber = shift;
3157
3158    my $i = 0;
3159    while (1)
3160    {
3161        return $i unless (defined $plugin_data->{"$grabber-$i"});
3162        $i++;
3163        die "Insane infinite loop suspected!" if ($i > 15);
3164    }
3165}
3166
3167# -----------------------------------------
3168# Subs: Intelli-random grabber selection
3169# -----------------------------------------
3170
3171sub choose_grabber
3172{
3173    my $grabber_policy = shift;
3174
3175    $missing = detect_missing_data($grabber_policy) if ($grabber_policy ne "paytv");
3176    my $total;
3177
3178    do { # while (!$total);
3179
3180        if (defined $gscore)    # Reset score hash
3181        {
3182            foreach (keys %$gscore)
3183            {
3184                $gscore->{$_} = 0;
3185            }
3186        }
3187        else                    # Create score hash
3188        {
3189            foreach (query_grabbers())
3190            {
3191                unless (($components->{$_}->{disabled}) || (defined $plugin_data->{$_}->{failed_test}))
3192                {
3193                    $gscore->{$_} = 0;
3194                    if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
3195                    {
3196                        $gscore->{$_ . ' [cache]'} = 0;
3197                    }
3198                }
3199            }
3200        }
3201
3202        if ($grabber_policy ne "paytv") {
3203            # no point calling these on paytv channels - paytv channels are always $opt_channels ..
3204
3205            remove_missing_unfillable();
3206            $timeslice = find_best_timeslice();
3207
3208            if ($timeslice->{chandays} == 0 && !$find_microgaps and $grabber_policy eq 'standard') {
3209                &log("SHEPHERD: No fillable timeslices, trying microgaps!\n\n");
3210                $find_microgaps = 1;
3211                $missing = detect_missing_data($grabber_policy);
3212                remove_missing_unfillable();
3213                $timeslice = find_best_timeslice();
3214            }
3215
3216            if ($timeslice->{chandays} == 0) {
3217                &log("SHEPHERD: No fillable timeslices!\n");
3218                return undef;
3219            }
3220
3221            &log("SHEPHERD: Best timeslice: " . display_best_timeslice());
3222        } else {
3223            # if we are grabbing paytv, remove grabbers that can't provide paytv data
3224            foreach my $grabber (keys %$gscore) {
3225                # Only want grabbers of type 'paytv' or 'both' (undef == FTA)
3226                if (!query_config($grabber, 'type')) {
3227                    delete $gscore->{$grabber};
3228                } else {
3229                    # can this grabber provide any channels we are interested in?
3230                    my $channels_supported = query_config($grabber, 'channels');
3231                    unless (defined $channels_supported)
3232                    {
3233                        &log("WARNING: Grabber $grabber has no channel support " .
3234                        "specified in config.\n");
3235                        $channels_supported = '';
3236                    }
3237
3238                    my $matching_channels = 0;
3239                    if ($channels_supported) {
3240                        if (($channels_supported =~/^-/)) {
3241                            # find a non-matching channel
3242                            foreach my $ch (keys %$opt_channels) {
3243                                if ($channels_supported !~ /\b$ch\b/) {
3244                                    $matching_channels = 1;
3245                                    last;
3246                                }
3247                            }
3248                        } else {
3249                            # find a matching channel
3250                            foreach my $ch (keys %$opt_channels) {
3251                                if ($channels_supported =~ /\b$ch\b/) {
3252                                    $matching_channels = 1;
3253                                    last;
3254                                }
3255                            }
3256                        }
3257                    } else {
3258                        # Empty string means we support all
3259                        $matching_channels = 1;
3260                    }
3261                    delete $gscore->{$grabber} if ($matching_channels == 0);
3262                }
3263            }
3264        }
3265
3266        $total = score_grabbers($grabber_policy);
3267 
3268        &log("SHEPHERD: Scoring grabbers on ability to efficiently provide needed data:\n");
3269        &log("SHEPHERD: Only considering micro-grabbers.\n") if ($find_microgaps);
3270        foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
3271        {
3272            next if ($_ =~ /\[cache\]/);
3273
3274            my $score  = $gscore->{$_};
3275            my $cscore = $gscore->{"$_ [cache]"};
3276            my $cstr   = $cscore ? "(inc. $cscore cache pts) " : "";
3277            $cstr .= "(already called)" if (($score == 0) && ($grabber_policy eq "paytv"));
3278
3279            if ($opt->{randomize})
3280            {
3281                &log(sprintf "%22s %6.1f%% %8d %s\n",
3282                            $_, 
3283                            ($total ? 100* $score / $total : 0), 
3284                            "$score pts",
3285                            $cstr);
3286            }
3287            else
3288            {
3289                &log(sprintf "%22s %8d pts %s\n",
3290                            $_, 
3291                            $score,
3292                            $cstr);
3293            }
3294        }
3295
3296        if ($opt->{grabwith})
3297        {
3298            my @a = split(/,/, $opt->{grabwith});
3299            my $g;
3300            while ($g = shift @a)
3301            {
3302                $opt->{grabwith} = (@a ? join(',', @a) : undef);
3303
3304                if ($components->{$g}->{disabled})
3305                {
3306                    &log("\nSkipping --grabwith grabber \"$g\": it is disabled.\n");
3307                    next;
3308                }
3309
3310                &log("\nObeying --grabwith option: selecting grabber \"$g\".\n");
3311                if ($components->{$g} and $components->{$g}->{type} eq 'grabber')
3312                {
3313                    return(select_grabber($g, $gscore), "--grabwith policy");
3314                }
3315                &log("Not a grabber: \"$g\".\n");
3316            }
3317        }
3318
3319        return undef if $grabber_policy eq "paytv" && !$total;
3320
3321        if (!$total) { # $grabber_policy ne "paytv"
3322            &log("SHEPHERD: Unfillable timeslice.\n\n");
3323            add_timeslice_to_missing_unfillable();
3324        }
3325
3326    } while (!$total); # $grabber_policy ne "paytv"
3327
3328    # If the user has specified a pref_title_source -- i.e. he is
3329    # transitioning from a known grabber -- then we make sure it
3330    # has run at least once, to build the list of title translations.
3331    if ($pref_title_source)
3332    {
3333        my @prefs = split(/,/, $pref_title_source);
3334        foreach my $grabber (@prefs)
3335        {
3336            unless ($components->{$grabber}->{lastdata})
3337            {
3338                &log("Need to build title translation list for transitional grabber $grabber.\n");
3339                return(select_grabber($grabber, $gscore), "transitional for title translation") if ($gscore->{$grabber});
3340                &log("WARNING: Can't run $grabber to build title translation list!\n");
3341            }
3342        }
3343    }
3344
3345    # If run with --randomize, then rather than always selecting the highest-scoring
3346    # grabber first we'll make a weighted random selection.
3347    if ($opt->{randomize})
3348    {
3349        my $r = int(rand($total));
3350        my $c = 0;
3351        foreach my $grabber (keys %$gscore)
3352        {
3353            next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
3354            if ($r >= $c and $r < ($c + $gscore->{$grabber}))
3355            {
3356                return(select_grabber($grabber, $gscore), "--randomize weighted policy");
3357            }
3358            $c += $gscore->{$grabber};
3359        }
3360        die "ERROR: failed to choose grabber.";
3361    }
3362
3363    # Choose grabber with best score. If there are multiple grabbers with the
3364    # best score, randomly select one of them.
3365    my @sorted = sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore;
3366    my @candidates = ( $sorted[0] );
3367    my $c = 1;
3368    while ($c < @sorted and $gscore->{$sorted[$c]} == $gscore->{$sorted[0]})
3369    {
3370        push @candidates, $sorted[$c] unless ($sorted[$c] =~ /\[cache\]/);
3371        $c++;
3372    }
3373
3374    my $num_choices = grep (($gscore->{$_} and $_ !~ /\[cache\]/), @sorted);
3375    if (@candidates > 1)
3376    {
3377        &log("Multiple grabbers with best score: @candidates.\n");
3378        return(select_grabber($candidates[int(rand(scalar(@candidates)))], $gscore),
3379                        "equal best of $num_choices options, randomly selected from " .
3380                        (scalar(@candidates)-1) .
3381                        " peer" . 
3382                        (@candidates > 2 ? 's' : ''));
3383    }
3384    return(select_grabber($candidates[0], $gscore),
3385            $num_choices == 1 ? "only option" : "best of $num_choices options");
3386}
3387
3388sub select_grabber
3389{
3390    my ($grabber, $gscore) = @_;
3391
3392    &log(1, "Selected $grabber.\n");
3393    if (query_config($grabber, 'category') == 2)
3394    {
3395        # We might want to run C1 grabbers multiple times
3396        # to grab various timeslices, but not C2 grabbers,
3397        # which should get everything at once.
3398        delete $gscore->{$grabber};
3399    }
3400    return $grabber;
3401}
3402
3403# Grabbers earn 1 point for each slot or chanday they can fill.
3404# This score is multiplied if the grabber:
3405# * is a category 2 grabber (i.e. fast/cheap)
3406# * is a category 1 grabber that has the data we want in a cache
3407# * can supply high-quality data
3408# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
3409sub score_grabbers
3410{
3411    my $grabber_policy = shift;
3412    my ($total, $key);
3413
3414    my $bestdq = 0;
3415
3416    # Compare C2 grabbers against the raw missing file, because we'll get
3417    # everything. But compare C1 grabbers against the timeslice, because we'll
3418    # only ask them for a slice. This goes for the [cache] and regular C1s.
3419    foreach my $grabber (keys %$gscore)
3420    {
3421        # for each slot, say whether we can fill it or not -- that is,
3422        # whether we support this channel and this day #.
3423
3424        my $hits = 0;
3425        my $cat = query_config($grabber, 'category');
3426        my $dq = query_config($grabber, 'quality');
3427
3428        if ($cat == 1)
3429        {
3430            $key = cut_down_missing($grabber);
3431            # &log(1, "Grabber $grabber is Category 1: comparing capability to best timeslice.\n");
3432        }
3433        else
3434        {
3435            $key = $missing;
3436            # &log(1, "Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n");
3437        }
3438
3439        if ($grabber_policy eq 'expanded' and ($cat != 2 or !&query_config($grabber, 'has_subtitles')))
3440        {
3441            $hits = 0;
3442        }
3443        elsif (!supports_region($grabber))
3444        {
3445#           &log(1, "Zeroing $grabber due to no region support\n");
3446            $hits = 0;
3447        }
3448        elsif (($find_microgaps) and (!query_config($grabber, 'micrograbs')))
3449        {
3450#           &log(1, "Zeroing $grabber due to non-micrograbbing\n");
3451            $hits = 0;
3452        }
3453        elsif ($grabber =~ /\[cache\]/)
3454        {
3455            $hits = find_cache_hits($grabber, $key);
3456        }
3457        elsif ($grabber_policy eq "paytv")
3458        {
3459                foreach my $day (($opt->{offset} ? $opt->{offset} : 0) .. $days-1)
3460                {
3461                        my $val = supports_day($grabber, $day);
3462                        next unless ($val);
3463                        foreach my $ch (keys %$opt_channels)
3464                        {
3465                                $hits += $val * &supports_channel($grabber, $ch, $day);
3466                        }
3467                        $hits = 1 if ($hits > 0 and $hits < 1);
3468                }
3469        }
3470        else
3471        {
3472                foreach my $day (sort keys %$key)
3473                {
3474                        my $val = supports_day($grabber, $day);
3475                        next unless ($val);
3476                        # &log(1, "Day $day:");
3477                        foreach my $ch (@{$key->{$day}})
3478                        {
3479                                $hits += $val * &supports_channel($grabber, $ch, $day)
3480                        }
3481                        $hits = 1 if ($hits > 0 and $hits < 1);
3482                }
3483        }
3484
3485        $dq -= 0.8 if (!&query_config($grabber, 'has_subtitles'));
3486
3487        my $score = 0;
3488        if ($grabber =~ /\[cache\]/)
3489        {
3490            # Bonus is on a sliding scale between 1 and 2 depending on
3491            # % of required data in cache
3492            $score = $hits;
3493        }
3494        elsif ($hits)
3495        {
3496            if ($opt->{mode} and lc($opt->{mode}) eq 'efficiency')
3497            {
3498                $score += 1000 * ($cat - 1);
3499                $score += 400 * ($dq - 1);
3500                $score += $hits;
3501                $score -= 0.2 * $hits if (&query_config($grabber, 'has_noncritical_gaps'));
3502            }
3503            elsif ($opt->{mode} and lc($opt->{mode} eq 'speed'))
3504            {
3505                $score += 2000 * ($cat - 1);
3506                $score += 100 * ($dq - 1);
3507                $score += $hits;
3508                $score -= 0.1 * $hits if (&query_config($grabber, 'has_noncritical_gaps'));
3509            }
3510            else        # Quality mode
3511            {
3512                $score += 1000 * ($dq - 1);
3513                $score += 500 * ($cat - 1);
3514                $score += $hits;
3515                $score -= 0.2 * $hits if (&query_config($grabber, 'has_noncritical_gaps'));
3516            }
3517        }
3518
3519        if ($debug)
3520        {
3521            my $str = sprintf "Grabber %s can supply %d chandays", $grabber, $hits;
3522            $str .= sprintf(" (cat: %d, DQ: %d): %d pts",
3523                            $cat,
3524                            $dq,
3525                            $score) if ($hits);
3526            &log(1, "$str.\n");
3527        }
3528
3529        if ($score and query_config($grabber, 'option_anon_socks') and !defined $plugin_data->{tor_pid}) 
3530        {
3531#           &log(1, "Grabber $grabber needs Tor to run efficiently: reducing score.\n");
3532            $score = int($score/10)+1;
3533        }
3534
3535        $gscore->{$grabber} += $score;
3536        $total += $score;
3537        if ($grabber =~ /\[cache\]/)
3538        {
3539            $gscore->{query_name($grabber)} += $score;
3540        }
3541
3542        if ($score and $dq > $bestdq)
3543        {
3544            $bestdq = $dq;
3545        }
3546    }
3547   
3548    # Eliminate grabbers of data quality 1 if there are any better-quality
3549    # alternatives. (Only need to do this with 'randomize' option, since otherwise
3550    # we will always pick the highest score.)
3551    if ($opt->{randomize})
3552    {
3553        foreach (keys %$gscore)
3554        {
3555            if (query_config($_, 'quality') == 1 and $bestdq > 1)
3556            {
3557                $total -= $gscore->{$_};
3558                $gscore->{$_} = 0;
3559#               &log(1, "Zeroing grabber $_ due to low data quality.\n");
3560            }
3561        }
3562    }
3563
3564    return $total;
3565}
3566
3567# Return 1 if the grabber can provide data for this channel,
3568# 0.5 if it supports it unreliably, and 0 if it doesn't support
3569# it at all May optionally be sent 'day' arg, which allows
3570# specific checking to see if the channel is supported for that
3571# day number.
3572#
3573# Note that Shepherd considers today to be Day 0, so a grabber
3574# that says it can grab 7 days of data supports Day 0 to Day 6.
3575sub supports_channel
3576{
3577    my ($grabber, $ch, $day) = @_;
3578
3579    my $val = 1;
3580
3581    # If grabber has 'max_reliable_days_per_channel' specified, and
3582    # we're looking at a channel and day that's outside that, we'll
3583    # never return more than a value of 0.5.
3584    my $mdpc = query_config($grabber, 'max_reliable_days_per_chan');
3585    $val = 0.5 if ($mdpc and defined $day and $mdpc->{$ch} and $day >= $mdpc->{$ch});
3586
3587    # If grabber has a 'max_days_per_chan' specified that includes
3588    # the channel we're looking at, return 0 if we're outside it and
3589    # 1 if we're within it (or 0.5 if modified by the previous check).
3590    $mdpc = query_config($grabber, 'max_days_per_chan');
3591    return ($day >= $mdpc->{$ch} ? 0 : $val) if ($mdpc and defined $day and $mdpc->{$ch});
3592
3593    $ch =~ s/ /_/g;
3594
3595    # Does this grabber have any channel support exceptions? If so,
3596    # see if the wanted channel is listed for our region.
3597    my $exceptions = query_config($grabber, 'channel_support_exceptions');
3598    if ($exceptions and $exceptions =~ /\b$region:(-?)\S*\b$ch\b/)
3599    {
3600        return ($1 ne '-' ? $val : 0);
3601    }
3602
3603    # No special regional exemptions, so check the main support string.
3604
3605    my $channels_supported = query_config($grabber, 'channels');
3606    unless (defined $channels_supported)
3607    {
3608        &log("WARNING: Grabber $grabber has no channel support " .
3609             "specified in config.\n");
3610        $channels_supported = '';
3611    }
3612
3613    return $val unless ($channels_supported); # Empty string means we support all
3614   
3615    my $match = ($channels_supported =~ /\b$ch\b/);
3616    $exceptions = ($channels_supported =~/^-/);
3617    return ($match != $exceptions ? $val : 0);
3618}
3619
3620# Returns 1 if the grabber supports our set region, else 0
3621sub supports_region
3622{
3623    my ($grabber) = @_;
3624
3625    my $rsupport = query_config($grabber, 'regions');
3626    return 1 unless ($rsupport);    # Empty string means full support
3627
3628    my $match = ($rsupport =~ /\b$region\b/);
3629    my $exceptions = ($rsupport =~/^-/);
3630    return ($match != $exceptions);
3631}
3632
3633# Return 0 if the grabber can't provide data for this day,
3634# 1 if it can reliably, and 0.5 if it can unreliably.
3635#
3636# Note that a max_days of 7 means the grabber can retrieve data for
3637# today plus 6 days.
3638sub supports_day
3639{
3640    my ($grabber, $day) = @_;
3641
3642    return 0 unless ($day < query_config($grabber, 'max_days'));
3643    return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
3644    return 1;
3645}
3646
3647sub find_cache_hits
3648{
3649    my ($grabber, $key) = @_;
3650
3651    $grabber = query_name($grabber);
3652
3653    return 0 unless ($components->{$grabber}->{cached});
3654
3655    my $hits = 0;
3656
3657    foreach my $day (keys %$key)
3658    {
3659        next unless (supports_day($grabber, $day));
3660        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
3661        foreach my $ch (@{$key->{$day}})
3662        {
3663            next unless (supports_channel($grabber, $ch, $day));
3664            $hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
3665        }
3666    }
3667    return $hits;
3668}
3669
3670# Build a dayhash of what channel/day data we're currently missing.
3671# Only policy-violating holes count unless $find_microgaps is set.
3672sub detect_missing_data
3673{
3674    my ($grabber_policy, $quiet) = @_;
3675
3676    my $m = { };
3677
3678    &log("SHEPHERD: Hunting for microgaps!\n") if ($find_microgaps and !$quiet);
3679    foreach my $ch (keys %$channels)
3680    {
3681        # is this channel missing too much data?
3682        if ($find_microgaps)
3683        {
3684            my $lastday = -1;
3685            foreach my $line (@{$channel_data->{$ch}->{analysis}->{missing_all}})
3686            {
3687                $line =~ /^#(\d)/ or die "Bad line $line";
3688                my $day = $1;
3689                unless ($day == $lastday)
3690                {
3691                    push (@{($m->{$day})}, $ch);
3692                    $lastday = $day;
3693                }
3694            }
3695        }
3696        elsif ($grabber_policy eq 'expanded')
3697        {
3698            # Search our guide data for any channel-days that were filled
3699            # by grabbers that don't support sub-titles.
3700
3701            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})})
3702            {
3703                next unless ($day and keys %$day);
3704
3705                my $str;
3706
3707                foreach my $plugin (keys %$plugin_data)
3708                {
3709                    next unless ($plugin =~ /^(.*)-\d+$/);
3710                    my $pluginname = $1;
3711
3712                    next unless ($components->{$pluginname} and $components->{$pluginname}->{type} eq 'grabber');
3713
3714                    if ($plugin_data->{$plugin}->{analysis}->{$ch}->{day}->[$day->{num}]->{have})
3715                    {
3716                        # This grabber has supplied some data for this channel-day
3717   
3718                        if (&query_config($pluginname, 'has_subtitles'))
3719                        {
3720                            # The grabber supports subtitles
3721       
3722                            if (!$plugin_data->{$plugin}->{analysis}->{$ch}->{day}->[$day->{num}]->{missing})
3723                            {
3724                                # A subtitle-supporting grabber supplied this channel-day;
3725                                # no need for further data.
3726
3727                                $m->{$day->{num}} = [ grep($_ ne $ch, @{$m->{$day->{num}}}) ];
3728                                delete $m->{$day->{num}} unless (@{$m->{$day->{num}}});
3729                                undef $str;
3730                                last;
3731                            }
3732
3733                            # Otherwise this grabber didn't fill the whole day, so
3734                            # we still should seek data
3735                        }
3736                        else
3737                        {
3738                            # The grabber that supplied data doesn't support sub-titles;
3739                            # add this channel-day to our list of holes.
3740
3741                            $str = "May lack episode names: $ch day $day->{num} (filled by $pluginname)\n";
3742                            push(@{($m->{($day->{num})})}, $ch);
3743                        }
3744                    }
3745                }
3746                &log(1, "SHEPHERD: $str") if ($str);    # If we get this far, it's a 'suspect' channel-day
3747            }
3748        }
3749        elsif (!$channel_data->{$ch}->{analysis}->{data_ok}) 
3750        {
3751            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) 
3752            {
3753                next unless ($day and keys %$day); 
3754                push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
3755            }
3756        }
3757    }
3758
3759    my @chans;
3760    foreach my $day (keys %$m)
3761    {
3762        $m->{$day} = [ sort @{$m->{$day}} ];
3763        foreach my $ch (@{$m->{$day}})
3764        {
3765            push (@chans, $ch) unless (grep ($_ eq $ch, @chans));
3766        }
3767    }
3768
3769    &log(sprintf "SHEPHERD: Need %d channel-days of data (%d channels across %d days).\n",
3770                 scalar(keys %$m) * @chans,
3771                 scalar(@chans),
3772                 scalar(keys %$m)
3773             ) if (keys %$m and !$quiet);
3774    return $m;
3775}
3776
3777# Find the largest timeslice in the current $missing dayhash; i.e.
3778# something like "Days 4 - 6 of ABC and SBS." This works by iterating
3779# through the days and looking for overlaps where consecutive days
3780# want the same channels.
3781sub find_best_timeslice
3782{
3783    my ($overlap, $a);
3784    my $slice = { 'chandays' => 0 };
3785
3786    foreach my $day (($opt->{offset} ? $opt->{offset} : 0) .. $days-1)
3787    {
3788        consider_slice($slice, $day, $day, @{$missing->{$day}});
3789        $overlap = $missing->{$day};
3790        foreach my $nextday (($day + 1) .. $days-1)
3791        {
3792            last unless ($missing->{$nextday});
3793            $a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
3794            last unless ($a and @{$a});
3795            consider_slice($slice, $day, $nextday, @{$a});
3796            $overlap = $a;
3797        }
3798    }
3799    return $slice;
3800}
3801
3802sub consider_slice
3803{
3804    my ($slice, $startday, $stopday, @chans) = @_;
3805
3806    my $challenger = ($stopday - $startday + 1) * scalar(@chans);
3807    return unless ($challenger > $slice->{chandays});
3808
3809    # We have a winner!
3810    $slice->{start} = $startday;
3811    $slice->{stop} = $stopday;
3812    $slice->{chans} = [ @chans ];
3813    $slice->{chandays} = $challenger;
3814}
3815
3816sub remove_missing_unfillable
3817{
3818    foreach my $day (keys %{$missing_unfillable}) {
3819        next if !defined $missing->{$day};
3820        foreach my $ch (@{$missing_unfillable->{$day}}) {
3821                @{$missing->{$day}} = grep($_ ne $ch, @{$missing->{$day}});
3822        }
3823    }
3824}
3825
3826sub add_timeslice_to_missing_unfillable
3827{
3828    foreach my $day ($timeslice->{start} .. $timeslice->{stop}) {
3829        foreach my $ch (@{$timeslice->{chans}}) {
3830                push(@{$missing_unfillable->{$day}}, $ch)
3831                                unless grep($_ eq $ch, @{$missing_unfillable->{$day}});
3832        }
3833    }
3834}
3835
3836sub display_best_timeslice
3837{
3838    return sprintf "day%s of channel%s %s (%d channel-day%s).\n",
3839                   ($timeslice->{start} == $timeslice->{stop} ?
3840                       " $timeslice->{start}" :
3841                       "s $timeslice->{start} - $timeslice->{stop}"),
3842                   (@{$timeslice->{chans}} > 1 ? 's' : ''),
3843                   join(', ', @{$timeslice->{chans}}),
3844                   $timeslice->{chandays},
3845                   $timeslice->{chandays} == 1 ? '' : 's';
3846}
3847
3848# Creates temporary gaps file suitable for passing to grabbers with
3849# --gaps_file option, and records the requested buckets for later
3850# analysis by analyze_plugin_data().
3851sub record_requested_gaps
3852{
3853    my ($fn, $timeslice, $grabber) = @_;
3854
3855    my $gaps;
3856    my $gapstr = '';
3857
3858    # Clear any previously-set gaps
3859    delete $plugin_data->{$grabber}->{requested_gaps};
3860
3861    my $timeslice_epoch_start = $policy{starttime} + ($timeslice->{start} * 24 * 60 * 60);
3862    my $timeslice_epoch_end = $policy{starttime} + (($timeslice->{stop} + 1) * 24 * 60 * 60);
3863
3864    foreach my $ch (@{$timeslice->{chans}})
3865    {
3866        my $missinglist = $channel_data->{$ch}->{analysis}->{missing_all_epoch};
3867        my @a = split(/,/, $missinglist);
3868        foreach my $period (@a)
3869        {
3870            $period =~ /(\d+)-(\d+)/;
3871            my ($gap_start, $gap_end) = ($1, $2);
3872            if ($gap_start < $timeslice_epoch_end or $gap_end > $timeslice_epoch_start)
3873            {
3874                # we want this period
3875                push (@{$gaps->{$ch}}, $period);
3876
3877                # record as requested
3878                for (my $etime = $gap_start; $etime <= $gap_end; $etime += $policy{timeslot_size})
3879                {
3880                    my $bucket = ($etime - $policy{starttime}) / $policy{timeslot_size};
3881                    push @{$plugin_data->{$grabber}->{requested_gaps}->{$ch}}, $bucket;
3882                }
3883            }
3884        }
3885        $gapstr .= "$ch:" . join(',', @{$gaps->{$ch}}) . ' ' if ($gaps->{$ch});
3886    }
3887
3888    write_file($fn, 'temporary gaps file', [ $gaps ], [ 'gaps' ]);
3889
3890    return $gapstr;
3891}
3892
3893# Record what a cacheable C1 grabber has just retrieved for us,
3894# so we know next time that this data can be grabbed quickly.
3895sub record_cached
3896{
3897    my ($grabber, @grabbed) = @_;
3898
3899    &log(1, "SHEPHERD: Recording cache for grabber $grabber.\n");
3900
3901    my $gcache = $components->{$grabber}->{cached};
3902    $gcache = [ ] unless ($gcache);
3903    my @newcache;
3904    my $today = strftime("%Y%m%d", localtime);
3905
3906    # remove old chandays
3907    foreach my $chanday (@$gcache)
3908    {
3909        $chanday =~ /(\d+):(.*)/;
3910        if ($1 >= $today)
3911        {
3912            push (@newcache, $chanday);
3913        }
3914    }
3915
3916    # record new chandays
3917    foreach my $chanday (@grabbed)
3918    {
3919        push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
3920    }
3921    $components->{$grabber}->{cached} = [ @newcache ];
3922}
3923
3924# Takes a dayhash and returns it as a list like this:
3925# ( "20061018:ABC", "20061018:Seven", ... )
3926sub convert_dayhash_to_list
3927{
3928    my $h = shift;
3929
3930    my @ret;
3931    foreach my $day (keys %$h)
3932    {
3933        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
3934        foreach my $ch (@{$h->{$day}})
3935        {
3936            push (@ret, "$date:$ch");
3937        }
3938    }
3939    @ret = sort @ret;
3940    return \@ret;
3941}
3942
3943
3944# If we're about to re-try a grabber, make sure that we're not asking
3945# it for the same data. That is, prevent a broken C1 grabber causing
3946# an infinite loop.
3947sub record_requested_chandays
3948{
3949    my ($grabber, $slice) = @_;
3950
3951    &log(1, "SHEPHERD: Recording timeslice request; will not request these chandays " .
3952            "from $grabber again.\n");
3953
3954    # Clear out anything set previously
3955    delete $plugin_data->{$grabber}->{requested_data};
3956
3957    my @requested;
3958    for my $day ($slice->{start} .. $slice->{stop})
3959    {
3960        foreach my $ch (@{$slice->{chans}})
3961        {
3962            push @requested, "$day:$ch";
3963            $plugin_data->{$grabber}->{requested_data}->{$ch}[$day] = 1;
3964            # &log(1, "  requesting ch $ch on day $day\n");
3965        }
3966    }
3967    if ($grabbed->{$grabber})
3968    {
3969        push @{$grabbed->{$grabber}}, @requested;
3970    }
3971    else
3972    {
3973        $grabbed->{$grabber} = [ @requested ];
3974    }
3975}
3976
3977# If this grabber has been called previously, remove those chandays
3978# from the current request -- we don't want to ask it over and over
3979# for a timeslice that it has already failed to provide.
3980sub cut_down_missing
3981{
3982    my $grabber = shift;
3983
3984    $grabber = query_name($grabber);
3985    my $dayhash = {};
3986
3987    # Take the timeslice and expand it to a dayhash, while pruning
3988    # any chandays that have previously been requested from this
3989    # grabber.
3990    foreach my $day ($timeslice->{start} .. $timeslice->{stop})
3991    {
3992        my @chans;
3993        foreach my $ch (@{$timeslice->{chans}})
3994        {
3995            unless ($grabbed->{$grabber} and grep($_ eq "$day:$ch", @{$grabbed->{$grabber}}))
3996            {
3997                push (@chans, $ch)
3998            }
3999        }
4000        $dayhash->{$day} = [ @chans ] if (@chans);
4001    }
4002
4003    return $dayhash;
4004}
4005
4006# -----------------------------------------
4007# Subs: Analyzing data
4008# -----------------------------------------
4009
4010# interpret xmltv data from this grabber/postprocessor
4011sub soak_up_data
4012{
4013    my ($pluginname, $output, $plugintype, $stage) = @_;
4014
4015    $components_used .= sprintf " + %s(v%s)", $pluginname, $components->{$pluginname}->{ver};
4016    $components_used .= "[tainted]" if (defined $plugin_data->{$pluginname}->{tainted});
4017
4018    if ($plugintype eq "grabber") {
4019        if ((defined $stage) && ($stage eq "paytv")) {
4020            $components_used .= "[ptv]";
4021        } else {
4022            $components_used .= "[m]" if ($find_microgaps);
4023        }
4024    }
4025
4026    my $plugin = $pluginname;
4027    if ($plugintype eq 'grabber')
4028    {
4029        $plugin .= '-' . query_iteration($pluginname);
4030    }
4031
4032    if (! -r $output) {
4033        &log("SHEPHERD: Error: plugin '$pluginname' output file '$output' does not exist\n");
4034        $components_used .= "[failed_notfound]";
4035        $plugin_data->{$plugin}->{failure_reason} = 'no XMLTV output';
4036        return;
4037    }
4038
4039    my $this_plugin = $plugin_data->{$plugin};
4040    &log("SHEPHERD: Started parsing XMLTV from '$pluginname' in '$output' .. any errors below are from parser:\n");
4041    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
4042    &log("SHEPHERD: Completed XMLTV parsing from '$pluginname'\n");
4043
4044    # Note: as far as I can tell, XMLTV will ALWAYS return an {xmltv} field, even
4045    # if it was unable to parse the file, which makes this little block useless
4046    if (!($this_plugin->{xmltv})) {
4047        &log("WARNING: Plugin $pluginname didn't seem to return valid XMLTV!\n");
4048        $components_used .= "[failed_invalid]";
4049        $plugin_data->{$plugin}->{failure_reason} = 'invalid XMLTV';
4050        return;
4051    }
4052
4053    $this_plugin->{name} = $pluginname;
4054    $this_plugin->{valid} = 1;
4055    $this_plugin->{output_filename} = $output;
4056
4057    my $xmltv = $this_plugin->{xmltv};
4058    my ($encoding, $credits, $chan, $progs) = @$xmltv;
4059
4060    # explicitly track unparsable dates, excessive durations, etc
4061    foreach ( qw( programmes total_duration progs_with_invalid_date progs_too_long progs_too_short progs_with_unknown channel progs_outside_window progs_optional progs_tba))
4062    {
4063        $this_plugin->{$_} = 0;
4064    }
4065
4066    my $seen_channels_with_data = 0;
4067
4068    #
4069    # first iterate through all programmes and see if there are any channels we don't know about
4070    #
4071    my %chan_xml_list;
4072    foreach my $ch (sort keys %{$channels}) {
4073        $chan_xml_list{($channels->{$ch})} = $ch;
4074    }
4075    foreach my $ch (sort keys %{$opt_channels}) {
4076        $chan_xml_list{($opt_channels->{$ch})} = $ch;
4077    }
4078    foreach my $prog (@$progs) {
4079        if (!defined $chan_xml_list{($prog->{channel})}) {
4080            $this_plugin->{progs_with_unknown_channel}++;
4081            &log((sprintf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$pluginname,$prog->{channel}));
4082            $chan_xml_list{($prog->{channel})} = 1;     # so we warn only once
4083        }
4084    }
4085       
4086    # iterate thru channels
4087    foreach my $ch_xmlid (sort keys %chan_xml_list) {
4088        my $seen_progs_on_this_channel = 0;
4089        my $ch = $chan_xml_list{$ch_xmlid};
4090
4091        # iterate thru programmes per channel
4092        foreach my $prog (@$progs) {
4093            next if ($prog->{channel} ne $ch_xmlid);
4094
4095            my $t1 = &parse_xmltv_date($prog->{start});
4096            # Deduct 1 second from end time, so that a show that finishes at
4097            # 2AM is considered to finish at 1:59.59AM, and does not fill
4098            # the 2AM - 2:05AM bucket.
4099            my $t2 = &parse_xmltv_date($prog->{stop}) - 1;
4100
4101            if (!$t1 || !$t2) {
4102                &log((sprintf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
4103                    $pluginname,(!$t1 ? $prog->{start} : $prog->{stop}))) if (!$this_plugin->{progs_with_invalid_date});
4104                $this_plugin->{progs_with_invalid_date}++;
4105                next;
4106            }
4107
4108            my $this_duration = $t2 - $t1;
4109            # skip if on required channel and too long OR extra long provided title isn't 'close'
4110            if (((defined $channels->{$ch} && $this_duration > $policy{max_programme_length}) ||
4111                 ($this_duration > $policy{max_programme_length_opt_channels})) &&
4112                ($prog->{title}->[0]->[0] !~ /\bclose\b/i)) {
4113                &log((sprintf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
4114                    $pluginname, int($policy{max_programme_length} / 3600),
4115                    int(($policy{max_programme_length} % 3600) / 60)))
4116                    if (!$this_plugin->{progs_too_long});
4117                $this_plugin->{progs_too_long}++;
4118                next;
4119            }
4120
4121            if ($this_duration < 1) {
4122                &log(sprintf "- WARNING: plugin '%s' returned programme data with invalid duration (%s to %s): ignored.\n", $pluginname, $prog->{start}, $prog->{stop});
4123                $this_plugin->{progs_too_short}++;
4124                next;
4125            }
4126
4127            # Don't count shows that are simply 'To Be Advised'
4128            # These will be dropped by the reconciler
4129            if ($prog->{title}->[0]->[0] =~ /^to be advised$/i
4130                    or
4131                $prog->{title}->[0]->[0] =~ /^tba$/i)
4132            {
4133                $this_plugin->{progs_tba}++;
4134                next;
4135            }
4136
4137            # store plugin-specific stats
4138            $this_plugin->{programmes}++;
4139            $this_plugin->{total_duration} += $this_duration;
4140            $seen_progs_on_this_channel++;
4141            $this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
4142            $this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
4143            $this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
4144            $this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
4145
4146            # only analyze / check against policy if its a non optional channel
4147            if (defined $channels->{$ch}) {
4148
4149                # programme is outside the timeslots we are interested in.
4150                if ($t1 > $policy{endtime} or $t2 < $policy{starttime})
4151                {
4152                    $this_plugin->{progs_outside_window}++;
4153                    next;
4154                }
4155
4156                # store channel-specific stats
4157                $channel_data->{$ch}->{programmes}++;
4158                $channel_data->{$ch}->{total_duration} += $this_duration;
4159
4160                # store timeslot info
4161                my $start_slotnum = 0;
4162                $start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
4163                  if ($t1 >= $policy{starttime});
4164
4165                my $end_slotnum = ($policy{num_timeslots}-1);
4166                $end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
4167                  if ($t2 < $policy{endtime});
4168
4169                $this_plugin->{progs_outside_window}++ if ($end_slotnum < $start_slotnum);
4170   
4171                &log((sprintf "DEBUG: ch '%s' prog start '%s' stop '%s' storing into timeslots %d-%d (%s-%s)\n",
4172                  $ch, $prog->{start}, $prog->{stop}, $start_slotnum, $end_slotnum,
4173                  POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($start_slotnum * $policy{timeslot_size}))),
4174                  POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($end_slotnum * $policy{timeslot_size})))))
4175                  if $policy{timeslot_debug};
4176
4177                # add this programme into the global and per-plugin timeslots table for this channel
4178                foreach my $slotnum ($start_slotnum..$end_slotnum) {
4179                    $channel_data->{$ch}->{timeslots}[$slotnum]++;
4180                    $this_plugin->{timeslots}->{$ch}[$slotnum]++;
4181                    $this_plugin->{slots_filled}++;
4182                }
4183            } else {
4184                $this_plugin->{progs_optional}++;
4185            }
4186        }
4187
4188        $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
4189    }
4190
4191    # print some stats about what we saw!
4192    &log((sprintf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
4193        ucfirst($plugintype), $pluginname, $seen_channels_with_data, $this_plugin->{programmes},
4194        int($this_plugin->{total_duration} / 86400),            # days
4195        int(($this_plugin->{total_duration} % 86400) / 3600),   # hours
4196        int(($this_plugin->{total_duration} % 3600) / 60),      # mins
4197        int($this_plugin->{total_duration} % 60),               # sec
4198        (defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
4199        (defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '')));
4200
4201    $this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
4202        $seen_channels_with_data, $this_plugin->{programmes},
4203        int($this_plugin->{total_duration} / 3600),
4204        (defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
4205        (defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
4206
4207    if (!$this_plugin->{slots_filled} and !&query_config($pluginname, 'type'))
4208    {
4209        # Call this a failure if there was some kind of weirdness. If
4210        # the grabber genuinely couldn't retrieve any shows for the
4211        # requested period, that's MISSING_DATA, but if it did and
4212        # we couldn't understand them, that's a FAIL.
4213
4214        if ($this_plugin->{progs_with_invalid_date}
4215                or
4216            $this_plugin->{progs_too_long}
4217                or
4218            $this_plugin->{progs_too_short}
4219                or
4220            $this_plugin->{progs_outside_window}
4221                or
4222            $this_plugin->{progs_with_unknown_channel}
4223                or
4224            $this_plugin->{progs_optional})
4225        {
4226            $this_plugin->{valid} = 0;
4227            $components_used .= '[failed_unparseable]';
4228            $this_plugin->{failure_reason} = 
4229                sprintf "Unparseable: %d ch, %d shows, %d dur, %d slots, %d invalid_date, %d too_long, %d too_short, %d outside_window, %d unknown_channel, %d optional",
4230                    $seen_channels_with_data, 
4231                    $this_plugin->{programmes},
4232                    $this_plugin->{total_duration},
4233                    $this_plugin->{slots_filled},
4234                    $this_plugin->{progs_with_invalid_date},
4235                    $this_plugin->{progs_too_long},
4236                    $this_plugin->{progs_too_short},
4237                    $this_plugin->{progs_outside_window},
4238                    $this_plugin->{progs_with_unknown_channel},
4239                    $this_plugin->{progs_optional};
4240        }
4241    }
4242
4243    $plugin_data->{$plugin} = $this_plugin;
4244}
4245
4246
4247# analyze grabber data - do we have all the data we want?
4248#  this can analyze either the cumulative data from ALL plugins ($proggy="shepherd")
4249#  or can analyze the data from one specific plugin
4250
4251sub analyze_plugin_data
4252{
4253    my ($analysisname, $quiet, $proggy, $iteration) = @_;
4254    &log("SHEPHERD: $analysisname:\n") unless $quiet;
4255
4256    my $total_channels = 0;
4257    my $plugin_epoch_missing_data = "";
4258    my $overall_data_ok = 1; # until proven otherwise
4259    my $total_missing = 0;
4260    my $total_data = 0;
4261    my $plugin = $proggy;
4262    $plugin .= "-$iteration" if (defined $iteration);
4263
4264    # iterate across each channel
4265    foreach my $ch (sort keys %{$channels}) {
4266
4267        # if we're analyzing data for a grabber and it doesn't support this channel, skip it
4268        if (($proggy ne $progname) &&
4269            ($components->{$proggy}->{type} eq "grabber") &&
4270            (supports_channel($proggy, $ch, 1) == 0)) {
4271                &log(1, (sprintf "DEBUG: analysis of channel %s for plugin %s skipped since plugin doesn't support channel\n",
4272                    $ch, $proggy));
4273                next;
4274        }
4275
4276        $total_channels++;
4277
4278        my $data;
4279        my $lastpol = "";
4280        $data->{data_ok} = 1; # unless proven otherwise
4281        $data->{have} = 0;
4282        $data->{missing} = 0;
4283
4284        for my $slotnum (0..($policy{num_timeslots}-1)) {
4285            my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
4286
4287            # work out day number of when this bucket is.
4288            # number from 0 onwards.  (i.e. today=0).
4289            # for a typical 7 day grabber this will actually mean 8 days of data (0-7)
4290            # with days 0 and 7 truncated to half-days
4291            my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
4292            $day += $opt->{offset} if ($opt->{offset});
4293
4294            if (!defined $data->{day}->[$day]) {
4295                $data->{day}->[$day]->{num} = $day;
4296                $data->{day}->[$day]->{have} = 0;
4297                $data->{day}->[$day]->{missing} = 0;
4298                $data->{day}->[$day]->{missing_peak} = 0;
4299                $data->{day}->[$day]->{missing_nonpeak} = 0;
4300                $data->{day}->[$day]->{missing_other} = 0;
4301
4302                $data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
4303
4304                # day changed, dump any 'already_missing' data
4305                &dump_already_missing($data, $proggy);
4306            }
4307
4308            # we have programming data for this bucket.  great!  process next bucket
4309            if ((($proggy eq $progname) &&
4310                 (defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
4311                 ($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) ||
4312                (($proggy ne $progname) &&
4313                 (defined $plugin_data->{$plugin}->{timeslots}->{$ch}[$slotnum]) &&
4314                 ($plugin_data->{$plugin}->{timeslots}->{$ch}[$slotnum] > 0))) {
4315                # if we have missing data queued up, push it now
4316                &dump_already_missing($data, $proggy);
4317                &dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
4318
4319                $data->{day}->[$day]->{have} += $policy{timeslot_size};
4320                $data->{have} += $policy{timeslot_size};
4321                next;
4322            }
4323
4324            # some grabbers take HOURS to run. if this bucket (missing data) is for
4325            # a time period now in the past, then don't include it
4326            next if (($bucket_start_offset + $policy{starttime}) < time);
4327
4328            # we don't have programming for this channel for this bucket
4329            &log((sprintf "DEBUG: missing timeslot data for ch '%s' bucket %d (%s)\n",
4330                $ch, $slotnum, POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($slotnum * $policy{timeslot_size})))))
4331                if $policy{timeslot_debug};
4332
4333
4334            if (($proggy ne $progname) && ($components->{$proggy}->{type} eq "grabber")) {
4335                # if we're analyzing data for a grabber and it doesn't have data for this
4336                # channel on this day, don't record it as missing data if:
4337                #   1. grabber doesn't reliably support this day
4338                #   2. we didn't _request_ the data for this channel/day (C1 grabbers only)
4339                #   3. grabber doesn't reliably support this channel
4340
4341                my $ignore_missing = 0; # don't ignore missing unless proven otherwise
4342
4343                # 1. ignore if it exceeds 'max_reliable_days' for this grabber
4344                if (supports_day($proggy,$day) != 1) {
4345                    $ignore_missing++;
4346                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to max_reliable_days\n",
4347                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4348                }
4349
4350                # 2(a). ignore if we didn't request data for channel/day (C1 grabbers)
4351                if ((query_config($proggy, 'category') == 1) &&
4352                    (!defined $plugin_data->{$proggy}->{requested_data}->{$ch}[$day])) {
4353                    $ignore_missing++;
4354                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not requested\n",
4355                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4356                }
4357
4358                # 2(b). ignore if we didn't request this gap (C1 grabbers)
4359                if ($find_microgaps
4360                        and
4361                    &query_config($proggy, 'category') == 1
4362                        and
4363                    grep ($_ ne $slotnum, @{$plugin_data->{$proggy}->{requested_gaps}->{$ch}}))
4364                {
4365                    $ignore_missing++;
4366                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' due to bucket %d being outside requested gap\n",
4367                            $proggy, $ch, $slotnum)) if ($policy{timeslot_debug});
4368                }
4369
4370                # 3. ignore if this grabber can't reliably supply this channel
4371                if (supports_channel($proggy,$ch,$day) != 1) {
4372                    $ignore_missing++;
4373                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to cannot-supply\n",
4374                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4375                }
4376
4377                if ($ignore_missing > 0) {
4378                    # if we have missing data queued up, push it now
4379                    &dump_already_missing($data, $proggy);
4380                    &dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
4381                    next;
4382                }
4383            }
4384
4385
4386            if (($proggy ne $progname) && ($components->{$proggy}->{type} ne "grabber")) {
4387                # if we're analyzing data for a reconciler/postprocessor and it doesn't have
4388                # data for a timeslot, only record that as an error if the source data _was_
4389                # previously available in the 'overall' data
4390
4391                if ((!defined $channel_data->{$ch}->{timeslots}[$slotnum]) ||
4392                    ($channel_data->{$ch}->{timeslots}[$slotnum] == 0)) {
4393                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not-in-overall-data\n",
4394                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4395                    next;
4396                }
4397            }
4398
4399            # work out the localtime of when this bucket is
4400            my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
4401
4402            # store details of where we are missing data
4403            if (!defined $data->{already_missing}) {
4404                $data->{already_missing} = sprintf "#%d/%02d:%02d",
4405                  $day,
4406                  int($bucket_seconds_offset / 3600),
4407                  int(($bucket_seconds_offset % 3600) / 60);
4408                $data->{already_missing_epoch} = $policy{starttime} + $bucket_start_offset;
4409            }
4410            $data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
4411            $data->{already_missing_last_epoch} = $policy{starttime} + $bucket_start_offset + $policy{timeslot_size} - 1;
4412
4413            $data->{day}->[$day]->{missing} += $policy{timeslot_size};
4414            $data->{missing} += $policy{timeslot_size};
4415
4416            # work out what policy missing data for this bucket fits into
4417            my $pol;
4418            if (($bucket_seconds_offset >= $policy{peak_start}) &&
4419                (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
4420                $pol = "peak";
4421            } elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
4422                     (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
4423                $pol = "nonpeak";
4424            } else {
4425                $pol = "other";
4426            }
4427
4428            &dump_already_missing_period($data->{day}->[$day],$lastpol)
4429              if (($lastpol ne $pol) && ($lastpol ne ""));
4430
4431            $lastpol = $pol;
4432
4433            $data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
4434
4435            $data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
4436              if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
4437            $data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
4438
4439            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
4440            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
4441            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
4442            $data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
4443            $overall_data_ok = 0 if ($data->{data_ok} == 0);
4444        }
4445
4446        # finished all timeslots in this channel.
4447        # if we have missing data queued up, push it now
4448        &dump_already_missing($data, $proggy);
4449
4450        # fill in any last missing period data
4451        foreach my $day (@{($data->{day})}) {
4452            &dump_already_missing_period($day,"peak");
4453            &dump_already_missing_period($day,"nonpeak");
4454            &dump_already_missing_period($day,"other");
4455        }
4456
4457        my $statusstring = sprintf " > ch %s: %s%s\n", 
4458          $ch, 
4459          $data->{have} ? ($data->{missing} ? ($data->{data_ok} ? "PASS (within policy thresholds)" : "FAIL (missing data exceeds policy thresholds):") : "PASS (complete)") : "FAIL (no data):",
4460          $data->{have} ? ", have " . pretty_duration($data->{have}) : '';
4461
4462        # display per-day missing data statistics
4463        foreach my $day (@{($data->{day})}) {
4464            next unless ($day->{missing});
4465
4466            $statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime} + (($day->{num} - ($opt->{offset} or 0)) * 86400)))).": missing ";
4467            if ($day->{have})
4468            {
4469                $statusstring .= pretty_duration($day->{missing}) . ": ";
4470
4471                # do we have any data for this day?
4472                $statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
4473                  if (($day->{missing_peak}) && ($day->{missing_peak}));
4474
4475                $statusstring .= sprintf "%snon-peak %s",
4476                  ($day->{missing_peak} ? " / " : ""),
4477                  join(", ",(@{($day->{missing_nonpeak_table})}))
4478                  if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak}));
4479
4480                $statusstring .= sprintf "%sother %s",
4481                  (($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
4482                  join(", ",(@{($day->{missing_other_table})}))
4483                  if (($day->{missing_other}) && ($day->{missing_other}));
4484            }
4485            else
4486            {
4487                $statusstring .= "entire day";
4488            }
4489            $statusstring .= "\n";
4490        }
4491        &log($statusstring) unless $quiet;
4492        $data->{statusstring} = $statusstring;
4493        $plugin_epoch_missing_data .= sprintf "%s:%s\t",$ch,$data->{missing_all_epoch} if (defined $data->{missing_all_epoch});
4494        $total_missing += $data->{missing};
4495        $total_data += $data->{have};
4496
4497        if ($proggy eq $progname) {
4498            delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
4499            $channel_data->{$ch}->{analysis} = $data;
4500        } else {
4501            delete $plugin_data->{$plugin}->{analysis}->{$ch} if (defined $plugin_data->{$plugin}->{analysis}->{$ch});
4502            $plugin_data->{$plugin}->{analysis}->{$ch} = $data;
4503        }
4504    }
4505
4506    &log((sprintf " > OVERALL: [%2.2f%%] %s\n", 
4507                   ($total_data + $total_missing > 0 ? (100 * $total_data / ($total_data + $total_missing)) : 0),
4508                  ($total_missing ? ($overall_data_ok ? "PASS (within policy thresholds)" : "FAIL (exceeds policy thresholds)") : "PASS (complete)")))
4509          unless $quiet;
4510
4511    if ($plugin_epoch_missing_data ne '') {
4512        &add_pending_message($proggy, 'MISSING_DATA', $plugin_epoch_missing_data) unless ($plugin_data->{tainted});
4513    } elsif ($proggy eq $progname) {
4514        delete $pending_messages->{$progname}->{MISSING_DATA};
4515    }
4516
4517    if ($proggy eq $progname) {
4518        $plugin_data->{$progname}->{total_missing} = $total_missing;
4519        $plugin_data->{$progname}->{total_duration} = $total_data;
4520        $data_found_all = ($total_missing ? 0 : 1);
4521        $data_satisfies_policy = $overall_data_ok;
4522    }
4523    return $overall_data_ok; # return 1 for satisifies policy, 0 for need more
4524}
4525
4526# helper routine for filling in 'missing_all' array
4527sub dump_already_missing
4528{
4529    my ($d, $proggy) = @_;
4530
4531    if (defined $d->{already_missing}) 
4532    {
4533        if (defined $d->{already_missing_last})
4534        {
4535            $d->{already_missing} .= sprintf "-%02d:%02d",
4536                                             int($d->{already_missing_last} / 3600),
4537                                             int(($d->{already_missing_last} % 3600) / 60);
4538        }
4539
4540        push(@{($d->{missing_all})}, $d->{already_missing});
4541
4542        $d->{already_missing_epoch} .= sprintf "-%d",$d->{already_missing_last_epoch};
4543
4544        # Don't report noncritical data holes in grabbers we know have those.
4545        #
4546        # Two things to note here:
4547        # 1. We can only do this for individual grabbers, not Shepherd overall;
4548        #    $plugin_data -> 'missing_all_epoch' is used for further analysis
4549        #    at the Shepherd & channel levels, not just stats reporting.
4550        # 2. Normally we flag data as '$ignore_missing++' in &analyse_plugin_data,
4551        #    but that loops through individual buckets: it knows whether each
4552        #    bucket is filled or not but not how large each gap is.
4553        unless (&query_config($proggy, 'has_noncritical_gaps') and &is_noncritical_gap($d->{already_missing_epoch}))
4554        {
4555            $d->{missing_all_epoch} .= "," if (defined $d->{missing_all_epoch});
4556            $d->{missing_all_epoch} .= $d->{already_missing_epoch};
4557        }
4558
4559        delete $d->{already_missing};
4560        delete $d->{already_missing_last};
4561
4562        delete $d->{already_missing_epoch};
4563        delete $d->{already_missing_last_epoch};
4564    }
4565}
4566
4567# helper routine for filling in per-day missing data
4568# specific to peak/nonpeak/other
4569sub dump_already_missing_period
4570{
4571    my ($d,$p) = @_;
4572    my $startvar = "already_missing_".$p."_start";
4573    my $stopvar = "already_missing_".$p."_stop";
4574
4575    if (defined $d->{$startvar}) {
4576        push(@{($d->{"missing_".$p."_table"})},
4577          sprintf "%02d:%02d-%02d:%02d",
4578            int($d->{$startvar} / 3600),
4579            int(($d->{$startvar} % 3600) / 60),
4580            int($d->{$stopvar} / 3600),
4581            int(($d->{$stopvar} % 3600) / 60));
4582        delete $d->{$startvar};
4583        delete $d->{$stopvar};
4584    }
4585}
4586
4587# Don't bother reporting small gaps when we already know that this
4588# grabber tends to have them.
4589#
4590# It's actually difficult to say exactly which gaps are critical
4591# (or policy-violating), because our analysis operates on a
4592# per-day basis, not per-gap -- for example, four 5-minute gaps
4593# in prime time is a policy violation, even though each individual
4594# gap isn't. So our solution is not perfect: we are simply
4595# disregarding SMALL gaps, regardless of how many there are.
4596#
4597# A gap is considered non-critical if it's:
4598# (a) in peak time and less than 15 minutes long; or
4599# (b) in nonpeak time and less than 30 minutes long; or
4600# (c) in other time and less than 25 minutes long
4601sub is_noncritical_gap
4602{
4603    my $gap = shift;
4604
4605    return 0 unless ($gap =~ /(\d+)-(\d+)/);
4606    my $zero_hr = $policy{starttime} - $policy{first_bucket_offset};
4607
4608    my $gap_start = (($1 - $zero_hr) % 86400);
4609    my $gap_stop = (($2 - $zero_hr) % 86400);
4610    my $diff = $gap_stop - $gap_start;
4611
4612    if ($gap_start <= $policy{peak_stop} and $gap_stop >= $policy{peak_start})
4613    {
4614        # PEAK
4615        return ($diff < 15*60);
4616    }
4617    elsif ($gap_start <= $policy{nonpeak_stop} and $gap_stop >= $policy{nonpeak_start})
4618    {
4619        # NONPEAK
4620        return ($diff < 30*60);
4621    }
4622    else
4623    {
4624        # OTHER
4625        return ($diff < 25*60);
4626    }
4627}
4628
4629# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
4630# and indication of whether the duration is over its threshold or not
4631sub pretty_duration
4632{
4633    my ($d,$crit) = @_;
4634    my $s = "";
4635    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
4636    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if (($d % (60*60*24)) >= (60*60));
4637    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if (($d % (60*60)) >= 60);
4638    $s .= sprintf "%ds",int($d % 60) if (($s eq "") && ($d > 0));
4639    $s .= "no" if ($s eq "");
4640
4641    if (defined $crit) {
4642        $s .= "[!]" if ($d > $crit);
4643    }
4644    return $s;
4645}
4646
4647# work out date range we are expecting data to be in
4648sub calc_date_range
4649{
4650
4651    $policy{starttime} = time;
4652
4653    # set endtime as per $days less 1 day + hours left today
4654    $policy{endtime} = $policy{starttime} + ((60*60*24)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
4655
4656    # normalize starttime to beginning of next bucket
4657    $policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
4658
4659    # work out how many seconds into a day our first bucket starts
4660    $policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
4661
4662    # normalize endtime to end of previous bucket
4663    $policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
4664
4665    # if we are working with an --offset, apply it now.
4666    $policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
4667
4668    # work out number of buckets
4669    $policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
4670
4671    &log((sprintf "DEBUG: policy settings: starttime=%d, endtime=%d, first_bucket_offset=%d, gmt_offset=%d, strftime_tz=%s\n",
4672        $policy{starttime}, $policy{endtime}, $policy{first_bucket_offset}, $gmt_offset,
4673        (strftime("%z", localtime(time)))))
4674        if ($policy{timeslot_debug});
4675}
4676
4677sub calc_gmt_offset
4678{
4679    # work out GMT offset - we only do this once
4680    if (!$gmt_offset) {
4681        # work out our gmt offset
4682        my $tzstring = strftime("%z", localtime(time));
4683
4684        $gmt_offset = (60*60) * int(substr($tzstring,1,2));     # hr
4685        $gmt_offset += (60 * int(substr($tzstring,3,2)));       # min
4686        $gmt_offset *= -1 if (substr($tzstring,0,1) eq "-");    # +/-
4687    }
4688}
4689
4690# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
4691# rather than the various other perl implementation which treat it as being in UTC/GMT
4692sub parse_xmltv_date
4693{
4694    my $datestring = shift;
4695    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
4696    my $tz_offset = 0;
4697
4698    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
4699        ($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);
4700        ($t[6],$t[7],$t[8]) = (-1,-1,-1);
4701
4702        # if input data has a timezone offset, then offset by that
4703        if ($datestring =~ /\+(\d{2})(\d{2})/) {
4704            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
4705        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
4706            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
4707        }
4708
4709        my $e = mktime(@t);
4710        return ($e+$tz_offset) if ($e > 1);
4711    }
4712    return undef;
4713}
4714
4715# -----------------------------------------
4716# Subs: Reconciling data
4717# -----------------------------------------
4718
4719# for all the data we have, try to pick the best bits!
4720sub reconcile_data
4721{
4722    &log("\nReconciling data:\n\n");
4723
4724    my $num_grabbers = 0;
4725    my $input_files = "";
4726    my @input_file_list;
4727
4728    # when reconciling & postprocessing, increase the thresholds of how much
4729    # missing data we permit.
4730    # generally, if a postprocessor or reconciler breaks, it'll return
4731    # no data rather than 'most' data.
4732    $policy{peak_max_missing} *= 3;
4733    $policy{nonpeak_max_missing} *= 1.5;
4734    $policy{other_max_missing} *= 3;
4735
4736    &log("Preferred title preferences from '$pref_title_source'\n")
4737        if ((defined $pref_title_source) &&
4738            ($plugin_data->{$pref_title_source}) &&
4739            ($plugin_data->{$pref_title_source}->{valid}));
4740
4741    &log("Preference for whose data we prefer as follows:\n");
4742    foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
4743        next if ($components->{$proggy}->{disabled});
4744        next if (defined $plugin_data->{$proggy}->{failed_test});
4745
4746        foreach my $plugin (keys %$plugin_data) {
4747            next unless (($plugin =~ /^$proggy-\d+$/) 
4748                            and 
4749                        ($plugin_data->{$plugin})
4750                            and 
4751                        ($plugin_data->{$plugin}->{valid}));
4752            $num_grabbers++;
4753            &log((sprintf "  %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$plugin}->{output_filename}));
4754
4755            $input_files .= $plugin_data->{$plugin}->{output_filename}." ";
4756            push(@input_file_list,$plugin_data->{$plugin}->{output_filename});
4757        }
4758    }
4759
4760    if ($num_grabbers == 0) {
4761        &log("ERROR! Nothing to reconcile! No valid grabber data!\n");
4762        return 0;
4763    }
4764
4765    foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
4766        next if ($components->{$reconciler}->{disabled});
4767        next if (defined $plugin_data->{$reconciler}->{failed_test});
4768        next if (!$components->{$reconciler}->{ready});
4769
4770        $reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
4771
4772        if ((!$reconciler_found_all_data) && ($data_found_all)) {
4773            # urgh.  this reconciler did a bad bad thing ...
4774            &log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
4775        } else {
4776            &log("SHEPHERD: Data from reconciler $reconciler looks good\n");
4777            $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
4778        }
4779
4780        last if ($input_postprocess_file ne "");
4781    }
4782
4783    if ($input_postprocess_file eq "") {
4784        # no reconcilers worked!!
4785        &log("SHEPHERD: WARNING: No reconcilers seemed to work!  Falling back to concatenating the data together!\n");
4786
4787        my %w_args = ();
4788        $input_postprocess_file = "$CWD/input_preprocess.xmltv";
4789        my $fh = new IO::File ">$input_postprocess_file" || die "could not open $input_postprocess_file for writing: $!\n";
4790        %w_args = (OUTPUT => $fh);
4791        XMLTV::catfiles(\%w_args, @input_file_list);
4792    }
4793    return 1;
4794}
4795
4796
4797# -----------------------------------------
4798# Subs: Postprocessing
4799# -----------------------------------------
4800
4801sub postprocess_data
4802{
4803    # for our first postprocessor, we feed it ALL of the XMLTV files we have
4804    # as each postprocessor runs, we feed in the output from the previous one
4805    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
4806    # reverts back to the previous postprocessor if it was shown to be bad
4807
4808    # first time around: feed in reconciled data ($input_postprocess_file)
4809
4810    &log("\nSHEPHERD: Postprocessing stage:\n");
4811
4812    foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
4813        next if ($components->{$postprocessor}->{disabled});
4814        next if (defined $plugin_data->{$postprocessor}->{failed_test});
4815        next if (!$components->{$postprocessor}->{ready});
4816
4817        my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
4818
4819        if ($found_all_data) {
4820            # accept what this postprocessor did to our output ...
4821            &log("SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n");
4822            $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
4823            next;
4824        }
4825
4826        # urgh.  this postprocessor did a bad bad thing ...
4827        &log("SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n");
4828    }
4829}
4830
4831
4832# -----------------------------------------
4833# Subs: Postprocessing/Reconciler helpers
4834# -----------------------------------------
4835
4836sub call_data_processor
4837{
4838    my ($data_processor_type, $data_processor_name, $input_files) = @_;
4839
4840    &log("\nSHEPHERD: Using $data_processor_type: $data_processor_name\n");
4841
4842    my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
4843    my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
4844    $comm .= " --region $region" .
4845             " --channels_file $channels_file" .
4846             " --output $output";
4847    $comm .= " --days $days" if ($days);
4848    $comm .= " --offset $opt->{offset}" if ($opt->{offset});
4849    $comm .= " --debug" if ($debug);
4850    $comm .= " @ARGV" if (@ARGV);
4851
4852    $comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
4853      if (($data_processor_type eq "reconciler") &&
4854          (defined $pref_title_source) &&
4855          ($plugin_data->{$pref_title_source}) &&
4856          ($plugin_data->{$pref_title_source}->{valid}));
4857
4858    $comm .= " $input_files";
4859    &log("SHEPHERD: Executing command: $comm\n");
4860
4861    if (-e $output)
4862    {
4863        &log(1, "SHEPHERD: Removing old output file: $output\n");
4864        unlink($output) or &log("SHEPHERD: Failed to remove old output file: $output\n$!\n");
4865    }
4866    my $component_start = time;
4867    my ($retval,$msg) = call_prog($data_processor_name,$comm,0,(query_config($data_processor_name,'max_runtime')*60));
4868    my $component_duration = time - $component_start;
4869
4870    if ($retval) {
4871        &log("$data_processor_type exited with non-zero code $retval: assuming it failed.\n" .
4872             "Last message: $msg\n");
4873        $components->{$data_processor_name}->{laststatus} = "Failed ($retval)";
4874        $components->{$data_processor_name}->{consecutive_failures}++;
4875        &add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
4876            $components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
4877        return 0;
4878    }
4879
4880    delete $components->{$data_processor_name}->{conescutive_failures};
4881
4882    #
4883    # soak up the data we just collected and check it
4884    # YES - these are the SAME routines we used in the previous 'grabber' phase
4885    # but the difference here is that we clear out our 'channel_data' beforehand
4886    # so we can independently analyze the impact of this postprocessor.
4887    # if it clearly returns bad data, don't use that data (go back one step) and
4888    # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
4889    #
4890
4891    # clear out channel_data
4892    foreach my $ch (keys %{$channels}) {
4893        delete $channel_data->{$ch};
4894    }
4895
4896    # process and analyze it!
4897    &soak_up_data($data_processor_name, $output, $data_processor_type);
4898
4899    my $have_all_data = 0;
4900    if ((defined $plugin_data->{$data_processor_name}) &&
4901        (defined $plugin_data->{$data_processor_name}->{valid})) {
4902        $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name",0,$data_processor_name);
4903    }
4904
4905    if ($have_all_data) {
4906        $components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
4907        $components->{$data_processor_name}->{lastdata} = time;
4908        delete $components->{$data_processor_name}->{consecutive_failures}
4909          if (defined $components->{$data_processor_name}->{consecutive_failures});
4910        &add_pending_message($data_processor_name,"SUCCESS", $retval, $component_start, $component_duration,
4911            $components->{$data_processor_name}->{ver}, 0);
4912    } else {
4913        $components->{$data_processor_name}->{laststatus} = "missing data: ".$plugin_data->{$data_processor_name}->{laststatus};
4914        $components->{$data_processor_name}->{consecutive_failures}++;
4915        &add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
4916            $components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
4917    }
4918
4919    return $have_all_data;
4920}
4921
4922# We test out ability to write to the output file early, since if
4923# that fails there's no point continuing.
4924sub test_output_file
4925{
4926    my $fh = new IO::File(">>$output_filename")
4927        or die "Can't open $output_filename for writing: $!";
4928    $fh->close;
4929}
4930
4931sub output_data
4932{
4933    my $reuse_cached_output = shift;
4934    $reuse_cached_output = 0 if (!defined $reuse_cached_output);
4935   
4936    my $output_cache_copy = "$CWD/output.xmltv";
4937
4938    if ($reuse_cached_output) {
4939        # re-use existing cached output
4940        $input_postprocess_file = $output_cache_copy;
4941    }
4942
4943    if ($output_filename eq $input_postprocess_file) {
4944        # nothing to do - the input is the same as the output
4945        &log("Re-using existing output $output_filename\n");
4946    }
4947    else {
4948        my %writer_args = ( encoding => 'ISO-8859-1' );
4949        my $fh = new IO::File(">$output_filename") || die "Can't open $output_filename for writing: $!";
4950        $writer_args{OUTPUT} = $fh;
4951
4952        $writer = new XMLTV::Writer(%writer_args);
4953        $writer->start( {
4954                'source-info-name' => "$progname v".$components->{$progname}->{ver},
4955                'generator-info-name' => $components_used } );
4956
4957        XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb, 
4958            \&output_data_programme_cb, $input_postprocess_file);
4959        $writer->end();
4960        $fh->close;
4961
4962        &log("Final output stored in $output_filename.\n");
4963
4964        # copy final output to our cache copy as well
4965        if ($output_filename ne $output_cache_copy) {
4966            unlink($output_cache_copy);
4967            open(F1,"<$output_filename");
4968            open(F2,">$output_cache_copy");
4969            while (<F1>) {
4970                print F2 $_;
4971            }
4972            close(F1);
4973            close(F2);
4974        }
4975        &log("Cached output stored in $output_cache_copy.\n");
4976    }
4977
4978    if (!$opt->{'output'} and !$opt->{'nooutput'}) {
4979        &log("\nPrinting XMLTV output to STDOUT in 5 seconds...\n");
4980        sleep 5;
4981        my $fh = new IO::File("< $output_filename") || die "Can't open $output_filename for reading: $!";
4982        print <$fh>;
4983        $fh->close;
4984    }
4985}
4986
4987sub output_data_channel_cb
4988{
4989    my $c = shift;
4990    $writer->write_channel($c);
4991}
4992
4993sub output_data_programme_cb
4994{
4995    my $prog=shift;
4996    $writer->write_programme($prog);
4997}
4998
4999# -----------------------------------------
5000# Subs: Tor support
5001# -----------------------------------------
5002
5003sub start_tor
5004{
5005    # do we have any components requesting the use of tor?
5006    my $want_tor = 0;
5007    foreach (query_grabbers()) {
5008        unless (($components->{$_}->{disabled}) || (defined $plugin_data->{$_}->{failed_test})) {
5009            $want_tor++ if (query_config($_, 'option_anon_socks'));
5010        }
5011    }
5012
5013    return if ($want_tor == 0);
5014
5015    # try to find tor
5016    my $searchpath = ".:/usr/sbin:".$ENV{PATH};
5017    my $found_tor;
5018    foreach my $dir (split(/:/,$searchpath)) {
5019        if ((-x "$dir/tor") && (-f "$dir/tor")) {
5020            $found_tor = "$dir/tor";
5021            last;
5022        }
5023    }
5024
5025    if (!defined $found_tor) {
5026        &log("\nWARNING: $want_tor components wanted to use Tor but could not find it.\n");
5027        &log("This may cause data collection to run slower than it otherwise would.\n");
5028        return;
5029    }
5030
5031    # we'll run our own local copy of Tor exclusively for shepherd
5032    my $tordir = $CWD."/tor";
5033    if (!-d $tordir) {
5034        if (!mkdir $tordir) {
5035            &log("\nWARNING: Could not create $tordir, Tor not started!\n");
5036            &log("This may cause data collection to run slower than it otherwise would.\n");
5037            return;
5038        }
5039    }
5040
5041    &log("\nStarting Tor ($found_tor) in the background (wanted by $want_tor components).\n");
5042    my $pid = fork;
5043    if (!defined $pid) {
5044        # failed
5045        &log("Failed to start $found_tor: $!\n");
5046        return;
5047    } elsif ($pid > 0) {
5048        # parent
5049        sleep 2; # wait a few seconds for Tor to start
5050
5051        # test that it is running
5052        if (!kill 0, $pid) {
5053            &log("Tor doesn't seem to be running on pid $pid anymore, ignoring Tor option.\n");
5054        } else {
5055            &log("Tor appears to have successfully started (pid $pid).\n");
5056            $plugin_data->{tor_address} = "127.0.0.1:9051";
5057            $plugin_data->{tor_pid} = $pid;
5058        }
5059    } else {
5060        # child
5061        exec $found_tor,"SocksListenAddress","127.0.0.1:9051","MaxCircuitDirtiness","30","DataDirectory",$tordir;
5062        exit(1); # we won't reach this
5063    }
5064}
5065
5066
5067sub stop_tor
5068{
5069    if (defined $plugin_data->{tor_pid}) {
5070        # INTR sig stops tor
5071        kill 2,$plugin_data->{tor_pid};
5072    }
5073}
5074
5075sub test_tor
5076{
5077        &start_tor;
5078        return if (!defined $plugin_data->{tor_pid});   # no components require it
5079
5080        &log("\nSome components want to use Tor.\n".
5081             "Testing that it is working by connecting to www.google.com via Tor...\n\n");
5082
5083        sleep 10;
5084
5085        use LWP::Protocol::http;
5086        my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
5087
5088        # override LWP::Protocol::http's _new_socket method with our own
5089        local($^W) = 0;
5090        *LWP::Protocol::http::_new_socket = \&socks_new_socket;
5091
5092        # test that it works
5093        my $retries = 0;
5094        my $data;
5095        while ($retries < 10) {
5096                $retries++;
5097                &log("Connecting to www.google.com (try $retries) ... ");
5098                $data = &fetch_file("http://www.google.com/");
5099                last if (($data) && ($data =~ /Google/i));
5100
5101                sleep 10;
5102        }
5103
5104        if (($data) && ($data =~ /Google/i)) {
5105                &log("\nSUCCESS.\nTor appears to be working!\n");
5106        } else {
5107                &log("Tor doesn't appear to be working. Suggest you look into this!\n");
5108        }
5109
5110        *LWP::Protocol::http::_new_socket = $orig_new_socket;
5111        &stop_tor;
5112
5113        sleep 2;
5114}
5115
5116##############################################################################
5117# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
5118
5119sub socks_new_socket
5120{
5121        my($self, $host, $port, $timeout) = @_;
5122
5123        my ($socks_ip,$socks_port) = split(/:/,$plugin_data->{tor_address});
5124
5125        local($^W) = 0;  # IO::Socket::INET can be noisy
5126        my $sock = $self->socket_class->new(
5127                PeerAddr => $socks_ip,
5128                PeerPort => $socks_port,
5129                Proto    => 'tcp');
5130
5131        unless ($sock) {
5132                # IO::Socket::INET leaves additional error messages in $@
5133                $@ =~ s/^.*?: //;
5134                &log("Can't connect to $host:$port ($@)\n");
5135                return undef;
5136        }
5137
5138        # perl 5.005's IO::Socket does not have the blocking method.
5139        eval { $sock->blocking(0); };
5140
5141        # establish connectivity with socks server - SOCKS4A protocol
5142        print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
5143                (pack 'x') .
5144                $host . (pack 'x');
5145
5146        my $received = "";
5147        my $timeout_time = time + $timeout;
5148        while ($sock->sysread($received, 8) && (length($received) < 8) ) {
5149                select(undef, undef, undef, 0.25);
5150                last if ($timeout_time < time);
5151        }
5152
5153        if ($timeout_time < time) {
5154                &log("Timeout ($timeout) while connecting via SOCKS server\n");
5155                return $sock;
5156        }
5157
5158        my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
5159        &log("Connection via SOCKS4A server rejected or failed\n") if ($req_status == 0x5b);
5160        &log("Connection via SOCKS4A server because client is not running identd\n") if ($req_status == 0x5c);
5161        &log("Connection via SOCKS4A server because client's identd could not confirm the user\n") if ($req_status == 0x5d);
5162
5163        $sock;
5164}
5165
5166##############################################################################
5167
5168# For self-locking
5169__DATA__
5170
Note: See TracBrowser for help on using the repository browser.