source: trunk/applications/shepherd @ 1474

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

shepherd v1.9.0: Add "autorefresh"

  • Property svn:executable set to *
File size: 155.5 KB
Line 
1#!/usr/bin/env perl
2
3our $progname = 'shepherd';
4my $version = '1.9.0';
5
6# tv_grab_au
7# "Shepherd"
8# A wrapper for various Aussie TV guide data grabbers
9#
10# Use --help for command-line options.
11#
12# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
13# make one cohesive reliable data set. It works by calling a series of
14# scripts that grab data from a large variety of sources, and then
15# analysing the resulting XML data sets and determining which of the many
16# is the most reliable.
17
18# Shepherd runs in 5 stages:
19#  stage 1: Checks that all components are up-to-date, auto-updates if not.
20#  stage 2: calls grabbers to fill in missing data
21#  stage 3: calls reconciler to reconcile overlapping data and normalize
22#           programme titles to our preferred title
23#  stage 4: calls postprocessors to postprocess data
24#           (e.g. flag HDTV programmes, augment with IMDb etc.)
25#  stage 5: write final XMLTV out
26
27BEGIN { *CORE::GLOBAL::die = \&my_die; }
28
29use strict;
30no strict 'refs';
31use warnings;
32use lib 'references';
33
34# ---------------------------------------------------------------------------
35# --- required perl modules
36# ---------------------------------------------------------------------------
37
38our $wiki = 'http://svn.whuffy.com/wiki';
39
40&require_module("Cwd", qw(realpath));
41&require_module("LWP::UserAgent");
42&require_module("Getopt::Long");
43&require_module("Data::Dumper");
44&require_module("XMLTV");
45&require_module("XMLTV::Ask");
46&require_module("POSIX", qw(strftime mktime getcwd));
47&require_module("Compress::Zlib");
48&require_module("Date::Manip");
49&require_module("Algorithm::Diff");
50&require_module("List::Compare");
51&require_module("Digest::SHA");
52&require_module("Fcntl");
53our $have_Sort_Versions = &soft_require_module("Sort::Versions");
54
55# ---------------------------------------------------------------------------
56# --- Global Variables
57# ---------------------------------------------------------------------------
58#
59# Shared with libraries:
60#
61
62our $CWD = &find_home;
63-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
64chdir($CWD);
65
66our $opt = {};
67our $debug = 0;
68our $region;
69our $channels;
70our $opt_channels;
71our $components = { };
72our $want_paytv_channels;
73our $pref_title_source;
74my $last_successful_run;
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 ONE");
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 = 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)
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                     ));
2062  $debug = $opt->{debug};
2063  $days = $opt->{days} if ($opt->{days});
2064  $opt->{configure} = 1 if (defined $opt->{configure} and !$opt->{configure});
2065  $output_filename = $opt->{output} if ($opt->{output});
2066  delete $opt->{quiet} if (defined $opt->{notquiet});
2067}
2068
2069sub check_lock
2070{
2071    $lock = (flock DATA, &Fcntl::LOCK_EX | &Fcntl::LOCK_NB);
2072    &log("Lock failed.\n") unless ($lock);
2073}
2074
2075sub check_other_instance
2076{
2077    if (!$lock)
2078    {
2079        &log("\n*** IN PROGRESS ***\nAnother instance of Shepherd is currently running.\n");
2080    }
2081}
2082
2083# Here we can specify which command-line options should call
2084# subroutines of the same name. The field following each sub
2085# name is a string that can contain a key for what action should
2086# be performed following the sub:
2087#   W : write config file
2088#   S : print --status output
2089# Shepherd will exit if at least one of these routines was
2090# called.
2091sub process_setup_commands
2092{
2093    my %routines = (    enable => 'WS',
2094                        disable => 'WS',
2095                        'delete' => 'WS',
2096                        setorder => 'WS',
2097                        check => 'WS',
2098                        setpreftitle => 'W',
2099                        clearpreftitle => 'W',
2100                        'reset' => 'W',
2101                        'component-set' => 'W',
2102                        addsource => 'W',
2103                        delsource => 'W',
2104                        status => '',
2105                        history => '',
2106                        desc => '',
2107                        'show-config' => '',
2108                        'show-channels' => '',
2109                        'list-chan-names' => '',
2110                        'set-icons' => '',
2111                        'configure-mythtv' => '',
2112                        'pending' => '',
2113                        ancestry => '',
2114                        sources => ''
2115                    );
2116
2117    my ($run, $write_flag, $status_flag);
2118    foreach my $func (keys %routines)
2119    {
2120        if ($opt->{$func})
2121        {
2122            $run = 1;
2123            my $sub = $func;
2124            $sub =~ s/-/_/g;
2125            if (!$lock and $routines{$func} =~ /W/)
2126            {
2127                print "\nERROR: Cannot --$func while another instance of Shepherd is running.\n".
2128                      "Please try again later.\n";
2129            }
2130            else
2131            {
2132                &$sub($opt->{$func});
2133                $write_flag = 1 if ($routines{$func} =~ /W/);
2134                $status_flag = 1 if ($routines{$func} =~ /S/);
2135            }
2136        }
2137    }
2138    return unless ($run);
2139    &write_config_file if ($write_flag);
2140    &status if ($status_flag);
2141    exit;
2142}
2143
2144# if a preferred title source has been specified, add it to our config
2145sub setpreftitle
2146{
2147    my $arg = shift;
2148    $pref_title_source = $arg;
2149    &log("Added preferred title source: $pref_title_source\n");
2150    1;
2151}
2152
2153# if requesting to clear preferred title and we have one, remove it
2154sub clearpreftitle
2155{
2156    &log("Removed preferred title source: $pref_title_source\n");
2157    $pref_title_source = undef;
2158    1;
2159}
2160
2161sub reset
2162{
2163    &log(2, "\nWARNING! The --reset argument will remove your established\n" .
2164            "title translation data. This may cause Shepherd to lose the\n" .
2165            "ability to keep show titles consistent with what you have seen\n" .
2166            "in the past!\n\n");
2167    &countdown(20);
2168    my @r = query_component_type('reconciler');
2169    foreach (@r)        # Not that there should be more than one...
2170    {
2171        my $fn = query_ldir($_, 'reconciler') . '/' . $_ . '.storable.config';
2172        &log("Removing $fn.\n");
2173        unlink($fn) or &log("Failed to remove file! $!\n");
2174    }
2175
2176    if ($pref_title_source)
2177    {
2178        my @prefs = split(/,/, $pref_title_source);
2179        foreach my $grabber (@prefs)
2180        {
2181            if ($components->{$grabber}->{lastdata})
2182            {
2183                &log( "Clearing lastdata for '$grabber' to trigger it to be called.\n");
2184                delete $components->{$grabber}->{lastdata};
2185            }
2186        }
2187    }
2188}
2189
2190sub delete
2191{
2192    my $proggy = shift;
2193
2194    delete $components->{$proggy};
2195    &log("\nDeleted component \"$proggy\".");
2196}
2197
2198# used to call a component in a manner so it can set some tunable parameter
2199sub component_set
2200{
2201    my $compset = shift;
2202
2203    my $helpstr = "Format: --component-set <component>:<argument>[:<argument2>...]\n".
2204                  "  e.g.: --component-set oztivo:region=101\n".
2205                  "        --component-set oztivo:region=101:debug:config=default.conf\n\n";
2206
2207    my ($component, @args) = split(/:/,$compset);
2208    if (!defined $components->{$component}) {
2209        &log("\nError: No component called '$component'!\n$helpstr");
2210        return;
2211    }
2212    my $arg = join(":",@args);
2213
2214    if ((!defined $arg) || ($arg eq "")) {
2215        delete $components->{$component}->{default_cmdline};
2216        &log("\n*** Cleared default options for $component. ***\n\n".
2217             "If you wish to set new options:\n$helpstr");
2218    } else {
2219        $components->{$component}->{default_cmdline} = "--".join(":--",@args);
2220        &log("\nSet default options for $component to: --".join(" --",@args)."\n");
2221    }
2222}
2223
2224sub sources
2225{
2226    my $arg = shift;
2227
2228    if ($arg and $arg eq 'reset')
2229    {
2230        print "Resetting sources.\n";
2231        &reset_sources;
2232    }
2233    print "Sources:\n".
2234          "  # Source                                        Can Update\n".
2235          "-------------------------------------------------------------------\n";
2236
2237    my $count = 1;
2238    foreach my $site (@$sources)
2239    {
2240        printf " %2d %-50s\n",
2241               $count,
2242               $site;
2243        $count++;
2244    }
2245}
2246
2247sub addsource
2248{
2249    my $source = shift;
2250
2251    my ($site, $priority, @rest) = split(/,/, $source);
2252
2253    if (@rest)
2254    {
2255        print "Warning: Ignoring unknown options: @rest\n";
2256    }
2257
2258    $site = "$site/" unless ($site =~ /\/$/);
2259
2260    &delsource($site, 1);
2261
2262    if (!$priority or $priority < 1 or $priority > @$sources)
2263    {
2264        $priority = @$sources;
2265    }
2266    else
2267    {
2268        $priority--;
2269    }
2270    splice (@$sources, $priority, 0, $site);
2271    &log("\nAdded source $site\n");
2272    if (&fetch_file($site . 'status.csum?', undef, 1))
2273    {
2274        &log("Source appears valid.\n");
2275    }
2276    else
2277    {
2278        &log("\n*** WARNING: Source unreachable! ***\n\n");
2279    }
2280    &sources;
2281    &log("\n*** PLEASE READ CAREFULLY! ***\n".
2282         "Adding a source allows the remote host to install and execute\n".
2283         "software on your system. Each time Shepherd runs (except when\n".
2284         "invoked with --noupdate), it will ask this host for updates.\n".
2285         "This is a serious security risk, and we STRONGLY RECOMMEND that\n".
2286         "you take steps to limit the damage a malicious source could do\n".
2287         "to your system. For more information, see:\n".
2288         "   $wiki/Security\n" .
2289         "To remove a source, use \"--delsource <source>\".\n");
2290}
2291
2292sub delsource 
2293{
2294    my ($source, $quietcheck) = @_;
2295
2296    if ($source eq 'all')
2297    {
2298        print "Resetting sources.\n";
2299        &reset_sources;
2300        return &sources;
2301    }
2302    $source = "$source/" unless ($source =~ /\/$/);
2303    for (my $i = 0; $i < @$sources; $i++)
2304    {
2305        my $site = $sources->[$i];
2306        if ($source eq $site)
2307        {
2308            splice (@$sources, $i, 1);
2309            &reset_sources if (@$sources < 1);
2310            return if ($quietcheck);
2311            print "\nDeleted source: $source\n";
2312            return &sources;
2313        }
2314    }
2315    unless ($quietcheck)
2316    {
2317        print "\nError: No such source: \"$source\"\n";
2318        exit;
2319    }
2320}
2321
2322sub reset_sources
2323{
2324    $sources = [ 'http://www.whuffy.com/shepherd/' ];
2325}
2326
2327sub list_chan_names
2328{
2329    require Shepherd::Configure;
2330    &Shepherd::Configure::list_chan_names;
2331}
2332
2333sub set_icons
2334{
2335    require Shepherd::Configure;
2336    &Shepherd::Configure::set_icons;
2337}
2338
2339sub configure_mythtv
2340{
2341    require Shepherd::Configure;
2342    &Shepherd::Configure::configure_mythtv;
2343}
2344
2345sub refill_mythtv
2346{
2347    my ($refresh, $reoutput) = @_;
2348
2349    my $t = time;
2350    if (!$refresh and (!$last_successful_run or $t - $last_successful_run > (24 * 3600)))
2351    {
2352        if ($last_successful_run)
2353        {
2354            &log("\nWARNING: Last successful run was " . 
2355                &pretty_duration($t - $last_successful_run) .
2356                " ago, which is a pretty long time.\n");
2357        }
2358        else
2359        {
2360            &log("\nWARNING: Shepherd doesn't seem to have ever run successfully,\n" .
2361                 "so we may have no guide data to feed to MythTV.\n");
2362        }
2363        &log("You may want to run 'tv_grab_au --refresh-mythtv' instead, to generate\n" .
2364             "fresh guide data.\n");
2365        &countdown(10);
2366    }
2367    my $mythtv_version;
2368    &log("\nAttempting to figure out your version of mythfilldatabase...\n");
2369    my $result = `mythfilldatabase --version`;
2370    if ($result =~ /MythTV Version.*?v([\.0-9]+)/)
2371    {
2372        $mythtv_version = $1;
2373        &log("MythTV version seems to be $mythtv_version\n");
2374    }
2375    else
2376    {
2377        &log("Couldn't understand the response from 'mythfilldatabase --version'.\n" .
2378                "Assuming a version prior to 0.25.\n");
2379        $mythtv_version = '0.24';
2380    }
2381    $result = &versioncmp('0.25', $mythtv_version);
2382    my ($mythfilldatabase_exec, $mythfilldatabase_exec2);
2383    if ($result <= 0)
2384    {
2385        if ($reoutput)
2386        {
2387            $mythfilldatabase_exec = 'mythfilldatabase -- --reoutput';
2388        }
2389        else
2390        {
2391            $mythfilldatabase_exec = "mythfilldatabase --update --file --sourceid 1 --xmlfile $output_filename";
2392        }
2393    }
2394    else
2395    {
2396        if ($reoutput)
2397        {
2398            $mythfilldatabase_exec2 = "mythfilldatabase --graboptions '--reoutput'";
2399        }
2400        else
2401        {
2402            $mythfilldatabase_exec = "mythfilldatabase --update --file 1 $output_filename";
2403        }
2404    }
2405    &log("Trying now...\nExecuting: $mythfilldatabase_exec\n\n".
2406        "-------------------mythfilldatabase output---------------------\n");
2407    sleep 1;
2408    $result = system("$mythfilldatabase_exec");
2409    &log("-----------------end mythfilldatabase output-------------------\n\n");
2410    if ($result)
2411    {
2412        &log("Hmm, that didn't seem to work (got a non-zero exit value!).\n");
2413        if ($reoutput)
2414        {
2415            &log("Consider trying 'tv_grab_au --refill-mythtv', which does the same\n" .
2416                "thing, only using mythfilldatabase's --file option.\n\n");
2417        }
2418        else
2419        {
2420            &log("Consider trying 'tv_grab_au --reoutput-mythtv', which does the same\n" .
2421                "thing, only by feeding output directly to MythTV. This requires\n" .
2422                "that MythTV be already configured to use Shepherd as its default\n" .
2423                "grabber, however.\n\n");
2424        }
2425    }
2426    &log("Shepherd: Hopefully your guide data has now been loaded into MythTV.\n" .
2427        "          If not, please report it to the Shepherd mailing list.\n");
2428}
2429
2430sub ancestry
2431{
2432    # Since this subroutine is optional and manually invoked, we won't
2433    # require users have the File::Find dependency until they need it.
2434    # It's probably a little annoying to suddenly realize you need
2435    # another module when you thought everything was installed, but
2436    # that's better than requiring all users have this dependency even
2437    # if they don't really need it.
2438    &require_module("File::Find::Rule");
2439
2440    # Step 1: figure out start and stop dates
2441
2442    my $t = time;
2443    $opt->{'ancestry-zone'} = POSIX::strftime("%z", localtime($t));
2444    print "Assuming local time zone is $opt->{'ancestry-zone'}.\n";
2445    my ($start, $stop);
2446    if ($opt->{ancestry} =~ /(.*)\+(\d+):?(.*)/)
2447    {
2448        $opt->{'ancestry-start'} = Date::Manip::UnixDate("$1 $opt->{'ancestry-zone'}","%s");
2449        $opt->{'ancestry-stop'} = $opt->{'ancestry-start'} + (60 * $2);
2450        $opt->{'ancestry-title'} = $3 if ($3);
2451    }
2452    unless ($opt->{'ancestry-start'} and $opt->{'ancestry-stop'})
2453    {
2454        &log("\nSorry, I don't understand the argument sent to --ancestry.\n".
2455             "Format: --ancestry \"<timestamp>+<minutes>[:title]\"\n".
2456             "Timestamp can be any of a variety of formats. Some examples:\n".
2457             "  --ancestry 200706210800+30             (June 21 2007 8am-8:30am)\n".
2458             "  --ancestry \"today 9pm+10\"            (today 9pm-9:10pm)\n".
2459             "  --ancestry \"midnight tomorrow+60\"    (12am-1am tomorrow)\n".
2460             "  --ancestry \"tuesday 8:28pm+10:news\"  (also only shows with \"news\" in title)\n");
2461        return;
2462    }
2463
2464    my $dformat = "%A %e %B %Y %I:%M %p %z";
2465    printf "Examining ancestry of data from %s to %s.\n",
2466        POSIX::strftime($dformat, localtime($opt->{'ancestry-start'})),
2467        POSIX::strftime($dformat, localtime($opt->{'ancestry-stop'}));
2468    print "Only looking for shows with \"$opt->{'ancestry-title'}\" in title.\n" if ($opt->{'ancestry-title'});
2469
2470    # Step 2: Figure out dates of interest of output files
2471    #
2472    # A little tricky because we only store the timestamp of when Shepherd's
2473    # last run finished, not when it started.
2474
2475    print "Last successful run was " . pretty_duration($t - $last_successful_run) ." ago.\n" if ($last_successful_run);
2476    my $previous_run = (reverse sort keys %$last_successful_runs)[1] if (ref $last_successful_runs and keys %$last_successful_runs > 1);
2477
2478    if ($previous_run)
2479    {
2480        print "Second-last successful run was " . pretty_duration($t - $previous_run)." ago.\n";
2481    }
2482    else
2483    {
2484        $previous_run = $t - (24*60*60);
2485        print "No data on second-last successful run.\n";
2486    }
2487    if ($last_successful_run and $last_successful_run - $previous_run > (6*60*60))
2488    {
2489        $previous_run = $last_successful_run - (6 * 60 * 60);
2490        print "Setting cut-off point to 6 hours before end of last successful run.\n";
2491    }
2492    print "Looking for output files more recent than " . pretty_duration($t - $previous_run) . " ago.\n";
2493
2494    # Step 3: gather files
2495
2496    my @f = File::Find::Rule->file()
2497                            ->name('output*.xmltv')
2498                            ->mtime(">$previous_run")
2499                            ->nonempty
2500                            ->in('grabbers', 'reconcilers', 'postprocessors');
2501    push @f, "output.xmltv" if (-e 'output.xmltv' and (stat 'output.xmltv')[9] > $previous_run);
2502
2503    # Step 4: Process files via XMLTV callback
2504
2505    foreach my $f (@f) 
2506    { 
2507        my $str;
2508        if ($f =~ /.*?\/(.*?)\/(.*)/)
2509        {
2510            $str = "$1: $2";
2511        }
2512        else
2513        {
2514            $str = "Shepherd Final Output: $f";
2515        }
2516        print  "********************************************************************************\n";
2517        printf "%*s\n", int((80 - length($str)) / 2) + length ($str), $str;
2518        XMLTV::parsefiles_callback(undef, undef, undef, \&ancestry_cb, $f);
2519    }
2520}
2521
2522sub ancestry_cb
2523{
2524    my $s = shift;
2525
2526    my ($start, $stop) = ($s->{start}, $s->{stop});
2527    $start .= " $opt->{'ancestry-zone'}" unless ($start =~ /\+\d{4}/);
2528    $stop  .= " $opt->{'ancestry-zone'}" unless ($stop =~ /\+\d{4}/);
2529
2530    $start = Date::Manip::UnixDate($start, "%s");
2531    $stop = Date::Manip::UnixDate($stop, "%s");
2532   
2533    return unless ($stop > $opt->{'ancestry-start'} and $start < $opt->{'ancestry-stop'});
2534
2535    my $title = (ref $s->{title} ? $s->{title}[0][0] : $s->{title});
2536    return if ($opt->{'ancestry-title'} and $title !~ /$opt->{'ancestry-title'}/i);
2537    my $channame;
2538    foreach (keys %$channels)
2539    {
2540        if ($channels->{$_} eq $s->{channel})
2541        {
2542            $channame = $_;
2543            $channame =~ s/\(.*?\)//g;
2544            last;
2545        }
2546    }
2547    $channame = $s->{channel} unless ($channame);
2548    my $subtitle = (ref $s->{'sub-title'} ? $s->{'sub-title'}[0][0] : $s->{'sub-title'});
2549    printf "+ %-50s%s\n",
2550        "$title [$channame]",
2551        POSIX::strftime("%a %d/%m %I:%M%p", localtime($start)) . ' - ' . POSIX::strftime("%I:%M%p", localtime($stop));
2552    print "     \"$subtitle\"\n" if ($subtitle);
2553    print "     $s->{start}  -  $s->{stop}\n";
2554}
2555
2556# -----------------------------------------
2557# Subs: Configuration
2558# -----------------------------------------
2559
2560sub configure
2561{
2562    eval
2563    {
2564        require Shepherd::Configure;
2565
2566        return &Shepherd::Configure::configure;
2567    };
2568    if ($@)
2569    {
2570        &log("Error from Shepherd::Configure:\n-> $@\n");
2571        return undef;
2572    }
2573}
2574
2575# -----------------------------------------
2576# Subs: Status & Help
2577# -----------------------------------------
2578
2579sub show_config
2580{
2581    &log("\nConfiguration\n".
2582         "-------------\n" .
2583         "Config file: $config_file\n" .
2584         "Debug mode : " . is_set($debug) . "\n" .
2585         "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
2586         "Region ID  : $region\n");
2587    show_channels();
2588    &log("\n");
2589    status();
2590    &log("\n");
2591}
2592
2593sub show_channels
2594{
2595    my $mchans = &retrieve_mythtv_channels;
2596    if ($mchans) {
2597        &show_mythtv_mappings($debug, $mchans);
2598    } else {
2599        &log(sprintf "\nYou have subscribed to %d standard channels and %d HDTV/PayTV channels.\n",
2600                        scalar(keys %$channels), scalar(keys %$opt_channels));
2601        &log("\nShepherd XMLTV IDs:\n");
2602        &log(" Standard channels (priority):\n");
2603        &log("    $_ -> $channels->{$_}\n") for sort keys %$channels;
2604        &log(" HDTV and PayTV channels (best-effort):\n");
2605        &log("    $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
2606    }
2607}
2608
2609sub is_set
2610{
2611    my $arg = shift;
2612    return $arg ? "Yes" : "No";
2613}
2614
2615sub pretty_print
2616{
2617    my ($p, $len) = @_;
2618    my $spaces = ' ' x (79-$len);
2619    my $ret = "";
2620
2621    while (length($p) > 0) {
2622        if (length($p) <= $len) {
2623            $ret .= $p;
2624            $p = "";
2625        } else {
2626            # find a space to the left of cutoff
2627            my $len2 = $len;
2628            while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
2629                $len2--;
2630            }
2631            if ($len2 == 0) {
2632                # no space - just print it with cutoff
2633                $ret .= substr($p,0,$len);
2634                $p = substr($p,$len,(length($p)-$len));
2635            } else {
2636                # print up to space
2637                $ret .= substr($p,0,$len2);
2638                $p = substr($p,($len2+1),(length($p)-$len2+1));
2639            }
2640            # print whitespace
2641            $ret .= "\n".$spaces;
2642        }
2643    }
2644    return $ret;
2645}
2646
2647sub pretty_date
2648{
2649    my $t = shift;
2650
2651    return "-    " unless $t;
2652
2653    my @lt = localtime($t);
2654    my @ltnow = localtime();
2655    if (time - $t > 15768000)   # 6 months or older
2656    {
2657        return POSIX::strftime("%d-%b-%y", @lt);    # eg 18-Mar-05
2658    }
2659    if (time - $t < 43200       # less than 12 hours ago
2660            or
2661        ($lt[4] == $ltnow[4] and $lt[3] == $ltnow[3]))  # today
2662    {
2663        return POSIX::strftime("%l:%M%P ", @lt);    # eg 10:45pm
2664    }
2665    return POSIX::strftime("%a %d-%b", @lt);        # eg Mon 25-Dec
2666}
2667
2668sub retrieve_mythtv_channels
2669{
2670    print "\nAttempting Mysql connection to MythTV database mythconverg.\n";
2671
2672    my $mchans;
2673    eval
2674    {
2675        require Shepherd::MythTV;
2676
2677        my $dbh = &Shepherd::MythTV::open_connection();
2678        return unless ($dbh); # end eval
2679        $mchans = $dbh->selectall_arrayref("SELECT name,callsign,channum,xmltvid FROM channel;", { Slice => {} } );
2680        &Shepherd::MythTV::close_connection;
2681    };
2682    if ($@)
2683    {
2684        &log("Error trying to access MythTV database: $@\n");
2685        return undef;
2686    }
2687    return $mchans;
2688}
2689
2690sub show_mythtv_mappings
2691{
2692    my ($show_xmltvids, $mchans) = @_;
2693
2694    &log(sprintf "\nRegion %d. %d MythTV channels. %d Shepherd channels.\n\n",
2695        $region, scalar(@$mchans), scalar(keys %$channels) + scalar(keys %$opt_channels));
2696    if ($show_xmltvids)
2697    {
2698        &log("   #  MythTV Channel                 XMLTV ID             Shepherd Guide Data\n".
2699             " -----------------------------------------------------------------------------\n");
2700    }
2701    else
2702    {
2703        &log("   #  MythTV Channel                 Shepherd Guide Data\n".
2704             " --------------------------------------------------------\n");
2705    }
2706    my %xmltvids;
2707    map { $xmltvids{$channels->{$_}} = $_ } keys %$channels;
2708    map { $xmltvids{$opt_channels->{$_}} = $_ } keys %$opt_channels;
2709    my %unmapped = %xmltvids;
2710    foreach my $chan (@$mchans)
2711    {
2712        my $mapped_to = $chan->{'xmltvid'} ? $xmltvids{$chan->{'xmltvid'}} || '-' : '-';
2713        delete $unmapped{$chan->{'xmltvid'}} if ($mapped_to ne '-');
2714
2715        my $longname = $chan->{'name'};
2716        $longname .= " ($chan->{callsign})" if ($chan->{'callsign'} and lc($chan->{'callsign'}) ne lc($chan->{'name'}));
2717        my $channum = $chan->{'channum'};
2718        if ($show_xmltvids)
2719        {
2720            &log(sprintf "%4s  %-30s %-20s <- %s\n",
2721                         $channum,
2722                         $longname,
2723                         $chan->{'xmltvid'} || '-',
2724                         $mapped_to
2725                        );
2726        }
2727        else
2728        {
2729            &log(sprintf "%4s  %-30s <- %s\n",
2730                    $channum,
2731                    $longname,
2732                    $mapped_to);
2733        }
2734    }
2735    if (keys %unmapped)
2736    {
2737        &log("\nWARNING! Unmapped guide data: " . join(', ', values %unmapped) . ".\n".
2738             "         Shepherd is set to download guide data that no MythTV channel wants.\n".
2739             "         Either map these to a MythTV channel, or do not subscribe to them!\n\n");
2740    }
2741}
2742
2743sub desc
2744{
2745    my $lasttype = '';
2746    my %qual_table = ( 3 => "Excellent", 2 => "Good", 1 => "Poor" );
2747
2748    foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) 
2749    {
2750        if ($lasttype ne $components->{$_}->{type})
2751        {
2752            $lasttype = $components->{$_}->{type};
2753            &log("\n*** " . uc($lasttype) . "S ***\n");
2754        }
2755        &log("\n$_ v$components->{$_}->{ver}" .
2756             "\n* " . pretty_print(query_config($_, 'desc'), 77) . "\n".
2757             "* Component source: " . $components->{$_}->{source} . "\n");
2758        if ($lasttype eq 'grabber')
2759        {
2760            &log("* Data Quality: " . $qual_table{int(query_config($_, 'quality'))} . "\n");
2761            &log("* Speed: " . (query_config($_, 'category') == 1 ? "Slow" : "Fast") . "\n");
2762            my $ch = query_config($_, 'channels');
2763            $ch = "All" if ($ch eq '');
2764            $ch = "All except $1" if ($ch =~ /^\-(.*)/);
2765            &log("* Channels: $ch\n");
2766            my $d1 = query_config($_, 'max_days');
2767            my $d2 = query_config($_, 'max_reliable_days');
2768            &log("* Days: " . ($d1 == $d2 ? $d1 : "$d2 to $d1") . "\n");
2769        }
2770    }
2771}
2772
2773sub status
2774{
2775    foreach my $ctype ('grabber', 'reconciler', 'postprocessor')
2776    {
2777        &log("\n " . 
2778             ($ctype eq 'grabber' ?
2779                "                        Enabled/\n".
2780                sprintf(" %-15s Version Ready  Last Run  Status", ucfirst($ctype)) 
2781                : ucfirst($ctype)) .
2782             "\n --------------- ------- ----- ---------- -------------------------------------\n");
2783        foreach (sort { ($components->{$b}->{lastdata} or 0) <=> ($components->{$a}->{lastdata} or 0) } query_component_type($ctype))
2784        {
2785            my $h = $components->{$_};
2786            &log(sprintf  " %-16s%7s %1s/%1s%1s %11s %s\n",
2787                 length($_) > 16 ? substr($_,0,14).".." : $_,
2788                 $h->{ver},
2789                 $h->{disabled} ? 'N' : 'Y',
2790                 $h->{ready} ? 'Y' : 'N',
2791                 (defined $plugin_data->{$_}->{tainted} ? "!" : ""),
2792                 pretty_date($h->{lastdata}),
2793                 ((defined $h->{disabled} && $h->{disabled} == 2) ? "centrally disabled" :
2794                     ($h->{laststatus} ? pretty_print($h->{laststatus},37) : '')));
2795        }
2796    }
2797    if (defined $last_successful_run)
2798    {
2799        my $str = sprintf "Shepherd last ran successfully %s ago", 
2800                          pretty_duration(time - $last_successful_run);
2801        if (defined $last_successful_run_data)
2802        {
2803            $str .= sprintf " and acquired %2.2f%% of data",
2804                            $last_successful_run_data;
2805        }
2806        $str .= ".\n";
2807        if ($last_successful_refresh and $last_successful_refresh != $last_successful_run)
2808        {
2809            $str .= sprintf "Shepherd last autorefreshed %s ago.\n", 
2810                            &pretty_duration(time - $last_successful_refresh);
2811        }
2812        &log($str);
2813    }
2814    &log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
2815    &log("\nWARNING: [!] against components above indicate TAINTED components.\n\n")
2816      if (defined $plugin_data->{tainted});
2817    &check_other_instance;
2818}
2819
2820sub history
2821{
2822    my @all_runs = (sort {$a <=> $b} keys %{$last_successful_runs});
2823    if (scalar @all_runs == 0) {
2824        &log("\nNo runs recorded yet.\n\n");
2825        return;
2826    }
2827
2828    &log(sprintf "\nShepherd has run successfully %d times in the last %d days.\n\n",
2829                 scalar(keys %$last_successful_runs),
2830                 int((time - $all_runs[0]) / 86400));
2831    if ($last_successful_refresh and $last_successful_refresh != $last_successful_run)
2832    {
2833        &log(sprintf "Shepherd last successfully autorefreshed %s ago (%s).\n\n",
2834                &pretty_duration(time - $last_successful_refresh),
2835                &pretty_date($last_successful_refresh));
2836    }
2837
2838    my $str;
2839    foreach my $when (sort {$b <=> $a} keys (%{$last_successful_runs})) 
2840    {
2841        $str = ($str ? "$str," : 'History:');
2842        my $append = sprintf " %s ago (%2.2f%%)", 
2843                     &pretty_duration(time - $when),
2844                     $last_successful_runs->{$when};
2845        if (length($str.$append) > 79) 
2846        {
2847            &log("$str\n");
2848            $str = '        ';
2849        }
2850        $str .= $append;
2851    }
2852    &log("$str.\n");
2853    &check_other_instance;
2854}
2855
2856sub capabilities
2857{
2858    print "baseline\nmanualconfig\npreferredmethod\n";
2859    exit 0;
2860}
2861
2862sub preferredmethod
2863{
2864    print "allatonce\n";
2865    exit 0;
2866}
2867
2868sub description
2869{
2870    print "Australia\n";
2871    exit 0;
2872}
2873
2874sub help
2875{
2876    print q{Info options:
2877    --help                Hello!
2878    --dev-help            Display advanced options
2879    --version             Display version
2880    --status              Display status
2881    --desc                Display detailed status
2882    --history             Display usage history
2883    --check               Verify current installation
2884
2885    --show-config         Show setup details
2886    --show-channels       Show subscribed channels
2887    --pending             Show any pending component installs
2888    --ancestry <s>        Show origin of recent guide data
2889                          (See "--ancestry help")
2890
2891Session options:
2892    --output <file>       Specify an output file (default: ~/.shepherd/output.xmltv)
2893    --days <n>            Retrieve <n> days of data
2894    --offset <n>          Skip first <n> days
2895
2896    --reoutput            Don't grab fresh data; just return cache
2897    --reoutput-mythtv     Don't grab fresh data; feed cache to MythTV
2898    --refill-mythtv       Don't grab fresh data; feed cache to MythTV via --file
2899    --refresh-mythtv      Grab fresh data, then feed to MythTV via --file
2900
2901    --noupdate            Don't update Shepherd; just grab data
2902    --update              Update Shepherd but don't grab data
2903    --skipupdate          Don't update Shepherd or verify components; just grab data
2904    --skippost            Don't run any postprocessors on data
2905    --noautorefresh       Don't switch to autorefresh mode (i.e. "--days 1")
2906
2907    --mode <s>            Quality (default), Efficiency or Speed
2908    --grabwith <s>        Run grabber(s) <s> before any others
2909                          (e.g. --grabwith sbsweb,abc_website)
2910
2911    --debug               Print debugging messages
2912    --quiet               Don't print anything except errors
2913    --notquiet            Override --quiet
2914    --nolog               Don't write a logfile
2915    --nonotify            Don't report anonymous usage statistics
2916
2917Configuration options:
2918    --configure           Setup
2919    --configure-mythtv    Create symlink & cron job to feed data to MythTV
2920
2921    --disable <s>         Set component <s> (or "all") as not to be used
2922    --enable <s>          Set component <s> (or "all") as available for use
2923
2924    --component-set <s:s> Set default argument for component
2925    --configure <s>       Configure component <s>
2926
2927    --set-icons           Download channel icons and update MythTV to use them
2928    --setpreftitle <s>    Set preferred 'title' source as grabber <s>
2929    --clearpreftitle      Clear preferred 'title' source
2930    --reset               Remove all previous title translation data
2931};
2932    exit 0;
2933}
2934
2935sub dev_help
2936{
2937    print q{Developer options:
2938
2939    These options are probably never useful to regular users.
2940
2941    --dontcallgrabbers    Don't call the grabbers, just process cached data
2942    --list-chan-names     List official channel names
2943    --delete <s>          Delete a Shepherd component
2944    --randomize           Use weighted random method of grabber selection
2945
2946    --sources             List Shepherd sources
2947    --addsource <s>[,p]   Add a Shepherd source (optional: priority #)
2948    --delsource <s>       Delete a Shepherd source (or 'all')
2949   };
2950    exit 0;
2951}
2952
2953
2954# -----------------------------------------
2955# Subs: override handlers for standard perl.
2956# -----------------------------------------
2957
2958# ugly hack. please don't try this at home kids!
2959sub my_die {
2960    my ($arg,@rest) = @_;
2961    my ($pack,$file,$line,$sub) = caller(0);
2962
2963    # check if we are in an eval()
2964    if ($^S) {
2965        printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
2966    } else {
2967            printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
2968            if ($arg) {
2969                CORE::die($arg,@rest);
2970            } else {
2971                CORE::die(join("",@rest));
2972            }
2973    }
2974}
2975
2976
2977# -----------------------------------------
2978# Subs: Grabbing
2979# -----------------------------------------
2980
2981sub grab_data
2982{
2983    my $grab_policy = shift;
2984    $grab_policy = "standard" if (!defined $grab_policy);
2985
2986    $find_microgaps = 0;
2987    $missing_unfillable = undef;
2988
2989    my $used_grabbers = 0;
2990    &log("\nSHEPHERD: Grabber stage ($grab_policy).\n");
2991    &log("SHEPHERD: Seeking supplementary data for episode names ('sub-titles').\n") if ($grab_policy eq 'expanded');
2992    &log("SHEPHERD: " .
2993         (($opt->{mode} and grep($_ eq lc($opt->{mode}), qw(efficiency speed))) ?
2994             ucfirst(lc($opt->{mode})) : 'Quality') . 
2995             " mode.\n");
2996
2997    &analyze_plugin_data("",1,$progname);   
2998
2999    my ($grabber, $reason_chosen);
3000    while (my ($grabber, $reason_chosen) = choose_grabber($grab_policy))
3001    {
3002        last if (!defined $grabber);
3003
3004        $data_satisfies_policy = 0;
3005        $data_found_all = 0;
3006        $used_grabbers++;
3007
3008        &log("\nSHEPHERD: Using grabber: ($used_grabbers) $grabber ($reason_chosen)\n");
3009
3010        my $iteration = query_iteration($grabber);
3011
3012        my $output = sprintf "%s/grabbers/%s/%s-%d.xmltv", 
3013                             $CWD, $grabber, 
3014                             ($opt->{'autorefresh'} ? 'refresh' : 'output'),
3015                             $iteration;
3016
3017        my $comm = "$CWD/grabbers/$grabber/$grabber " .
3018                   "--region $region " .
3019                   "--output $output";
3020
3021        if (query_config($grabber, 'option_grabber_settings')) {
3022                $comm .= " " . query_config($grabber, 'option_grabber_settings');
3023        }
3024
3025        # Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
3026        # that we need. Category 2 grabbers are requested to get everything, since there's
3027        # very little cost in grabbing that extra data, and we can use it in the reconciler
3028        # to verify that everything looks OK.
3029        if (query_config($grabber, 'category') == 1)
3030        {
3031            &log("SHEPHERD: Asking $grabber for " . 
3032                 ($find_microgaps ? 'microgaps within ' : '') .
3033                 display_best_timeslice());
3034
3035            # Shepherd internally considers Today == Day 0, but
3036            # grabbers expect Today == Day 1, so add 1.
3037            my $n = $timeslice->{stop} + 1;
3038
3039            # Don't ask the grabber for more than it can provide. This is not
3040            # prevented earlier because we only checked whether the grabber can
3041            # return SOME data within the desired window.
3042            if ($n > query_config($grabber, 'max_days'))
3043            {
3044                $n = query_config($grabber, 'max_days');
3045            }
3046
3047            # Can we use --offset?
3048            if ($timeslice->{start} != 0 and query_config($grabber, 'option_days_offset'))
3049            {
3050                # We want to skip the first X days. We calculate X by taking the
3051                # start day that we want, which is $timeslice->{start}, adding 1
3052                # to convert from Shepherd's "today is day 0" system, then deducting
3053                # 1 because we want to skip until the day before this. So:
3054                my $offset = $timeslice->{start};
3055
3056                $comm .= " " . 
3057                         query_config($grabber, 'option_days_offset') .
3058                         " " .
3059                         $offset;
3060
3061                # 'option_days_offset' / 'option_offset_eats_days'
3062                #
3063                # Grabbers that can skip the first X days of data have the
3064                # 'option_days_offset' flag set in their .conf files.
3065                #
3066                # Of those grabbers that support --offset, there are two
3067                # slightly different interpretations:
3068                #
3069                # --offset 2 --days 3
3070                # Interpretation 1: Grab data for day 3 only.
3071                # Interpretation 2: Grab data for days 3-6 (i.e. skip 2 days,
3072                #                   then grab 3 more).
3073                #
3074                # Most grabbers follow interpretation 1, and they have
3075                # 'option_offset_eats_days' set to indicate this.
3076               
3077                if (!query_config($grabber, 'option_offset_eats_days'))
3078                {
3079                    $n -= $offset;
3080                }
3081            }
3082
3083            $comm .= " " .
3084                     query_config($grabber, 'option_days') .
3085                     " " . 
3086                     $n;
3087           
3088            # Write a temporary channels file specifying only the channels we want
3089            my $tmpchans;
3090            foreach (@{$timeslice->{chans}})
3091            {
3092                $tmpchans->{$_} = $channels->{$_};
3093            }
3094            my $tmpcf = "$CWD/channels.conf.tmp";
3095            write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
3096            $comm .= " --channels_file $tmpcf";
3097
3098            # Create gaps_file if we want less than (roughly) the full day
3099            if ($find_microgaps)
3100            {
3101                my $tmpgf = "$CWD/gaps.tmp";
3102                my $gapstr = record_requested_gaps($tmpgf, $timeslice, $grabber);
3103                $comm .= " --gaps_file $tmpgf";
3104                &log(1, "SHEPHERD: Asking $grabber to fill gaps: $gapstr\n");
3105            }
3106        }
3107        else
3108        {
3109            &log("SHEPHERD: Asking $grabber for days " . 
3110                 ($opt->{offset} ? $opt->{offset} : 0) . 
3111                 " - " . ($days-1). " of all channels\n");
3112            $comm .= " --days $days" if ($days);
3113            $comm .= " --offset $opt->{offset}" if ($opt->{offset});
3114            $comm .= " --channels_file $channels_file";
3115        }
3116
3117        &record_requested_chandays($grabber, $timeslice);
3118
3119        if ((defined $plugin_data->{tor_pid}) &&
3120            (query_config($grabber, 'option_anon_socks'))) {
3121            $comm .= " ".query_config($grabber, 'option_anon_socks')." ".$plugin_data->{tor_address};
3122        }
3123
3124        $comm .= " --debug" if ($debug);
3125        $comm .= " @ARGV" if (@ARGV);
3126
3127        my $retval = 0;
3128        my $msg;
3129        my $component_start = time;
3130        if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
3131            &log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
3132            &log(1, "SHEPHERD: would have called: $comm\n");
3133        } else {
3134            &log("SHEPHERD: Executing command: $comm\n");
3135            if (-e $output) {
3136                &log(1, "SHEPHERD: Removing old output file: $output\n");
3137                unlink($output) or &log("SHEPHERD: Failed to remove old output file: $output\n$!\n");
3138            }
3139            ($retval,$msg) = call_prog($grabber,$comm,0,(query_config($grabber,'max_runtime')*60));
3140        }
3141        my $component_duration = time - $component_start;
3142
3143        if ($retval) {
3144            &log("Grabber exited with non-zero code $retval: assuming it failed.\n" .
3145                 "Last message: \"$msg\"\n");
3146            $components->{$grabber}->{laststatus} = "Failed (code $retval)";
3147            $components->{$grabber}->{consecutive_failures}++;
3148            &add_pending_message($grabber,"FAIL", $retval.":".$msg, $component_start, $component_duration, 
3149                $components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
3150            next;
3151        }
3152
3153        # soak up the data we just collected
3154        &soak_up_data($grabber, $output, "grabber", $grab_policy);
3155        $components->{$grabber}->{laststatus} = $plugin_data->{"$grabber-$iteration"}->{laststatus};
3156
3157        # analyze the data that this grabber returned
3158        # (useful to detect individual components going bad and report them upstream)
3159        &analyze_plugin_data("grabber $grabber", 1, $grabber, $iteration);
3160
3161        if ($plugin_data->{"$grabber-$iteration"}->{valid}) {
3162            $components->{$grabber}->{lastdata} = time;
3163            delete $components->{$grabber}->{consecutive_failures}
3164              if (defined $components->{$grabber}->{consecutive_failures});
3165            &add_pending_message($grabber,"SUCCESS", $retval, $component_start, $component_duration, 
3166                $components->{$grabber}->{ver}, ($plugin_data->{"$grabber-$iteration"}->{total_duration}/60) );
3167        } else {
3168            $components->{$grabber}->{laststatus} = sprintf "Failed (%s)", $plugin_data->{"$grabber-$iteration"}->{failure_reason};
3169            $components->{$grabber}->{consecutive_failures}++;
3170            &add_pending_message($grabber,"FAIL", '0:'.$plugin_data->{"$grabber-$iteration"}->{failure_reason},
3171                $component_start, $component_duration, $components->{$grabber}->{ver}, 
3172                $components->{$grabber}->{consecutive_failures});
3173            # Don't report MISSING_DATA if the component failed
3174            delete $pending_messages->{"$grabber-$iteration"}->{MISSING_DATA};
3175        }
3176
3177        # check to see if we have all the data we want
3178        $data_satisfies_policy = &analyze_plugin_data("analysis of all grabbers so far",0,$progname);
3179
3180        my $missing_before = convert_dayhash_to_list($missing);
3181        my $missing_after = convert_dayhash_to_list(detect_missing_data($grab_policy, 1));
3182        my $list = List::Compare->new($missing_before, $missing_after);
3183        my @grabbed = $list->get_symmetric_difference();
3184        &log("SHEPHERD: Filled " . scalar(@grabbed) . " channel-days with new data from $grabber.\n");
3185        &log(1, "SHEPHERD: Channel-days acquired: " . join (', ', @grabbed) . ".\n");
3186
3187        # Record what we grabbed from cacheable C1 grabbers
3188        if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
3189        {
3190            record_cached($grabber, @grabbed);
3191            write_config_file();
3192        }
3193
3194        # Force paytv to exit because analysis is only for freetv (could maybe move this higher)
3195        if ($grab_policy eq "paytv") {
3196                $data_satisfies_policy = 1;
3197                $data_found_all = 1;
3198                last;
3199        }
3200
3201        last if ($data_found_all);
3202        if ($data_satisfies_policy and $grab_policy ne 'expanded')
3203        {
3204            $find_microgaps = 1;
3205        }
3206    }
3207
3208    if ($used_grabbers == 0)
3209    {
3210        &log("SHEPHERD: No valid grabbers available for $grab_policy stage.\n");
3211    }
3212    elsif (!$data_satisfies_policy)
3213    {
3214        &log("SHEPHERD: Ran through all grabbers but still have policy-violating gaps in data. :(\n");
3215    }
3216    elsif (!$data_found_all)
3217    {
3218        &log("SHEPHERD: Unfillable micro-gaps exist in data.\n");
3219    }
3220}
3221
3222sub query_iteration
3223{
3224    my $grabber = shift;
3225
3226    my $i = 0;
3227    while (1)
3228    {
3229        return $i unless (defined $plugin_data->{"$grabber-$i"});
3230        $i++;
3231        die "Insane infinite loop suspected!" if ($i > 15);
3232    }
3233}
3234
3235# -----------------------------------------
3236# Subs: Intelli-random grabber selection
3237# -----------------------------------------
3238
3239sub choose_grabber
3240{
3241    my $grabber_policy = shift;
3242
3243    $missing = detect_missing_data($grabber_policy) if ($grabber_policy ne "paytv");
3244    my $total;
3245
3246    do { # while (!$total);
3247
3248        if (defined $gscore)    # Reset score hash
3249        {
3250            foreach (keys %$gscore)
3251            {
3252                $gscore->{$_} = 0;
3253            }
3254        }
3255        else                    # Create score hash
3256        {
3257            foreach (query_grabbers())
3258            {
3259                unless (($components->{$_}->{disabled}) || (defined $plugin_data->{$_}->{failed_test}))
3260                {
3261                    $gscore->{$_} = 0;
3262                    if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
3263                    {
3264                        $gscore->{$_ . ' [cache]'} = 0;
3265                    }
3266                }
3267            }
3268        }
3269
3270        if ($grabber_policy ne "paytv") {
3271            # no point calling these on paytv channels - paytv channels are always $opt_channels ..
3272
3273            remove_missing_unfillable();
3274            $timeslice = find_best_timeslice();
3275
3276            if ($timeslice->{chandays} == 0 && !$find_microgaps and $grabber_policy eq 'standard') {
3277                &log("SHEPHERD: No fillable timeslices, trying microgaps!\n\n");
3278                $find_microgaps = 1;
3279                $missing = detect_missing_data($grabber_policy);
3280                remove_missing_unfillable();
3281                $timeslice = find_best_timeslice();
3282            }
3283
3284            if ($timeslice->{chandays} == 0) {
3285                &log("SHEPHERD: No fillable timeslices!\n");
3286                return undef;
3287            }
3288
3289            &log("SHEPHERD: Best timeslice: " . display_best_timeslice());
3290        } else {
3291            # if we are grabbing paytv, remove grabbers that can't provide paytv data
3292            foreach my $grabber (keys %$gscore) {
3293                # Only want grabbers of type 'paytv' or 'both' (undef == FTA)
3294                if (!query_config($grabber, 'type')) {
3295                    delete $gscore->{$grabber};
3296                } else {
3297                    # can this grabber provide any channels we are interested in?
3298                    my $channels_supported = query_config($grabber, 'channels');
3299                    unless (defined $channels_supported)
3300                    {
3301                        &log("WARNING: Grabber $grabber has no channel support " .
3302                        "specified in config.\n");
3303                        $channels_supported = '';
3304                    }
3305
3306                    my $matching_channels = 0;
3307                    if ($channels_supported) {
3308                        if (($channels_supported =~/^-/)) {
3309                            # find a non-matching channel
3310                            foreach my $ch (keys %$opt_channels) {
3311                                if ($channels_supported !~ /\b$ch\b/) {
3312                                    $matching_channels = 1;
3313                                    last;
3314                                }
3315                            }
3316                        } else {
3317                            # find a matching channel
3318                            foreach my $ch (keys %$opt_channels) {
3319                                if ($channels_supported =~ /\b$ch\b/) {
3320                                    $matching_channels = 1;
3321                                    last;
3322                                }
3323                            }
3324                        }
3325                    } else {
3326                        # Empty string means we support all
3327                        $matching_channels = 1;
3328                    }
3329                    delete $gscore->{$grabber} if ($matching_channels == 0);
3330                }
3331            }
3332        }
3333
3334        $total = score_grabbers($grabber_policy);
3335 
3336        &log("SHEPHERD: Scoring grabbers on ability to efficiently provide needed data:\n");
3337        &log("SHEPHERD: Only considering micro-grabbers.\n") if ($find_microgaps);
3338        foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
3339        {
3340            next if ($_ =~ /\[cache\]/);
3341
3342            my $score  = $gscore->{$_};
3343            my $cscore = $gscore->{"$_ [cache]"};
3344            my $cstr   = $cscore ? "(inc. $cscore cache pts) " : "";
3345            $cstr .= "(already called)" if (($score == 0) && ($grabber_policy eq "paytv"));
3346
3347            if ($opt->{randomize})
3348            {
3349                &log(sprintf "%22s %6.1f%% %8d %s\n",
3350                            $_, 
3351                            ($total ? 100* $score / $total : 0), 
3352                            "$score pts",
3353                            $cstr);
3354            }
3355            else
3356            {
3357                &log(sprintf "%22s %8d pts %s\n",
3358                            $_, 
3359                            $score,
3360                            $cstr);
3361            }
3362        }
3363
3364        if ($opt->{grabwith})
3365        {
3366            my @a = split(/,/, $opt->{grabwith});
3367            my $g;
3368            while ($g = shift @a)
3369            {
3370                $opt->{grabwith} = (@a ? join(',', @a) : undef);
3371
3372                if ($components->{$g}->{disabled})
3373                {
3374                    &log("\nSkipping --grabwith grabber \"$g\": it is disabled.\n");
3375                    next;
3376                }
3377
3378                &log("\nObeying --grabwith option: selecting grabber \"$g\".\n");
3379                if ($components->{$g} and $components->{$g}->{type} eq 'grabber')
3380                {
3381                    return(select_grabber($g, $gscore), "--grabwith policy");
3382                }
3383                &log("Not a grabber: \"$g\".\n");
3384            }
3385        }
3386
3387        return undef if $grabber_policy eq "paytv" && !$total;
3388
3389        if (!$total) { # $grabber_policy ne "paytv"
3390            &log("SHEPHERD: Unfillable timeslice.\n\n");
3391            add_timeslice_to_missing_unfillable();
3392        }
3393
3394    } while (!$total); # $grabber_policy ne "paytv"
3395
3396    # If the user has specified a pref_title_source -- i.e. he is
3397    # transitioning from a known grabber -- then we make sure it
3398    # has run at least once, to build the list of title translations.
3399    if ($pref_title_source)
3400    {
3401        my @prefs = split(/,/, $pref_title_source);
3402        foreach my $grabber (@prefs)
3403        {
3404            unless ($components->{$grabber}->{lastdata})
3405            {
3406                &log("Need to build title translation list for transitional grabber $grabber.\n");
3407                return(select_grabber($grabber, $gscore), "transitional for title translation") if ($gscore->{$grabber});
3408                &log("WARNING: Can't run $grabber to build title translation list!\n");
3409            }
3410        }
3411    }
3412
3413    # If run with --randomize, then rather than always selecting the highest-scoring
3414    # grabber first we'll make a weighted random selection.
3415    if ($opt->{randomize})
3416    {
3417        my $r = int(rand($total));
3418        my $c = 0;
3419        foreach my $grabber (keys %$gscore)
3420        {
3421            next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
3422            if ($r >= $c and $r < ($c + $gscore->{$grabber}))
3423            {
3424                return(select_grabber($grabber, $gscore), "--randomize weighted policy");
3425            }
3426            $c += $gscore->{$grabber};
3427        }
3428        die "ERROR: failed to choose grabber.";
3429    }
3430
3431    # Choose grabber with best score. If there are multiple grabbers with the
3432    # best score, randomly select one of them.
3433    my @sorted = sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore;
3434    my @candidates = ( $sorted[0] );
3435    my $c = 1;
3436    while ($c < @sorted and $gscore->{$sorted[$c]} == $gscore->{$sorted[0]})
3437    {
3438        push @candidates, $sorted[$c] unless ($sorted[$c] =~ /\[cache\]/);
3439        $c++;
3440    }
3441
3442    my $num_choices = grep (($gscore->{$_} and $_ !~ /\[cache\]/), @sorted);
3443    if (@candidates > 1)
3444    {
3445        &log("Multiple grabbers with best score: @candidates.\n");
3446        return(select_grabber($candidates[int(rand(scalar(@candidates)))], $gscore),
3447                        "equal best of $num_choices options, randomly selected from " .
3448                        (scalar(@candidates)-1) .
3449                        " peer" . 
3450                        (@candidates > 2 ? 's' : ''));
3451    }
3452    return(select_grabber($candidates[0], $gscore),
3453            $num_choices == 1 ? "only option" : "best of $num_choices options");
3454}
3455
3456sub select_grabber
3457{
3458    my ($grabber, $gscore) = @_;
3459
3460    &log(1, "Selected $grabber.\n");
3461    if (query_config($grabber, 'category') == 2)
3462    {
3463        # We might want to run C1 grabbers multiple times
3464        # to grab various timeslices, but not C2 grabbers,
3465        # which should get everything at once.
3466        delete $gscore->{$grabber};
3467    }
3468    return $grabber;
3469}
3470
3471# Grabbers earn 1 point for each slot or chanday they can fill.
3472# This score is multiplied if the grabber:
3473# * is a category 2 grabber (i.e. fast/cheap)
3474# * is a category 1 grabber that has the data we want in a cache
3475# * can supply high-quality data
3476# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
3477sub score_grabbers
3478{
3479    my $grabber_policy = shift;
3480    my ($total, $key);
3481
3482    my $bestdq = 0;
3483
3484    # Compare C2 grabbers against the raw missing file, because we'll get
3485    # everything. But compare C1 grabbers against the timeslice, because we'll
3486    # only ask them for a slice. This goes for the [cache] and regular C1s.
3487    foreach my $grabber (keys %$gscore)
3488    {
3489        # for each slot, say whether we can fill it or not -- that is,
3490        # whether we support this channel and this day #.
3491
3492        my $hits = 0;
3493        my $cat = query_config($grabber, 'category');
3494        my $dq = query_config($grabber, 'quality');
3495
3496        if ($cat == 1)
3497        {
3498            $key = cut_down_missing($grabber);
3499            # &log(1, "Grabber $grabber is Category 1: comparing capability to best timeslice.\n");
3500        }
3501        else
3502        {
3503            $key = $missing;
3504            # &log(1, "Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n");
3505        }
3506
3507        if ($grabber_policy eq 'expanded' and ($cat != 2 or !&query_config($grabber, 'has_subtitles')))
3508        {
3509            $hits = 0;
3510        }
3511        elsif (!supports_region($grabber))
3512        {
3513#           &log(1, "Zeroing $grabber due to no region support\n");
3514            $hits = 0;
3515        }
3516        elsif (($find_microgaps) and (!query_config($grabber, 'micrograbs')))
3517        {
3518#           &log(1, "Zeroing $grabber due to non-micrograbbing\n");
3519            $hits = 0;
3520        }
3521        elsif ($grabber =~ /\[cache\]/)
3522        {
3523            $hits = find_cache_hits($grabber, $key);
3524        }
3525        elsif ($grabber_policy eq "paytv")
3526        {
3527                foreach my $day (($opt->{offset} ? $opt->{offset} : 0) .. $days-1)
3528                {
3529                        my $val = supports_day($grabber, $day);
3530                        next unless ($val);
3531                        foreach my $ch (keys %$opt_channels)
3532                        {
3533                                $hits += $val * &supports_channel($grabber, $ch, $day);
3534                        }
3535                        $hits = 1 if ($hits > 0 and $hits < 1);
3536                }
3537        }
3538        else
3539        {
3540                foreach my $day (sort keys %$key)
3541                {
3542                        my $val = supports_day($grabber, $day);
3543                        next unless ($val);
3544                        # &log(1, "Day $day:");
3545                        foreach my $ch (@{$key->{$day}})
3546                        {
3547                                $hits += $val * &supports_channel($grabber, $ch, $day)
3548                        }
3549                        $hits = 1 if ($hits > 0 and $hits < 1);
3550                }
3551        }
3552
3553        $dq -= 0.8 if (!&query_config($grabber, 'has_subtitles'));
3554
3555        my $score = 0;
3556        if ($grabber =~ /\[cache\]/)
3557        {
3558            # Bonus is on a sliding scale between 1 and 2 depending on
3559            # % of required data in cache
3560            $score = $hits;
3561        }
3562        elsif ($hits)
3563        {
3564            if ($opt->{mode} and lc($opt->{mode}) eq 'efficiency')
3565            {
3566                $score += 1000 * ($cat - 1);
3567                $score += 400 * ($dq - 1);
3568                $score += $hits;
3569                $score -= 0.2 * $hits if (&query_config($grabber, 'has_noncritical_gaps'));
3570            }
3571            elsif ($opt->{mode} and lc($opt->{mode} eq 'speed'))
3572            {
3573                $score += 2000 * ($cat - 1);
3574                $score += 100 * ($dq - 1);
3575                $score += $hits;
3576                $score -= 0.1 * $hits if (&query_config($grabber, 'has_noncritical_gaps'));
3577            }
3578            else        # Quality mode
3579            {
3580                $score += 1000 * ($dq - 1);
3581                $score += 500 * ($cat - 1);
3582                $score += $hits;
3583                $score -= 0.2 * $hits if (&query_config($grabber, 'has_noncritical_gaps'));
3584            }
3585        }
3586
3587        if ($debug)
3588        {
3589            my $str = sprintf "Grabber %s can supply %d chandays", $grabber, $hits;
3590            $str .= sprintf(" (cat: %d, DQ: %d): %d pts",
3591                            $cat,
3592                            $dq,
3593                            $score) if ($hits);
3594            &log(1, "$str.\n");
3595        }
3596
3597        if ($score and query_config($grabber, 'option_anon_socks') and !defined $plugin_data->{tor_pid}) 
3598        {
3599#           &log(1, "Grabber $grabber needs Tor to run efficiently: reducing score.\n");
3600            $score = int($score/10)+1;
3601        }
3602
3603        $gscore->{$grabber} += $score;
3604        $total += $score;
3605        if ($grabber =~ /\[cache\]/)
3606        {
3607            $gscore->{query_name($grabber)} += $score;
3608        }
3609
3610        if ($score and $dq > $bestdq)
3611        {
3612            $bestdq = $dq;
3613        }
3614    }
3615   
3616    # Eliminate grabbers of data quality 1 if there are any better-quality
3617    # alternatives. (Only need to do this with 'randomize' option, since otherwise
3618    # we will always pick the highest score.)
3619    if ($opt->{randomize})
3620    {
3621        foreach (keys %$gscore)
3622        {
3623            if (query_config($_, 'quality') == 1 and $bestdq > 1)
3624            {
3625                $total -= $gscore->{$_};
3626                $gscore->{$_} = 0;
3627#               &log(1, "Zeroing grabber $_ due to low data quality.\n");
3628            }
3629        }
3630    }
3631
3632    return $total;
3633}
3634
3635# Return 1 if the grabber can provide data for this channel,
3636# 0.5 if it supports it unreliably, and 0 if it doesn't support
3637# it at all May optionally be sent 'day' arg, which allows
3638# specific checking to see if the channel is supported for that
3639# day number.
3640#
3641# Note that Shepherd considers today to be Day 0, so a grabber
3642# that says it can grab 7 days of data supports Day 0 to Day 6.
3643sub supports_channel
3644{
3645    my ($grabber, $ch, $day) = @_;
3646
3647    my $val = 1;
3648
3649    # If grabber has 'max_reliable_days_per_channel' specified, and
3650    # we're looking at a channel and day that's outside that, we'll
3651    # never return more than a value of 0.5.
3652    my $mdpc = query_config($grabber, 'max_reliable_days_per_chan');
3653    $val = 0.5 if ($mdpc and defined $day and $mdpc->{$ch} and $day >= $mdpc->{$ch});
3654
3655    # If grabber has a 'max_days_per_chan' specified that includes
3656    # the channel we're looking at, return 0 if we're outside it and
3657    # 1 if we're within it (or 0.5 if modified by the previous check).
3658    $mdpc = query_config($grabber, 'max_days_per_chan');
3659    return ($day >= $mdpc->{$ch} ? 0 : $val) if ($mdpc and defined $day and $mdpc->{$ch});
3660
3661    $ch =~ s/ /_/g;
3662
3663    # Does this grabber have any channel support exceptions? If so,
3664    # see if the wanted channel is listed for our region.
3665    my $exceptions = query_config($grabber, 'channel_support_exceptions');
3666    if ($exceptions and $exceptions =~ /\b$region:(-?)\S*\b$ch\b/)
3667    {
3668        return ($1 ne '-' ? $val : 0);
3669    }
3670
3671    # No special regional exemptions, so check the main support string.
3672
3673    my $channels_supported = query_config($grabber, 'channels');
3674    unless (defined $channels_supported)
3675    {
3676        &log("WARNING: Grabber $grabber has no channel support " .
3677             "specified in config.\n");
3678        $channels_supported = '';
3679    }
3680
3681    return $val unless ($channels_supported); # Empty string means we support all
3682   
3683    my $match = ($channels_supported =~ /\b$ch\b/);
3684    $exceptions = ($channels_supported =~/^-/);
3685    return ($match != $exceptions ? $val : 0);
3686}
3687
3688# Returns 1 if the grabber supports our set region, else 0
3689sub supports_region
3690{
3691    my ($grabber) = @_;
3692
3693    my $rsupport = query_config($grabber, 'regions');
3694    return 1 unless ($rsupport);    # Empty string means full support
3695
3696    my $match = ($rsupport =~ /\b$region\b/);
3697    my $exceptions = ($rsupport =~/^-/);
3698    return ($match != $exceptions);
3699}
3700
3701# Return 0 if the grabber can't provide data for this day,
3702# 1 if it can reliably, and 0.5 if it can unreliably.
3703#
3704# Note that a max_days of 7 means the grabber can retrieve data for
3705# today plus 6 days.
3706sub supports_day
3707{
3708    my ($grabber, $day) = @_;
3709
3710    return 0 unless ($day < query_config($grabber, 'max_days'));
3711    return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
3712    return 1;
3713}
3714
3715sub find_cache_hits
3716{
3717    my ($grabber, $key) = @_;
3718
3719    $grabber = query_name($grabber);
3720
3721    return 0 unless ($components->{$grabber}->{cached});
3722
3723    my $hits = 0;
3724
3725    foreach my $day (keys %$key)
3726    {
3727        next unless (supports_day($grabber, $day));
3728        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
3729        foreach my $ch (@{$key->{$day}})
3730        {
3731            next unless (supports_channel($grabber, $ch, $day));
3732            $hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
3733        }
3734    }
3735    return $hits;
3736}
3737
3738# Build a dayhash of what channel/day data we're currently missing.
3739# Only policy-violating holes count unless $find_microgaps is set.
3740sub detect_missing_data
3741{
3742    my ($grabber_policy, $quiet) = @_;
3743
3744    my $m = { };
3745
3746    &log("SHEPHERD: Hunting for microgaps!\n") if ($find_microgaps and !$quiet);
3747    foreach my $ch (keys %$channels)
3748    {
3749        # is this channel missing too much data?
3750        if ($find_microgaps)
3751        {
3752            my $lastday = -1;
3753            foreach my $line (@{$channel_data->{$ch}->{analysis}->{missing_all}})
3754            {
3755                $line =~ /^#(\d)/ or die "Bad line $line";
3756                my $day = $1;
3757                unless ($day == $lastday)
3758                {
3759                    push (@{($m->{$day})}, $ch);
3760                    $lastday = $day;
3761                }
3762            }
3763        }
3764        elsif ($grabber_policy eq 'expanded')
3765        {
3766            # Search our guide data for any channel-days that were filled
3767            # by grabbers that don't support sub-titles.
3768
3769            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})})
3770            {
3771                next unless ($day and keys %$day);
3772
3773                my $str;
3774
3775                foreach my $plugin (keys %$plugin_data)
3776                {
3777                    next unless ($plugin =~ /^(.*)-\d+$/);
3778                    my $pluginname = $1;
3779
3780                    next unless ($components->{$pluginname} and $components->{$pluginname}->{type} eq 'grabber');
3781
3782                    if ($plugin_data->{$plugin}->{analysis}->{$ch}->{day}->[$day->{num}]->{have})
3783                    {
3784                        # This grabber has supplied some data for this channel-day
3785   
3786                        if (&query_config($pluginname, 'has_subtitles'))
3787                        {
3788                            # The grabber supports subtitles
3789       
3790                            if (!$plugin_data->{$plugin}->{analysis}->{$ch}->{day}->[$day->{num}]->{missing})
3791                            {
3792                                # A subtitle-supporting grabber supplied this channel-day;
3793                                # no need for further data.
3794
3795                                $m->{$day->{num}} = [ grep($_ ne $ch, @{$m->{$day->{num}}}) ];
3796                                delete $m->{$day->{num}} unless (@{$m->{$day->{num}}});
3797                                undef $str;
3798                                last;
3799                            }
3800
3801                            # Otherwise this grabber didn't fill the whole day, so
3802                            # we still should seek data
3803                        }
3804                        else
3805                        {
3806                            # The grabber that supplied data doesn't support sub-titles;
3807                            # add this channel-day to our list of holes.
3808
3809                            $str = "May lack episode names: $ch day $day->{num} (filled by $pluginname)\n";
3810                            push(@{($m->{($day->{num})})}, $ch);
3811                        }
3812                    }
3813                }
3814                &log(1, "SHEPHERD: $str") if ($str);    # If we get this far, it's a 'suspect' channel-day
3815            }
3816        }
3817        elsif (!$channel_data->{$ch}->{analysis}->{data_ok}) 
3818        {
3819            foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) 
3820            {
3821                next unless ($day and keys %$day); 
3822                push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
3823            }
3824        }
3825    }
3826
3827    my @chans;
3828    foreach my $day (keys %$m)
3829    {
3830        $m->{$day} = [ sort @{$m->{$day}} ];
3831        foreach my $ch (@{$m->{$day}})
3832        {
3833            push (@chans, $ch) unless (grep ($_ eq $ch, @chans));
3834        }
3835    }
3836
3837    &log(sprintf "SHEPHERD: Need %d channel-days of data (%d channels across %d days).\n",
3838                 scalar(keys %$m) * @chans,
3839                 scalar(@chans),
3840                 scalar(keys %$m)
3841             ) if (keys %$m and !$quiet);
3842    return $m;
3843}
3844
3845# Find the largest timeslice in the current $missing dayhash; i.e.
3846# something like "Days 4 - 6 of ABC and SBS." This works by iterating
3847# through the days and looking for overlaps where consecutive days
3848# want the same channels.
3849sub find_best_timeslice
3850{
3851    my ($overlap, $a);
3852    my $slice = { 'chandays' => 0 };
3853
3854    foreach my $day (($opt->{offset} ? $opt->{offset} : 0) .. $days-1)
3855    {
3856        consider_slice($slice, $day, $day, @{$missing->{$day}});
3857        $overlap = $missing->{$day};
3858        foreach my $nextday (($day + 1) .. $days-1)
3859        {
3860            last unless ($missing->{$nextday});
3861            $a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
3862            last unless ($a and @{$a});
3863            consider_slice($slice, $day, $nextday, @{$a});
3864            $overlap = $a;
3865        }
3866    }
3867    return $slice;
3868}
3869
3870sub consider_slice
3871{
3872    my ($slice, $startday, $stopday, @chans) = @_;
3873
3874    my $challenger = ($stopday - $startday + 1) * scalar(@chans);
3875    return unless ($challenger > $slice->{chandays});
3876
3877    # We have a winner!
3878    $slice->{start} = $startday;
3879    $slice->{stop} = $stopday;
3880    $slice->{chans} = [ @chans ];
3881    $slice->{chandays} = $challenger;
3882}
3883
3884sub remove_missing_unfillable
3885{
3886    foreach my $day (keys %{$missing_unfillable}) {
3887        next if !defined $missing->{$day};
3888        foreach my $ch (@{$missing_unfillable->{$day}}) {
3889                @{$missing->{$day}} = grep($_ ne $ch, @{$missing->{$day}});
3890        }
3891    }
3892}
3893
3894sub add_timeslice_to_missing_unfillable
3895{
3896    foreach my $day ($timeslice->{start} .. $timeslice->{stop}) {
3897        foreach my $ch (@{$timeslice->{chans}}) {
3898                push(@{$missing_unfillable->{$day}}, $ch)
3899                                unless grep($_ eq $ch, @{$missing_unfillable->{$day}});
3900        }
3901    }
3902}
3903
3904sub display_best_timeslice
3905{
3906    return sprintf "day%s of channel%s %s (%d channel-day%s).\n",
3907                   ($timeslice->{start} == $timeslice->{stop} ?
3908                       " $timeslice->{start}" :
3909                       "s $timeslice->{start} - $timeslice->{stop}"),
3910                   (@{$timeslice->{chans}} > 1 ? 's' : ''),
3911                   join(', ', @{$timeslice->{chans}}),
3912                   $timeslice->{chandays},
3913                   $timeslice->{chandays} == 1 ? '' : 's';
3914}
3915
3916# Creates temporary gaps file suitable for passing to grabbers with
3917# --gaps_file option, and records the requested buckets for later
3918# analysis by analyze_plugin_data().
3919sub record_requested_gaps
3920{
3921    my ($fn, $timeslice, $grabber) = @_;
3922
3923    my $gaps;
3924    my $gapstr = '';
3925
3926    # Clear any previously-set gaps
3927    delete $plugin_data->{$grabber}->{requested_gaps};
3928
3929    my $timeslice_epoch_start = $policy{starttime} + ($timeslice->{start} * 24 * 60 * 60);
3930    my $timeslice_epoch_end = $policy{starttime} + (($timeslice->{stop} + 1) * 24 * 60 * 60);
3931
3932    foreach my $ch (@{$timeslice->{chans}})
3933    {
3934        my $missinglist = $channel_data->{$ch}->{analysis}->{missing_all_epoch};
3935        my @a = split(/,/, $missinglist);
3936        foreach my $period (@a)
3937        {
3938            $period =~ /(\d+)-(\d+)/;
3939            my ($gap_start, $gap_end) = ($1, $2);
3940            if ($gap_start < $timeslice_epoch_end or $gap_end > $timeslice_epoch_start)
3941            {
3942                # we want this period
3943                push (@{$gaps->{$ch}}, $period);
3944
3945                # record as requested
3946                for (my $etime = $gap_start; $etime <= $gap_end; $etime += $policy{timeslot_size})
3947                {
3948                    my $bucket = ($etime - $policy{starttime}) / $policy{timeslot_size};
3949                    push @{$plugin_data->{$grabber}->{requested_gaps}->{$ch}}, $bucket;
3950                }
3951            }
3952        }
3953        $gapstr .= "$ch:" . join(',', @{$gaps->{$ch}}) . ' ' if ($gaps->{$ch});
3954    }
3955
3956    write_file($fn, 'temporary gaps file', [ $gaps ], [ 'gaps' ]);
3957
3958    return $gapstr;
3959}
3960
3961# Record what a cacheable C1 grabber has just retrieved for us,
3962# so we know next time that this data can be grabbed quickly.
3963sub record_cached
3964{
3965    my ($grabber, @grabbed) = @_;
3966
3967    &log(1, "SHEPHERD: Recording cache for grabber $grabber.\n");
3968
3969    my $gcache = $components->{$grabber}->{cached};
3970    $gcache = [ ] unless ($gcache);
3971    my @newcache;
3972    my $today = strftime("%Y%m%d", localtime);
3973
3974    # remove old chandays
3975    foreach my $chanday (@$gcache)
3976    {
3977        $chanday =~ /(\d+):(.*)/;
3978        if ($1 >= $today)
3979        {
3980            push (@newcache, $chanday);
3981        }
3982    }
3983
3984    # record new chandays
3985    foreach my $chanday (@grabbed)
3986    {
3987        push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
3988    }
3989    $components->{$grabber}->{cached} = [ @newcache ];
3990}
3991
3992# Takes a dayhash and returns it as a list like this:
3993# ( "20061018:ABC", "20061018:Seven", ... )
3994sub convert_dayhash_to_list
3995{
3996    my $h = shift;
3997
3998    my @ret;
3999    foreach my $day (keys %$h)
4000    {
4001        my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
4002        foreach my $ch (@{$h->{$day}})
4003        {
4004            push (@ret, "$date:$ch");
4005        }
4006    }
4007    @ret = sort @ret;
4008    return \@ret;
4009}
4010
4011
4012# If we're about to re-try a grabber, make sure that we're not asking
4013# it for the same data. That is, prevent a broken C1 grabber causing
4014# an infinite loop.
4015sub record_requested_chandays
4016{
4017    my ($grabber, $slice) = @_;
4018
4019    &log(1, "SHEPHERD: Recording timeslice request; will not request these chandays " .
4020            "from $grabber again.\n");
4021
4022    # Clear out anything set previously
4023    delete $plugin_data->{$grabber}->{requested_data};
4024
4025    my @requested;
4026    for my $day ($slice->{start} .. $slice->{stop})
4027    {
4028        foreach my $ch (@{$slice->{chans}})
4029        {
4030            push @requested, "$day:$ch";
4031            $plugin_data->{$grabber}->{requested_data}->{$ch}[$day] = 1;
4032            # &log(1, "  requesting ch $ch on day $day\n");
4033        }
4034    }
4035    if ($grabbed->{$grabber})
4036    {
4037        push @{$grabbed->{$grabber}}, @requested;
4038    }
4039    else
4040    {
4041        $grabbed->{$grabber} = [ @requested ];
4042    }
4043}
4044
4045# If this grabber has been called previously, remove those chandays
4046# from the current request -- we don't want to ask it over and over
4047# for a timeslice that it has already failed to provide.
4048sub cut_down_missing
4049{
4050    my $grabber = shift;
4051
4052    $grabber = query_name($grabber);
4053    my $dayhash = {};
4054
4055    # Take the timeslice and expand it to a dayhash, while pruning
4056    # any chandays that have previously been requested from this
4057    # grabber.
4058    foreach my $day ($timeslice->{start} .. $timeslice->{stop})
4059    {
4060        my @chans;
4061        foreach my $ch (@{$timeslice->{chans}})
4062        {
4063            unless ($grabbed->{$grabber} and grep($_ eq "$day:$ch", @{$grabbed->{$grabber}}))
4064            {
4065                push (@chans, $ch)
4066            }
4067        }
4068        $dayhash->{$day} = [ @chans ] if (@chans);
4069    }
4070
4071    return $dayhash;
4072}
4073
4074# -----------------------------------------
4075# Subs: Analyzing data
4076# -----------------------------------------
4077
4078# interpret xmltv data from this grabber/postprocessor
4079sub soak_up_data
4080{
4081    my ($pluginname, $output, $plugintype, $stage) = @_;
4082
4083    $components_used .= sprintf " + %s(v%s)", $pluginname, $components->{$pluginname}->{ver};
4084    $components_used .= "[tainted]" if (defined $plugin_data->{$pluginname}->{tainted});
4085
4086    if ($plugintype eq "grabber") {
4087        if ((defined $stage) && ($stage eq "paytv")) {
4088            $components_used .= "[ptv]";
4089        } else {
4090            $components_used .= "[m]" if ($find_microgaps);
4091        }
4092    }
4093
4094    my $plugin = $pluginname;
4095    if ($plugintype eq 'grabber')
4096    {
4097        $plugin .= '-' . query_iteration($pluginname);
4098    }
4099
4100    if (! -r $output) {
4101        &log("SHEPHERD: Error: plugin '$pluginname' output file '$output' does not exist\n");
4102        $components_used .= "[failed_notfound]";
4103        $plugin_data->{$plugin}->{failure_reason} = 'no XMLTV output';
4104        return;
4105    }
4106
4107    my $this_plugin = $plugin_data->{$plugin};
4108    &log("SHEPHERD: Started parsing XMLTV from '$pluginname' in '$output' .. any errors below are from parser:\n");
4109    eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
4110    &log("SHEPHERD: Completed XMLTV parsing from '$pluginname'\n");
4111
4112    # Note: as far as I can tell, XMLTV will ALWAYS return an {xmltv} field, even
4113    # if it was unable to parse the file, which makes this little block useless
4114    if (!($this_plugin->{xmltv})) {
4115        &log("WARNING: Plugin $pluginname didn't seem to return valid XMLTV!\n");
4116        $components_used .= "[failed_invalid]";
4117        $plugin_data->{$plugin}->{failure_reason} = 'invalid XMLTV';
4118        return;
4119    }
4120
4121    $this_plugin->{name} = $pluginname;
4122    $this_plugin->{valid} = 1;
4123    $this_plugin->{output_filename} = $output;
4124
4125    my $xmltv = $this_plugin->{xmltv};
4126    my ($encoding, $credits, $chan, $progs) = @$xmltv;
4127
4128    # explicitly track unparsable dates, excessive durations, etc
4129    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))
4130    {
4131        $this_plugin->{$_} = 0;
4132    }
4133
4134    my $seen_channels_with_data = 0;
4135
4136    #
4137    # first iterate through all programmes and see if there are any channels we don't know about
4138    #
4139    my %chan_xml_list;
4140    foreach my $ch (sort keys %{$channels}) {
4141        $chan_xml_list{($channels->{$ch})} = $ch;
4142    }
4143    foreach my $ch (sort keys %{$opt_channels}) {
4144        $chan_xml_list{($opt_channels->{$ch})} = $ch;
4145    }
4146    foreach my $prog (@$progs) {
4147        if (!defined $chan_xml_list{($prog->{channel})}) {
4148            $this_plugin->{progs_with_unknown_channel}++;
4149            &log((sprintf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$pluginname,$prog->{channel}));
4150            $chan_xml_list{($prog->{channel})} = 1;     # so we warn only once
4151        }
4152    }
4153       
4154    # iterate thru channels
4155    foreach my $ch_xmlid (sort keys %chan_xml_list) {
4156        my $seen_progs_on_this_channel = 0;
4157        my $ch = $chan_xml_list{$ch_xmlid};
4158
4159        # iterate thru programmes per channel
4160        foreach my $prog (@$progs) {
4161            next if ($prog->{channel} ne $ch_xmlid);
4162
4163            my $t1 = &parse_xmltv_date($prog->{start});
4164            # Deduct 1 second from end time, so that a show that finishes at
4165            # 2AM is considered to finish at 1:59.59AM, and does not fill
4166            # the 2AM - 2:05AM bucket.
4167            my $t2 = &parse_xmltv_date($prog->{stop}) - 1;
4168
4169            if (!$t1 || !$t2) {
4170                &log((sprintf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
4171                    $pluginname,(!$t1 ? $prog->{start} : $prog->{stop}))) if (!$this_plugin->{progs_with_invalid_date});
4172                $this_plugin->{progs_with_invalid_date}++;
4173                next;
4174            }
4175
4176            my $this_duration = $t2 - $t1;
4177            # skip if on required channel and too long OR extra long provided title isn't 'close'
4178            if (((defined $channels->{$ch} && $this_duration > $policy{max_programme_length}) ||
4179                 ($this_duration > $policy{max_programme_length_opt_channels})) &&
4180                ($prog->{title}->[0]->[0] !~ /\bclose\b/i)) {
4181                &log((sprintf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
4182                    $pluginname, int($policy{max_programme_length} / 3600),
4183                    int(($policy{max_programme_length} % 3600) / 60)))
4184                    if (!$this_plugin->{progs_too_long});
4185                $this_plugin->{progs_too_long}++;
4186                next;
4187            }
4188
4189            if ($this_duration < 1) {
4190                &log(sprintf "- WARNING: plugin '%s' returned programme data with invalid duration (%s to %s): ignored.\n", $pluginname, $prog->{start}, $prog->{stop});
4191                $this_plugin->{progs_too_short}++;
4192                next;
4193            }
4194
4195            # Don't count shows that are simply 'To Be Advised'
4196            # These will be dropped by the reconciler
4197            if ($prog->{title}->[0]->[0] =~ /^to be advised$/i
4198                    or
4199                $prog->{title}->[0]->[0] =~ /^tba$/i)
4200            {
4201                $this_plugin->{progs_tba}++;
4202                next;
4203            }
4204
4205            # store plugin-specific stats
4206            $this_plugin->{programmes}++;
4207            $this_plugin->{total_duration} += $this_duration;
4208            $seen_progs_on_this_channel++;
4209            $this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
4210            $this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
4211            $this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
4212            $this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
4213
4214            # only analyze / check against policy if its a non optional channel
4215            if (defined $channels->{$ch}) {
4216
4217                # programme is outside the timeslots we are interested in.
4218                if ($t1 > $policy{endtime} or $t2 < $policy{starttime})
4219                {
4220                    $this_plugin->{progs_outside_window}++;
4221                    next;
4222                }
4223
4224                # store channel-specific stats
4225                $channel_data->{$ch}->{programmes}++;
4226                $channel_data->{$ch}->{total_duration} += $this_duration;
4227
4228                # store timeslot info
4229                my $start_slotnum = 0;
4230                $start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
4231                  if ($t1 >= $policy{starttime});
4232
4233                my $end_slotnum = ($policy{num_timeslots}-1);
4234                $end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
4235                  if ($t2 < $policy{endtime});
4236
4237                $this_plugin->{progs_outside_window}++ if ($end_slotnum < $start_slotnum);
4238   
4239                &log((sprintf "DEBUG: ch '%s' prog start '%s' stop '%s' storing into timeslots %d-%d (%s-%s)\n",
4240                  $ch, $prog->{start}, $prog->{stop}, $start_slotnum, $end_slotnum,
4241                  POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($start_slotnum * $policy{timeslot_size}))),
4242                  POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($end_slotnum * $policy{timeslot_size})))))
4243                  if $policy{timeslot_debug};
4244
4245                # add this programme into the global and per-plugin timeslots table for this channel
4246                foreach my $slotnum ($start_slotnum..$end_slotnum) {
4247                    $channel_data->{$ch}->{timeslots}[$slotnum]++;
4248                    $this_plugin->{timeslots}->{$ch}[$slotnum]++;
4249                    $this_plugin->{slots_filled}++;
4250                }
4251            } else {
4252                $this_plugin->{progs_optional}++;
4253            }
4254        }
4255
4256        $seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
4257    }
4258
4259    # print some stats about what we saw!
4260    &log((sprintf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
4261        ucfirst($plugintype), $pluginname, $seen_channels_with_data, $this_plugin->{programmes},
4262        int($this_plugin->{total_duration} / 86400),            # days
4263        int(($this_plugin->{total_duration} % 86400) / 3600),   # hours
4264        int(($this_plugin->{total_duration} % 3600) / 60),      # mins
4265        int($this_plugin->{total_duration} % 60),               # sec
4266        (defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
4267        (defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '')));
4268
4269    $this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
4270        $seen_channels_with_data, $this_plugin->{programmes},
4271        int($this_plugin->{total_duration} / 3600),
4272        (defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
4273        (defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
4274
4275    if (!$this_plugin->{slots_filled} and !&query_config($pluginname, 'type'))
4276    {
4277        # Call this a failure if there was some kind of weirdness. If
4278        # the grabber genuinely couldn't retrieve any shows for the
4279        # requested period, that's MISSING_DATA, but if it did and
4280        # we couldn't understand them, that's a FAIL.
4281
4282        if ($this_plugin->{progs_with_invalid_date}
4283                or
4284            $this_plugin->{progs_too_long}
4285                or
4286            $this_plugin->{progs_too_short}
4287                or
4288            $this_plugin->{progs_outside_window}
4289                or
4290            $this_plugin->{progs_with_unknown_channel}
4291                or
4292            $this_plugin->{progs_optional})
4293        {
4294            $this_plugin->{valid} = 0;
4295            $components_used .= '[failed_unparseable]';
4296            $this_plugin->{failure_reason} = 
4297                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",
4298                    $seen_channels_with_data, 
4299                    $this_plugin->{programmes},
4300                    $this_plugin->{total_duration},
4301                    $this_plugin->{slots_filled},
4302                    $this_plugin->{progs_with_invalid_date},
4303                    $this_plugin->{progs_too_long},
4304                    $this_plugin->{progs_too_short},
4305                    $this_plugin->{progs_outside_window},
4306                    $this_plugin->{progs_with_unknown_channel},
4307                    $this_plugin->{progs_optional};
4308        }
4309    }
4310
4311    $plugin_data->{$plugin} = $this_plugin;
4312}
4313
4314
4315# analyze grabber data - do we have all the data we want?
4316#  this can analyze either the cumulative data from ALL plugins ($proggy="shepherd")
4317#  or can analyze the data from one specific plugin
4318
4319sub analyze_plugin_data
4320{
4321    my ($analysisname, $quiet, $proggy, $iteration) = @_;
4322    &log("SHEPHERD: $analysisname:\n") unless $quiet;
4323
4324    my $total_channels = 0;
4325    my $plugin_epoch_missing_data = "";
4326    my $overall_data_ok = 1; # until proven otherwise
4327    my $total_missing = 0;
4328    my $total_data = 0;
4329    my $plugin = $proggy;
4330    $plugin .= "-$iteration" if (defined $iteration);
4331
4332    # iterate across each channel
4333    foreach my $ch (sort keys %{$channels}) {
4334
4335        # if we're analyzing data for a grabber and it doesn't support this channel, skip it
4336        if (($proggy ne $progname) &&
4337            ($components->{$proggy}->{type} eq "grabber") &&
4338            (supports_channel($proggy, $ch, 1) == 0)) {
4339                &log(1, (sprintf "DEBUG: analysis of channel %s for plugin %s skipped since plugin doesn't support channel\n",
4340                    $ch, $proggy));
4341                next;
4342        }
4343
4344        $total_channels++;
4345
4346        my $data;
4347        my $lastpol = "";
4348        $data->{data_ok} = 1; # unless proven otherwise
4349        $data->{have} = 0;
4350        $data->{missing} = 0;
4351
4352        for my $slotnum (0..($policy{num_timeslots}-1)) {
4353            my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
4354
4355            # work out day number of when this bucket is.
4356            # number from 0 onwards.  (i.e. today=0).
4357            # for a typical 7 day grabber this will actually mean 8 days of data (0-7)
4358            # with days 0 and 7 truncated to half-days
4359            my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
4360            $day += $opt->{offset} if ($opt->{offset});
4361
4362            if (!defined $data->{day}->[$day]) {
4363                $data->{day}->[$day]->{num} = $day;
4364                $data->{day}->[$day]->{have} = 0;
4365                $data->{day}->[$day]->{missing} = 0;
4366                $data->{day}->[$day]->{missing_peak} = 0;
4367                $data->{day}->[$day]->{missing_nonpeak} = 0;
4368                $data->{day}->[$day]->{missing_other} = 0;
4369
4370                $data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
4371
4372                # day changed, dump any 'already_missing' data
4373                &dump_already_missing($data, $proggy);
4374            }
4375
4376            # we have programming data for this bucket.  great!  process next bucket
4377            if ((($proggy eq $progname) &&
4378                 (defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
4379                 ($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) ||
4380                (($proggy ne $progname) &&
4381                 (defined $plugin_data->{$plugin}->{timeslots}->{$ch}[$slotnum]) &&
4382                 ($plugin_data->{$plugin}->{timeslots}->{$ch}[$slotnum] > 0))) {
4383                # if we have missing data queued up, push it now
4384                &dump_already_missing($data, $proggy);
4385                &dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
4386
4387                $data->{day}->[$day]->{have} += $policy{timeslot_size};
4388                $data->{have} += $policy{timeslot_size};
4389                next;
4390            }
4391
4392            # some grabbers take HOURS to run. if this bucket (missing data) is for
4393            # a time period now in the past, then don't include it
4394            next if (($bucket_start_offset + $policy{starttime}) < time);
4395
4396            # we don't have programming for this channel for this bucket
4397            &log((sprintf "DEBUG: missing timeslot data for ch '%s' bucket %d (%s)\n",
4398                $ch, $slotnum, POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($slotnum * $policy{timeslot_size})))))
4399                if $policy{timeslot_debug};
4400
4401
4402            if (($proggy ne $progname) && ($components->{$proggy}->{type} eq "grabber")) {
4403                # if we're analyzing data for a grabber and it doesn't have data for this
4404                # channel on this day, don't record it as missing data if:
4405                #   1. grabber doesn't reliably support this day
4406                #   2. we didn't _request_ the data for this channel/day (C1 grabbers only)
4407                #   3. grabber doesn't reliably support this channel
4408
4409                my $ignore_missing = 0; # don't ignore missing unless proven otherwise
4410
4411                # 1. ignore if it exceeds 'max_reliable_days' for this grabber
4412                if (supports_day($proggy,$day) != 1) {
4413                    $ignore_missing++;
4414                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to max_reliable_days\n",
4415                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4416                }
4417
4418                # 2(a). ignore if we didn't request data for channel/day (C1 grabbers)
4419                if ((query_config($proggy, 'category') == 1) &&
4420                    (!defined $plugin_data->{$proggy}->{requested_data}->{$ch}[$day])) {
4421                    $ignore_missing++;
4422                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not requested\n",
4423                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4424                }
4425
4426                # 2(b). ignore if we didn't request this gap (C1 grabbers)
4427                if ($find_microgaps
4428                        and
4429                    &query_config($proggy, 'category') == 1
4430                        and
4431                    grep ($_ ne $slotnum, @{$plugin_data->{$proggy}->{requested_gaps}->{$ch}}))
4432                {
4433                    $ignore_missing++;
4434                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' due to bucket %d being outside requested gap\n",
4435                            $proggy, $ch, $slotnum)) if ($policy{timeslot_debug});
4436                }
4437
4438                # 3. ignore if this grabber can't reliably supply this channel
4439                if (supports_channel($proggy,$ch,$day) != 1) {
4440                    $ignore_missing++;
4441                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to cannot-supply\n",
4442                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4443                }
4444
4445                if ($ignore_missing > 0) {
4446                    # if we have missing data queued up, push it now
4447                    &dump_already_missing($data, $proggy);
4448                    &dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
4449                    next;
4450                }
4451            }
4452
4453
4454            if (($proggy ne $progname) && ($components->{$proggy}->{type} ne "grabber")) {
4455                # if we're analyzing data for a reconciler/postprocessor and it doesn't have
4456                # data for a timeslot, only record that as an error if the source data _was_
4457                # previously available in the 'overall' data
4458
4459                if ((!defined $channel_data->{$ch}->{timeslots}[$slotnum]) ||
4460                    ($channel_data->{$ch}->{timeslots}[$slotnum] == 0)) {
4461                    &log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not-in-overall-data\n",
4462                        $proggy, $ch, $day)) if ($policy{timeslot_debug});
4463                    next;
4464                }
4465            }
4466
4467            # work out the localtime of when this bucket is
4468            my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
4469
4470            # store details of where we are missing data
4471            if (!defined $data->{already_missing}) {
4472                $data->{already_missing} = sprintf "#%d/%02d:%02d",
4473                  $day,
4474                  int($bucket_seconds_offset / 3600),
4475                  int(($bucket_seconds_offset % 3600) / 60);
4476                $data->{already_missing_epoch} = $policy{starttime} + $bucket_start_offset;
4477            }
4478            $data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
4479            $data->{already_missing_last_epoch} = $policy{starttime} + $bucket_start_offset + $policy{timeslot_size} - 1;
4480
4481            $data->{day}->[$day]->{missing} += $policy{timeslot_size};
4482            $data->{missing} += $policy{timeslot_size};
4483
4484            # work out what policy missing data for this bucket fits into
4485            my $pol;
4486            if (($bucket_seconds_offset >= $policy{peak_start}) &&
4487                (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
4488                $pol = "peak";
4489            } elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
4490                     (($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
4491                $pol = "nonpeak";
4492            } else {
4493                $pol = "other";
4494            }
4495
4496            &dump_already_missing_period($data->{day}->[$day],$lastpol)
4497              if (($lastpol ne $pol) && ($lastpol ne ""));
4498
4499            $lastpol = $pol;
4500
4501            $data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
4502
4503            $data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
4504              if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
4505            $data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
4506
4507            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
4508            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
4509            $data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
4510            $data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
4511            $overall_data_ok = 0 if ($data->{data_ok} == 0);
4512        }
4513
4514        # finished all timeslots in this channel.
4515        # if we have missing data queued up, push it now
4516        &dump_already_missing($data, $proggy);
4517
4518        # fill in any last missing period data
4519        foreach my $day (@{($data->{day})}) {
4520            &dump_already_missing_period($day,"peak");
4521            &dump_already_missing_period($day,"nonpeak");
4522            &dump_already_missing_period($day,"other");
4523        }
4524
4525        my $statusstring = sprintf " > ch %s: %s%s\n", 
4526          $ch, 
4527          $data->{have} ? ($data->{missing} ? ($data->{data_ok} ? "PASS (within policy thresholds)" : "FAIL (missing data exceeds policy thresholds):") : "PASS (complete)") : "FAIL (no data):",
4528          $data->{have} ? ", have " . pretty_duration($data->{have}) : '';
4529
4530        # display per-day missing data statistics
4531        foreach my $day (@{($data->{day})}) {
4532            next unless ($day->{missing});
4533
4534            $statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime} + (($day->{num} - ($opt->{offset} or 0)) * 86400)))).": missing ";
4535            if ($day->{have})
4536            {
4537                $statusstring .= pretty_duration($day->{missing}) . ": ";
4538
4539                # do we have any data for this day?
4540                $statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
4541                  if (($day->{missing_peak}) && ($day->{missing_peak}));
4542
4543                $statusstring .= sprintf "%snon-peak %s",
4544                  ($day->{missing_peak} ? " / " : ""),
4545                  join(", ",(@{($day->{missing_nonpeak_table})}))
4546                  if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak}));
4547
4548                $statusstring .= sprintf "%sother %s",
4549                  (($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
4550                  join(", ",(@{($day->{missing_other_table})}))
4551                  if (($day->{missing_other}) && ($day->{missing_other}));
4552            }
4553            else
4554            {
4555                $statusstring .= "entire day";
4556            }
4557            $statusstring .= "\n";
4558        }
4559        &log($statusstring) unless $quiet;
4560        $data->{statusstring} = $statusstring;
4561        $plugin_epoch_missing_data .= sprintf "%s:%s\t",$ch,$data->{missing_all_epoch} if (defined $data->{missing_all_epoch});
4562        $total_missing += $data->{missing};
4563        $total_data += $data->{have};
4564
4565        if ($proggy eq $progname) {
4566            delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
4567            $channel_data->{$ch}->{analysis} = $data;
4568        } else {
4569            delete $plugin_data->{$plugin}->{analysis}->{$ch} if (defined $plugin_data->{$plugin}->{analysis}->{$ch});
4570            $plugin_data->{$plugin}->{analysis}->{$ch} = $data;
4571        }
4572    }
4573
4574    &log((sprintf " > OVERALL: [%2.2f%%] %s\n", 
4575                   ($total_data + $total_missing > 0 ? (100 * $total_data / ($total_data + $total_missing)) : 0),
4576                  ($total_missing ? ($overall_data_ok ? "PASS (within policy thresholds)" : "FAIL (exceeds policy thresholds)") : "PASS (complete)")))
4577          unless $quiet;
4578
4579    if ($plugin_epoch_missing_data ne '') {
4580        &add_pending_message($proggy, 'MISSING_DATA', $plugin_epoch_missing_data) unless ($plugin_data->{tainted});
4581    } elsif ($proggy eq $progname) {
4582        delete $pending_messages->{$progname}->{MISSING_DATA};
4583    }
4584
4585    if ($proggy eq $progname) {
4586        $plugin_data->{$progname}->{total_missing} = $total_missing;
4587        $plugin_data->{$progname}->{total_duration} = $total_data;
4588        $data_found_all = ($total_missing ? 0 : 1);
4589        $data_satisfies_policy = $overall_data_ok;
4590    }
4591    return $overall_data_ok; # return 1 for satisifies policy, 0 for need more
4592}
4593
4594# helper routine for filling in 'missing_all' array
4595sub dump_already_missing
4596{
4597    my ($d, $proggy) = @_;
4598
4599    if (defined $d->{already_missing}) 
4600    {
4601        if (defined $d->{already_missing_last})
4602        {
4603            $d->{already_missing} .= sprintf "-%02d:%02d",
4604                                             int($d->{already_missing_last} / 3600),
4605                                             int(($d->{already_missing_last} % 3600) / 60);
4606        }
4607
4608        push(@{($d->{missing_all})}, $d->{already_missing});
4609
4610        $d->{already_missing_epoch} .= sprintf "-%d",$d->{already_missing_last_epoch};
4611
4612        # Don't report noncritical data holes in grabbers we know have those.
4613        #
4614        # Two things to note here:
4615        # 1. We can only do this for individual grabbers, not Shepherd overall;
4616        #    $plugin_data -> 'missing_all_epoch' is used for further analysis
4617        #    at the Shepherd & channel levels, not just stats reporting.
4618        # 2. Normally we flag data as '$ignore_missing++' in &analyse_plugin_data,
4619        #    but that loops through individual buckets: it knows whether each
4620        #    bucket is filled or not but not how large each gap is.
4621        unless (&query_config($proggy, 'has_noncritical_gaps') and &is_noncritical_gap($d->{already_missing_epoch}))
4622        {
4623            $d->{missing_all_epoch} .= "," if (defined $d->{missing_all_epoch});
4624            $d->{missing_all_epoch} .= $d->{already_missing_epoch};
4625        }
4626
4627        delete $d->{already_missing};
4628        delete $d->{already_missing_last};
4629
4630        delete $d->{already_missing_epoch};
4631        delete $d->{already_missing_last_epoch};
4632    }
4633}
4634
4635# helper routine for filling in per-day missing data
4636# specific to peak/nonpeak/other
4637sub dump_already_missing_period
4638{
4639    my ($d,$p) = @_;
4640    my $startvar = "already_missing_".$p."_start";
4641    my $stopvar = "already_missing_".$p."_stop";
4642
4643    if (defined $d->{$startvar}) {
4644        push(@{($d->{"missing_".$p."_table"})},
4645          sprintf "%02d:%02d-%02d:%02d",
4646            int($d->{$startvar} / 3600),
4647            int(($d->{$startvar} % 3600) / 60),
4648            int($d->{$stopvar} / 3600),
4649            int(($d->{$stopvar} % 3600) / 60));
4650        delete $d->{$startvar};
4651        delete $d->{$stopvar};
4652    }
4653}
4654
4655# Don't bother reporting small gaps when we already know that this
4656# grabber tends to have them.
4657#
4658# It's actually difficult to say exactly which gaps are critical
4659# (or policy-violating), because our analysis operates on a
4660# per-day basis, not per-gap -- for example, four 5-minute gaps
4661# in prime time is a policy violation, even though each individual
4662# gap isn't. So our solution is not perfect: we are simply
4663# disregarding SMALL gaps, regardless of how many there are.
4664#
4665# A gap is considered non-critical if it's:
4666# (a) in peak time and less than 15 minutes long; or
4667# (b) in nonpeak time and less than 30 minutes long; or
4668# (c) in other time and less than 25 minutes long
4669sub is_noncritical_gap
4670{
4671    my $gap = shift;
4672
4673    return 0 unless ($gap =~ /(\d+)-(\d+)/);
4674    my $zero_hr = $policy{starttime} - $policy{first_bucket_offset};
4675
4676    my $gap_start = (($1 - $zero_hr) % 86400);
4677    my $gap_stop = (($2 - $zero_hr) % 86400);
4678    my $diff = $gap_stop - $gap_start;
4679
4680    if ($gap_start <= $policy{peak_stop} and $gap_stop >= $policy{peak_start})
4681    {
4682        # PEAK
4683        return ($diff < 15*60);
4684    }
4685    elsif ($gap_start <= $policy{nonpeak_stop} and $gap_stop >= $policy{nonpeak_start})
4686    {
4687        # NONPEAK
4688        return ($diff < 30*60);
4689    }
4690    else
4691    {
4692        # OTHER
4693        return ($diff < 25*60);
4694    }
4695}
4696
4697# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
4698# and indication of whether the duration is over its threshold or not
4699sub pretty_duration
4700{
4701    my ($d,$crit) = @_;
4702    my $s = "";
4703    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
4704    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if (($d % (60*60*24)) >= (60*60));
4705    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if (($d % (60*60)) >= 60);
4706    $s .= sprintf "%ds",int($d % 60) if (($s eq "") && ($d > 0));
4707    $s .= "no" if ($s eq "");
4708
4709    if (defined $crit) {
4710        $s .= "[!]" if ($d > $crit);
4711    }
4712    return $s;
4713}
4714
4715# work out date range we are expecting data to be in
4716sub calc_date_range
4717{
4718
4719    $policy{starttime} = time;
4720
4721    # set endtime as per $days less 1 day + hours left today
4722    $policy{endtime} = $policy{starttime} + ((60*60*24)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
4723
4724    # normalize starttime to beginning of next bucket
4725    $policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
4726
4727    # work out how many seconds into a day our first bucket starts
4728    $policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
4729
4730    # normalize endtime to end of previous bucket
4731    $policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
4732
4733    # if we are working with an --offset, apply it now.
4734    $policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
4735
4736    # work out number of buckets
4737    $policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
4738
4739    &log((sprintf "DEBUG: policy settings: starttime=%d, endtime=%d, first_bucket_offset=%d, gmt_offset=%d, strftime_tz=%s\n",
4740        $policy{starttime}, $policy{endtime}, $policy{first_bucket_offset}, $gmt_offset,
4741        (strftime("%z", localtime(time)))))
4742        if ($policy{timeslot_debug});
4743}
4744
4745sub calc_gmt_offset
4746{
4747    # work out GMT offset - we only do this once
4748    if (!$gmt_offset) {
4749        # work out our gmt offset
4750        my $tzstring = strftime("%z", localtime(time));
4751
4752        $gmt_offset = (60*60) * int(substr($tzstring,1,2));     # hr
4753        $gmt_offset += (60 * int(substr($tzstring,3,2)));       # min
4754        $gmt_offset *= -1 if (substr($tzstring,0,1) eq "-");    # +/-
4755    }
4756}
4757
4758# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
4759# rather than the various other perl implementation which treat it as being in UTC/GMT
4760sub parse_xmltv_date
4761{
4762    my $datestring = shift;
4763    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
4764    my $tz_offset = 0;
4765
4766    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
4767        ($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);
4768        ($t[6],$t[7],$t[8]) = (-1,-1,-1);
4769
4770        # if input data has a timezone offset, then offset by that
4771        if ($datestring =~ /\+(\d{2})(\d{2})/) {
4772            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
4773        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
4774            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
4775        }
4776
4777        my $e = mktime(@t);
4778        return ($e+$tz_offset) if ($e > 1);
4779    }
4780    return undef;
4781}
4782
4783# -----------------------------------------
4784# Subs: Reconciling data
4785# -----------------------------------------
4786
4787# for all the data we have, try to pick the best bits!
4788sub reconcile_data
4789{
4790    &log("\nReconciling data:\n\n");
4791
4792    my $num_grabbers = 0;
4793    my $input_files = "";
4794    my @input_file_list;
4795
4796    # when reconciling & postprocessing, increase the thresholds of how much
4797    # missing data we permit.
4798    # generally, if a postprocessor or reconciler breaks, it'll return
4799    # no data rather than 'most' data.
4800    $policy{peak_max_missing} *= 3;
4801    $policy{nonpeak_max_missing} *= 1.5;
4802    $policy{other_max_missing} *= 3;
4803
4804    &log("Preferred title preferences from '$pref_title_source'\n")
4805        if ((defined $pref_title_source) &&
4806            ($plugin_data->{$pref_title_source}) &&
4807            ($plugin_data->{$pref_title_source}->{valid}));
4808
4809    &log("Preference for whose data we prefer as follows:\n");
4810    foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
4811        next if ($components->{$proggy}->{disabled});
4812        next if (defined $plugin_data->{$proggy}->{failed_test});
4813
4814        foreach my $plugin (keys %$plugin_data) {
4815            next unless (($plugin =~ /^$proggy-\d+$/) 
4816                            and 
4817                        ($plugin_data->{$plugin})
4818                            and 
4819                        ($plugin_data->{$plugin}->{valid}));
4820            $num_grabbers++;
4821            &log((sprintf "  %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$plugin}->{output_filename}));
4822
4823            $input_files .= $plugin_data->{$plugin}->{output_filename}." ";
4824            push(@input_file_list,$plugin_data->{$plugin}->{output_filename});
4825        }
4826    }
4827
4828    if ($num_grabbers == 0) {
4829        &log("ERROR! Nothing to reconcile! No valid grabber data!\n");
4830        return 0;
4831    }
4832
4833    foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
4834        next if ($components->{$reconciler}->{disabled});
4835        next if (defined $plugin_data->{$reconciler}->{failed_test});
4836        next if (!$components->{$reconciler}->{ready});
4837
4838        $reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
4839
4840        if ((!$reconciler_found_all_data) && ($data_found_all)) {
4841            # urgh.  this reconciler did a bad bad thing ...
4842            &log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
4843        } else {
4844            &log("SHEPHERD: Data from reconciler $reconciler looks good\n");
4845            $input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
4846        }
4847
4848        last if ($input_postprocess_file ne "");
4849    }
4850
4851    if ($input_postprocess_file eq "") {
4852        # no reconcilers worked!!
4853        &log("SHEPHERD: WARNING: No reconcilers seemed to work!  Falling back to concatenating the data together!\n");
4854
4855        my %w_args = ();
4856        $input_postprocess_file = "$CWD/input_preprocess.xmltv";
4857        my $fh = new IO::File ">$input_postprocess_file" || die "could not open $input_postprocess_file for writing: $!\n";
4858        %w_args = (OUTPUT => $fh);
4859        XMLTV::catfiles(\%w_args, @input_file_list);
4860    }
4861    return 1;
4862}
4863
4864
4865# -----------------------------------------
4866# Subs: Postprocessing
4867# -----------------------------------------
4868
4869sub postprocess_data
4870{
4871    # for our first postprocessor, we feed it ALL of the XMLTV files we have
4872    # as each postprocessor runs, we feed in the output from the previous one
4873    # Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
4874    # reverts back to the previous postprocessor if it was shown to be bad
4875
4876    # first time around: feed in reconciled data ($input_postprocess_file)
4877
4878    &log("\nSHEPHERD: Postprocessing stage:\n");
4879
4880    foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
4881        next if ($components->{$postprocessor}->{disabled});
4882        next if (defined $plugin_data->{$postprocessor}->{failed_test});
4883        next if (!$components->{$postprocessor}->{ready});
4884
4885        my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
4886
4887        if ($found_all_data) {
4888            # accept what this postprocessor did to our output ...
4889            &log("SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n");
4890            $input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
4891            next;
4892        }
4893
4894        # urgh.  this postprocessor did a bad bad thing ...
4895        &log("SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n");
4896    }
4897}
4898
4899
4900# -----------------------------------------
4901# Subs: Postprocessing/Reconciler helpers
4902# -----------------------------------------
4903
4904sub call_data_processor
4905{
4906    my ($data_processor_type, $data_processor_name, $input_files) = @_;
4907
4908    &log("\nSHEPHERD: Using $data_processor_type: $data_processor_name\n");
4909
4910    my $out = ($opt->{'autorefresh'} ? 'refresh' : 'output');
4911    my $output = sprintf "%s/%ss/%s/%s.xmltv",$CWD,$data_processor_type,$data_processor_name, $out;
4912    my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
4913    $comm .= " --region $region" .
4914             " --channels_file $channels_file" .
4915             " --output $output";
4916    $comm .= " --days $days" if ($days);
4917    $comm .= " --offset $opt->{offset}" if ($opt->{offset});
4918    $comm .= " --debug" if ($debug);
4919    $comm .= " @ARGV" if (@ARGV);
4920
4921    $comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
4922      if (($data_processor_type eq "reconciler") &&
4923          (defined $pref_title_source) &&
4924          ($plugin_data->{$pref_title_source}) &&
4925          ($plugin_data->{$pref_title_source}->{valid}));
4926
4927    $comm .= " $input_files";
4928    &log("SHEPHERD: Executing command: $comm\n");
4929
4930    if (-e $output)
4931    {
4932        &log(1, "SHEPHERD: Removing old output file: $output\n");
4933        unlink($output) or &log("SHEPHERD: Failed to remove old output file: $output\n$!\n");
4934    }
4935    my $component_start = time;
4936    my ($retval,$msg) = call_prog($data_processor_name,$comm,0,(query_config($data_processor_name,'max_runtime')*60));
4937    my $component_duration = time - $component_start;
4938
4939    if ($retval) {
4940        &log("$data_processor_type exited with non-zero code $retval: assuming it failed.\n" .
4941             "Last message: $msg\n");
4942        $components->{$data_processor_name}->{laststatus} = "Failed ($retval)";
4943        $components->{$data_processor_name}->{consecutive_failures}++;
4944        &add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
4945            $components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
4946        return 0;
4947    }
4948
4949    delete $components->{$data_processor_name}->{conescutive_failures};
4950
4951    #
4952    # soak up the data we just collected and check it
4953    # YES - these are the SAME routines we used in the previous 'grabber' phase
4954    # but the difference here is that we clear out our 'channel_data' beforehand
4955    # so we can independently analyze the impact of this postprocessor.
4956    # if it clearly returns bad data, don't use that data (go back one step) and
4957    # flag the postprocessor as having failed.  after 3 consecutive failures, disable it
4958    #
4959
4960    # clear out channel_data
4961    foreach my $ch (keys %{$channels}) {
4962        delete $channel_data->{$ch};
4963    }
4964
4965    # process and analyze it!
4966    &soak_up_data($data_processor_name, $output, $data_processor_type);
4967
4968    my $have_all_data = 0;
4969    if ((defined $plugin_data->{$data_processor_name}) &&
4970        (defined $plugin_data->{$data_processor_name}->{valid})) {
4971        $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name",0,$data_processor_name);
4972    }
4973
4974    if ($have_all_data) {
4975        $components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
4976        $components->{$data_processor_name}->{lastdata} = time;
4977        delete $components->{$data_processor_name}->{consecutive_failures}
4978          if (defined $components->{$data_processor_name}->{consecutive_failures});
4979        &add_pending_message($data_processor_name,"SUCCESS", $retval, $component_start, $component_duration,
4980            $components->{$data_processor_name}->{ver}, 0);
4981    } else {
4982        $components->{$data_processor_name}->{laststatus} = "missing data: ".$plugin_data->{$data_processor_name}->{laststatus};
4983        $components->{$data_processor_name}->{consecutive_failures}++;
4984        &add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
4985            $components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
4986    }
4987
4988    return $have_all_data;
4989}
4990
4991# We test out ability to write to the output file early, since if
4992# that fails there's no point continuing.
4993sub test_output_file
4994{
4995    my $fh = new IO::File(">>$output_filename")
4996        or die "Can't open $output_filename for writing: $!";
4997    $fh->close;
4998}
4999
5000sub output_data
5001{
5002    my $reuse_cached_output = shift;
5003    $reuse_cached_output = 0 if (!defined $reuse_cached_output);
5004   
5005    my $output_cache_copy = $output_filename;
5006
5007    if ($reuse_cached_output) {
5008        # re-use existing cached output
5009        $input_postprocess_file = $output_cache_copy;
5010    }
5011
5012    if ($output_filename eq $input_postprocess_file) {
5013        # nothing to do - the input is the same as the output
5014        &log("Re-using existing output $output_filename\n");
5015    }
5016    else {
5017        my %writer_args = ( encoding => 'ISO-8859-1' );
5018        my $fh = new IO::File(">$output_filename") || die "Can't open $output_filename for writing: $!";
5019        $writer_args{OUTPUT} = $fh;
5020
5021        $writer = new XMLTV::Writer(%writer_args);
5022        $writer->start( {
5023                'source-info-name' => "$progname v".$components->{$progname}->{ver},
5024                'generator-info-name' => $components_used } );
5025
5026        XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb, 
5027            \&output_data_programme_cb, $input_postprocess_file);
5028        $writer->end();
5029        $fh->close;
5030
5031        &log("Final output stored in $output_filename.\n");
5032
5033        unless ($opt->{'autorefresh'})
5034        {
5035            # copy final output to our cache copy as well
5036            if ($output_filename ne $output_cache_copy) {
5037                unlink($output_cache_copy);
5038                open(F1,"<$output_filename");
5039                open(F2,">$output_cache_copy");
5040                while (<F1>) {
5041                    print F2 $_;
5042                }
5043                close(F1);
5044                close(F2);
5045            }
5046            &log("Cached output stored in $output_cache_copy.\n");
5047        }
5048    }
5049
5050    if (!$opt->{'nooutput'} and ($reuse_cached_output or !$opt->{'output'})) {
5051        &log("\nPrinting XMLTV output to STDOUT in 5 seconds...\n");
5052        sleep 5;
5053        my $fh = new IO::File("< $output_filename") || die "Can't open $output_filename for reading: $!";
5054        print <$fh>;
5055        $fh->close;
5056    }
5057}
5058
5059sub output_data_channel_cb
5060{
5061    my $c = shift;
5062    $writer->write_channel($c);
5063}
5064
5065sub output_data_programme_cb
5066{
5067    my $prog=shift;
5068    $writer->write_programme($prog);
5069}
5070
5071# -----------------------------------------
5072# Subs: Tor support
5073# -----------------------------------------
5074
5075sub start_tor
5076{
5077    # do we have any components requesting the use of tor?
5078    my $want_tor = 0;
5079    foreach (query_grabbers()) {
5080        unless (($components->{$_}->{disabled}) || (defined $plugin_data->{$_}->{failed_test})) {
5081            $want_tor++ if (query_config($_, 'option_anon_socks'));
5082        }
5083    }
5084
5085    return if ($want_tor == 0);
5086
5087    # try to find tor
5088    my $searchpath = ".:/usr/sbin:".$ENV{PATH};
5089    my $found_tor;
5090    foreach my $dir (split(/:/,$searchpath)) {
5091        if ((-x "$dir/tor") && (-f "$dir/tor")) {
5092            $found_tor = "$dir/tor";
5093            last;
5094        }
5095    }
5096
5097    if (!defined $found_tor) {
5098        &log("\nWARNING: $want_tor components wanted to use Tor but could not find it.\n");
5099        &log("This may cause data collection to run slower than it otherwise would.\n");
5100        return;
5101    }
5102
5103    # we'll run our own local copy of Tor exclusively for shepherd
5104    my $tordir = $CWD."/tor";
5105    if (!-d $tordir) {
5106        if (!mkdir $tordir) {
5107            &log("\nWARNING: Could not create $tordir, Tor not started!\n");
5108            &log("This may cause data collection to run slower than it otherwise would.\n");
5109            return;
5110        }
5111    }
5112
5113    &log("\nStarting Tor ($found_tor) in the background (wanted by $want_tor components).\n");
5114    my $pid = fork;
5115    if (!defined $pid) {
5116        # failed
5117        &log("Failed to start $found_tor: $!\n");
5118        return;
5119    } elsif ($pid > 0) {
5120        # parent
5121        sleep 2; # wait a few seconds for Tor to start
5122
5123        # test that it is running
5124        if (!kill 0, $pid) {
5125            &log("Tor doesn't seem to be running on pid $pid anymore, ignoring Tor option.\n");
5126        } else {
5127            &log("Tor appears to have successfully started (pid $pid).\n");
5128            $plugin_data->{tor_address} = "127.0.0.1:9051";
5129            $plugin_data->{tor_pid} = $pid;
5130        }
5131    } else {
5132        # child
5133        exec $found_tor,"SocksListenAddress","127.0.0.1:9051","MaxCircuitDirtiness","30","DataDirectory",$tordir;
5134        exit(1); # we won't reach this
5135    }
5136}
5137
5138
5139sub stop_tor
5140{
5141    if (defined $plugin_data->{tor_pid}) {
5142        # INTR sig stops tor
5143        kill 2,$plugin_data->{tor_pid};
5144    }
5145}
5146
5147sub test_tor
5148{
5149        &start_tor;
5150        return if (!defined $plugin_data->{tor_pid});   # no components require it
5151
5152        &log("\nSome components want to use Tor.\n".
5153             "Testing that it is working by connecting to www.google.com via Tor...\n\n");
5154
5155        sleep 10;
5156
5157        use LWP::Protocol::http;
5158        my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
5159
5160        # override LWP::Protocol::http's _new_socket method with our own
5161        local($^W) = 0;
5162        *LWP::Protocol::http::_new_socket = \&socks_new_socket;
5163
5164        # test that it works
5165        my $retries = 0;
5166        my $data;
5167        while ($retries < 10) {
5168                $retries++;
5169                &log("Connecting to www.google.com (try $retries) ... ");
5170                $data = &fetch_file("http://www.google.com/");
5171                last if (($data) && ($data =~ /Google/i));
5172
5173                sleep 10;
5174        }
5175
5176        if (($data) && ($data =~ /Google/i)) {
5177                &log("\nSUCCESS.\nTor appears to be working!\n");
5178        } else {
5179                &log("Tor doesn't appear to be working. Suggest you look into this!\n");
5180        }
5181
5182        *LWP::Protocol::http::_new_socket = $orig_new_socket;
5183        &stop_tor;
5184
5185        sleep 2;
5186}
5187
5188##############################################################################
5189# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
5190
5191sub socks_new_socket
5192{
5193        my($self, $host, $port, $timeout) = @_;
5194
5195        my ($socks_ip,$socks_port) = split(/:/,$plugin_data->{tor_address});
5196
5197        local($^W) = 0;  # IO::Socket::INET can be noisy
5198        my $sock = $self->socket_class->new(
5199                PeerAddr => $socks_ip,
5200                PeerPort => $socks_port,
5201                Proto    => 'tcp');
5202
5203        unless ($sock) {
5204                # IO::Socket::INET leaves additional error messages in $@
5205                $@ =~ s/^.*?: //;
5206                &log("Can't connect to $host:$port ($@)\n");
5207                return undef;
5208        }
5209
5210        # perl 5.005's IO::Socket does not have the blocking method.
5211        eval { $sock->blocking(0); };
5212
5213        # establish connectivity with socks server - SOCKS4A protocol
5214        print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
5215                (pack 'x') .
5216                $host . (pack 'x');
5217
5218        my $received = "";
5219        my $timeout_time = time + $timeout;
5220        while ($sock->sysread($received, 8) && (length($received) < 8) ) {
5221                select(undef, undef, undef, 0.25);
5222                last if ($timeout_time < time);
5223        }
5224
5225        if ($timeout_time < time) {
5226                &log("Timeout ($timeout) while connecting via SOCKS server\n");
5227                return $sock;
5228        }
5229
5230        my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
5231        &log("Connection via SOCKS4A server rejected or failed\n") if ($req_status == 0x5b);
5232        &log("Connection via SOCKS4A server because client is not running identd\n") if ($req_status == 0x5c);
5233        &log("Connection via SOCKS4A server because client's identd could not confirm the user\n") if ($req_status == 0x5d);
5234
5235        $sock;
5236}
5237
5238##############################################################################
5239
5240# For self-locking
5241__DATA__
5242
Note: See TracBrowser for help on using the repository browser.