Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

shepherd

Last change on this file was 1501, checked in by mbarry, 7 years ago
Channel "SBS ONE" has been renamed back to "SBS" (again)
Property svn:executable set to ``*
File size: 161.0 KB

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