source: trunk/applications/shepherd @ 1501

Revision 1501, 161.0 KB checked in by mbarry, 19 months ago (diff)

Channel "SBS ONE" has been renamed back to "SBS" (again)

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