Context Navigation

shepherd @ 601

Revision 601, 121.4 kB (checked in by max, 6 years ago)
Shepherd now reports overall failure when no grabbers could obtain data, rather than failure of every individual component.
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	my $progname = 'shepherd';
4	my $version = '0.4.76';
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	# Changelog:
28	# 0.2.31 : split tv_grab_au (install/test/upgrade/enable/disable) from
29	# shepherd (grab/reconcile/postprocess). Previous changelog history
30	# is in shepherd
31	# 0.3.0 : This split deserves a real version bump, Linc! :)
32	# 0.3.1 : honour $option_ready
33	# 0.3.10 : split out into apps directory, renamed back to 'shepherd' with
34	# an auto symlink to tv_grab_au
35	# logging to logs/ directory
36	# 0.4.1 : revert split - dog and shepherd are back as one
37
38	BEGIN { *CORE::GLOBAL::die = \&my_die; }
39
40	use strict;
41	no strict 'refs';
42
43	# ---------------------------------------------------------------------------
44	# --- required perl modules
45	# ---------------------------------------------------------------------------
46
47	&require_module("Cwd", qw(realpath));
48	&require_module("LWP::UserAgent");
49	&require_module("Getopt::Long");
50	&require_module("Data::Dumper");
51	&require_module("XMLTV");
52	&require_module("XMLTV::Ask");
53	&require_module("POSIX", qw(strftime mktime getcwd));
54	&require_module("Compress::Zlib");
55	&require_module("Date::Manip");
56	&require_module("Algorithm::Diff");
57	&require_module("List::Compare");
58	&require_module("Digest::SHA1");
59
60	# ---------------------------------------------------------------------------
61	# --- Global Variables
62	# ---------------------------------------------------------------------------
63
64	my $HOME = 'http://www.whuffy.com';
65
66	my $CWD = &find_home;
67	-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
68	chdir($CWD);
69
70	my $ARCHIVE_DIR = "$CWD/archive";
71	my $LOG_DIR = "$CWD/log";
72
73	my @options;
74	my $opt = {};
75	my $pref_title_source;
76	my $want_paytv_channels;
77	my $mirror_site;
78	my $debug = 0;
79	my $last_successful_run;
80	my $components = { };
81	my $components_pending_install = { };
82	my $region;
83	my $channels;
84	my $opt_channels;
85	my $config_file = "$CWD/$progname.conf";
86	my $channels_file = "$CWD/channels.conf";
87	my $log_file = "$progname.log";
88	my $sysid = time.".".$$;
89	my $pending_messages = { };
90	my $starttime = time;
91	my $any_data;
92	my %REGIONS = (
93	126 => "ACT", 73 => "NSW: Sydney", 184 => "NSW: Newcastle",
94	66 => "NSW: Central Coast", 67 => "NSW: Griffith", 63 => "NSW: Broken Hill",
95	69 => "NSW: Northern NSW", 71 => "NSW: Southern NSW", 106 => "NSW: Remote and Central",
96	74 => "NT: Darwin", 108 => "NT: Remote & Central", 75 => "QLD: Brisbane",
97	78 => "QLD: Gold Coast", 79 => "QLD: Regional", 114 => "QLD: Remote & Central",
98	81 => "SA: Adelaide", 82 => "SA: Renmark", 83 => "SA: Riverland",
99	85 => "SA: South East SA", 86 => "SA: Spencer Gulf", 107 => "SA: Remote & Central",
100	88 => "Tasmania", 94 => "VIC: Melbourne", 93 => "VIC: Geelong",
101	90 => "VIC: Eastern Victoria", 95 => "VIC: Mildura/Sunraysia", 98 => "VIC: Western Victoria",
102	101 => "WA: Perth", 102 => "WA: Regional");
103
104	my $invoked = get_full_path($0);
105
106	# grabbing
107	my $gscore;
108	my $days = 7;
109	my $missing;
110	my $timeslice;
111	my $grabbed;
112	my $gmt_offset;
113	my $data_found_all;
114	my $data_satisfies_policy;
115	my $find_microgaps;
116	my $writer;
117	my $components_used = $progname."(v".$version.")";
118
119	# postprocessing
120	my $langs = [ 'en' ];
121	my $plugin_data = { };
122	my $channel_data = { };
123	my $reconciler_found_all_data;
124	my $input_postprocess_file = "";
125
126	# ---------------------------------------------------------------------------
127	# --- Policies
128	# ---------------------------------------------------------------------------
129	# the following thresholds are used to control whether we keep calling grabbers or
130	# not.
131
132	my %policy;
133	$policy{timeslot_size} = (5 * 60); # 5 minute slots
134	$policy{timeslot_debug} = 0; # don't debug timeslot policy by default
135
136	# PEAK timeslots -
137	# between 4.30pm and 10.30pm every day, only allow a maximum of
138	# 15 minutes "programming data" missing
139	# if there is more than this, we will continue asking grabbers for more
140	# programming on this channel
141	$policy{peak_max_missing} = 15*60; # up to 15 mins max allowed missing
142	$policy{peak_start} = (16(6060))+(30*60); # 4.30pm
143	$policy{peak_stop} = (22(6060))+(30*60); # 10.30pm
144
145	# NON-PEAK timeslots -
146	# between midnight and 7.15am every day, only allow up to 6 hours missing
147	# if there is more than this, we will continue asking grabbers for more
148	# programming on this channel
149	$policy{nonpeak_max_missing} = 7(6060); # up to 7 hours can be missing
150	$policy{nonpeak_start} = 0; # midnight
151	$policy{nonpeak_stop} = (7(6060))+(15*60); # 7.15am
152
153	# all other timeslots - (7.15am-4.30pm, 10.30pm-midnight)
154	# allow up to 60 minutes maximum missing programming
155	$policy{other_max_missing} = 36060; # up to 3 hrs max allowed missing
156
157	# don't accept programmes that last for longer than 8 hours.
158	$policy{max_programme_length} = (8 * 60 * 60); # 8 hours
159
160
161	# ---------------------------------------------------------------------------
162	# --- Setup
163	# ---------------------------------------------------------------------------
164
165	&get_command_line_options;
166
167	&capabilities if ($opt->{capabilities});
168	&preferredmethod if ($opt->{preferredmethod});
169	&description if ($opt->{description});
170
171	$\| = 1;
172	print "$progname v$version\n\n";
173
174	exit if ($opt->{version});
175	&help if ($opt->{help});
176
177	&check_user;
178
179	&read_config_file;
180	&check_region;
181	&read_channels_file;
182	&check_channels;
183
184	&process_setup_commands;
185
186	&open_logfile unless ($opt->{nolog} or $opt->{update} or $opt->{configure});
187
188	# ---------------------------------------------------------------------------
189	# --- Update
190	# ---------------------------------------------------------------------------
191
192	if (&update())
193	{
194	&write_config_file;
195	}
196
197	if ($opt->{configure})
198	{
199	&configure;
200	}
201
202	# ---------------------------------------------------------------------------
203	# --- Go!
204	# ---------------------------------------------------------------------------
205
206	# If the previous run failed to complete, we'll have some pending stats:
207	# deliver these.
208	if (&report_stats)
209	{
210	&write_config_file;
211	}
212
213	unless ($opt->{update})
214	{
215	&check_last_run;
216	&calc_gmt_offset;
217	&commence_stats;
218	&calc_date_range;
219	&start_tor;
220	&grab_data("standard");
221	&grab_data("paytv") if (defined $want_paytv_channels);
222	$any_data = &reconcile_data;
223	if ($any_data)
224	{
225	&postprocess_data;
226	&output_data;
227	&finalize_stats;
228	&report_stats;
229	}
230	else
231	{
232	&no_data;
233	}
234	&write_config_file;
235	&stop_tor;
236	}
237
238	&log("Done.\n");
239	&close_logfile() unless $opt->{nolog};
240
241	exit (!$any_data);
242
243	# ---------------------------------------------------------------------------
244	# --- Subroutines
245	# ---------------------------------------------------------------------------
246
247	# -----------------------------------------
248	# Subs: Updates & Installations
249	# -----------------------------------------
250
251	sub update
252	{
253	my $made_changes = 0;
254	my $wanted_prog = get_full_path(query_filename('shepherd','application'));
255	if (($invoked ne $wanted_prog) && (!$opt->{configure}))
256	{
257	if (-e $wanted_prog)
258	{
259	&log("\n* Restarting ($invoked invoked, $wanted_prog wanted) *\n\n");
260	&close_logfile unless $opt->{nolog};
261	exec("$wanted_prog @options");
262	# This exits.
263	exit(0);
264	}
265
266	&log(2, "\nWARNING: you should really be running ".ucfirst($progname)."\n".
267	" as '".query_filename('shepherd','application')."'\n".
268	" rather than '$invoked'!\n".
269	" Auto-update has been disabled until you fix this!\n\n");
270	&countdown();
271	&log("\nSkipped auto-update.\n\n");
272	return 0;
273	}
274
275	&log("\nChecking for updates:\n\n");
276	my $data = fetch_shepherd_file("shepherd/status.csum");
277
278	unless ($data)
279	{
280	&log("Skipping update.\n");
281	return 0;
282	}
283
284	my %clist = %$components;
285
286	while ($data =~ /(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/g)
287	{
288	my ($progtype, $proggy, $latestversion, $csum1, $csum2) = ($1,$2,$3,$4,$5);
289	if (update_component($proggy, $latestversion, $progtype, $csum1, $csum2))
290	{
291	$made_changes++;
292	}
293	delete $clist{$proggy};
294	}
295
296	# if user has set system to not update, then simply tell them if there are updates
297	if ((defined $opt->{noupdate}) && ($made_changes)) {
298	&log(2,"\n$made_changes components with pending updates, but --noupdate specified.\n".
299	"It is recommended that you manually run --update at your earliest convenience,\n".
300	"as these updates may be for critical bugfixes!\n\n");
301	&countdown(20);
302	return 0;
303	}
304
305	# work out what components disappeared (if any)
306	foreach (keys %clist) {
307	unless ($components->{$_}->{disabled}) {
308	&log("\nDeleted component: $_.\n");
309	disable($_, 2);
310	$made_changes++;
311	}
312	}
313	$made_changes;
314	}
315
316	sub update_component
317	{
318	my ($proggy, $latestversion, $progtype, $csum1, $csum2) = @_;
319
320	my $ver = 0;
321	$ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e query_filename($proggy,$progtype));
322
323	my ($result, $action);
324
325	if ($progtype eq 'application'
326	or $progtype eq 'engine'
327	or $progtype eq 'reconciler')
328	{
329	$result = &majorversioncmp($ver, $latestversion);
330
331	# Ignore major versions that are lower. This lets us maintain branches
332	# of Shepherd; i.e. release a bugfix for a previous version while continuing
333	# development of a newer version with new dependencies.
334	return 0 if ($result == 1);
335
336	if ($result == -1 and !$opt->{'update-version'})
337	{
338	&log(ucfirst($progtype) . " $proggy has new major version available: " .
339	"v$latestversion.\nNot auto-updating. To update, run: $progname " .
340	"--update-version\n");
341	$result = 0;
342	$action = 'IGNORING';
343	}
344	}
345	elsif ($components->{$proggy} and $components->{$proggy}->{disabled} and $components->{$proggy}->{disabled} == 1)
346	{
347	$action = 'DISABLED BY USER';
348	}
349
350	unless ($action)
351	{
352	$result = &versioncmp($ver, $latestversion);
353
354	if (!defined $opt->{noupdate}) {
355	$action = $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
356	$result == 1 ? "DOWNGRADING" :
357	"up to date";
358	} else {
359	$action = $result == -1 ? ($ver ? "UPDATE AVAILABLE" : "NEW COMPONENT") :
360	$result == 1 ? "DOWNGRADE ADVISED" :
361	"up to date";
362	}
363	}
364	&log(2,sprintf "* %-54s%17s\n",
365	ucfirst($progtype) . " $proggy" .
366	($ver ? " v$ver" : '') . "...",
367	$action);
368
369	return $result if (defined $opt->{noupdate});
370	return 0 unless ($result);
371	install($proggy, $latestversion, $progtype, $ver, $csum1, $csum2);
372	return 1;
373	}
374
375	sub install
376	{
377	my ($proggy, $latestversion, $progtype, $oldver, $csum1, $csum2) = @_;
378	my $config;
379
380	my $rdir = "";
381	my $basedir = $CWD."/".$progtype."s";
382	my $ldir = query_ldir($proggy, $progtype);
383
384	-d $basedir or mkdir $basedir or die "Cannot create directory $basedir: $!\n";
385	-d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!\n";
386	my $newfile = "$ldir/$proggy-$latestversion";
387
388	$rdir = $progtype . 's';
389	my $rfile = "shepherd/$rdir/$proggy";
390
391	# have we previously downloaded it but haven't been able to install it
392	# (due to a failed test or failed dependencies or something like that)?
393	if ((-e "$newfile") && (-s "$newfile") && (defined $components_pending_install->{$proggy})) {
394	&log("Appear to have previously downloaded $proggy v$latestversion.\n");
395	$config = Data::Dumper->Dump([$components_pending_install->{$proggy}->{config}], ["config"]);
396	} else {
397	&log("Downloading $proggy v$latestversion.\n");
398	return unless (fetch_shepherd_file($rfile, $newfile, undef, $csum2));
399
400	# Make component executable
401	chmod 0755,$newfile unless ($progtype eq 'reference');
402	}
403
404	# Fetch config file
405	$rfile .= ".conf";
406	$config = fetch_shepherd_file($rfile, undef, undef, $csum1) if (!defined $config);
407
408	return unless ($config); # everyone MUST have config files
409
410	eval $config;
411	if ($@) {
412	&log("Config file $rfile was invalid, not updating this component: $@\n");
413	return;
414	}
415
416	if ($progtype eq 'reference')
417	{
418	$components->{$proggy}->{ready} = 1;
419	}
420	else
421	{
422	# test that the component works BEFORE we install it
423	my $ready_test = test_proggy("$proggy", $progtype, $latestversion);
424	if (!$ready_test) {
425	&log("$proggy v$latestversion failed ready test - marking as a pending update.\n");
426	$components_pending_install->{$proggy}->{config} = $config;
427	$components_pending_install->{$proggy}->{updated} = time;
428
429	if (defined $components->{$proggy}) {
430	$components->{$proggy}->{admin_status} = sprintf "update to version %s pending: %s",
431	$latestversion, $components_pending_install->{$proggy}->{admin_status};
432	}
433
434	return;
435	}
436	$components->{$proggy}->{ready} = $ready_test;
437	}
438
439	-d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!\n";
440
441	rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$oldver") if (-e "$ldir/$proggy");
442	rename($newfile, "$ldir/$proggy");
443
444	&log(1, "Installed $proggy v$latestversion.\n");
445
446	$components->{$proggy}->{type} = $progtype;
447	$components->{$proggy}->{ver} = $latestversion;
448	$components->{$proggy}->{config} = $config;
449	$components->{$proggy}->{updated} = time;
450	$components->{$proggy}->{admin_status} = sprintf "updated from %s to %s", $oldver, $latestversion;
451	delete $components_pending_install->{$proggy} if (defined $components_pending_install->{$proggy});
452
453	# if the update was for the main app, restart it
454	if ($proggy eq $progname) {
455	&write_config_file;
456
457	# special case for main app - we create a symlink also
458	unlink("$CWD/tv_grab_au","$CWD/shepherd");
459	eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/tv_grab_au"); 1 };
460	eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/shepherd"); 1 };
461
462	&log("\n* Restarting *\n\n");
463	&close_logfile unless $opt->{nolog};
464	exec("$ldir/$proggy @options"); # this exits
465	exit(0);
466	}
467
468	# If this component was disabled automatically, re-enable it.
469	# But if it was disabled manually, leave it off.
470	my $d = $components->{$proggy}->{disabled};
471	if ($d and $d == 2)
472	{
473	enable($proggy);
474	}
475	}
476
477	sub fetch_shepherd_file
478	{
479	my ($fn, $store, $postvars, $csum) = @_;
480
481	my $sites = "";
482	$sites = "$mirror_site," if ($mirror_site);
483	$sites .= $HOME;
484
485	my $ret;
486	foreach my $site (split(/,/,$sites))
487	{
488	$ret = fetch_file("$site/$fn", $store, 1, $postvars, $csum);
489	return $ret if ($ret);
490	}
491	return undef;
492	}
493
494	sub test_proggy
495	{
496	my ($proggy, $progtype, $specific_version) = @_;
497
498	&log("Testing $proggy ... ");
499
500	my $ldir = query_ldir($proggy, $progtype);
501	my $progname = query_filename($proggy, $progtype);
502	$progname .= "-".$specific_version if ((defined $specific_version) && ($specific_version ne ""));
503
504	my $opt_ready = query_config($proggy, 'option_ready');
505	$opt_ready \|\|= '--version';
506
507	chdir($ldir);
508	my ($result,$resultmsg,$test_output) = call_prog($proggy, $progname." $opt_ready"." 2>&1",1,1,0);
509	chdir ($CWD);
510
511	&log(1, "Return value: $result\n");
512
513	my $statusmsg;
514
515	if ($result)
516	{
517	&log("FAIL.\n\n".ucfirst($progtype) . " $proggy did not exit cleanly!\n" .
518	"It may require configuration.\n");
519
520	&log(sprintf("<<<<<< output from $proggy was as follows:\n%s\n>>>>>> end output from $proggy\n",$test_output));
521
522	# set proggy status accordingly
523	$statusmsg = sprintf "FAILED (return code %d%s) on %s",
524	$result,
525	($resultmsg eq "" ? "" : ", '$resultmsg'"),
526	POSIX::strftime("%a%d%b%y", localtime(time));
527
528	# can we give any more details on why it failed?
529	if ($test_output and $test_output =~ /Can't locate (.*) in \@INC/) {
530	my $modname = $1;
531	$modname =~ s#/#::#g; # turn / into ::
532	$modname =~ s#\.pm##g; # remove .pm suffix
533	$statusmsg .= ": missing '".$modname."' module.";
534
535	&log("Probably failed due to dependency on missing module '".$modname."'\n");
536	}
537
538	&log("\n");
539	}
540	else
541	{
542	&log("OK.\n");
543
544	# mark as successful but only if previously unsuccessful
545	# (we only mark it if it was previously unsuccessful otherwise a --check
546	# will result in clearing out all of the admin_status fields)
547	$statusmsg = sprintf "tested successfully on %s", POSIX::strftime("%a%d%b%y", localtime(time))
548	if ((defined $components->{$proggy}->{ready}) && (!$components->{$proggy}->{ready}));
549	}
550
551	# update status message
552	if ((defined $statusmsg) && ($statusmsg ne "")) {
553	if ((defined $specific_version) && ($specific_version ne "")) {
554	$components_pending_install->{$proggy}->{admin_status} = $statusmsg;
555	} elsif (defined $components->{$proggy}) {
556	$components->{$proggy}->{admin_status} = $statusmsg;
557	}
558	}
559
560	return !$result;
561	}
562
563	sub enable
564	{
565	return &enable_or_disable('enable', @_);
566	}
567
568	sub disable
569	{
570	return &enable_or_disable('disable', @_);
571	}
572
573	sub enable_or_disable
574	{
575	my ($which, $proggy, $n) = @_;
576
577	if ($proggy =~ /,/)
578	{
579	foreach (split(/,/, $proggy))
580	{
581	&enable_or_disable($which, $_, $n);
582	}
583	return;
584	}
585
586	return unless ($which eq 'enable' or $which eq 'disable');
587
588	unless ($components->{$proggy})
589	{
590	&log("No such component: \"$proggy\".\n");
591	return;
592	}
593
594	if ($components->{$proggy}->{type} eq "application")
595	{
596	&log("Can't $which component: \"$proggy\".\n");
597	return;
598	}
599
600	if (($which eq 'enable') == !$components->{$proggy}->{disabled})
601	{
602	&log("Already " . $which . "d: $proggy.\n");
603	return;
604	}
605	&log(ucfirst($which) . "d $proggy.\n");
606	if ($which eq 'enable')
607	{
608	delete $components->{$proggy}->{disabled};
609	}
610	else
611	{
612	$n \|\|= 1;
613	$components->{$proggy}->{disabled} = $n;
614	}
615	$components->{$proggy}->{admin_status} = sprintf "manually %s on %s", $which . 'd', POSIX::strftime("%a%d%b%y", localtime(time));
616	}
617
618	sub check
619	{
620	my $result;
621
622	&log("\nTesting all components...\n\n");
623
624	foreach my $proggy (keys %$components) {
625	my $progtype = $components->{$proggy}->{type};
626	next if ($progtype eq 'application' or $progtype eq 'reference');
627	my $try_count = 0;
628
629	RETRY:
630	$try_count++;
631	$result = test_proggy($proggy, $components->{$proggy}->{type});
632	$components->{$proggy}->{ready} = $result;
633
634	if ((!$result) && ($try_count < 2) && (query_config($proggy, 'option_config'))) {
635	&log("Trying to configure '$proggy'\n");
636
637	chdir(query_ldir($proggy, $progtype));
638	system(query_filename($proggy, $progtype) . " ". query_config($proggy, 'option_config') . " 2>&1");
639	chdir ($CWD);
640
641	goto RETRY;
642	}
643	}
644
645	&test_tor;
646	}
647
648	sub pending
649	{
650	return unless ($components_pending_install);
651
652	my @pending;
653	foreach (keys %$components_pending_install)
654	{
655	push @pending, $_;
656	}
657	unless (@pending)
658	{
659	&log("\nNo components are pending install.\n");
660	return;
661	}
662	&log("\nThe following components are pending install: " .
663	join(', ', @pending) . ".\n\n" .
664	"You may have missing Perl dependencies. To see errors,\n".
665	"run: $progname --update or $progname --check\n");
666
667	# Exit with non-zero status so this sub can be used to
668	# notify an external program (to email the owner, perhaps)
669	# about pending installs.
670	exit 1;
671	}
672
673	# Set this to a failure message as a default; if we complete successfully we'll change it.
674	sub commence_stats
675	{
676	&add_pending_message($progname, 'FAIL', $sysid, $starttime, 0, $region, 'incomplete');
677	}
678
679	sub finalize_stats
680	{
681	delete $pending_messages->{$progname}->{FAIL};
682	&add_pending_message($progname, "SUCCESS", $sysid, $starttime, (time-$starttime), $region, $components_used);
683	$last_successful_run = time;
684	}
685
686	# If no grabbers returned data, don't report individual component failures but rather
687	# an overall Shepherd failure.
688	sub no_data
689	{
690	$pending_messages = undef;
691	&add_pending_message($progname, 'FAIL', $sysid, $starttime, (time-$starttime), $region, 'no data');
692	}
693
694	# Report any pending stats to main server.
695	sub report_stats
696	{
697	my $postvars = build_stats();
698	return unless $postvars;
699
700	if ($opt->{nonotify} or $opt->{dontcallgrabbers})
701	{
702	&log("Not posting usage statistics due to --" . ($opt->{nonotify} ? 'nonotify' : 'dontcallgrabbers' ) . " option.\n");
703	}
704	else
705	{
706	&log("Posting anonymous usage statistics.\n");
707	return 0 unless (fetch_shepherd_file("report.cgi", undef, $postvars));
708	}
709
710	# successful post, clear out our pending messages
711	$pending_messages = undef;
712
713	return 1; # made changes
714	}
715
716	# gather pending messages
717	sub build_stats
718	{
719	return unless (keys %$pending_messages);
720
721	my $postvars = "";
722	my %postmsgs;
723
724	foreach my $component (keys %$pending_messages) {
725	foreach my $msgtype ( 'SUCCESS', 'FAIL', 'stats', 'MISSING_DATA') {
726	if ($pending_messages->{$component}->{$msgtype}) {
727	$postmsgs{$component} .= urlify("\n".$component."\t") if (defined $postmsgs{$component});
728	$postmsgs{$component} .= urlify($msgtype."\t".$pending_messages->{$component}->{$msgtype});
729	}
730	}
731	}
732
733	# shepherd first
734	$postvars = "$progname=$postmsgs{$progname}";
735
736	# the rest
737	foreach my $component (sort keys %postmsgs) {
738	next if ($component eq $progname);
739	$postvars .= sprintf "%s%s=%s",
740	(length($postvars) > 0 ? "&" : ""),
741	$component, $postmsgs{$component};
742	}
743
744	return $postvars;
745	}
746
747	# -----------------------------------------
748	# Subs: Utilities
749	# -----------------------------------------
750
751	# versioncmp from Sort::Versions by Kenneth J. Albanowski
752	sub versioncmp( $$ ) {
753	my @A = ($_[0] =~ /([-.]\|\d+\|[^-.\d]+)/g);
754	my @B = ($_[1] =~ /([-.]\|\d+\|[^-.\d]+)/g);
755
756	my ($A, $B);
757	while (@A and @B) {
758	$A = shift @A;
759	$B = shift @B;
760	if ($A eq '-' and $B eq '-') {
761	next;
762	} elsif ( $A eq '-' ) {
763	return -1;
764	} elsif ( $B eq '-') {
765	return 1;
766	} elsif ($A eq '.' and $B eq '.') {
767	next;
768	} elsif ( $A eq '.' ) {
769	return -1;
770	} elsif ( $B eq '.' ) {
771	return 1;
772	} elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
773	if ($A =~ /^0/ \|\| $B =~ /^0/) {
774	return $A cmp $B if $A cmp $B;
775	} else {
776	return $A <=> $B if $A <=> $B;
777	}
778	} else {
779	$A = uc $A;
780	$B = uc $B;
781	return $A cmp $B if $A cmp $B;
782	}
783	}
784	@A <=> @B;
785	}
786
787	sub majorversioncmp
788	{
789	my ($v1, $v2) = @_;
790
791	$v1 =~ /^(\d+)\./ and $v1 = $1;
792	$v2 =~ /^(\d+)\./ and $v2 = $1;
793
794	$v1 <=> $v2;
795	}
796
797	sub get_full_path
798	{
799	my $path = shift;
800	my $real = realpath($path);
801	return $path if (!$real);
802	return $real;
803	}
804
805	sub require_module
806	{
807	my ($mod, @imports) = @_;
808
809	my $modname = $mod.".pm";
810	$modname =~ s/::/\//g;
811
812	eval { require $modname; };
813	if ($@) {
814	&log("\nERROR:\nMandatory module '$mod' not found.\n\n" .
815	"Please see the Wiki at http://svn.whuffy.com/wiki/Installation\n" .
816	"for details on how to install this module.\n", 1);
817	exit(1);
818	}
819
820	import $mod @imports;
821	}
822
823	# check that user isn't root, warn them if they are!
824	sub check_user
825	{
826	if ($< == 0) {
827	&log(2, "WARNING:\n You are running ".ucfirst($progname).
828	" as 'root' super-user.\n".
829	" It is HIGHLY RECOMMENDED that you set your system to run ".
830	ucfirst($progname)."\n from within a normal user account!\n\n", 1);
831	&countdown(10);
832	}
833	}
834
835	# if last run was successful and was less than 12 hours ago, refuse to run.
836	# there's really no point calling shepherd more frequently than this.
837	sub check_last_run
838	{
839	return if (!defined $last_successful_run);
840	my $last_ran_secs_ago = time - $last_successful_run;
841
842	&log(0,"\n".ucfirst($progname)." was successfully run ".pretty_duration($last_ran_secs_ago)." ago.\n");
843	return if ($last_ran_secs_ago > (126060));
844
845	&log(2, "WARNING: ".ucfirst($progname)." is being run too frequently.\n");
846
847	if (defined $opt->{notimetest}) {
848	&log(2, "Allowing operation due to '--notimetest' override but\n".
849	"please don't make a habit of this.\n\n");
850	return;
851	}
852
853	&log(2, "Please don't run ".ucfirst($progname)." so frequently.\n\n".
854	"If you are experimenting/testing and really mean to run ".ucfirst($progname).", do so using\n".
855	"the --notimetest setting but please don't make a habit of this.\n");
856
857	&countdown(10, "Aborting");
858	exit(1);
859	}
860
861	# Somehow some users are ending up with no region
862	sub check_region
863	{
864	unless ($opt->{configure} or ($region and $region =~ /^\d+$/))
865	{
866	&log(2, "ERROR: No or invalid region set! " .
867	ucfirst($progname) . " must be configured.\n");
868	$opt->{configure} = 1;
869	$region = undef;
870	}
871	}
872
873	# Make sure the user hasn't edited the config file to try to support
874	# additional channels. This seems to happen reasonably often, and
875	# (a) makes Shepherd waste time and bandwith looking for unsupported channels,
876	# and (b) confuses our stats.
877	sub check_channels
878	{
879	my @supported_channels = &read_official_channels($region);
880	unless (@supported_channels)
881	{
882	&log("Skipping channel check.\n");
883	return;
884	}
885	foreach my $ch (keys %$channels)
886	{
887	unless (grep($_ eq $ch, @supported_channels))
888	{
889	&log("Ignoring unsupported channel for region $region: \"$ch\"\n");
890	delete $channels->{$ch};
891	}
892	}
893	}
894
895	sub read_official_channels
896	{
897	my $reg = shift;
898
899	my $fn = 'references/channel_list/channel_list';
900	unless (open (FN, $fn))
901	{
902	&log("ERROR: Unable to open $fn!\n");
903	return;
904	}
905	while (my $line = <FN>)
906	{
907	return split(/,/, $1) if ($line =~ /^$reg:(.*)/);
908	}
909	&log("ERROR: Unable to find region \"$reg\" in $fn\n");
910	}
911
912	sub query_grabbers
913	{
914	my ($conf, $val) = @_;
915	return query_component_type('grabber',$conf,$val);
916	}
917
918	sub query_reconcilers
919	{
920	return query_component_type('reconciler');
921	}
922
923	sub query_postprocessors
924	{
925	return query_component_type('postprocessor');
926	}
927
928	sub query_component_type
929	{
930	my ($progtype,$conf,$val) = @_;
931
932	my @ret = ();
933	foreach (keys %$components)
934	{
935	if ($components->{$_}->{type} eq $progtype) {
936	if (defined $conf) {
937	push (@ret, $_) if (query_config($_,$conf) eq $val);
938	} else {
939	push (@ret, $_);
940	}
941	}
942	}
943	return @ret;
944	}
945
946	sub query_name
947	{
948	my $str = shift;
949	if ($str =~ /(.*) \[cache\]/)
950	{
951	return $1;
952	}
953	return $str;
954	}
955
956	sub query_filename
957	{
958	my ($proggy, $progtype) = @_;
959	return query_ldir($proggy,$progtype).'/'.$proggy;
960	}
961
962	sub query_ldir
963	{
964	my ($proggy, $progtype) = @_;
965	return $CWD.'/'.$progtype.'s/'.$proggy;
966	}
967
968	sub query_config
969	{
970	my ($grabber, $key) = @_;
971
972	$grabber = query_name($grabber);
973	return undef unless ($components->{$grabber});
974	return $components->{$grabber}->{config}->{$key};
975	}
976
977	sub countdown
978	{
979	my ($n, $contstring) = @_;
980
981	$n \|\|= 10;
982	$contstring \|\|= "Continuing";
983
984	&log(2, "You may wish to CTRL-C and fix this.\n\n$contstring anyway in:");
985	foreach (1 .. $n)
986	{
987	&log(2, " " . ($n + 1 - $_));
988	sleep 1;
989	}
990	&log(2, "\n");
991	}
992
993	sub rotate_logfiles
994	{
995	# keep last 10 log files
996	my $num;
997	for ($num = 10; $num > 0; $num--) {
998	my $f1 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num;
999	my $f2 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num+1;
1000	unlink($f2);
1001	rename($f1,$f2);
1002	}
1003
1004	my $f1 = sprintf "%s/%s",$LOG_DIR,$log_file;
1005	my $f2 = sprintf "%s/%s.1",$LOG_DIR,$log_file;
1006	rename($f1,$f2);
1007	}
1008
1009	sub compress_file
1010	{
1011	my $infile = shift;
1012	my $outfile = sprintf "%s.gz",$infile;
1013	my $gz;
1014
1015	if (!(open(INFILE,"<$infile"))) {
1016	warn "could not open file $infile for reading: $!\n";
1017	return;
1018	}
1019
1020	if (!($gz = gzopen($outfile,"wb"))) {
1021	warn "could not open file $outfile for writing: $!\n";
1022	return;
1023	}
1024
1025	while (<INFILE>) {
1026	my $byteswritten = $gz->gzwrite($_);
1027	warn "error writing to compressed file: error $gz->gzerror"
1028	if ($byteswritten == 0);
1029	}
1030	close(INFILE);
1031	$gz->gzclose();
1032	unlink($infile);
1033	}
1034
1035	sub open_logfile
1036	{
1037	-d $LOG_DIR or mkdir $LOG_DIR or die "Cannot create directory $LOG_DIR: $!";
1038
1039	&rotate_logfiles;
1040	&log(1, "Logging to $log_file.\n");
1041	open(LOG_FILE,">>$LOG_DIR/$log_file") \|\| die "can't open log file $LOG_DIR/$log_file for writing: $!\n";
1042
1043	my $now = localtime(time);
1044	printf LOG_FILE "$progname v$version started at $now\n";
1045	printf LOG_FILE "Invoked as: $invoked ".join(" ",@options)."\n\n";
1046
1047	my $old_log_file = $LOG_DIR."/".$log_file.".1";
1048	compress_file($old_log_file) if (-f $old_log_file);
1049	}
1050
1051	sub close_logfile
1052	{
1053	close(LOG_FILE);
1054	}
1055
1056	# Optionally sent a loglevel as first arg:
1057	# 0: print to STDOUT and logfile (default)
1058	# 1: print to STDOUT only if $debug is set, print to logfile either way
1059	# 2: print to STDERR and logfile
1060	# If $opt->{quiet} is set, no output will be sent to STDOUT regardless of
1061	# loglevel. Similarly, if $opt->{nolog} is set, no output will be printed
1062	# to the logfile regardless of loglevel.
1063	sub log
1064	{
1065	my $loglevel = shift;
1066
1067	my $entry;
1068	if ($loglevel =~ /^\d$/)
1069	{
1070	$entry = shift;
1071	}
1072	else
1073	{
1074	$entry = $loglevel;
1075	$loglevel = 0;
1076	}
1077	if ($loglevel == 2)
1078	{
1079	print STDERR $entry;
1080	}
1081	elsif ($debug or $loglevel == 0)
1082	{
1083	print $entry unless ($opt->{quiet});
1084	}
1085	print LOG_FILE $entry if (fileno(*LOG_FILE) and !$opt->{nolog});
1086	}
1087
1088	sub call_prog
1089	{
1090	my ($component,$prog,$want_output,$timeout,$display_output) = @_;
1091	$timeout = 0 if (!defined $timeout);
1092	$want_output = 0 if (!defined $want_output);
1093	$display_output = 1 if (!defined $display_output);
1094
1095	my $prog_output = "";
1096
1097	if (!(open(PROG,"$prog 2>&1\|"))) {
1098	&log("warning: couldn't exec $component as \"$prog\": $!\n");
1099	return(-1,"open failed",$prog_output);
1100	}
1101
1102	&log("\n:::::: Output from $component\n") if ($display_output);
1103
1104	my $msg;
1105	eval {
1106	local $SIG{ALRM};
1107	if ($timeout > 0) {
1108	$SIG{ALRM} = sub { die "alarm\n" };
1109	alarm $timeout; # set alarm
1110	}
1111	while(<PROG>) {
1112	$msg = $_;
1113	&log(": $msg") if ($display_output);
1114	$prog_output .= $msg if ($want_output);
1115	&add_pending_message($component, 'stats', $1) if ($msg =~ /^STATS: (.*)/);
1116
1117	}
1118	alarm(0) if ($timeout > 0); # cancel alarm
1119	close(PROG);
1120	};
1121
1122	&log(":::::: End output from $component\n\n") if ($display_output);
1123
1124	if ($@) {
1125	die unless $@ eq "alarm\n"; # propagate unexpected errors
1126
1127	# timeout
1128	&log(ucfirst($component) . " ran for $timeout seconds, stopping it.\n");
1129	close(PROG);
1130	}
1131
1132	if ($? == -1) {
1133	&log("Failed to execute $component: $!\n");
1134	return (-1,"Failed to execute",$prog_output);
1135	}
1136	if ($msg)
1137	{
1138	chomp $msg;
1139	$msg =~ s/(.) at .\/(.*)/$1 at $2/g;
1140	}
1141	if ($? & 127) {
1142	&log((sprintf "%s died with signal %d, %s coredump\n",
1143	ucfirst($component), ($? & 127), (($? & 128) ? "with" : "without")));
1144	return (($? & 127), "Died:$msg", $prog_output);
1145	}
1146	&log(1, (sprintf "%s exited with value %d\n", ucfirst($component), ($? >> 8)));
1147
1148	return (0,"",$prog_output) unless ($? >> 8);
1149	return (($? >> 8), $msg, $prog_output);
1150	}
1151
1152	sub fetch_file
1153	{
1154	my ($url, $store, $id_self, $postvars, $csum) = @_;
1155	my $request;
1156
1157	&log(1, "Fetching $url.\n");
1158
1159	my $ua = LWP::UserAgent->new();
1160	if ($id_self)
1161	{
1162	$ua->agent(ucfirst("$progname/$version"));
1163	}
1164	else
1165	{
1166	$ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322');
1167	}
1168
1169	if (defined $postvars) {
1170	$request = HTTP::Request->new(POST => $url);
1171	$request->add_content($postvars);
1172	} else {
1173	$request = HTTP::Request->new(GET => $url);
1174	}
1175	$request->header('Accept-Encoding' => 'gzip');
1176
1177	my $response = $ua->request($request);
1178	if ($response->is_success())
1179	{
1180	if ($response->header('Content-Encoding') &&
1181	$response->header('Content-Encoding') eq 'gzip') {
1182	$response->content(Compress::Zlib::memGunzip($response->content));
1183	}
1184
1185	# check the checksum
1186	if (defined $csum) {
1187	my $sha1 = Digest::SHA1->new();
1188	$sha1->add($response->content);
1189	if ($sha1->hexdigest ne $csum) {
1190	&log("$url corrupt: expected checksum $csum but got ".$sha1->hexdigest."\n");
1191	return undef;
1192	}
1193	}
1194
1195	if ($store)
1196	{
1197	open (FILE, ">$store")
1198	or (&log("ERROR: Unable to open $store for writing.\n") and return undef);
1199	print FILE $response->content();
1200	close FILE;
1201	return 1;
1202	}
1203	else
1204	{
1205	return $response->content();
1206	}
1207	}
1208	&log("Failed to retrieve $url: " . $response->status_line() . "\n");
1209	return undef;
1210	}
1211
1212	sub add_pending_message
1213	{
1214	my ($component, $field, @rest) = @_;
1215
1216	my $iteration = 0;
1217	my $componentname = $component;
1218	if ($component ne $progname)
1219	{
1220	while (defined $pending_messages->{"$component-$iteration"}->{SUCCESS}
1221	or
1222	defined $pending_messages->{"$component-$iteration"}->{FAIL})
1223	{
1224	$iteration++;
1225	last if ($iteration > 19); # just in case
1226	}
1227	$componentname = "$component-$iteration";
1228	}
1229	$pending_messages->{$componentname}->{$field} = join("\t",@rest);
1230	}
1231
1232	sub urlify
1233	{
1234	my $str = shift;
1235	$str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
1236	return $str;
1237	}
1238
1239	# Try to find a sensible place to put Shepherd files. Default is ~/.shepherd/
1240	sub find_home
1241	{
1242	my $home = $ENV{HOME};
1243	$home = undef if ($home eq '/' or $home eq '');
1244	if (!$home and $ENV{USER})
1245	{
1246	foreach ( "/home/$ENV{USER}", "/usr/home/$ENV{USER}", "/$ENV{USER}" )
1247	{
1248	if (-o $_ and -d $_)
1249	{
1250	$home = $_;
1251	last;
1252	}
1253	}
1254	}
1255	if ($home)
1256	{
1257	$home =~ s'/$'';
1258	return "$home/.$progname";
1259	}
1260	return "/opt/$progname";
1261	}
1262
1263	# -----------------------------------------
1264	# Subs: Setup
1265	# -----------------------------------------
1266
1267	sub read_config_file
1268	{
1269	read_file($config_file, 'configuration');
1270	}
1271
1272	sub read_channels_file
1273	{
1274	read_file($channels_file, 'channels');
1275	}
1276
1277	sub read_file
1278	{
1279	my $fn = shift;
1280	my $name = shift;
1281
1282	print "Reading $name file: $fn\n";
1283	unless (-r $fn)
1284	{
1285	unless ($opt->{configure})
1286	{
1287	print "\nNo $name file found.\n" .
1288	ucfirst($progname) . " must be configured: " .
1289	"configuring now.\n\n";
1290	$opt->{'configure'} = 1;
1291	$opt->{'nolog'} = 1;
1292	}
1293	return;
1294	}
1295	local (@ARGV, $/) = ($fn);
1296	no warnings 'all';
1297	eval <>;
1298	if ($@ and !$opt->{configure})
1299	{
1300	warn "\nERROR in $name file! Details:\n$@";
1301	&countdown();
1302	}
1303	}
1304
1305	sub write_config_file
1306	{
1307	write_file($config_file, 'configuration',
1308	[$region, $pref_title_source, $want_paytv_channels, $sysid, $last_successful_run, $mirror_site, $components, $components_pending_install, $pending_messages ],
1309	["region", "pref_title_source", "want_paytv_channels", "sysid", "last_successful_run", "mirror_site", "components", "components_pending_install", "pending_messages" ]);
1310	}
1311
1312	sub write_channels_file
1313	{
1314	write_file($channels_file, 'channels',
1315	[ $channels, $opt_channels ],
1316	[ 'channels', 'opt_channels' ]);
1317	}
1318
1319	sub write_file
1320	{
1321	my ($fn, $name, $vars, $varnames) = @_;
1322	open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
1323	print FN Data::Dumper->Dump($vars, $varnames);
1324	close FN;
1325	&log(1, "SHEPHERD: Wrote $name file $fn.\n");
1326	}
1327
1328	sub get_command_line_options
1329	{
1330	# Record so we can pass the unmodified args to components later
1331	@options = @ARGV; # Record so we can pass the unmodified args to components later
1332	push (@options,"") if ($#options == -1); # silence warnings if none
1333
1334	# filter what options we don't pass on ..
1335	foreach (0..$#options) {
1336	next if (!$options[$_]);
1337
1338	splice(@options,$_,2) if ($options[$_] =~ /^--config-file/); # don't pass on "--config-file (file)"
1339	splice(@options,$_,1) if ($options[$_] =~ /^--quiet/); # never be quiet
1340	}
1341
1342	Getopt::Long::Configure(qw/pass_through/);
1343
1344	GetOptions($opt, qw( config-file=s
1345	help
1346	configure
1347	setmirror=s
1348	setpreftitle=s
1349	clearpreftitle
1350	capabilities
1351	preferredmethod
1352	description
1353	quiet
1354	version
1355	debug
1356	status
1357	desc
1358	show-config
1359	show-channels
1360	update
1361	noupdate
1362	disable=s
1363	enable=s
1364	component-set=s
1365	nolog
1366	nonotify
1367	notimetest
1368	check
1369	update-version
1370	reset
1371	dontcallgrabbers
1372	days=i
1373	offset=i
1374	output=s
1375	randomize
1376	pending
1377	grabwith=s
1378	list-chan-names
1379	set-icons
1380	));
1381	$debug = $opt->{debug};
1382	$days = $opt->{days} if ($opt->{days});
1383	$opt->{update} = 1 if ($opt->{'update-version'});
1384	}
1385
1386
1387	# Here we can specify which command-line options should call
1388	# subroutines of the same name. The field following each sub
1389	# name is a string that can contain a key for what action should
1390	# be performed following the sub:
1391	# W : write config file
1392	# S : print --status output
1393	# Shepherd will exit if at least one of these routines was
1394	# called.
1395	sub process_setup_commands
1396	{
1397	my %routines = ( enable => 'WS',
1398	disable => 'WS',
1399	setorder => 'WS',
1400	check => 'WS',
1401	setpreftitle => 'W',
1402	clearpreftitle => 'W',
1403	setmirror => 'W',
1404	'reset' => 'W',
1405	status => '',
1406	desc => '',
1407	'show-config' => '',
1408	'show-channels' => '',
1409	'list-chan-names' => '',
1410	'set-icons' => '',
1411	'component-set' => '',
1412	'pending' => ''
1413	);
1414
1415	my @run;
1416	foreach (keys %routines)
1417	{
1418	if ($opt->{$_})
1419	{
1420	push @run, $_;
1421	my $sub = $_;
1422	$sub =~ s/-/_/g;
1423	&$sub($opt->{$_});
1424	}
1425	}
1426	return unless (@run);
1427	foreach (@run)
1428	{
1429	&write_config_file if ($routines{$_} =~ /W/);
1430	&status if ($routines{$_} =~ /S/);
1431	}
1432	exit;
1433	}
1434
1435	# if a preferred title source has been specified, add it to our config
1436	sub setpreftitle
1437	{
1438	my $arg = shift;
1439	$pref_title_source = $arg;
1440	&log("Added preferred title source: $pref_title_source\n");
1441	1;
1442	}
1443
1444	# if requesting to clear preferred title and we have one, remove it
1445	sub clearpreftitle
1446	{
1447	$pref_title_source = undef;
1448	&log("Removed preferred title source $pref_title_source\n");
1449	1;
1450	}
1451
1452	# if a mirror has been specified, add it into our config
1453	sub setmirror
1454	{
1455	my $arg = shift;
1456	$mirror_site = $arg;
1457	&log("Setting mirror site(s): $mirror_site\n");
1458	}
1459
1460	sub reset
1461	{
1462	&log(2, "\nWARNING! The --reset argument will remove your established\n" .
1463	"title translation data. This may cause Shepherd to lose the\n" .
1464	"ability to keep show titles consistent with what you have seen\n" .
1465	"in the past!\n\n");
1466	&countdown(20);
1467	my @r = query_component_type('reconciler');
1468	foreach (@r) # Not that there should be more than one...
1469	{
1470	my $fn = query_ldir($_, 'reconciler') . '/' . $_ . '.storable.config';
1471	&log("Removing $fn.\n");
1472	unlink($fn) or &log("Failed to remove file! $!\n");
1473	}
1474
1475	if ($pref_title_source)
1476	{
1477	my @prefs = split(/,/, $pref_title_source);
1478	foreach my $grabber (@prefs)
1479	{
1480	if ($components->{$grabber}->{lastdata})
1481	{
1482	&log( "Clearing lastdata for '$grabber' to trigger it to be called.\n");
1483	delete $components->{$grabber}->{lastdata};
1484	}
1485	}
1486	}
1487	}
1488
1489	# used to call a component in a manner so it can set some tunable parameter
1490	sub component_set
1491	{
1492	my $compset = shift;
1493	my ($component, @args) = split(/:/,$compset);
1494	if (!defined $components->{$component}) {
1495	&log("\nNo component called '$component'.\n");
1496	return;
1497	}
1498	my $arg = join(":",@args);
1499	if ((!defined $arg) \|\| ($arg eq "")) {
1500	&log("\nNothing to set: you need to use this as --component-set (component):(settings)\n");
1501	return;
1502	}
1503
1504	my $opt_set = query_config($component, 'option_set');
1505	if (!defined $opt_set) {
1506	&log("\nComponent $component does not have any tunable parameters.\n");
1507	return;
1508	}
1509
1510	my $ldir = query_ldir($component, $components->{$component}->{type});
1511
1512	chdir($ldir);
1513	my ($result,$resultmsg,$test_output) = call_prog($component, $ldir."/".$component." $opt_set $arg"." 2>&1",1,1,1);
1514	chdir ($CWD);
1515	}
1516
1517	# This does a web lookup rather than reading the official
1518	# channels_list reference.
1519	sub list_chan_names
1520	{
1521	printf "Select your region:\n";
1522	printf(" (%3d) %s\n", 0, 'All regions');
1523
1524	foreach (sort { $REGIONS{$a} cmp $REGIONS{$b} } keys %REGIONS) {
1525	printf(" (%3d) %s\n", $_, $REGIONS{$_});
1526	}
1527	my $reg = ask_choice("Enter region code:", ($region \|\| "94"),
1528	'0', keys %REGIONS);
1529
1530	if (!$reg)
1531	{
1532	print "\nListing channels for all regions:\n";
1533	foreach my $id (sort { scalar($a) <=> scalar($b) } keys %REGIONS)
1534	{
1535	my @rchans = fetch_channels($id, 1);
1536	printf "%s:%s\n", $id, join(',', @rchans);
1537	sleep 1;
1538	}
1539	printf "Foxtel:%s\n", join (',', fetch_channels_foxtel());
1540	return;
1541	}
1542
1543	printf "\nChannels for region %d (%s) are as follows:\n\t%s\n\n",
1544	$reg, $REGIONS{$reg}, join("\n\t",fetch_channels($reg));
1545	}
1546
1547	sub set_icons
1548	{
1549	print "\n\nPopulating Channel Icons.\n\n";
1550
1551	-d "$CWD/icons" or mkdir "$CWD/icons" or die "Cannot create directory $CWD/icons: $!";
1552	&require_module("DBI");
1553
1554	print "In order to update channel icons, Shepherd will need to connect to your\n".
1555	"MythTV backend database. Provide the database details below.\n".
1556	"If you don't understand or know what these settings are set to, the chances\n".
1557	"are you can simply accept the default values below.\n\n";
1558
1559	my $myth_host = ask("IP address of database backend [default: 127.0.0.1]: ") \|\| "127.0.0.1";
1560	my $myth_db = ask("Database name [default: mythconverg]: ") \|\| "mythconverg";
1561	my $myth_user = ask("Database username [default: mythtv]: ") \|\| "mythtv";
1562	my $myth_pass = ask("Database password [default: mythtv]: ") \|\| "mythtv";
1563
1564	# test database settings
1565	print "\nConnecting to database ... ";
1566	my $dbh;
1567	die "Could not connect to database: $!\n"
1568	if (!($dbh = DBI->connect("dbi:mysql:database=".$myth_db.":host=".$myth_host,$myth_user, $myth_pass)));
1569
1570	# fetch icon styles
1571	print "Done.\n\nFetching icon styles ... ";
1572	my $icon_styles = fetch_file($HOME."/shepherd/logo_list.txt");
1573	exit(1) if (!$icon_styles);
1574
1575	print "Done\n\n".
1576	"There are (typically) multiple themes available for each channel.\n".
1577	"For each channel you will be asked which theme graphic you'd like for\n".
1578	"each channel icon\n".
1579	"Aesthetically, you probably want all channel graphics sourced from a single\n".
1580	"theme, but you can choose individual graphics for each if you choose.\n\n".
1581	"The following themes are available. Please browse the URL of each theme\n".
1582	"to see if you like the general style:\n\n".
1583	" Theme Name Theme Description Theme Preview URL\n".
1584	" ---------------- ------------------------------ ------------------------------\n";
1585
1586	my $t;
1587
1588	foreach my $line (split/\n/,$icon_styles) {
1589	if ($line =~ /^THEME\t(.)\t(.)\t(.*)$/) {
1590	my ($theme_name, $theme_desc, $theme_preview_url) = ($1, $2, $3, $4);
1591	printf " %-16s %-30s %s\n",$theme_name,$theme_desc,$theme_preview_url;
1592	} elsif ($line =~ /^ICON\t(.)\t(.)\t(.*)$/) {
1593	my ($ch, $ch_theme, $url) = ($1, $2, $3);
1594	my $themename = "$ch_theme [$url]";
1595	$t->{ch}->{$ch}->{themes}->{$themename}->{url} = $url;
1596
1597	$t->{ch}->{$ch}->{themes}->{$themename}->{fname} = $ch_theme."_".$ch;
1598	if ($url =~ /\/([a-zA-Z0-9\.\_]+)$/) {
1599	$t->{ch}->{$ch}->{themes}->{$themename}->{fname} = $ch_theme."_".$1;
1600	}
1601
1602	$t->{ch}->{$ch}->{first_theme} = $themename if (!defined $t->{ch}->{$ch}->{first_theme});
1603	$t->{ch}->{$ch}->{count}++;
1604	}
1605	}
1606
1607	print "\nFor each channel, choose the icon theme you would like to use:\n";
1608	foreach my $ch (sort keys %{($t->{ch})}) {
1609	next if ((!defined $channels->{$ch}) && (!defined $opt_channels->{$ch}));
1610	my $xmlid = $channels->{$ch};
1611	$xmlid = $opt_channels->{$ch} if (defined $opt_channels->{$ch});
1612
1613	printf "\n\n$ch: [%s]\n",$xmlid;
1614
1615	# verify that channel is in database
1616	my ($chan_id,$curr_icon) = $dbh->selectrow_array("SELECT chanid,icon FROM channel WHERE xmltvid LIKE '".$xmlid."'");
1617	if (!$chan_id) {
1618	print " Skipped - not in channels database.\n";
1619	next;
1620	} else {
1621	print "Icon currently set to: $curr_icon\n";
1622	}
1623
1624	# let user choose the icon theme they want. if there is only one choice, choose it for them
1625	my $chosen_theme = "";
1626	if (($t->{ch}->{$ch}->{count} == 1) && ($curr_icon eq "none")) {
1627	$chosen_theme = $t->{ch}->{$ch}->{first_theme};
1628	print "Only one theme and icon not currently set, using: $chosen_theme\n";
1629	} else {
1630	$chosen_theme = ask_choice("Choose theme:",
1631	($curr_icon eq "none" ? $t->{ch}->{$ch}->{first_theme} : "current icon ($curr_icon)"),
1632	"current icon ($curr_icon)", "none",
1633	sort keys %{($t->{ch}->{$ch}->{themes})});
1634	}
1635
1636	if (($chosen_theme ne "") && ($chosen_theme !~ /^current/)) {
1637	my $fname;
1638	if ($chosen_theme eq "none") {
1639	$fname = "none";
1640	} else {
1641	# always re-fetch icons even if we already had them.
1642	# this simplifies the case if a download was corrupt.
1643	my $url = $t->{ch}->{$ch}->{themes}->{$chosen_theme}->{url};
1644	$fname = "$CWD/icons/".$t->{ch}->{$ch}->{themes}->{$chosen_theme}->{fname};
1645
1646	print "Fetching $url .. ";
1647	if (!(fetch_file($url, $fname, 1))) {
1648	print "Failed.\n";
1649	next;
1650	}
1651	print "done.\n";
1652	}
1653
1654	# update database
1655	print "Updating database to $fname .. ";
1656	$dbh->do("UPDATE channel SET icon='".$fname."' WHERE chanid LIKE $chan_id") \|\|
1657	die "could not update database channel icon: ".$dbh->errstr;
1658	print "done.\n";
1659	}
1660	}
1661
1662	print "\n\nAll done.\n".
1663	"You will need to restart both mythbackend and mythfrontend for any icon changes to appear.\n\n";
1664	}
1665
1666	# -----------------------------------------
1667	# Subs: Configuration
1668	# -----------------------------------------
1669
1670	sub configure
1671	{
1672	print "\nConfiguring.\n\n" .
1673	"Select your region:\n";
1674	foreach (sort { $REGIONS{$a} cmp $REGIONS{$b} } keys %REGIONS)
1675	{
1676	printf(" (%3d) %s\n", $_, $REGIONS{$_});
1677	}
1678	$region = ask_choice("Enter region code:", ($region \|\| "94"),
1679	keys %REGIONS);
1680
1681	my @channellist = &read_official_channels($region);
1682
1683	print "\nYour region has " . scalar(@channellist) . " channels:\n " .
1684	join(', ', @channellist) . ".\n\n" .
1685	"For each channel you want guide data for, enter an XMLTV id of your choice.\n" .
1686	"To accept the [default], simply press Enter. If you don't need guide\n" .
1687	"data for this channel, enter \"n\".\n\n" .
1688	"Please don't subscribe to unneeded channels.\n\nChannels:\n";
1689	my $oldchannels = $channels;
1690	$channels = {};
1691	my $line;
1692	my $c = 0;
1693	foreach (@channellist)
1694	{
1695	my $default = lc($_); # make a default id by lower-casing
1696	$default =~ s/[ \t()]//g; # removing whitespace and parens
1697	$default =~ s\|[/,].*\|\|; # and deleting after / or ,
1698	$default = $oldchannels->{$_} \|\| "$default.free.au";
1699	# and tack on ".free.au". But use
1700	# old id as default if possible.
1701	$c++;
1702	$line = ask(sprintf "(%2d/%2d) \"%s\" [%s] ? ", $c, scalar(@channellist), $_, $default);
1703	$line =~ s/\s//g;
1704	if ($line ne "n") { $channels->{$_} = $line \|\| $default; }
1705	}
1706
1707	my $oldopt_channels = $opt_channels;
1708	$opt_channels = {};
1709	print "\nHigh Definition TV (HDTV)\n".
1710	"Most Australian TV networks broadcast at least some\n".
1711	"programmes in HDTV each week, but for the most part\n".
1712	"either upsample SD to HD or play a rolling demonstration\n".
1713	"HD clip when they don't have the programme in HD format.\n\n".
1714	"If you have a HDTV capable system and are interested in\n".
1715	"having Shepherd's postprocessors populate HDTV content\n".
1716	"then Shepherd will need to know the XMLTV IDs for the HD\n".
1717	"channels also.\n";
1718	if (ask_boolean("\nDo you wish to include HDTV channels?")) {
1719	print "\nFor each channel you want guide data for, enter an XMLTV id\n" .
1720	"of your choice (e.g. \"sevenhd.free.au\"). To accept the [default],\n" .
1721	"simply press Enter. If you don't need guide data for this channel,\n".
1722	"enter \"n\".\n\nHD Channels:\n";
1723
1724	my @hd_channellist = grep(!/ABC2\|SBS News\|31/i, @channellist);
1725	$c = 0;
1726	foreach (@hd_channellist)
1727	{
1728	# next if (($_ =~ /ABC2/i) \|\| ($_ =~ /SBS News/i) \|\| ($_ =~ /31/));
1729	my $default = lc($_); # make a default id by lower-casing
1730	$default =~ s/[ \t()]//g; # removing whitespace and parens
1731	$default =~ s\|[/,].*\|\|; # and deleting after / or ,
1732	$default = $oldopt_channels->{$_} \|\| $default . "hd.free.au";
1733	# and tack on "hd.free.au". But use
1734	# old id as default if possible.
1735	$_ .= "HD";
1736	$c++;
1737	$line = ask(sprintf "(%2d/%2d) \"%s\" [%s] ? ", $c, scalar(@hd_channellist), $_, $default);
1738	$line =~ s/\s//g;
1739	if ($line ne "n") { $opt_channels->{$_} = $line \|\| $default; }
1740	}
1741	}
1742
1743	$want_paytv_channels = undef;
1744	if (ask_boolean("\nDo you wish to include PayTV (e.g. Foxtel) channels?")) {
1745	my @paytv_channellist = &read_official_channels('Foxtel');
1746	print "\nThe following PayTV channels are known:\n " .
1747	join(', ', @paytv_channellist) . ".\n\n" .
1748	"For each channel you want guide data for, enter an XMLTV id\n" .
1749	"of your choice (e.g. \"arena.paytv.au\"). To accept the [default],\n" .
1750	"simply press Enter. If you don't need guide data for this channel,\n".
1751	"enter \"n\".\n\nPay TV Channels:\n";
1752
1753	$c = 0;
1754	foreach (@paytv_channellist) {
1755	my $default = lc($_); # make a default id by lower-casing
1756	$default = $oldopt_channels->{$_} \|\| $default . ".paytv.au";
1757	# and tack on ".paytv.au". But use
1758	# old id as default if possible.
1759	$c++;
1760	$line = ask(sprintf "(%2d/%2d) \"%s\" [%s] ? ", $c, scalar(@paytv_channellist), $_, $default);
1761	$line =~ s/\s//g;
1762	if ($line ne "n") {
1763	$opt_channels->{$_} = $line \|\| $default;
1764	$want_paytv_channels = 1;
1765	}
1766	}
1767	}
1768
1769	print "\nWould you like to transition seamlessly from your current grabber?\n\n".
1770	"Different data sources can have different names for the same show. For\n".
1771	"example, one grabber might call a show \"Spicks & Specks\" while another\n".
1772	"calls it \"Spicks and Specks\". These differences can make MythTV think\n".
1773	"they're actually different shows.\n\n".
1774	ucfirst($progname) . " is able to merge these differences so that it always\n".
1775	"presents shows with a consistent name, no matter where it actually sourced\n".
1776	"show data from. If you'd like, it can also rename shows so they're consistent\n".
1777	"with whichever grabber you've been using until now.\n\n".
1778	"The advantage of this is that you should get a smoother transition to\n".
1779	ucfirst($progname) . ", with no shows changing names and no need to re-create\n".
1780	"any recording rules. The main disadvantage is that if your previous grabber\n".
1781	"used an inferior data source -- i.e. it sometimes has typos or less\n".
1782	"informative program names -- then you'll continue to see these.\n\n".
1783	"If you were using one of the following grabbers previously AND you want\n".
1784	ucfirst($progname) . " to use that grabber's program names, select it here.\n\n";
1785
1786	my $def = "Do not transition; just use best quality titles";
1787	my %transition = ( "ltd (aka tv_grab_au, versions 1,30, 1.40 or 1.41)" => "yahoo7widget,abc2_website",
1788	"OzTivo" => 'oztivo',
1789	"Rex" => 'rex',
1790	"JRobbo" => 'jrobbo' );
1791	my $defaulttrans = $def;
1792	foreach my $key (keys %transition) {
1793	$defaulttrans = $key if ((defined $pref_title_source) && ($transition{$key} eq $pref_title_source));
1794	}
1795	my $pref = ask_choice("Transition from grabber?", $defaulttrans,
1796	$def, keys %transition);
1797	$pref_title_source = $transition{$pref};
1798
1799	print "\n";
1800	show_channels();
1801	unless(ask_boolean("\nCreate configuration file?"))
1802	{
1803	print "Aborting configuration.\n";
1804	exit 0;
1805	}
1806
1807	write_config_file();
1808	write_channels_file();
1809
1810	print "Checking if any components require configuration.\n\n";
1811	&check;
1812
1813	print "Finished configuring.\n\n";
1814
1815	status();
1816
1817	print "\nShepherd is installed into $CWD.\n\n" .
1818	"Run it as: $CWD/shepherd\n\n".
1819	"MythTV users may wish to create the following symlink, by " .
1820	"doing this (as root):\n" .
1821	" \"ln -s $CWD/$progname /usr/bin/tv_grab_au\".\n\n";
1822
1823	# if ($invoked ne get_full_path(query_filename('shepherd','application')))
1824	# {
1825	# print "You may safely delete $invoked.\n\n";
1826	# }
1827
1828	unless (ask_boolean("\nGrab data now?"))
1829	{
1830	exit 0;
1831	}
1832	}
1833
1834	# Obsolete but left for now in case we want to go back to it
1835	sub fetch_channels_yahoo
1836	{
1837	my @date = localtime;
1838	my $page = fetch_file(
1839	"http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1840	($date[5] + 1900) . "-$date[4]-$date[3]");
1841	my @channellist;
1842	while ($page =~ /<tr class=rtb><td class=rth><a .?>(.?)<\/a>/g)
1843	{
1844	push @channellist, $1;
1845	}
1846	return @channellist;
1847	}
1848
1849	# Sourced from YourTV
1850	sub fetch_channels
1851	{
1852	my ($reg, $shh) = @_;
1853
1854	&log("Fetching free-to-air channel information...\n") unless ($shh);
1855
1856	# Download list
1857	my $ua = LWP::UserAgent->new();
1858	$ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322');
1859	$ua->cookie_jar({});
1860	$ua->get('http://www.yourtv.com.au');
1861	my $response = $ua->get('http://www.yourtv.com.au/profile/ajax.cfm?action=channels&region_id='.$reg);
1862
1863	my $page = $response->content;
1864	die "Unable to download channel list" if ($response->is_error());
1865
1866	# Rules for Station Names:
1867	# Station names are comprised of the channel name (eg "Seven") and an
1868	# optional regional qualifier in brackets (eg "(Cairns/Rockhampton)").
1869	# Station names shall not contain a regional qualifer unless
1870	# necessary to distinguish between identical channel names in
1871	# the same region; in this case, a regional qualifier shall always
1872	# be included. In the absence of anything better, the region name
1873	# (eg "NSW: Regional NSW") is used as the regional qualifier.
1874	my (@channellist, $clist, $cn, $rq);
1875	while ($page =~ /<label for="venue_id.?>(.?)<\/label>/sg)
1876	{
1877	my $channel = $1;
1878	$channel =~ s/\s{2,}//g;
1879	if ($channel =~ /(.) ($.$)/)
1880	{
1881	($cn, $rq) = ($1, $2);
1882	}
1883	else
1884	{
1885	$cn = $channel;
1886	$rq = '';
1887	}
1888	# Is there already a channel with this name?
1889	if ($clist->{$cn})
1890	{
1891	# Set regional qualifier for existing station if not already set
1892	if (@{$clist->{$cn}} == 1 and $clist->{$cn}[0] eq '')
1893	{
1894	$clist->{$cn} = [ "(".$REGIONS{$reg}.")" ];
1895	}
1896	$rq = $REGIONS{$reg} if ($rq eq '');
1897	die "Bad channel list in region $reg!" if (grep($rq eq $_, @{$clist->{$cn}}));
1898	push @{$clist->{$cn}}, $rq;
1899	}
1900	else
1901	{
1902	$clist->{$cn} = [ $rq ];
1903	}
1904	}
1905	foreach $cn (keys %$clist)
1906	{
1907	if (@{$clist->{$cn}} == 1)
1908	{
1909	next if (($reg == 79) && ($cn eq "Prime")); # ignore Prime in Regional QLD
1910	push @channellist, $cn;
1911	}
1912	else
1913	{
1914	foreach $rq (@{$clist->{$cn}})
1915	{
1916	push @channellist, "$cn $rq";
1917	}
1918	}
1919	}
1920	return @channellist;
1921	}
1922
1923	sub fetch_channels_foxtel
1924	{
1925	my $shh = shift;
1926	&log("Fetching PayTV channel information...\n") unless ($shh);
1927
1928	my $ua = LWP::UserAgent->new();
1929	$ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322');
1930	$ua->cookie_jar({});
1931	my $response = $ua->get('http://www.foxtel.com.au/channel/lineup.html');
1932
1933	my $page = $response->content;
1934	die "Unable to download channel list" if ($response->is_error());
1935
1936	my @channellist;
1937	while ($page =~ /<option value="\/channel\/.?>(.?)<\/option>/sg)
1938	{
1939	my $ch = $1;
1940	$ch =~ s/[ \t()\[\]\+\.\-]//g; # remove special chars
1941	$ch =~ s/&/and/g; # & to and
1942	$ch =~ s\|[/,].*\|\|; # and deleting after / or ,
1943
1944	push @channellist,$ch;
1945	}
1946
1947	return @channellist;
1948	}
1949
1950	# -----------------------------------------
1951	# Subs: Status & Help
1952	# -----------------------------------------
1953
1954	sub show_config
1955	{
1956	&log("\nConfiguration\n".
1957	"-------------\n" .
1958	"Config file: $config_file\n" .
1959	"Debug mode : " . is_set($debug) . "\n" .
1960	"Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1961	"Region ID : $region\n");
1962	show_channels();
1963	&log("\n");
1964	status();
1965	&log("\n");
1966	}
1967
1968	sub show_channels
1969	{
1970	&log("Subscribed channels (priority):\n");
1971	&log(" $_ -> $channels->{$_}\n") for sort keys %$channels;
1972	&log("Optional channels (HDTV/PayTV: best-effort):\n");
1973	&log(" $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
1974	}
1975
1976	sub is_set
1977	{
1978	my $arg = shift;
1979	return $arg ? "Yes" : "No";
1980	}
1981
1982	sub pretty_print
1983	{
1984	my ($p, $len) = @_;
1985	my $spaces = ' ' x (79-$len);
1986	my $ret = "";
1987
1988	while (length($p) > 0) {
1989	if (length($p) <= $len) {
1990	$ret .= $p;
1991	$p = "";
1992	} else {
1993	# find a space to the left of cutoff
1994	my $len2 = $len;
1995	while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
1996	$len2--;
1997	}
1998	if ($len2 == 0) {
1999	# no space - just print it with cutoff
2000	$ret .= substr($p,0,$len);
2001	$p = substr($p,$len,(length($p)-$len));
2002	} else {
2003	# print up to space
2004	$ret .= substr($p,0,$len2);
2005	$p = substr($p,($len2+1),(length($p)-$len2+1));
2006	}
2007	# print whitespace
2008	$ret .= "\n".$spaces;
2009	}
2010	}
2011	return $ret;
2012	}
2013
2014	sub pretty_date
2015	{
2016	my $t = shift;
2017
2018	return "- " unless $t;
2019
2020	my @lt = localtime($t);
2021	my @ltnow = localtime();
2022	if (time - $t > 15768000) # 6 months or older
2023	{
2024	return POSIX::strftime("%d-%b-%y", @lt); # eg 18-Mar-05
2025	}
2026	if (time - $t < 43200 # less than 12 hours ago
2027	or
2028	($lt[4] == $ltnow[4] and $lt[3] == $ltnow[3])) # today
2029	{
2030	return POSIX::strftime("%l:%M%P ", @lt); # eg 10:45pm
2031	}
2032	return POSIX::strftime("%a %d-%b", @lt); # eg Mon 25-Dec
2033	}
2034
2035	sub desc
2036	{
2037	my $lasttype = '';
2038	my %qual_table = ( 3 => "Excellent", 2 => "Good", 1 => "Poor" );
2039
2040	foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components})
2041	{
2042	if ($lasttype ne $components->{$_}->{type})
2043	{
2044	$lasttype = $components->{$_}->{type};
2045	&log("\n* " . uc($lasttype) . "S *\n");
2046	}
2047	&log("\n$_ v$components->{$_}->{ver}" .
2048	"\n* " . pretty_print(query_config($_, 'desc'), 77) . "\n");
2049	if ($lasttype eq 'grabber')
2050	{
2051	&log("* Data Quality: " . $qual_table{query_config($_, 'quality')} . "\n");
2052	&log("* Speed: " . (query_config($_, 'category') == 1 ? "Slow" : "Fast") . "\n");
2053	my $ch = query_config($_, 'channels');
2054	$ch = "All" if ($ch eq '');
2055	$ch = "All except $1" if ($ch =~ /^\-(.*)/);
2056	&log("* Channels: $ch\n");
2057	my $d1 = query_config($_, 'max_days');
2058	my $d2 = query_config($_, 'max_reliable_days');
2059	&log("* Days: " . ($d1 == $d2 ? $d1 : "$d2 to $d1") . "\n");
2060	}
2061	}
2062	}
2063
2064	sub status
2065	{
2066	foreach my $ctype ('grabber', 'reconciler', 'postprocessor')
2067	{
2068	&log("\n " .
2069	($ctype eq 'grabber' ?
2070	" Enabled/\n".
2071	sprintf(" %-17s Version Ready Last Run Status", ucfirst($ctype))
2072	: ucfirst($ctype)) .
2073	"\n -------------- ---------- ----- ---------- -----------------------------------\n");
2074	foreach (sort (query_component_type($ctype)))
2075	{
2076	my $h = $components->{$_};
2077	&log(sprintf " %-15s%10s %1s/%1s %11s %s\n",
2078	length($_) > 15 ? substr($_,0,13).".." : $_,
2079	$h->{ver},
2080	$h->{disabled} ? 'N' : 'Y',
2081	$h->{ready} ? 'Y' : 'N',
2082	pretty_date($h->{lastdata}),
2083	$h->{laststatus} ? pretty_print($h->{laststatus},35) : '');
2084	}
2085	}
2086	&log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
2087	}
2088
2089	sub capabilities
2090	{
2091	print "baseline\nmanualconfig\npreferredmethod\n";
2092	exit 0;
2093	}
2094
2095	sub preferredmethod
2096	{
2097	print "allatonce\n";
2098	exit 0;
2099	}
2100
2101	sub description
2102	{
2103	print "Australia\n";
2104	exit 0;
2105	}
2106
2107	sub help
2108	{
2109	print q{Command-line options:
2110	--help Display this message
2111	--version Display version
2112	--status Display status of various components
2113	--desc Display detailed status of components
2114
2115	--configure Setup
2116	--show-config Display setup details
2117	--show-channels Display subscribed channels
2118	--set-icons Download channel icons and update MythTV to use them
2119
2120	--disable <s> Don't ever use grabber/postprocessor <s>
2121	--enable <s> Okay, use it again then
2122	--uninstall <s> Remove a disabled grabber/postprocessor
2123	--component-set <s> Used to update a component configuration/setting
2124
2125	--noupdate Don't update; just grab data
2126	--update Update only; don't grab data
2127
2128	--update-version Update major version
2129
2130	--check Check status of all components, configure if necessary
2131	--pending List pending installs, if any
2132
2133	--nonotify Block reporting of anonymous usage statistics
2134
2135	--debug Print lots of debugging messages
2136	--quiet Don't print anything except errors
2137	--nolog Don't write a logfile
2138
2139	--setmirror <s> Set URL <s> as primary location to check for updates
2140	--setpreftitle <s> Set preferred 'title' source as grabber <s>
2141	--clearpreftitle Clear preferred 'title' source
2142	--reset Remove all previous title translation data
2143
2144	};
2145	exit 0;
2146	}
2147
2148
2149	# -----------------------------------------
2150	# Subs: override handlers for standard perl.
2151	# -----------------------------------------
2152
2153	# ugly hack. please don't try this at home kids!
2154	sub my_die {
2155	my ($arg,@rest) = @_;
2156	my ($pack,$file,$line,$sub) = caller(0);
2157
2158	# check if we are in an eval()
2159	if ($^S) {
2160	printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
2161	} else {
2162	printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
2163	if ($arg) {
2164	CORE::die($arg,@rest);
2165	} else {
2166	CORE::die(join("",@rest));
2167	}
2168	}
2169	}
2170
2171
2172	# -----------------------------------------
2173	# Subs: Grabbing
2174	# -----------------------------------------
2175
2176	sub grab_data
2177	{
2178	my $grab_policy = shift;
2179	$grab_policy = "standard" if (!defined $grab_policy);
2180
2181	my $used_grabbers = 0;
2182	&log("\nSHEPHERD: Grabber stage ($grab_policy).\n");
2183
2184	&analyze_plugin_data("",1,$progname);
2185
2186	my ($grabber, $reason_chosen);
2187	while (my ($grabber, $reason_chosen) = choose_grabber($grab_policy))
2188	{
2189	last if (!defined $grabber);
2190
2191	$data_satisfies_policy = 0;
2192	$data_found_all = 0;
2193	$used_grabbers++;
2194
2195	&log("\nSHEPHERD: Using grabber: ($used_grabbers) $grabber ($reason_chosen)\n");
2196
2197	my $iteration = query_iteration($grabber);
2198
2199	my $output = sprintf "%s/grabbers/%s/output-%d.xmltv",
2200	$CWD, $grabber, $iteration;
2201
2202	my $comm = "$CWD/grabbers/$grabber/$grabber " .
2203	"--region $region " .
2204	"--output $output";
2205
2206	if (query_config($grabber, 'option_grabber_settings')) {
2207	$comm .= " " . query_config($grabber, 'option_grabber_settings');
2208	}
2209
2210	# Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
2211	# that we need. Category 2 grabbers are requested to get everything, since there's
2212	# very little cost in grabbing that extra data, and we can use it in the reconciler
2213	# to verify that everything looks OK.
2214	if (query_config($grabber, 'category') == 1)
2215	{
2216	&log("SHEPHERD: Asking $grabber for " .
2217	($find_microgaps ? 'microgaps within ' : '') .
2218	display_best_timeslice());
2219
2220	record_requested_chandays($grabber, $timeslice);
2221
2222	if ($timeslice->{start} != 0)
2223	{
2224	$comm .= " " .
2225	query_config($grabber, 'option_days_offset') .
2226	" " .
2227	$timeslice->{start};
2228	}
2229
2230	my $n = $timeslice->{stop} + 1;
2231	if ($timeslice->{start} != 0
2232	and
2233	!query_config($grabber, 'option_offset_eats_days'))
2234	{
2235	$n -= $timeslice->{start};
2236	}
2237	$comm .= " " .
2238	query_config($grabber, 'option_days') .
2239	" " .
2240	$n;
2241
2242	# Write a temporary channels file specifying only the channels we want
2243	my $tmpchans;
2244	foreach (@{$timeslice->{chans}})
2245	{
2246	$tmpchans->{$_} = $channels->{$_};
2247	}
2248	my $tmpcf = "$CWD/channels.conf.tmp";
2249	write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
2250	$comm .= " --channels_file $tmpcf";
2251
2252	# Create gaps_file if we want less than (roughly) the full day
2253	if ($find_microgaps)
2254	{
2255	my $tmpgf = "$CWD/gaps.tmp";
2256	my $gapstr = record_requested_gaps($tmpgf, $timeslice, $grabber);
2257	$comm .= " --gaps_file $tmpgf";
2258	&log(1, "SHEPHERD: Asking $grabber to fill gaps: $gapstr\n");
2259	}
2260	}
2261	else
2262	{
2263	&log("SHEPHERD: Asking $grabber for days " .
2264	($opt->{offset} ? $opt->{offset} : 0) .
2265	" - " . ($days-1). " of all channels\n");
2266	$comm .= " --days $days" if ($days);
2267	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
2268	$comm .= " --channels_file $channels_file";
2269	}
2270
2271	if ((defined $plugin_data->{tor_pid}) &&
2272	(query_config($grabber, 'option_anon_socks'))) {
2273	$comm .= " ".query_config($grabber, 'option_anon_socks')." ".$plugin_data->{tor_address};
2274	}
2275
2276	$comm .= " --debug" if ($debug);
2277	$comm .= " @ARGV" if (@ARGV);
2278
2279	my $retval = 0;
2280	my $msg;
2281	my $component_start = time;
2282	if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
2283	&log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
2284	&log(1, "SHEPHERD: would have called: $comm\n");
2285	} else {
2286	&log("SHEPHERD: Excuting command: $comm\n");
2287	if (-e $output) {
2288	&log(1, "SHEPHERD: Removing old output file: $output\n");
2289	unlink($output) or &log("SHEPHERD: Failed to remove old output file: $output\n$!\n");
2290	}
2291	chdir "$CWD/grabbers/$grabber/";
2292	($retval,$msg) = call_prog($grabber,$comm,0,(query_config($grabber,'max_runtime')*60));
2293	chdir $CWD;
2294	}
2295	my $component_duration = time - $component_start;
2296
2297	if ($retval) {
2298	&log("Grabber exited with non-zero code $retval: assuming it failed.\n" .
2299	"Last message: \"$msg\"\n");
2300	$components->{$grabber}->{laststatus} = "Failed (code $retval)";
2301	$components->{$grabber}->{consecutive_failures}++;
2302	&add_pending_message($grabber,"FAIL", $retval.":".$msg, $component_start, $component_duration,
2303	$components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
2304	next;
2305	}
2306
2307	# soak up the data we just collected
2308	&soak_up_data($grabber, $output, "grabber", $grab_policy);
2309	$components->{$grabber}->{laststatus} = $plugin_data->{"$grabber-$iteration"}->{laststatus};
2310
2311	# analyze the data that this grabber returned
2312	# (useful to detect individual components going bad and report them upstream)
2313	&analyze_plugin_data("grabber $grabber", 1, $grabber, $iteration);
2314
2315	if ($plugin_data->{"$grabber-$iteration"}->{valid}) {
2316	$components->{$grabber}->{lastdata} = time;
2317	delete $components->{$grabber}->{consecutive_failures}
2318	if (defined $components->{$grabber}->{consecutive_failures});
2319	&add_pending_message($grabber,"SUCCESS", $retval, $component_start, $component_duration,
2320	$components->{$grabber}->{ver}, ($plugin_data->{"$grabber-$iteration"}->{total_duration}/60) );
2321	} else {
2322	$components->{$grabber}->{laststatus} = "failed (invalid XMLTV)";
2323	$components->{$grabber}->{consecutive_failures}++;
2324	&add_pending_message($grabber,"FAIL", '0:XMLTV output marked as invalid', $component_start, $component_duration,
2325	$components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
2326	}
2327
2328	# check to see if we have all the data we want
2329	$data_satisfies_policy = &analyze_plugin_data("analysis of all grabbers so far",0,$progname);
2330
2331	my $missing_before = convert_dayhash_to_list($missing);
2332	my $missing_after = convert_dayhash_to_list(detect_missing_data(1));
2333	my $list = List::Compare->new($missing_before, $missing_after);
2334	my @grabbed = $list->get_symmetric_difference();
2335	&log("SHEPHERD: Filled " . scalar(@grabbed) . " channel-days with new data from $grabber.\n");
2336	&log(1, "SHEPHERD: Channel-days acquired: " . join (', ', @grabbed) . ".\n");
2337
2338	# Record what we grabbed from cacheable C1 grabbers
2339	if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
2340	{
2341	record_cached($grabber, @grabbed);
2342	write_config_file();
2343	}
2344
2345	last if ($data_found_all);
2346	if ($data_satisfies_policy)
2347	{
2348	$find_microgaps = 1;
2349	}
2350	}
2351
2352
2353	if ($used_grabbers == 0)
2354	{
2355	&log("SHEPHERD: No valid grabbers installed/enabled!\n");
2356	}
2357	elsif (!$data_satisfies_policy)
2358	{
2359	&log("SHEPHERD: Ran through all grabbers but still have policy-violating gaps in data! :(\n");
2360	}
2361	elsif (!$data_found_all)
2362	{
2363	&log("SHEPHERD: Unfillable micro-gaps exist in data!\n");
2364	}
2365	}
2366
2367	sub query_iteration
2368	{
2369	my $grabber = shift;
2370
2371	my $i = 0;
2372	while (1)
2373	{
2374	return $i unless (defined $plugin_data->{"$grabber-$i"});
2375	$i++;
2376	die "Insane infinite loop suspected!" if ($i > 10);
2377	}
2378	}
2379
2380	# -----------------------------------------
2381	# Subs: Intelli-random grabber selection
2382	# -----------------------------------------
2383
2384	sub choose_grabber
2385	{
2386	my $grabber_policy = shift;
2387
2388	if (defined $gscore) # Reset score hash
2389	{
2390	foreach (keys %$gscore)
2391	{
2392	$gscore->{$_} = 0;
2393	}
2394	}
2395	else # Create score hash
2396	{
2397	foreach (query_grabbers())
2398	{
2399	unless ($components->{$_}->{disabled})
2400	{
2401	$gscore->{$_} = 0;
2402	if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
2403	{
2404	$gscore->{$_ . ' [cache]'} = 0;
2405	}
2406	}
2407	}
2408	}
2409
2410	if ($grabber_policy ne "paytv") {
2411	# no point calling these on paytv channels - paytv channels are always $opt_channels ..
2412
2413	$missing = detect_missing_data();
2414	$timeslice = find_best_timeslice();
2415
2416	&log(1, "SHEPHERD: Best timeslice: " . display_best_timeslice());
2417	} else {
2418	# if we are grabbing paytv, remove grabbers that can't provide paytv data
2419	foreach (keys %$gscore) {
2420	my $grabber_type = query_config($_, 'type');
2421	if ((!defined $grabber_type) \|\| ($grabber_type eq "standard")) {
2422	delete $gscore->{$_};
2423	}
2424	}
2425	}
2426
2427	my $total = score_grabbers($grabber_policy);
2428
2429	&log("SHEPHERD: Scoring grabbers on ability to efficiently provide needed data:\n");
2430	&log("Only considering micro-grabbers.\n") if (($find_microgaps) && ($grabber_policy ne "paytv"));
2431	foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
2432	{
2433	next if ($_ =~ /\[cache\]/);
2434
2435	my $score = $gscore->{$_};
2436	my $cscore = $gscore->{"$_ [cache]"};
2437	my $cstr = $cscore ? "(inc. $cscore cache pts) " : "";
2438	$cstr .= "(already called)" if (($score == 0) && ($grabber_policy eq "paytv"));
2439
2440	if ($opt->{randomize})
2441	{
2442	&log(sprintf "%15s %6.1f%% %9s %s\n",
2443	$_,
2444	($total ? 100* $score / $total : 0),
2445	"$score pts",
2446	$cstr);
2447	}
2448	else
2449	{
2450	&log(sprintf "%15s %4s pts %s\n",
2451	$_,
2452	$score,
2453	$cstr);
2454	}
2455	}
2456
2457	if ($opt->{grabwith})
2458	{
2459	my @a = split(/,/, $opt->{grabwith});
2460	my $g;
2461	while ($g = shift @a)
2462	{
2463	$opt->{grabwith} = (@a ? join(',', @a) : undef);
2464	&log("\nObeying --grabwith option: selecting grabber \"$g\".\n");
2465	if ($components->{$g} and $components->{$g}->{type} eq 'grabber')
2466	{
2467	return(select_grabber($g, $gscore), "--grabwith policy");
2468	}
2469	&log("Not a grabber: \"$g\".\n");
2470	}
2471	}
2472
2473	return undef unless ($total);
2474
2475	# If the user has specified a pref_title_source -- i.e. he is
2476	# transitioning from a known grabber -- then we make sure it
2477	# has run at least once, to build the list of title translations.
2478	if ($pref_title_source)
2479	{
2480	my @prefs = split(/,/, $pref_title_source);
2481	foreach my $grabber (@prefs)
2482	{
2483	unless ($components->{$grabber}->{lastdata})
2484	{
2485	&log("Need to build title translation list for transitional grabber $grabber.\n");
2486	return(select_grabber($grabber, $gscore), "transitional for title translation") if ($gscore->{$grabber});
2487	&log("WARNING: Can't run $grabber to build title translation list!\n");
2488	}
2489	}
2490	}
2491
2492	# If run with --randomize, then rather than always selecting the highest-scoring
2493	# grabber first we'll make a weighted random selection.
2494	if ($opt->{randomize})
2495	{
2496	my $r = int(rand($total));
2497	my $c = 0;
2498	foreach my $grabber (keys %$gscore)
2499	{
2500	next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
2501	if ($r >= $c and $r < ($c + $gscore->{$grabber}))
2502	{
2503	return(select_grabber($grabber, $gscore), "--randomize weighted policy");
2504	}
2505	$c += $gscore->{$grabber};
2506	}
2507	die "ERROR: failed to choose grabber.";
2508	}
2509
2510	# Choose grabber with best score. If there are multiple grabbers with the
2511	# best score, randomly select one of them.
2512	my @sorted = sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore;
2513	my @candidates = ( $sorted[0] );
2514	my $c = 1;
2515	while ($gscore->{$sorted[$c]} == $gscore->{$sorted[0]})
2516	{
2517	push @candidates, $sorted[$c] unless ($sorted[$c] =~ /\[cache\]/);
2518	$c++;
2519	}
2520
2521	my $num_choices = grep (($gscore->{$_} and $_ !~ /\[cache\]/), @sorted);
2522	if (@candidates > 1)
2523	{
2524	&log("Multiple grabbers with best score: @candidates.\n");
2525	return(select_grabber($candidates[int(rand(scalar(@candidates)))], $gscore),
2526	"equal best of $num_choices options, randomly selected from " .
2527	(scalar(@candidates)-1) .
2528	" peer" .
2529	(@candidates > 2 ? 's' : ''));
2530	}
2531	return(select_grabber($candidates[0], $gscore),
2532	$num_choices == 1 ? "only option" : "best of $num_choices options");
2533	}
2534
2535	sub select_grabber
2536	{
2537	my ($grabber, $gscore) = @_;
2538
2539	&log(1, "Selected $grabber.\n");
2540	if (query_config($grabber, 'category') == 2)
2541	{
2542	# We might want to run C1 grabbers multiple times
2543	# to grab various timeslices, but not C2 grabbers,
2544	# which should get everything at once.
2545	delete $gscore->{$grabber};
2546	}
2547	return $grabber;
2548	}
2549
2550	# Grabbers earn 1 point for each slot or chanday they can fill.
2551	# This score is multiplied if the grabber:
2552	# * is a category 2 grabber (i.e. fast/cheap)
2553	# * is a category 1 grabber that has the data we want in a cache
2554	# * can supply high-quality data
2555	# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
2556	sub score_grabbers
2557	{
2558	my $grabber_policy = shift;
2559	my ($total, $key);
2560
2561	my $bestdq = 0;
2562
2563	# Compare C2 grabbers against the raw missing file, because we'll get
2564	# everything. But compare C1 grabbers against the timeslice, because we'll
2565	# only ask them for a slice. This goes for the [cache] and regular C1s.
2566	foreach my $grabber (keys %$gscore)
2567	{
2568	# for each slot, say whether we can fill it or not -- that is,
2569	# whether we support this channel and this day #.
2570
2571	my $hits = 0;
2572	my $cat = query_config($grabber, 'category');
2573	my $dq = query_config($grabber, 'quality');
2574
2575	if ($cat == 1)
2576	{
2577	$key = cut_down_missing($grabber);
2578	# &log(1, "Grabber $grabber is Category 1: comparing capability to best timeslice.\n");
2579	}
2580	else
2581	{
2582	$key = $missing;
2583	# &log(1, "Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n");
2584	}
2585
2586	if (!supports_region($grabber))
2587	{
2588	&log(1, "Zeroing $grabber due to no region support\n");
2589	$hits = 0;
2590	}
2591	elsif (($grabber_policy ne "paytv") && ($find_microgaps) and (!query_config($grabber, 'micrograbs')))
2592	{
2593	&log(1, "Zeroing $grabber due to non-micrograbbing\n");
2594	$hits = 0;
2595	}
2596	elsif ($grabber =~ /\[cache\]/)
2597	{
2598	$hits = find_cache_hits($grabber, $key);
2599	}
2600	else
2601	{
2602	foreach my $day (sort keys %$key)
2603	{
2604	my $val = supports_day($grabber, $day);
2605	next unless ($val);
2606	# &log(1, "Day $day:");
2607	foreach my $ch (@{$key->{$day}})
2608	{
2609	if ($grabber_policy eq "paytv") {
2610	$hits += $val;
2611	} else {
2612	if (supports_channel($grabber, $ch, $day)) {
2613	# &log(1, " $ch");
2614	$hits += $val;
2615	}
2616	}
2617	}
2618	# &log(1, "\n");
2619	$hits = 1 if ($hits > 0 and $hits < 1);
2620	}
2621	}
2622
2623	my $catbonus = 1;
2624	$catbonus = 3 if ($cat == 2);
2625	if ($grabber =~ /\[cache\]/)
2626	{
2627	# Bonus is on a sliding scale between 1 and 2 depending on
2628	# % of required data in cache
2629	$catbonus += $hits / $timeslice->{chandays};
2630	}
2631
2632	my $dqbonus = 2 ** ($dq-1);
2633
2634	my $mult = $dq ** $catbonus;
2635
2636	my $score = int($hits * $mult);
2637
2638	my $str = sprintf "Grabber %s can supply %d chandays",
2639	$grabber, $hits;
2640	$str .= sprintf(" at x%.1f (cat: %d, DQ: %d): %d pts",
2641	$mult,
2642	$cat,
2643	$dq,
2644	$score) if ($hits);
2645	&log(1, "$str.\n");
2646
2647	if ($score and query_config($grabber, 'option_anon_socks') and !defined $plugin_data->{tor_pid})
2648	{
2649	&log(1, "Grabber $grabber needs Tor to run efficiently: reducing score.\n");
2650	$score = int($score/10)+1;
2651	}
2652
2653	$gscore->{$grabber} += $score;
2654	$total += $score;
2655	if ($grabber =~ /\[cache\]/)
2656	{
2657	$gscore->{query_name($grabber)} += $score;
2658	}
2659
2660	if ($score and $dq > $bestdq)
2661	{
2662	$bestdq = $dq;
2663	}
2664	}
2665
2666	# Eliminate grabbers of data quality 1 if there are any better-quality
2667	# alternatives. (Only need to do this with 'randomize' option, since otherwise
2668	# we will always pick the highest score.)
2669	if ($opt->{randomize})
2670	{
2671	foreach (keys %$gscore)
2672	{
2673	if (query_config($_, 'quality') == 1 and $bestdq > 1)
2674	{
2675	$total -= $gscore->{$_};
2676	$gscore->{$_} = 0;
2677	&log(1, "Zeroing grabber $_ due to low data quality.\n");
2678	}
2679	}
2680	}
2681
2682	return $total;
2683	}
2684
2685	# Return 1 if the grabber can provide data for this channel, else 0.
2686	# May optionally be sent 'day' arg to see if the grabber supports
2687	# grabbing day X for this channel.
2688	sub supports_channel
2689	{
2690	my ($grabber, $ch, $day) = @_;
2691
2692	my $mdpc = query_config($grabber, 'max_days_per_chan');
2693	if ($mdpc and $day)
2694	{
2695	if ($mdpc->{$ch})
2696	{
2697	return ($mdpc->{$ch} > $day);
2698	}
2699	}
2700
2701	my $channels_supported = query_config($grabber, 'channels');
2702	unless (defined $channels_supported)
2703	{
2704	&log("WARNING: Grabber $grabber has no channel support " .
2705	"specified in config.\n");
2706	$channels_supported = '';
2707	}
2708
2709	return 1 unless ($channels_supported); # Empty string means we support all
2710
2711	$ch =~ s/ /_/g;
2712	my $match = ($channels_supported =~ /\b$ch\b/);
2713	my $exceptions = ($channels_supported =~/^-/);
2714	return ($match != $exceptions);
2715	}
2716
2717	# Returns 1 if the grabber supports our set region, else 0
2718	sub supports_region
2719	{
2720	my ($grabber) = @_;
2721
2722	my $rsupport = query_config($grabber, 'regions');
2723	return 1 unless ($rsupport); # Empty string means full support
2724
2725	my $match = ($rsupport =~ /\b$region\b/);
2726	my $exceptions = ($rsupport =~/^-/);
2727	return ($match != $exceptions);
2728	}
2729
2730	# Return 0 if the grabber can't provide data for this day,
2731	# 1 if it can reliably, and 0.5 if it can unreliably.
2732	#
2733	# Note that a max_days of 7 means the grabber can retrieve data for
2734	# today plus 6 days.
2735	sub supports_day
2736	{
2737	my ($grabber, $day) = @_;
2738
2739	return 0 unless ($day < query_config($grabber, 'max_days'));
2740	return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
2741	return 1;
2742	}
2743
2744	sub find_cache_hits
2745	{
2746	my ($grabber, $key) = @_;
2747
2748	$grabber = query_name($grabber);
2749
2750	return 0 unless ($components->{$grabber}->{cached});
2751
2752	my $hits = 0;
2753
2754	foreach my $day (keys %$key)
2755	{
2756	next unless (supports_day($grabber, $day));
2757	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2758	foreach my $ch (@{$key->{$day}})
2759	{
2760	next unless (supports_channel($grabber, $ch, $day));
2761	$hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
2762	}
2763	}
2764	return $hits;
2765	}
2766
2767	# Build a dayhash of what channel/day data we're currently missing.
2768	# Only policy-violating holes count unless it's sent the detect_microgaps
2769	# flag.
2770	sub detect_missing_data
2771	{
2772	my ($quiet) = @_;
2773
2774	my $m = { };
2775
2776	&log("SHEPHERD: Hunting for microgaps!\n") if ($find_microgaps and !$quiet);
2777	my @chans;
2778	foreach my $ch (keys %$channels)
2779	{
2780	# is this channel missing too much data?
2781	if ($find_microgaps)
2782	{
2783	my $lastday = -1;
2784	foreach my $line (@{$channel_data->{$ch}->{analysis}->{missing_all}})
2785	{
2786	$line =~ /^#(\d)/ or die "Bad line $line";
2787	my $day = $1;
2788	unless ($day == $lastday)
2789	{
2790	push (@{($m->{$day})}, $ch);
2791	$lastday = $day;
2792	push (@chans, $ch) unless (grep ($_ eq $ch, @chans));
2793	}
2794	}
2795	}
2796	elsif (!$channel_data->{$ch}->{analysis}->{data_ok})
2797	{
2798	foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})})
2799	{
2800	push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
2801	push (@chans, $ch) unless (grep ($_ eq $ch, @chans));
2802	}
2803	}
2804	}
2805
2806	foreach my $day (keys %$m)
2807	{
2808	$m->{$day} = [ sort @{$m->{$day}} ];
2809	}
2810
2811	&log(sprintf "SHEPHERD: Need %d channel-days of data (%d channels across %d days).\n",
2812	scalar(keys %$m) * @chans,
2813	scalar(@chans),
2814	scalar(keys %$m)
2815	) if (keys %$m and !$quiet);
2816	return $m;
2817	}
2818
2819	# Find the largest timeslice in the current $missing dayhash; i.e.
2820	# something like "Days 4 - 6 of ABC and SBS." This works by iterating
2821	# through the days and looking for overlaps where consecutive days
2822	# want the same channels.
2823	sub find_best_timeslice
2824	{
2825	my ($overlap, $a);
2826	my $slice = { 'chandays' => 0 };
2827
2828	foreach my $day (0 .. $days-1)
2829	{
2830	consider_slice($slice, $day, $day, @{$missing->{$day}});
2831	$overlap = $missing->{$day};
2832	foreach my $nextday (($day + 1) .. $days-1)
2833	{
2834	last unless ($missing->{$nextday});
2835	$a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
2836	last unless ($a and @{$a});
2837	consider_slice($slice, $day, $nextday, @{$a});
2838	$overlap = $a;
2839	}
2840	}
2841	return $slice;
2842	}
2843
2844	sub display_best_timeslice
2845	{
2846	return sprintf "day%s of channel%s %s (%d channel-day%s).\n",
2847	($timeslice->{start} == $timeslice->{stop} ?
2848	" $timeslice->{start}" :
2849	"s $timeslice->{start} - $timeslice->{stop}"),
2850	(@{$timeslice->{chans}} > 1 ? 's' : ''),
2851	join(', ', @{$timeslice->{chans}}),
2852	$timeslice->{chandays},
2853	$timeslice->{chandays} == 1 ? '' : 's';
2854	}
2855
2856	sub consider_slice
2857	{
2858	my ($slice, $startday, $stopday, @chans) = @_;
2859
2860	my $challenger = ($stopday - $startday + 1) * scalar(@chans);
2861	return unless ($challenger > $slice->{chandays});
2862
2863	# We have a winner!
2864	$slice->{start} = $startday;
2865	$slice->{stop} = $stopday;
2866	$slice->{chans} = [ @chans ];
2867	$slice->{chandays} = $challenger;
2868	}
2869
2870	# Creates temporary gaps file suitable for passing to grabbers with
2871	# --gaps_file option, and records the requested buckets for later
2872	# analysis by analyze_plugin_data().
2873	sub record_requested_gaps
2874	{
2875	my ($fn, $timeslice, $grabber) = @_;
2876
2877	my $gaps;
2878	my $gapstr = '';
2879
2880	# Clear any previously-set gaps
2881	delete $plugin_data->{$grabber}->{requested_gaps};
2882
2883	my $timeslice_epoch_start = $policy{starttime} + ($timeslice->{start} * 24 * 60 * 60);
2884	my $timeslice_epoch_end = $policy{starttime} + (($timeslice->{stop} + 1) * 24 * 60 * 60);
2885
2886	foreach my $ch (@{$timeslice->{chans}})
2887	{
2888	my $missinglist = $channel_data->{$ch}->{analysis}->{missing_all_epoch};
2889	my @a = split(/,/, $missinglist);
2890	foreach my $period (@a)
2891	{
2892	$period =~ /(\d+)-(\d+)/;
2893	my ($gap_start, $gap_end) = ($1, $2);
2894	if ($gap_start < $timeslice_epoch_end or $gap_end > $timeslice_epoch_start)
2895	{
2896	# we want this period
2897	push (@{$gaps->{$ch}}, $period);
2898
2899	# record as requested
2900	for (my $etime = $gap_start; $etime <= $gap_end; $etime += $policy{timeslot_size})
2901	{
2902	my $bucket = ($etime - $policy{starttime}) / $policy{timeslot_size};
2903	push @{$plugin_data->{$grabber}->{requested_gaps}->{$ch}}, $bucket;
2904	}
2905	}
2906	}
2907	$gapstr .= "$ch:" . join(',', @{$gaps->{$ch}}) . ' ' if ($gaps->{$ch});
2908	}
2909
2910	write_file($fn, 'temporary gaps file', [ $gaps ], [ 'gaps' ]);
2911
2912	return $gapstr;
2913	}
2914
2915	# Record what a cacheable C1 grabber has just retrieved for us,
2916	# so we know next time that this data can be grabbed quickly.
2917	sub record_cached
2918	{
2919	my ($grabber, @grabbed) = @_;
2920
2921	&log(1, "SHEPHERD: Recording cache for grabber $grabber.\n");
2922
2923	my $gcache = $components->{$grabber}->{cached};
2924	$gcache = [ ] unless ($gcache);
2925	my @newcache;
2926	my $today = strftime("%Y%m%d", localtime);
2927
2928	# remove old chandays
2929	foreach my $chanday (@$gcache)
2930	{
2931	$chanday =~ /(\d+):(.*)/;
2932	if ($1 >= $today)
2933	{
2934	push (@newcache, $chanday);
2935	}
2936	}
2937
2938	# record new chandays
2939	foreach my $chanday (@grabbed)
2940	{
2941	push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
2942	}
2943	$components->{$grabber}->{cached} = [ @newcache ];
2944	}
2945
2946	# Takes a dayhash and returns it as a list like this:
2947	# ( "20061018:ABC", "20061018:Seven", ... )
2948	sub convert_dayhash_to_list
2949	{
2950	my $h = shift;
2951
2952	my @ret;
2953	foreach my $day (keys %$h)
2954	{
2955	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2956	foreach my $ch (@{$h->{$day}})
2957	{
2958	push (@ret, "$date:$ch");
2959	}
2960	}
2961	@ret = sort @ret;
2962	return \@ret;
2963	}
2964
2965
2966	# If we're about to re-try a grabber, make sure that we're not asking
2967	# it for the same data. That is, prevent a broken C1 grabber causing
2968	# an infinite loop.
2969	sub record_requested_chandays
2970	{
2971	my ($grabber, $slice) = @_;
2972
2973	&log(1, "SHEPHERD: Recording timeslice request; will not request these chandays " .
2974	"from $grabber again.\n");
2975
2976	# Clear out anything set previously
2977	delete $plugin_data->{$grabber}->{requested_data};
2978
2979	my @requested;
2980	for my $day ($slice->{start} .. $slice->{stop})
2981	{
2982	foreach my $ch (@{$slice->{chans}})
2983	{
2984	push @requested, "$day:$ch";
2985	$plugin_data->{$grabber}->{requested_data}->{$ch}[$day] = 1;
2986	# &log(1, " requesting ch $ch on day $day\n");
2987	}
2988	}
2989	if ($grabbed->{$grabber})
2990	{
2991	push @{$grabbed->{$grabber}}, @requested;
2992	}
2993	else
2994	{
2995	$grabbed->{$grabber} = [ @requested ];
2996	}
2997	}
2998
2999	# If this grabber has been called previously, remove those chandays
3000	# from the current request -- we don't want to ask it over and over
3001	# for a timeslice that it has already failed to provide.
3002	sub cut_down_missing
3003	{
3004	my $grabber = shift;
3005
3006	$grabber = query_name($grabber);
3007	my $dayhash = {};
3008
3009	# Take the timeslice and expand it to a dayhash, while pruning
3010	# any chandays that have previously been requested from this
3011	# grabber.
3012	foreach my $day ($timeslice->{start} .. $timeslice->{stop})
3013	{
3014	my @chans;
3015	foreach my $ch (@{$timeslice->{chans}})
3016	{
3017	unless ($grabbed->{$grabber} and grep($_ eq "$day:$ch", @{$grabbed->{$grabber}}))
3018	{
3019	push (@chans, $ch)
3020	}
3021	}
3022	$dayhash->{$day} = [ @chans ] if (@chans);
3023	}
3024
3025	return $dayhash;
3026	}
3027
3028	# -----------------------------------------
3029	# Subs: Analyzing data
3030	# -----------------------------------------
3031
3032	# interpret xmltv data from this grabber/postprocessor
3033	sub soak_up_data
3034	{
3035	my ($pluginname, $output, $plugintype, $stage) = @_;
3036
3037	$components_used .= " + ".$pluginname."(v".$components->{$pluginname}->{ver}.")";
3038	if ($plugintype eq "grabber") {
3039	if ((defined $stage) && ($stage eq "paytv")) {
3040	$components_used .= "[ptv]";
3041	} else {
3042	$components_used .= "[m]" if ($find_microgaps);
3043	}
3044	}
3045
3046	if (! -r $output) {
3047	&log("SHEPHERD: Warning: plugin '$pluginname' output file '$output' does not exist\n");
3048	$components_used .= "[failed_notfound]";
3049	return;
3050	}
3051
3052	my $plugin = $pluginname;
3053	if ($plugintype eq 'grabber')
3054	{
3055	$plugin .= '-' . query_iteration($pluginname);
3056	}
3057
3058	my $this_plugin = $plugin_data->{$plugin};
3059	$this_plugin->{name} = $pluginname;
3060	&log("SHEPHERD: Started parsing XMLTV from '$pluginname' in '$output' .. any errors below are from parser:\n");
3061	eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
3062	&log("SHEPHERD: Completed XMLTV parsing from '$pluginname'\n");
3063
3064	if (!($this_plugin->{xmltv})) {
3065	&log("WARNING: Plugin $pluginname didn't seem to return any valid XMLTV!\n");
3066	$components_used .= "[failed_invalid]";
3067	return;
3068	}
3069
3070	$this_plugin->{valid} = 1;
3071	$this_plugin->{output_filename} = $output;
3072
3073	my $xmltv = $this_plugin->{xmltv};
3074	my ($encoding, $credits, $chan, $progs) = @$xmltv;
3075	$this_plugin->{total_duration} = 0;
3076	$this_plugin->{programmes} = 0;
3077	$this_plugin->{progs_with_invalid_date} = 0; # explicitly track unparsable dates
3078	$this_plugin->{progs_too_long} = 0; # explicitly track exxcessive programme durations
3079	$this_plugin->{progs_with_unknown_channel} = 0; # explicitly track unknown channels
3080
3081	my $seen_channels_with_data = 0;
3082
3083	#
3084	# first iterate through all programmes and see if there are any channels we don't know about
3085	#
3086	my %chan_xml_list;
3087	foreach my $ch (sort keys %{$channels}) {
3088	$chan_xml_list{($channels->{$ch})} = $ch;
3089	}
3090	foreach my $ch (sort keys %{$opt_channels}) {
3091	$chan_xml_list{($opt_channels->{$ch})} = $ch;
3092	}
3093	foreach my $prog (@$progs) {
3094	if (!defined $chan_xml_list{($prog->{channel})}) {
3095	$this_plugin->{progs_with_unknown_channel}++;
3096	&log((sprintf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$pluginname,$prog->{channel}));
3097	$chan_xml_list{($prog->{channel})} = 1; # so we warn only once
3098	}
3099	}
3100
3101	# iterate thru channels
3102	foreach my $ch_xmlid (sort keys %chan_xml_list) {
3103	my $seen_progs_on_this_channel = 0;
3104	my $ch = $chan_xml_list{$ch_xmlid};
3105
3106	# iterate thru programmes per channel
3107	foreach my $prog (@$progs) {
3108	next if ($prog->{channel} ne $ch_xmlid);
3109
3110	my $t1 = &parse_xmltv_date($prog->{start});
3111	my $t2 = &parse_xmltv_date($prog->{stop});
3112
3113	if (!$t1 \|\| !$t2) {
3114	&log((sprintf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
3115	$pluginname,(!$t1 ? $prog->{start} : $prog->{stop}))) if (!$this_plugin->{progs_with_invalid_date});
3116	$this_plugin->{progs_with_invalid_date}++;
3117	next;
3118	}
3119
3120	my $this_duration = $t2 - $t1;
3121	if (($this_duration > $policy{max_programme_length}) &&
3122	($prog->{title}->[0]->[0] !~ /close/i)) {
3123	&log((sprintf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
3124	$pluginname, int($policy{max_programme_length} / 3600),
3125	int(($policy{max_programme_length} % 3600) / 60)))
3126	if (!$this_plugin->{progs_too_long});
3127	$this_plugin->{progs_too_long}++;
3128	next;
3129	}
3130
3131	if ($this_duration < 1) {
3132	&log(sprintf "- WARNING: plugin '%s' returned programme data with invalid duration (%s to %s): ignored.\n", $pluginname, $prog->{start}, $prog->{stop});
3133	next;
3134	}
3135
3136	# store plugin-specific stats
3137	$this_plugin->{programmes}++;
3138	$this_plugin->{total_duration} += $this_duration;
3139	$seen_progs_on_this_channel++;
3140	$this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
3141	$this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
3142	$this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
3143	$this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
3144
3145	# only analyze / check against policy if its a non optional channel
3146	if (defined $channels->{$ch}) {
3147	# store channel-specific stats
3148	$channel_data->{$ch}->{programmes}++;
3149	$channel_data->{$ch}->{total_duration} += $this_duration;
3150
3151	# programme is outside the timeslots we are interested in.
3152	next if ($t1 > $policy{endtime});
3153	next if ($t2 < $policy{starttime});
3154
3155	# store timeslot info
3156	my $start_slotnum = 0;
3157	$start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
3158	if ($t1 >= $policy{starttime});
3159
3160	my $end_slotnum = ($policy{num_timeslots}-1);
3161	$end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
3162	if ($t2 < $policy{endtime});
3163
3164	&log((sprintf "DEBUG: ch '%s' prog start '%s' stop '%s' storing into timeslots %d-%d (%s-%s)\n",
3165	$ch, $prog->{start}, $prog->{stop}, $start_slotnum, $end_slotnum,
3166	POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($start_slotnum * $policy{timeslot_size}))),
3167	POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($end_slotnum * $policy{timeslot_size})))))
3168	if $policy{timeslot_debug};
3169
3170	# add this programme into the global and per-plugin timeslots table for this channel
3171	foreach my $slotnum ($start_slotnum..$end_slotnum) {
3172	$channel_data->{$ch}->{timeslots}[$slotnum]++;
3173	$this_plugin->{timeslots}->{$ch}[$slotnum]++;
3174	}
3175	}
3176	}
3177
3178	$seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
3179	}
3180
3181	# print some stats about what we saw!
3182	&log((sprintf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
3183	ucfirst($plugintype), $pluginname, $seen_channels_with_data, $this_plugin->{programmes},
3184	int($this_plugin->{total_duration} / 86400), # days
3185	int(($this_plugin->{total_duration} % 86400) / 3600), # hours
3186	int(($this_plugin->{total_duration} % 3600) / 60), # mins
3187	int($this_plugin->{total_duration} % 60), # sec
3188	(defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
3189	(defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '')));
3190
3191	$this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
3192	$seen_channels_with_data, $this_plugin->{programmes},
3193	int($this_plugin->{total_duration} / 3600),
3194	(defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
3195	(defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
3196
3197	$plugin_data->{$plugin} = $this_plugin;
3198	}
3199
3200
3201	# analyze grabber data - do we have all the data we want?
3202	# this can analyze either the cumulative data from ALL plugins ($proggy="shepherd")
3203	# or can analyze the data from one specific plugin
3204
3205	sub analyze_plugin_data
3206	{
3207	my ($analysisname, $quiet, $proggy, $iteration) = @_;
3208	&log("SHEPHERD: $analysisname:\n") unless $quiet;
3209
3210	my $total_channels = 0;
3211	my $plugin_epoch_missing_data = "";
3212	my $overall_data_ok = 1; # until proven otherwise
3213	my $total_missing = 0;
3214	my $plugin = $proggy;
3215	$plugin .= "-$iteration" if (defined $iteration);
3216
3217	# iterate across each channel
3218	foreach my $ch (sort keys %{$channels}) {
3219
3220	# if we're analyzing data for a grabber and it doesn't support this channel, skip it
3221	if (($proggy ne $progname) &&
3222	($components->{$proggy}->{type} eq "grabber") &&
3223	(supports_channel($proggy, $ch, 1) == 0)) {
3224	&log(1, (sprintf "DEBUG: analysis of channel %s for plugin %s skipped since plugin doesn't support channel\n",
3225	$ch, $proggy));
3226	next;
3227	}
3228
3229	$total_channels++;
3230
3231	my $data;
3232	my $lastpol = "";
3233	$data->{data_ok} = 1; # unless proven otherwise
3234	$data->{have} = 0;
3235	$data->{missing} = 0;
3236
3237	for my $slotnum (0..($policy{num_timeslots}-1)) {
3238	my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
3239
3240	# work out day number of when this bucket is.
3241	# number from 0 onwards. (i.e. today=0).
3242	# for a typical 7 day grabber this will actually mean 8 days of data (0-7)
3243	# with days 0 and 7 truncated to half-days
3244	my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
3245
3246	if (!defined $data->{day}->[$day]) {
3247	$data->{day}->[$day]->{num} = $day;
3248	$data->{day}->[$day]->{have} = 0;
3249	$data->{day}->[$day]->{missing} = 0;
3250	$data->{day}->[$day]->{missing_peak} = 0;
3251	$data->{day}->[$day]->{missing_nonpeak} = 0;
3252	$data->{day}->[$day]->{missing_other} = 0;
3253
3254	$data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
3255
3256	# day changed, dump any 'already_missing' data
3257	&dump_already_missing($data);
3258	}
3259
3260	# we have programming data for this bucket. great! process next bucket
3261	if ((($proggy eq $progname) &&
3262	(defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
3263	($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) \|\|
3264	(($proggy ne $progname) &&
3265	(defined $plugin_data->{$plugin}->{timeslots}->{$ch}[$slotnum]) &&
3266	($plugin_data->{$plugin}->{timeslots}->{$ch}[$slotnum] > 0))) {
3267	# if we have missing data queued up, push it now
3268	&dump_already_missing($data);
3269	&dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
3270
3271	$data->{day}->[$day]->{have} += $policy{timeslot_size};
3272	$data->{have} += $policy{timeslot_size};
3273	next;
3274	}
3275
3276	# some grabbers take HOURS to run. if this bucket (missing data) is for
3277	# a time period now in the past, then don't include it
3278	next if (($bucket_start_offset + $policy{starttime}) < time);
3279
3280	# we don't have programming for this channel for this bucket
3281	&log((sprintf "DEBUG: missing timeslot data for ch '%s' bucket %d (%s)\n",
3282	$ch, $slotnum, POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($slotnum * $policy{timeslot_size})))))
3283	if $policy{timeslot_debug};
3284
3285
3286	if (($proggy ne $progname) && ($components->{$proggy}->{type} eq "grabber")) {
3287	# if we're analyzing data for a grabber and it doesn't have data for this
3288	# channel on this day, don't record it as missing data if:
3289	# 1. its beyond 'max_reliable_days' for this grabber
3290	# 2. we didn't _request_ the data for this channel/day (C1 grabbers)
3291	# 3. grabber can't supply this channel (C2 grabbers)
3292
3293	my $ignore_missing = 0; # don't ignore missing unless proven otherwise
3294
3295	# 1. ignore if it exceeds 'max_reliable_days' for this grabber
3296	if (supports_day($proggy,$day) != 1) {
3297	$ignore_missing++;
3298	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to max_reliable_days\n",
3299	$proggy, $ch, $day)) if ($policy{timeslot_debug});
3300	}
3301
3302	# 2(a). ignore if we didn't request data for channel/day (C1 grabbers)
3303	if ((query_config($proggy, 'category') == 1) &&
3304	(!defined $plugin_data->{$proggy}->{requested_data}->{$ch}[$day])) {
3305	$ignore_missing++;
3306	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not requested\n",
3307	$proggy, $ch, $day)) if ($policy{timeslot_debug});
3308	}
3309
3310	# 2(b). ignore if we didn't request this gap (C1 grabbers)
3311	if ($find_microgaps
3312	and
3313	&query_config($proggy, 'category') == 1
3314	and
3315	grep ($_ ne $slotnum, @{$plugin_data->{$proggy}->{requested_gaps}->{$ch}}))
3316	{
3317	$ignore_missing++;
3318	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' due to bucket %d being outside requested gap\n",
3319	$proggy, $ch, $slotnum)) if ($policy{timeslot_debug});
3320	}
3321
3322	# 3. ignore if this grabber can't supply this channel (C2 grabbers)
3323	if ((query_config($proggy, 'category') == 2) &&
3324	(supports_channel($proggy,$ch,$day) == 0)) {
3325	$ignore_missing++;
3326	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to cannot-supply\n",
3327	$proggy, $ch, $day)) if ($policy{timeslot_debug});
3328	}
3329
3330	if ($ignore_missing > 0) {
3331	# if we have missing data queued up, push it now
3332	&dump_already_missing($data);
3333	&dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
3334	next;
3335	}
3336	}
3337
3338
3339	if (($proggy ne $progname) && ($components->{$proggy}->{type} ne "grabber")) {
3340	# if we're analyzing data for a reconciler/postprocessor and it doesn't have
3341	# data for a timeslot, only record that as an error if the source data _was_
3342	# previously available in the 'overall' data
3343
3344	if ((!defined $channel_data->{$ch}->{timeslots}[$slotnum]) \|\|
3345	($channel_data->{$ch}->{timeslots}[$slotnum] == 0)) {
3346	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not-in-overall-data\n",
3347	$proggy, $ch, $day)) if ($policy{timeslot_debug});
3348	next;
3349	}
3350	}
3351
3352	# work out the localtime of when this bucket is
3353	my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
3354
3355	# store details of where we are missing data
3356	if (!defined $data->{already_missing}) {
3357	$data->{already_missing} = sprintf "#%d/%02d:%02d",
3358	$day,
3359	int($bucket_seconds_offset / 3600),
3360	int(($bucket_seconds_offset % 3600) / 60);
3361	$data->{already_missing_epoch} = $policy{starttime} + $bucket_start_offset;
3362	}
3363	$data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
3364	$data->{already_missing_last_epoch} = $policy{starttime} + $bucket_start_offset + $policy{timeslot_size} - 1;
3365
3366	$data->{day}->[$day]->{missing} += $policy{timeslot_size};
3367	$data->{missing} += $policy{timeslot_size};
3368
3369	# work out what policy missing data for this bucket fits into
3370	my $pol;
3371	if (($bucket_seconds_offset >= $policy{peak_start}) &&
3372	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
3373	$pol = "peak";
3374	} elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
3375	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
3376	$pol = "nonpeak";
3377	} else {
3378	$pol = "other";
3379	}
3380
3381	&dump_already_missing_period($data->{day}->[$day],$lastpol)
3382	if (($lastpol ne $pol) && ($lastpol ne ""));
3383
3384	$lastpol = $pol;
3385
3386	$data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
3387
3388	$data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
3389	if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
3390	$data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
3391
3392	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
3393	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
3394	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
3395	$data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
3396	$overall_data_ok = 0 if ($data->{data_ok} == 0);
3397	}
3398
3399	# finished all timeslots in this channel.
3400	# if we have missing data queued up, push it now
3401	&dump_already_missing($data);
3402
3403	# fill in any last missing period data
3404	foreach my $day (@{($data->{day})}) {
3405	&dump_already_missing_period($day,"peak");
3406	&dump_already_missing_period($day,"nonpeak");
3407	&dump_already_missing_period($day,"other");
3408	}
3409
3410	my $statusstring = sprintf " > ch %s: %s%s\n",
3411	$ch,
3412	$data->{have} ? ($data->{missing} ? ($data->{data_ok} ? "PASS (within policy thresholds)" : "FAIL (missing data exceeds policy thresholds):") : "PASS (complete)") : "FAIL (no data):",
3413	$data->{have} ? ", have " . pretty_duration($data->{have}) : '';
3414
3415	# display per-day missing data statistics
3416	foreach my $day (@{($data->{day})}) {
3417	next unless ($day->{missing});
3418
3419	$statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": missing ";
3420	if ($day->{have})
3421	{
3422	$statusstring .= pretty_duration($day->{missing}) . ": ";
3423
3424	# do we have any data for this day?
3425	$statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
3426	if (($day->{missing_peak}) && ($day->{missing_peak}));
3427
3428	$statusstring .= sprintf "%snon-peak %s",
3429	($day->{missing_peak} ? " / " : ""),
3430	join(", ",(@{($day->{missing_nonpeak_table})}))
3431	if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak}));
3432
3433	$statusstring .= sprintf "%sother %s",
3434	(($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
3435	join(", ",(@{($day->{missing_other_table})}))
3436	if (($day->{missing_other}) && ($day->{missing_other}));
3437	}
3438	else
3439	{
3440	$statusstring .= "entire day";
3441	}
3442	$statusstring .= "\n";
3443	}
3444	&log($statusstring) unless $quiet;
3445	$data->{statusstring} = $statusstring;
3446	$plugin_epoch_missing_data .= sprintf "%s:%s\t",$ch,$data->{missing_all_epoch} if (defined $data->{missing_all_epoch});
3447	$total_missing += $data->{missing};
3448
3449	if ($proggy eq $progname) {
3450	delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
3451	$channel_data->{$ch}->{analysis} = $data;
3452	} else {
3453	delete $plugin_data->{$plugin}->{analysis}->{$ch} if (defined $plugin_data->{$plugin}->{analysis}->{$ch});
3454	$plugin_data->{$plugin}->{analysis}->{$ch} = $data;
3455	}
3456	}
3457
3458	&log((sprintf " > OVERALL: %s\n", ($total_missing ? ($overall_data_ok ? "PASS (within policy thresholds)" : "FAIL (exceeds policy thresholds)") : "PASS (complete)"))) unless $quiet;
3459
3460	if ($plugin_epoch_missing_data ne '') {
3461	&add_pending_message($proggy, 'MISSING_DATA', $plugin_epoch_missing_data);
3462	} elsif ($proggy eq $progname) {
3463	delete $pending_messages->{$progname}->{MISSING_DATA};
3464	}
3465
3466	if ($proggy eq $progname) {
3467	$data_found_all = ($total_missing ? 0 : 1);
3468	$data_satisfies_policy = $overall_data_ok;
3469	}
3470	return $overall_data_ok; # return 1 for satisifies policy, 0 for need more
3471	}
3472
3473	# helper routine for filling in 'missing_all' array
3474	sub dump_already_missing
3475	{
3476	my $d = shift;
3477	if (defined $d->{already_missing}) {
3478	$d->{already_missing} .= sprintf "-%02d:%02d",
3479	int($d->{already_missing_last} / 3600),
3480	int(($d->{already_missing_last} % 3600) / 60)
3481	if (defined $d->{already_missing_last});
3482	push(@{($d->{missing_all})}, $d->{already_missing});
3483
3484	$d->{already_missing_epoch} .= sprintf "-%d",$d->{already_missing_last_epoch};
3485	$d->{missing_all_epoch} .= "," if (defined $d->{missing_all_epoch});
3486	$d->{missing_all_epoch} .= $d->{already_missing_epoch};
3487
3488	delete $d->{already_missing};
3489	delete $d->{already_missing_last};
3490
3491	delete $d->{already_missing_epoch};
3492	delete $d->{already_missing_last_epoch};
3493	}
3494	}
3495
3496	# helper routine for filling in per-day missing data
3497	# specific to peak/nonpeak/other
3498	sub dump_already_missing_period
3499	{
3500	my ($d,$p) = @_;
3501	my $startvar = "already_missing_".$p."_start";
3502	my $stopvar = "already_missing_".$p."_stop";
3503
3504	if (defined $d->{$startvar}) {
3505	push(@{($d->{"missing_".$p."_table"})},
3506	sprintf "%02d:%02d-%02d:%02d",
3507	int($d->{$startvar} / 3600),
3508	int(($d->{$startvar} % 3600) / 60),
3509	int($d->{$stopvar} / 3600),
3510	int(($d->{$stopvar} % 3600) / 60));
3511	delete $d->{$startvar};
3512	delete $d->{$stopvar};
3513	}
3514	}
3515
3516	# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
3517	# and indication of whether the duration is over its threshold or not
3518	sub pretty_duration
3519	{
3520	my ($d,$crit) = @_;
3521	my $s = "";
3522	$s .= sprintf "%dd",int($d / (606024)) if ($d >= (606024));
3523	$s .= sprintf "%dh",int(($d % (606024)) / (6060)) if (($d % (606024)) >= (6060));
3524	$s .= sprintf "%dm",int(($d % (6060)) / 60) if (($d % (6060)) >= 60);
3525	$s .= sprintf "%ds",int($d % 60) if (($s eq "") && ($d > 0));
3526	$s .= "no" if ($s eq "");
3527
3528	if (defined $crit) {
3529	$s .= "[!]" if ($d > $crit);
3530	}
3531	return $s;
3532	}
3533
3534	# work out date range we are expecting data to be in
3535	sub calc_date_range
3536	{
3537
3538	$policy{starttime} = time;
3539
3540	# set endtime as per $days less 1 day + hours left today
3541	$policy{endtime} = $policy{starttime} + ((606024)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
3542
3543	# normalize starttime to beginning of next bucket
3544	$policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
3545
3546	# work out how many seconds into a day our first bucket starts
3547	$policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
3548
3549	# normalize endtime to end of previous bucket
3550	$policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
3551
3552	# if we are working with an --offset, apply it now.
3553	$policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
3554
3555	# work out number of buckets
3556	$policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
3557
3558	&log((sprintf "DEBUG: policy settings: starttime=%d, endtime=%d, first_bucket_offset=%d, gmt_offset=%d, strftime_tz=%s\n",
3559	$policy{starttime}, $policy{endtime}, $policy{first_bucket_offset}, $gmt_offset,
3560	(strftime("%z", localtime(time)))))
3561	if ($policy{timeslot_debug});
3562	}
3563
3564	sub calc_gmt_offset
3565	{
3566	# work out GMT offset - we only do this once
3567	if (!$gmt_offset) {
3568	# work out our gmt offset
3569	my $tzstring = strftime("%z", localtime(time));
3570
3571	$gmt_offset = (6060) int(substr($tzstring,1,2)); # hr
3572	$gmt_offset += (60 * int(substr($tzstring,3,2))); # min
3573	$gmt_offset *= -1 if (substr($tzstring,0,1) eq "-"); # +/-
3574	}
3575	}
3576
3577	# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
3578	# rather than the various other perl implementation which treat it as being in UTC/GMT
3579	sub parse_xmltv_date
3580	{
3581	my $datestring = shift;
3582	my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
3583	my $tz_offset = 0;
3584
3585	if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
3586	($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);
3587	($t[6],$t[7],$t[8]) = (-1,-1,-1);
3588
3589	# if input data has a timezone offset, then offset by that
3590	if ($datestring =~ /\+(\d{2})(\d{2})/) {
3591	$tz_offset = $gmt_offset - (($1(6060)) + ($2*60));
3592	} elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
3593	$tz_offset = $gmt_offset + (($1(6060)) + ($2*60));
3594	}
3595
3596	my $e = mktime(@t);
3597	return ($e+$tz_offset) if ($e > 1);
3598	}
3599	return undef;
3600	}
3601
3602	# -----------------------------------------
3603	# Subs: Reconciling data
3604	# -----------------------------------------
3605
3606	# for all the data we have, try to pick the best bits!
3607	sub reconcile_data
3608	{
3609	&log("\nReconciling data:\n\n");
3610
3611	my $num_grabbers = 0;
3612	my $input_files = "";
3613	my @input_file_list;
3614
3615	# when reconciling & postprocessing, increase the thresholds of how much
3616	# missing data we permit.
3617	# generally, if a postprocessor or reconciler breaks, it'll return
3618	# no data rather than 'most' data.
3619	$policy{peak_max_missing} *= 3;
3620	$policy{nonpeak_max_missing} *= 1.5;
3621	$policy{other_max_missing} *= 3;
3622
3623	&log("Preferred title preferences from '$pref_title_source'\n")
3624	if ((defined $pref_title_source) &&
3625	($plugin_data->{$pref_title_source}) &&
3626	($plugin_data->{$pref_title_source}->{valid}));
3627
3628	&log("Preference for whose data we prefer as follows:\n");
3629	foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
3630	next if ($components->{$proggy}->{disabled});
3631	foreach my $plugin (keys %$plugin_data) {
3632	next unless (($plugin =~ /^$proggy-\d+$/)
3633	and
3634	($plugin_data->{$plugin})
3635	and
3636	($plugin_data->{$plugin}->{valid}));
3637	$num_grabbers++;
3638	&log((sprintf " %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$plugin}->{output_filename}));
3639
3640	$input_files .= $plugin_data->{$plugin}->{output_filename}." ";
3641	push(@input_file_list,$plugin_data->{$plugin}->{output_filename});
3642	}
3643	}
3644
3645	if ($num_grabbers == 0) {
3646	&log("ERROR! Nothing to reconcile! No valid grabber data!\n");
3647	return 0;
3648	}
3649
3650	foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
3651	next if ($components->{$reconciler}->{disabled});
3652	next if (!$components->{$reconciler}->{ready});
3653
3654	$reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
3655
3656	if ((!$reconciler_found_all_data) && ($data_found_all)) {
3657	# urgh. this reconciler did a bad bad thing ...
3658	&log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
3659	} else {
3660	&log("SHEPHERD: Data from reconciler $reconciler looks good\n");
3661	$input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
3662	}
3663
3664	last if ($input_postprocess_file ne "");
3665	}
3666
3667	if ($input_postprocess_file eq "") {
3668	# no reconcilers worked!!
3669	&log("SHEPHERD: WARNING: No reconcilers seemed to work! Falling back to concatenating the data together!\n");
3670
3671	my %w_args = ();
3672	$input_postprocess_file = "$CWD/input_preprocess.xmltv";
3673	my $fh = new IO::File ">$input_postprocess_file" \|\| die "could not open $input_postprocess_file for writing: $!\n";
3674	%w_args = (OUTPUT => $fh);
3675	XMLTV::catfiles(\%w_args, @input_file_list);
3676	}
3677	return 1;
3678	}
3679
3680
3681	# -----------------------------------------
3682	# Subs: Postprocessing
3683	# -----------------------------------------
3684
3685	sub postprocess_data
3686	{
3687	# for our first postprocessor, we feed it ALL of the XMLTV files we have
3688	# as each postprocessor runs, we feed in the output from the previous one
3689	# Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
3690	# reverts back to the previous postprocessor if it was shown to be bad
3691
3692	# first time around: feed in reconciled data ($input_postprocess_file)
3693
3694	&log("\nSHEPHERD: Postprocessing stage:\n");
3695
3696	foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
3697	next if ($components->{$postprocessor}->{disabled});
3698	next if (!$components->{$postprocessor}->{ready});
3699
3700	my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
3701
3702	if ($found_all_data) {
3703	# accept what this postprocessor did to our output ...
3704	&log("SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n");
3705	$input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
3706	delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
3707	next;
3708	}
3709
3710	# urgh. this postprocessor did a bad bad thing ...
3711	&log("SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n");
3712
3713	if (defined $components->{$postprocessor}->{conescutive_failures}) {
3714	$components->{$postprocessor}->{conescutive_failures}++;
3715	} else {
3716	$components->{$postprocessor}->{conescutive_failures} = 1;
3717	}
3718	}
3719	}
3720
3721
3722	# -----------------------------------------
3723	# Subs: Postprocessing/Reconciler helpers
3724	# -----------------------------------------
3725
3726	sub call_data_processor
3727	{
3728	my ($data_processor_type, $data_processor_name, $input_files) = @_;
3729
3730	&log("\nSHEPHERD: Using $data_processor_type: $data_processor_name\n");
3731
3732	my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
3733	my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
3734	$comm .= " --region $region" .
3735	" --channels_file $channels_file" .
3736	" --output $output";
3737	$comm .= " --days $days" if ($days);
3738	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
3739	$comm .= " --debug" if ($debug);
3740	$comm .= " @ARGV" if (@ARGV);
3741
3742	$comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
3743	if (($data_processor_type eq "reconciler") &&
3744	(defined $pref_title_source) &&
3745	($plugin_data->{$pref_title_source}) &&
3746	($plugin_data->{$pref_title_source}->{valid}));
3747
3748	$comm .= " $input_files";
3749	&log("SHEPHERD: Excuting command: $comm\n");
3750
3751	if (-e $output)
3752	{
3753	&log(1, "SHEPHERD: Removing old output file: $output\n");
3754	unlink($output) or &log("SHEPHERD: Failed to remove old output file: $output\n$!\n");
3755	}
3756	my $component_start = time;
3757	my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
3758	chdir $dir;
3759	my ($retval,$msg) = call_prog($data_processor_name,$comm,0,(query_config($data_processor_name,'max_runtime')*60));
3760	chdir $CWD;
3761	my $component_duration = time - $component_start;
3762
3763	if ($retval) {
3764	&log("$data_processor_type exited with non-zero code $retval: assuming it failed.\n" .
3765	"Last message: $msg\n");
3766	$components->{$data_processor_name}->{laststatus} = "Failed ($retval)";
3767	$components->{$data_processor_name}->{consecutive_failures}++;
3768	&add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
3769	$components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
3770	return 0;
3771	}
3772
3773	#
3774	# soak up the data we just collected and check it
3775	# YES - these are the SAME routines we used in the previous 'grabber' phase
3776	# but the difference here is that we clear out our 'channel_data' beforehand
3777	# so we can independently analyze the impact of this postprocessor.
3778	# if it clearly returns bad data, don't use that data (go back one step) and
3779	# flag the postprocessor as having failed. after 3 consecutive failures, disable it
3780	#
3781
3782	# clear out channel_data
3783	foreach my $ch (keys %{$channels}) {
3784	delete $channel_data->{$ch};
3785	}
3786
3787	# process and analyze it!
3788	&soak_up_data($data_processor_name, $output, $data_processor_type);
3789
3790	my $have_all_data = 0;
3791	if ((defined $plugin_data->{$data_processor_name}) &&
3792	(defined $plugin_data->{$data_processor_name}->{valid})) {
3793	$have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name",0,$data_processor_name);
3794	}
3795
3796	if ($have_all_data) {
3797	$components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
3798	$components->{$data_processor_name}->{lastdata} = time;
3799	delete $components->{$data_processor_name}->{consecutive_failures}
3800	if (defined $components->{$data_processor_name}->{consecutive_failures});
3801	&add_pending_message($data_processor_name,"SUCCESS", $retval, $component_start, $component_duration,
3802	$components->{$data_processor_name}->{ver}, 0);
3803	} else {
3804	$components->{$data_processor_name}->{laststatus} = "missing data: ".$plugin_data->{$data_processor_name}->{laststatus};
3805	$components->{$data_processor_name}->{consecutive_failures}++;
3806	&add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
3807	$components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
3808	}
3809
3810	return $have_all_data;
3811	}
3812
3813
3814	sub output_data
3815	{
3816	# $input_postprocess_file contains our final output
3817	# send it to whereever --output told us to!
3818
3819	my $output_filename = "$CWD/output.xmltv";
3820	$output_filename = $opt->{output} if ($opt->{output});
3821
3822	my %writer_args = ( encoding => 'ISO-8859-1' );
3823	my $fh = new IO::File(">$output_filename") \|\|
3824	die "can't open $output_filename for writing: $!";
3825	$writer_args{OUTPUT} = $fh;
3826
3827	$writer = new XMLTV::Writer(%writer_args);
3828	$writer->start( {
3829	'source-info-name' => "$progname v".$components->{$progname}->{ver},
3830	'generator-info-name' => $components_used } );
3831
3832	XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb,
3833	\&output_data_programme_cb, $input_postprocess_file);
3834	$writer->end();
3835
3836	&log("Final output stored in $output_filename.\n");
3837	}
3838
3839	sub output_data_channel_cb
3840	{
3841	my $c = shift;
3842	$writer->write_channel($c);
3843	}
3844
3845	sub output_data_programme_cb
3846	{
3847	my $prog=shift;
3848	$writer->write_programme($prog);
3849	}
3850
3851	# -----------------------------------------
3852	# Subs: Tor support
3853	# -----------------------------------------
3854
3855	sub start_tor
3856	{
3857	# do we have any components requesting the use of tor?
3858	my $want_tor = 0;
3859	foreach (query_grabbers()) {
3860	unless ($components->{$_}->{disabled}) {
3861	$want_tor++ if (query_config($_, 'option_anon_socks'));
3862	}
3863	}
3864
3865	return if ($want_tor == 0);
3866
3867	# try to find tor
3868	my $searchpath = ".:/usr/sbin:".$ENV{PATH};
3869	my $found_tor;
3870	foreach my $dir (split(/:/,$searchpath)) {
3871	if ((-x "$dir/tor") && (-f "$dir/tor")) {
3872	$found_tor = "$dir/tor";
3873	last;
3874	}
3875	}
3876
3877	if (!defined $found_tor) {
3878	&log("\nWARNING: $want_tor components wanted to use Tor but could not find it.\n");
3879	&log("This may cause data collection to run slower than it otherwise would.\n");
3880	return;
3881	}
3882
3883	# we'll run our own local copy of Tor exclusively for shepherd
3884	my $tordir = $CWD."/tor";
3885	if (!-d $tordir) {
3886	if (!mkdir $tordir) {
3887	&log("\nWARNING: Could not create $tordir, Tor not started!\n");
3888	&log("This may cause data collection to run slower than it otherwise would.\n");
3889	return;
3890	}
3891	}
3892
3893	&log("\nStarting Tor ($found_tor) in the background (wanted by $want_tor components).\n");
3894	my $pid = fork;
3895	if (!defined $pid) {
3896	# failed
3897	&log("Failed to start $found_tor: $!\n");
3898	return;
3899	} elsif ($pid > 0) {
3900	# parent
3901	sleep 2; # wait a few seconds for Tor to start
3902
3903	# test that it is running
3904	if (!kill 0, $pid) {
3905	&log("Tor doesn't seem to be running on pid $pid anymore, ignoring Tor option.\n");
3906	} else {
3907	&log("Tor appears to have successfully started (pid $pid).\n");
3908	$plugin_data->{tor_address} = "127.0.0.1:9051";
3909	$plugin_data->{tor_pid} = $pid;
3910	}
3911	} else {
3912	# child
3913	exec $found_tor,"SocksListenAddress","127.0.0.1:9051","MaxCircuitDirtiness","30","DataDirectory",$tordir;
3914	exit(1); # we won't reach this
3915	}
3916	}
3917
3918
3919	sub stop_tor
3920	{
3921	if (defined $plugin_data->{tor_pid}) {
3922	# INTR sig stops tor
3923	kill 2,$plugin_data->{tor_pid};
3924	}
3925	}
3926
3927	sub test_tor
3928	{
3929	&start_tor;
3930	return if (!defined $plugin_data->{tor_pid}); # no components require it
3931
3932	&log("\nSome components want to use Tor.\n".
3933	"Testing that it is working by connecting to www.google.com via Tor...\n\n");
3934
3935	sleep 10;
3936
3937	use LWP::Protocol::http;
3938	my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
3939
3940	# override LWP::Protocol::http's _new_socket method with our own
3941	local($^W) = 0;
3942	*LWP::Protocol::http::_new_socket = \&socks_new_socket;
3943
3944	# test that it works
3945	my $retries = 0;
3946	my $data;
3947	while ($retries < 10) {
3948	$retries++;
3949	&log("Connecting to www.google.com (try $retries) ... ");
3950	$data = &fetch_file("http://www.google.com/");
3951	last if (($data) && ($data =~ /Google/i));
3952
3953	sleep 10;
3954	}
3955
3956	if (($data) && ($data =~ /Google/i)) {
3957	&log("\nSUCCESS.\nTor appears to be working!\n");
3958	} else {
3959	&log("Tor doesn't appear to be working. Suggest you look into this!\n");
3960	}
3961
3962	*LWP::Protocol::http::_new_socket = $orig_new_socket;
3963	&stop_tor;
3964
3965	sleep 2;
3966	}
3967
3968	##############################################################################
3969	# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
3970
3971	sub socks_new_socket
3972	{
3973	my($self, $host, $port, $timeout) = @_;
3974
3975	my ($socks_ip,$socks_port) = split(/:/,$plugin_data->{tor_address});
3976
3977	local($^W) = 0; # IO::Socket::INET can be noisy
3978	my $sock = $self->socket_class->new(
3979	PeerAddr => $socks_ip,
3980	PeerPort => $socks_port,
3981	Proto => 'tcp');
3982
3983	unless ($sock) {
3984	# IO::Socket::INET leaves additional error messages in $@
3985	$@ =~ s/^.*?: //;
3986	&log("Can't connect to $host:$port ($@)\n");
3987	return undef;
3988	}
3989
3990	# perl 5.005's IO::Socket does not have the blocking method.
3991	eval { $sock->blocking(0); };
3992
3993	# establish connectivity with socks server - SOCKS4A protocol
3994	print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
3995	(pack 'x') .
3996	$host . (pack 'x');
3997
3998	my $received = "";
3999	my $timeout_time = time + $timeout;
4000	while ($sock->sysread($received, 8) && (length($received) < 8) ) {
4001	select(undef, undef, undef, 0.25);
4002	last if ($timeout_time < time);
4003	}
4004
4005	if ($timeout_time < time) {
4006	&log("Timeout ($timeout) while connecting via SOCKS server\n");
4007	return $sock;
4008	}
4009
4010	my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
4011	&log("Connection via SOCKS4A server rejected or failed\n") if ($req_status == 0x5b);
4012	&log("Connection via SOCKS4A server because client is not running identd\n") if ($req_status == 0x5c);
4013	&log("Connection via SOCKS4A server because client's identd could not confirm the user\n") if ($req_status == 0x5d);
4014
4015	$sock;
4016	}
4017
4018	##############################################################################

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 601

Download in other formats: