source: trunk/applications/shepherd @ 1470

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

shepherd: More help text for people trying to install required modules.

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