Context Navigation

shepherd

Revision 1394, 147.4 kB (checked in by max, 6 weeks ago)
Shepherd: Use Digest::SHA instead of Digest::SHA1. Updated status to follow.
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/trunk/applications/shepherd

Download in other formats: