Context Navigation

shepherd @ 324

Revision 324, 86.4 kB (checked in by max, 6 years ago)
Add --pending, expand process_setup_options()
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	my $progname = 'shepherd';
4	my $version = '0.4.8';
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	# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
67	# it will try /opt/shepherd/ instead.
68	my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
69	-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
70	chdir($CWD);
71
72	my $ARCHIVE_DIR = "$CWD/archive";
73	my $LOG_DIR = "$CWD/log";
74
75	my @options;
76	my $opt = {};
77	my $pref_title_source;
78	my $mirror_site;
79	my $debug = 0;
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
92	my $invoked = get_full_path($0);
93
94	# grabbing
95	my $gscore;
96	my $days = 7;
97	my $missing;
98	my $timeslice;
99	my $grabbed;
100	my $gmt_offset;
101	my $grabber_found_all_data;
102	my $writer;
103	my $components_used = $progname."(v".$version.")";
104
105	# postprocessing
106	my $langs = [ 'en' ];
107	my $plugin_data = { };
108	my $channel_data = { };
109	my $reconciler_found_all_data;
110	my $input_postprocess_file = "";
111
112	# ---------------------------------------------------------------------------
113	# --- Policies
114	# ---------------------------------------------------------------------------
115	# the following thresholds are used to control whether we keep calling grabbers or
116	# not.
117
118	my %policy;
119	$policy{timeslot_size} = (5 * 60); # 5 minute slots
120	$policy{timeslot_debug} = 0; # don't debug timeslot policy by default
121
122	# PEAK timeslots -
123	# between 4.30pm and 10.30pm every day, only allow a maximum of
124	# 15 minutes "programming data" missing
125	# if there is more than this, we will continue asking grabbers for more
126	# programming on this channel
127	$policy{peak_max_missing} = 15*60; # up to 15 mins max allowed missing
128	$policy{peak_start} = (16(6060))+(30*60); # 4.30pm
129	$policy{peak_stop} = (22(6060))+(30*60); # 10.30pm
130
131	# NON-PEAK timeslots -
132	# between midnight and 7.15am every day, only allow up to 6 hours missing
133	# if there is more than this, we will continue asking grabbers for more
134	# programming on this channel
135	$policy{nonpeak_max_missing} = 7(6060); # up to 6 hours can be missing
136	$policy{nonpeak_start} = 0; # midnight
137	$policy{nonpeak_stop} = (7(6060))+(15*60); # 7.15am
138
139	# all other timeslots - (7.15am-4.30pm, 10.30pm-midnight)
140	# allow up to 60 minutes maximum missing programming
141	$policy{other_max_missing} = 36060; # up to 3 hrs max allowed missing
142
143	# don't accept programmes that last for longer than 8 hours.
144	$policy{max_programme_length} = (8 * 60 * 60); # 8 hours
145
146
147	# ---------------------------------------------------------------------------
148	# --- Setup
149	# ---------------------------------------------------------------------------
150
151	&get_command_line_options;
152
153	&capabilities if ($opt->{capabilities});
154	&description if ($opt->{description});
155
156	$\| = 1;
157	print "$progname v$version\n\n";
158
159	exit if ($opt->{version});
160	&help if ($opt->{help});
161
162	&check_user;
163
164	&read_config_file;
165	&read_channels_file;
166	&open_logfile unless ($opt->{nolog});
167
168	&process_setup_commands;
169
170	# ---------------------------------------------------------------------------
171	# --- Update
172	# ---------------------------------------------------------------------------
173
174	unless ($opt->{noupdate})
175	{
176	if (&update())
177	{
178	&write_config_file;
179	}
180	}
181
182	if ($opt->{configure})
183	{
184	&configure;
185	}
186
187	# ---------------------------------------------------------------------------
188	# --- Go!
189	# ---------------------------------------------------------------------------
190
191	unless ($opt->{update})
192	{
193	&calc_date_range;
194	&start_tor;
195	&grab_data;
196	&reconcile_data;
197	&postprocess_data;
198	&output_data;
199	&write_config_file;
200	&stop_tor;
201	}
202
203	&log("Done.\n");
204	&close_logfile() unless $opt->{nolog};
205
206	# ---------------------------------------------------------------------------
207	# --- Subroutines
208	# ---------------------------------------------------------------------------
209
210	# -----------------------------------------
211	# Subs: Updates & Installations
212	# -----------------------------------------
213
214	sub update
215	{
216	my $wanted_prog = get_full_path(query_filename('shepherd','application'));
217	if (($invoked ne $wanted_prog) && (!$opt->{configure}))
218	{
219	if (-e $wanted_prog)
220	{
221	&log("\n* Restarting ($invoked invoked, $wanted_prog wanted) *\n\n");
222	&close_logfile unless $opt->{nolog};
223	$ENV{shepherd_restart} = $invoked;
224	exec("$wanted_prog @options");
225	# This exits.
226	exit(0);
227	}
228
229	&log("\nWARNING: you should really be running ".ucfirst($progname)."\n".
230	" as '".query_filename('shepherd','application')."'\n".
231	" rather than '$invoked'!\n".
232	" Auto-update has been disabled until you fix this!\n\n");
233	&countdown();
234	&log("\nSkipped auto-update.\n\n");
235	return 0;
236	}
237
238
239	# gather pending messages
240	my $postvars = "";
241
242	unless ($opt->{nonotify}) {
243	my %postmsgs;
244
245	# shepherd first
246	if ((defined $pending_messages->{shepherd}) &&
247	(defined $pending_messages->{shepherd}->{STATUS})) { # shepherd is first
248	$postmsgs{shepherd} = urlify("STATUS\t".$pending_messages->{shepherd}->{STATUS});
249	}
250
251	# rest
252	foreach my $component (keys %$pending_messages) {
253	foreach my $msgtype (sort keys %{($pending_messages->{$component})}) {
254	next if (($component eq "shepherd") && ($msgtype eq "STATUS"));
255	$postmsgs{$component} .= urlify("\n".$component."\t") if (defined $postmsgs{$component});
256	$postmsgs{$component} .= urlify($msgtype."\t".$pending_messages->{$component}->{$msgtype});
257	}
258	}
259
260	# shepherd first
261	if (defined $postmsgs{shepherd}) {
262	$postvars = "shepherd=".$postmsgs{shepherd};
263	delete $postmsgs{shepherd};
264	}
265
266	# rest
267	foreach my $component (sort keys %postmsgs) {
268	$postvars .= sprintf "%s%s=%s",
269	(length($postvars) > 0 ? "&" : ""),
270	$component, $postmsgs{$component};
271	}
272	}
273
274	&log("\nChecking for updates:\n\n");
275	my $data = fetch_shepherd_file("getstatus.cgi",undef,$postvars);
276
277	return 0 unless ($data);
278
279	my $made_changes = 0;
280
281	# seemed to be successful, clear out our pending messages
282	unless ($opt->{nonotify}) {
283	$made_changes = 1 if (length($postvars) > 0);
284	foreach my $component (sort keys %$pending_messages) {
285	delete $pending_messages->{$component};
286	}
287	}
288
289	my %clist = %$components;
290
291	while ($data =~ /(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/g)
292	{
293	my ($progtype, $proggy, $latestversion, $csum1, $csum2) = ($1,$2,$3,$4,$5);
294	if (update_component($proggy, $latestversion, $progtype, $csum1, $csum2))
295	{
296	$made_changes = 1;
297	}
298	delete $clist{$proggy};
299	}
300
301	# work out what components disappeared (if any)
302	foreach (keys %clist) {
303	unless ($components->{$_}->{disabled}) {
304	&log("\nDeleted component: $_.\n");
305	disable($_, 2);
306	$made_changes = 1;
307	}
308	}
309	$made_changes;
310	}
311
312	sub update_component
313	{
314	my ($proggy, $latestversion, $progtype, $csum1, $csum2) = @_;
315
316	my $ver = 0;
317	$ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e query_filename($proggy,$progtype));
318
319	my ($result, $action);
320
321	if ($progtype eq 'application'
322	or $progtype eq 'engine'
323	or $progtype eq 'reconciler')
324	{
325	$result = &majorversioncmp($ver, $latestversion);
326
327	# Ignore major versions that are lower. This lets us maintain branches
328	# of Shepherd; i.e. release a bugfix for a previous version while continuing
329	# development of a newer version with new dependencies.
330	return 0 if ($result == 1);
331
332	if ($result == -1 and !$opt->{'update-version'})
333	{
334	&log(ucfirst($progtype) . " $proggy has new major version available: " .
335	"v$latestversion.\nNot auto-updating. To update, run: $progname " .
336	"--update-version\n");
337	$result = 0;
338	$action = 'IGNORING';
339	}
340	}
341
342	unless ($action)
343	{
344	$result = &versioncmp($ver, $latestversion);
345	$action = $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
346	$result == 1 ? "DOWNGRADING" :
347	"up to date";
348	}
349	&log(sprintf "* %-55s%16s\n",
350	ucfirst($progtype) . " $proggy" .
351	($ver ? " v$ver" : '') . "...",
352	$action);
353	return 0 unless ($result);
354	install($proggy, $latestversion, $progtype, $ver, $csum1, $csum2);
355	return 1;
356	}
357
358	sub install
359	{
360	my ($proggy, $latestversion, $progtype, $oldver, $csum1, $csum2) = @_;
361	my $config;
362
363	my $rdir = "";
364	my $basedir = $CWD."/".$progtype."s";
365	my $ldir = query_ldir($proggy, $progtype);
366
367	-d $basedir or mkdir $basedir or die "Cannot create directory $basedir: $!\n";
368	-d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!\n";
369	my $newfile = "$ldir/$proggy-$latestversion";
370
371	$rdir = $progtype . 's';
372	my $rfile = "shepherd/$rdir/$proggy";
373
374	# have we previously downloaded it but haven't been able to install it
375	# (due to a failed test or failed dependencies or something like that)?
376	if ((-e "$newfile") && (-s "$newfile") && (defined $components_pending_install->{$proggy})) {
377	&log("Appear to have previously downloaded $proggy v$latestversion.\n");
378	$config = Data::Dumper->Dump([$components_pending_install->{$proggy}->{config}], ["config"]);
379	} else {
380	&log("Downloading $proggy v$latestversion.\n");
381	return unless (fetch_shepherd_file($rfile, $newfile, undef, $csum2));
382
383	# Make component executable
384	chmod 0755,$newfile;
385	}
386
387	$rfile .= ".conf";
388	$config = fetch_shepherd_file($rfile, undef, undef, $csum1) if (!defined $config);
389
390	return unless ($config); # everyone MUST have config files
391
392	eval $config;
393	if ($@) {
394	&log("Config file $rfile was invalid, not updating this component: $@\n");
395	return;
396	}
397
398	# test that the component works BEFORE we install it
399	my $ready_test = test_proggy("$proggy", $progtype, $latestversion);
400	if (!$ready_test) {
401	&log("$proggy v$latestversion failed ready test - marking as a pending update.\n");
402	$components_pending_install->{$proggy}->{config} = $config;
403	$components_pending_install->{$proggy}->{updated} = time;
404
405	if (defined $components->{$proggy}) {
406	$components->{$proggy}->{admin_status} = sprintf "update to version %s pending: %s",
407	$latestversion, $components_pending_install->{$proggy}->{admin_status};
408	}
409
410	return;
411	}
412
413	$components->{$proggy}->{ready} = $ready_test;
414
415	-d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!\n";
416
417	rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$oldver") if (-e "$ldir/$proggy");
418	rename($newfile, "$ldir/$proggy");
419
420	&log("Installed $proggy v$latestversion.\n") if ($debug);
421
422	$components->{$proggy}->{type} = $progtype;
423	$components->{$proggy}->{ver} = $latestversion;
424	$components->{$proggy}->{config} = $config;
425	$components->{$proggy}->{updated} = time;
426	$components->{$proggy}->{admin_status} = sprintf "updated from %s to %s", $oldver, $latestversion;
427	delete $components_pending_install->{$proggy} if (defined $components_pending_install->{$proggy});
428
429	# if the update was for the main app, restart it
430	if ($proggy eq $progname) {
431	&write_config_file;
432
433	# special case for main app - we create a symlink also
434	unlink("$CWD/tv_grab_au","$CWD/shepherd");
435	eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/tv_grab_au"); 1 };
436	eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/shepherd"); 1 };
437
438	&log("\n* Restarting *\n\n");
439	&close_logfile unless $opt->{nolog};
440	$ENV{shepherd_restart} = $invoked;
441	exec("$ldir/$proggy @options"); # this exits
442	exit(0);
443	}
444
445	# If this component was disabled automatically, re-enable it.
446	# But if it was disabled manually, leave it off.
447	my $d = $components->{$proggy}->{disabled};
448	if ($d and $d == 2)
449	{
450	enable($proggy);
451	}
452	}
453
454	sub fetch_shepherd_file
455	{
456	my ($fn, $store, $postvars, $csum) = @_;
457
458	my $sites = "";
459	$sites = "$mirror_site," if ($mirror_site);
460	$sites .= $HOME;
461
462	my $ret;
463	foreach my $site (split(/,/,$sites))
464	{
465	$ret = fetch_file("$site/$fn", $store, 1, $postvars, $csum);
466	return $ret if ($ret);
467	}
468	return undef;
469	}
470
471	sub test_proggy
472	{
473	my ($proggy, $progtype, $specific_version) = @_;
474
475	&log("Testing $proggy...\n");
476
477	my $ldir = query_ldir($proggy, $progtype);
478	my $progname = query_filename($proggy, $progtype);
479	$progname .= "-".$specific_version if ((defined $specific_version) && ($specific_version ne ""));
480
481	my $opt_ready = query_config($proggy, 'option_ready');
482	$opt_ready \|\|= '--version';
483
484	chdir($ldir);
485	my ($result,$test_output) = call_prog($proggy, $progname . " $opt_ready" . " 2>&1",1);
486	chdir ($CWD);
487
488	&log("Return value: $result\n") if ($debug);
489
490	my $statusmsg;
491
492	if ($result)
493	{
494	&log("\n" . ucfirst($progtype) . " $proggy did not exit cleanly!\n" .
495	"It may require configuration.\n");
496
497	# set proggy status accordingly
498	$statusmsg = sprintf "FAILED (return code %d) on %s", $result, POSIX::strftime("%a%d%b%y", localtime(time));
499
500	# can we give any more details on why it failed?
501	if ($test_output and $test_output =~ /Can't locate (.*) in \@INC/) {
502	my $modname = $1;
503	$modname =~ s#/#::#g; # turn / into ::
504	$modname =~ s#\.pm##g; # remove .pm suffix
505	$statusmsg .= ": missing '".$modname."' module.";
506
507	&log("Probably failued due to dependency on missing module '".$modname."'\n");
508	}
509
510	&log("\n");
511	}
512	else
513	{
514	&log("OK.\n");
515
516	# mark as successful but only if previously unsuccessful
517	# (we only mark it if it was previously unsuccessful otherwise a --check
518	# will result in clearing out all of the admin_status fields)
519	$statusmsg = sprintf "tested successfully on %s", POSIX::strftime("%a%d%b%y", localtime(time))
520	if ((defined $components->{$proggy}->{ready}) && (!$components->{$proggy}->{ready}));
521	}
522
523	# update status message
524	if ((defined $statusmsg) && ($statusmsg ne "")) {
525	if ((defined $specific_version) && ($specific_version ne "")) {
526	$components_pending_install->{$proggy}->{admin_status} = $statusmsg;
527	} else {
528	$components->{$proggy}->{admin_status} = $statusmsg;
529	}
530	}
531
532	return !$result;
533	}
534
535	sub enable
536	{
537	my $proggy = shift;
538
539	# confirm it exists first
540	if (!$components->{$proggy}) {
541	&log("No such component: \"$proggy\".\n");
542	return;
543	}
544
545	&log("Enabling $proggy.\n");
546
547	delete $components->{$proggy}->{disabled};
548	$components->{$proggy}->{admin_status} = sprintf "enabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
549	}
550
551	sub disable
552	{
553	my ($proggy, $n) = @_;
554
555	# confirm it exists first
556	if (!$components->{$proggy}) {
557	&log("No such component: \"$proggy\".\n");
558	return;
559	}
560
561	if ($components->{$proggy}->{type} eq "application") {
562	&log("Can't disable component: \"$proggy\".\n");
563	return;
564	}
565
566	&log("Disabling $proggy.\n");
567
568	$n \|\|= 1;
569	$components->{$proggy}->{disabled} = $n;
570	$components->{$proggy}->{admin_status} = sprintf "manually disabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
571	}
572
573	sub check
574	{
575	my $result;
576
577	foreach my $proggy (keys %$components) {
578	my $progtype = $components->{$proggy}->{type};
579	my $try_count = 0;
580
581	RETRY:
582	$try_count++;
583	$result = test_proggy($proggy, $components->{$proggy}->{type});
584	$components->{$proggy}->{ready} = $result;
585
586	if ((!$result) && ($try_count < 2) && (query_config($proggy, 'option_config'))) {
587	&log("Trying to configure '$proggy'\n");
588
589	chdir(query_ldir($proggy, $progtype));
590	system(query_filename($proggy, $progtype) . " ". query_config($proggy, 'option_config') . " 2>&1");
591	chdir ($CWD);
592
593	goto RETRY;
594	}
595	}
596	}
597
598	sub pending
599	{
600	return unless ($components_pending_install);
601
602	my @pending;
603	foreach (keys %$components_pending_install)
604	{
605	push @pending, $_;
606	}
607	unless (@pending)
608	{
609	&log("\nNo components are pending install.\n");
610	return;
611	}
612	&log("\nThe following components are pending install: " .
613	join(', ', @pending) . ".\n\n" .
614	"You may have missing Perl dependencies. To see errors,\n".
615	"run: $progname --update or $progname --check\n");
616
617	# Exit with non-zero status so this sub can be used to
618	# notify an external program (to email the owner, perhaps)
619	# about pending installs.
620	exit 1;
621	}
622
623	# -----------------------------------------
624	# Subs: Utilities
625	# -----------------------------------------
626
627	# versioncmp from Sort::Versions by Kenneth J. Albanowski
628	sub versioncmp( $$ ) {
629	my @A = ($_[0] =~ /([-.]\|\d+\|[^-.\d]+)/g);
630	my @B = ($_[1] =~ /([-.]\|\d+\|[^-.\d]+)/g);
631
632	my ($A, $B);
633	while (@A and @B) {
634	$A = shift @A;
635	$B = shift @B;
636	if ($A eq '-' and $B eq '-') {
637	next;
638	} elsif ( $A eq '-' ) {
639	return -1;
640	} elsif ( $B eq '-') {
641	return 1;
642	} elsif ($A eq '.' and $B eq '.') {
643	next;
644	} elsif ( $A eq '.' ) {
645	return -1;
646	} elsif ( $B eq '.' ) {
647	return 1;
648	} elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
649	if ($A =~ /^0/ \|\| $B =~ /^0/) {
650	return $A cmp $B if $A cmp $B;
651	} else {
652	return $A <=> $B if $A <=> $B;
653	}
654	} else {
655	$A = uc $A;
656	$B = uc $B;
657	return $A cmp $B if $A cmp $B;
658	}
659	}
660	@A <=> @B;
661	}
662
663	sub majorversioncmp
664	{
665	my ($v1, $v2) = @_;
666
667	$v1 =~ /^(\d+)\./ and $v1 = $1;
668	$v2 =~ /^(\d+)\./ and $v2 = $1;
669
670	$v1 <=> $v2;
671	}
672
673	sub get_full_path
674	{
675	my $path = shift;
676	my $real = realpath($path);
677	return $path if (!$real);
678	return $real;
679	}
680
681	sub require_module
682	{
683	my ($mod, @imports) = @_;
684
685	my $modname = $mod.".pm";
686	$modname =~ s/::/\//g;
687
688	eval { require $modname; };
689	if ($@) {
690	&log("\nERROR:\nMandatory module '$mod' not found.\n\n" .
691	"Please see the Wiki at http://svn.whuffy.com/index.fcgi/wiki/Installation\n" .
692	"for details on how to install this module.\n", 1);
693	exit(1);
694	}
695
696	import $mod @imports;
697	}
698
699	# check that user isn't root, warn them if they are!
700	sub check_user
701	{
702	if ($< == 0) {
703	&log("WARNING:\n You are running ".ucfirst($progname).
704	" as 'root' super-user.\n".
705	" It is HIGHLY RECOMMENDED that you set your system to run ".
706	ucfirst($progname)."\n from within a normal user account!\n\n", 1);
707	&countdown(10, 1);
708	}
709	}
710
711	sub query_grabbers
712	{
713	my ($conf, $val) = @_;
714	return query_component_type('grabber',$conf,$val);
715	}
716
717	sub query_reconcilers
718	{
719	return query_component_type('reconciler');
720	}
721
722	sub query_postprocessors
723	{
724	return query_component_type('postprocessor');
725	}
726
727	sub query_component_type
728	{
729	my ($progtype,$conf,$val) = @_;
730
731	my @ret = ();
732	foreach (keys %$components)
733	{
734	if ($components->{$_}->{type} eq $progtype) {
735	if (defined $conf) {
736	push (@ret, $_) if (query_config($_,$conf) eq $val);
737	} else {
738	push (@ret, $_);
739	}
740	}
741	}
742	return @ret;
743	}
744
745	sub query_name
746	{
747	my $str = shift;
748	if ($str =~ /(.*) \[cache\]/)
749	{
750	return $1;
751	}
752	return $str;
753	}
754
755	sub query_filename
756	{
757	my ($proggy, $progtype) = @_;
758	return query_ldir($proggy,$progtype).'/'.$proggy;
759	}
760
761	sub query_ldir
762	{
763	my ($proggy, $progtype) = @_;
764	return $CWD.'/'.$progtype.'s/'.$proggy;
765	}
766
767	sub query_config
768	{
769	my ($grabber, $key) = @_;
770
771	$grabber = query_name($grabber);
772	return undef unless ($components->{$grabber});
773	return $components->{$grabber}->{config}->{$key};
774	}
775
776	sub countdown
777	{
778	my ($n, $stderr) = @_;
779
780	$n \|\|= 10;
781	&log("You may wish to CTRL-C and fix this.\n\nContinuing anyway in:", $stderr);
782	foreach (1 .. $n)
783	{
784	&log(" " . ($n + 1 - $_), $stderr);
785	sleep 1;
786	}
787	&log("\n", $stderr);
788	}
789
790	sub rotate_logfiles
791	{
792	# keep last 10 log files
793	my $num;
794	for ($num = 10; $num > 0; $num--) {
795	my $f1 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num;
796	my $f2 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num+1;
797	unlink($f2);
798	rename($f1,$f2);
799	}
800
801	my $f1 = sprintf "%s/%s",$LOG_DIR,$log_file;
802	my $f2 = sprintf "%s/%s.1",$LOG_DIR,$log_file;
803	rename($f1,$f2);
804	}
805
806	sub compress_file
807	{
808	my $infile = shift;
809	my $outfile = sprintf "%s.gz",$infile;
810	my $gz;
811
812	if (!(open(INFILE,"<$infile"))) {
813	warn "could not open file $infile for reading: $!\n";
814	return;
815	}
816
817	if (!($gz = gzopen($outfile,"wb"))) {
818	warn "could not open file $outfile for writing: $!\n";
819	return;
820	}
821
822	while (<INFILE>) {
823	my $byteswritten = $gz->gzwrite($_);
824	warn "error writing to compressed file: error $gz->gzerror"
825	if ($byteswritten == 0);
826	}
827	close(INFILE);
828	$gz->gzclose();
829	unlink($infile);
830	}
831
832	sub open_logfile
833	{
834	-d $LOG_DIR or mkdir $LOG_DIR or die "Cannot create directory $LOG_DIR: $!";
835
836	&rotate_logfiles;
837	print "Logging to $log_file.\n" if ($debug);
838	open(LOG_FILE,">>$LOG_DIR/$log_file") \|\| die "can't open log file $LOG_DIR/$log_file for writing: $!\n";
839
840	my $now = localtime(time);
841	printf LOG_FILE "$progname v$version started at $now\n";
842	printf LOG_FILE "Invoked as: $invoked ".join(" ",@options)."\n\n";
843	compress_file($LOG_DIR."/".$log_file.".1");
844	}
845
846	sub close_logfile
847	{
848	close(LOG_FILE);
849	}
850
851	sub log
852	{
853	my ($entry, $stderr) = @_;
854
855	if ($stderr)
856	{
857	print STDERR $entry;
858	}
859	else
860	{
861	print $entry unless ($opt->{quiet});
862	}
863	print LOG_FILE $entry if (fileno(*LOG_FILE) and !$opt->{nolog});
864	}
865
866	sub call_prog
867	{
868	my ($component,$prog,$want_output,$timeout) = @_;
869	$timeout = 0 if (!defined $timeout);
870	$want_output = 0 if (!defined $want_output);
871
872	my $prog_output = "";
873
874	if (!(open(PROG,"$prog\|"))) {
875	&log("warning: couldn't exec \"$prog\": $!\n");
876	return -1;
877	}
878
879	eval {
880	local $SIG{ALRM};
881	if ($timeout > 0) {
882	$SIG{ALRM} = sub { die "alarm\n" };
883	alarm $timeout; # set alarm
884	}
885	while(<PROG>) {
886	&log($_);
887	$prog_output .= $_ if ($want_output);
888	$pending_messages->{$component}->{stats} .= $1 if ($_ =~ /^STATS: (.*)/);
889	}
890	alarm(0) if ($timeout > 0); # cancel alarm
891	close(PROG);
892	};
893	if ($@) {
894	die unless $@ eq "alarm\n"; # propagate unexpected errors
895
896	# timeout
897	&log("prog ran for $timeout seconds, stopping it.\n");
898	close(PROG);
899	}
900
901	if ($? == -1) {
902	&log("Failed to execute prog: $!\n");
903	return -1;
904	} elsif ($? & 127) {
905	&log((sprintf "prog died with signal %d, %s coredump\n",
906	($? & 127), (($? & 128) ? "with" : "without")));
907	return $?;
908	} else {
909	&log((sprintf "prog exited with value %d\n", ($? >> 8)));
910	return ($? >> 8);
911	}
912	}
913
914	sub fetch_file
915	{
916	my ($url, $store, $id_self, $postvars, $csum) = @_;
917	my $request;
918
919	&log("Fetching $url.\n");
920
921	my $ua = LWP::UserAgent->new();
922	if ($id_self)
923	{
924	$ua->agent(ucfirst("$progname/$version"));
925	}
926	else
927	{
928	$ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322')
929	}
930
931	if (defined $postvars) {
932	$request = HTTP::Request->new(POST => $url);
933	$request->add_content($postvars);
934	} else {
935	$request = HTTP::Request->new(GET => $url);
936	}
937	$request->header('Accept-Encoding' => 'gzip');
938
939	my $response = $ua->request($request);
940	if ($response->is_success())
941	{
942	if ($response->header('Content-Encoding') &&
943	$response->header('Content-Encoding') eq 'gzip') {
944	$response->content(Compress::Zlib::memGunzip($response->content));
945	}
946
947	# check the checksum
948	if (defined $csum) {
949	my $sha1 = Digest::SHA1->new();
950	$sha1->add($response->content);
951	if ($sha1->hexdigest ne $csum) {
952	&log("$url corrupt: expected checksum $csum but got ".$sha1->hexdigest."\n");
953	return undef;
954	}
955	}
956
957	if ($store)
958	{
959	open (FILE, ">$store")
960	or (&log("ERROR: Unable to open $store for writing.\n") and return undef);
961	print FILE $response->content();
962	close FILE;
963	return 1;
964	}
965	else
966	{
967	return $response->content();
968	}
969	}
970	&log("Failed to retrieve $url!\n" . $response->status_line() . "\n");
971	return undef;
972	}
973
974
975	sub add_pending_message
976	{
977	my ($component, $status, @rest) = @_;
978	$pending_messages->{$component}->{$status} = join("\t",@rest);
979	}
980
981	sub urlify
982	{
983	my $str = shift;
984	$str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
985	return $str;
986	}
987
988	# -----------------------------------------
989	# Subs: Setup
990	# -----------------------------------------
991
992	sub read_config_file
993	{
994	read_file($config_file, 'configuration');
995	}
996
997	sub read_channels_file
998	{
999	read_file($channels_file, 'channels');
1000	}
1001
1002	sub read_file
1003	{
1004	my $fn = shift;
1005	my $name = shift;
1006
1007	print "Reading $name file: $fn\n";
1008	unless (-r $fn)
1009	{
1010	unless ($opt->{configure})
1011	{
1012	print "\nNo $name file found.\n" .
1013	ucfirst($progname) . " must be configured: " .
1014	"configuring now.\n\n";
1015	$opt->{'configure'} = 1;
1016	$opt->{'nolog'} = 1;
1017	}
1018	return;
1019	}
1020	local (@ARGV, $/) = ($fn);
1021	no warnings 'all';
1022	eval <>;
1023	if ($@ and !$opt->{configure})
1024	{
1025	warn "\nERROR in $name file! Details:\n$@";
1026	&countdown();
1027	}
1028	}
1029
1030	sub write_config_file
1031	{
1032	write_file($config_file, 'configuration',
1033	[$region, $pref_title_source, $sysid, $mirror_site, $components, $components_pending_install, $pending_messages ],
1034	["region", "pref_title_source", "sysid", "mirror_site", "components", "components_pending_install", "pending_messages" ]);
1035	}
1036
1037	sub write_channels_file
1038	{
1039	write_file($channels_file, 'channels',
1040	[ $channels, $opt_channels ],
1041	[ 'channels', 'opt_channels' ]);
1042	}
1043
1044	sub write_file
1045	{
1046	my ($fn, $name, $vars, $varnames) = @_;
1047	open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
1048	print FN Data::Dumper->Dump($vars, $varnames);
1049	close FN;
1050	&log("Wrote $name file $fn.\n") if ($debug);
1051	}
1052
1053	sub get_command_line_options
1054	{
1055	# Record so we can pass the unmodified args to components later
1056	@options = @ARGV; # Record so we can pass the unmodified args to components later
1057	push (@options,"") if ($#options == -1); # silence warnings if none
1058
1059	# filter what options we don't pass on ..
1060	foreach (0..$#options) {
1061	next if (!$options[$_]);
1062
1063	splice(@options,$_,2) if ($options[$_] =~ /^--config-file/); # don't pass on "--config-file (file)"
1064	splice(@options,$_,1) if ($options[$_] =~ /^--quiet/); # never be quiet
1065	}
1066
1067	Getopt::Long::Configure(qw/pass_through/);
1068
1069	GetOptions($opt, qw( config-file=s
1070	help
1071	configure
1072	setmirror=s
1073	setpreftitle=s
1074	clearpreftitle
1075	capabilities
1076	description
1077	quiet
1078	version
1079	debug
1080	status
1081	show-config
1082	show-channels
1083	update
1084	noupdate
1085	disable=s
1086	enable=s
1087	nolog
1088	nonotify
1089	check
1090	update-version
1091	reset
1092	dontcallgrabbers
1093	days=i
1094	offset=i
1095	output=s
1096	randomize
1097	pending
1098	));
1099	$debug = $opt->{debug};
1100	$days = $opt->{days} if ($opt->{days});
1101	$opt->{update} = 1 if ($opt->{'update-version'});
1102	}
1103
1104
1105	# Here we can specify which command-line options should call
1106	# subroutines of the same name. The field following each sub
1107	# name is a string that can contain a key for what action should
1108	# be performed following the sub:
1109	# W : write config file
1110	# S : print --status output
1111	# Shepherd will exit if at least one of these routines was
1112	# called.
1113	sub process_setup_commands
1114	{
1115	my %routines = ( enable => 'WS',
1116	disable => 'WS',
1117	setorder => 'WS',
1118	check => 'WS',
1119	setpreftitle => 'W',
1120	clearpreftitle => 'W',
1121	setmirror => 'W',
1122	'reset' => 'W',
1123	status => '',
1124	'show-config' => '',
1125	'show-channels' => '',
1126	'pending' => ''
1127	);
1128
1129	my @run;
1130	foreach (keys %routines)
1131	{
1132	if ($opt->{$_})
1133	{
1134	push @run, $_;
1135	my $sub = $_;
1136	$sub =~ s/-/_/g;
1137	&$sub($opt->{$_});
1138	}
1139	}
1140	return unless (@run);
1141	foreach (@run)
1142	{
1143	&write_config_file if ($routines{$_} =~ /W/);
1144	&status if ($routines{$_} =~ /S/);
1145	}
1146	exit;
1147	}
1148
1149	# if a preferred title source has been specified, add it to our config
1150	sub setpreftitle
1151	{
1152	my $arg = shift;
1153	$pref_title_source = $arg;
1154	&log("Added preferred title source: $pref_title_source\n");
1155	1;
1156	}
1157
1158	# if requesting to clear preferred title and we have one, remove it
1159	sub clearpreftitle
1160	{
1161	$pref_title_source = undef;
1162	&log("Removed preferred title source $pref_title_source\n");
1163	1;
1164	}
1165
1166	# if a mirror has been specified, add it into our config
1167	sub setmirror
1168	{
1169	my $arg = shift;
1170	$mirror_site = $arg;
1171	&log("Setting mirror site(s): $mirror_site\n");
1172	}
1173
1174	sub reset
1175	{
1176	&log( "\nWARNING! The --reset argument will remove your established\n" .
1177	"title translation data. This may cause Shepherd to lose the\n" .
1178	"ability to keep show titles consistent with what you have seen\n" .
1179	"in the past!\n\n");
1180	&countdown(20);
1181	my @r = query_component_type('reconciler');
1182	foreach (@r) # Not that there should be more than one...
1183	{
1184	my $fn = query_ldir($_, 'reconciler') . '/' . $_ . '.config';
1185	&log("Removing $fn.\n");
1186	unlink($fn) or &log("Failed to remove file! $!\n");
1187	}
1188
1189	if ($pref_title_source)
1190	{
1191	my @prefs = split(/,/, $pref_title_source);
1192	foreach my $grabber (@prefs)
1193	{
1194	if ($components->{$grabber}->{lastdata})
1195	{
1196	&log( "Clearing lastdata for '$grabber' to trigger it to be called.\n");
1197	delete $components->{$grabber}->{lastdata};
1198	}
1199	}
1200	}
1201	}
1202
1203	# -----------------------------------------
1204	# Subs: Configuration
1205	# -----------------------------------------
1206
1207	sub configure
1208	{
1209	my $REGIONS = {
1210	"ACT" => 126,
1211	"NSW: Sydney" => 73,
1212	"NSW: Newcastle" => 184,
1213	"NSW: Central Coast" => 66,
1214	"NSW: Griffith" => 67,
1215	"NSW: Broken Hill" => 63,
1216	"NSW: Northern NSW" => 69,
1217	"NSW: Southern NSW" => 71,
1218	"NSW: Remote and Central" => 106,
1219	"NT: Darwin" => 74,
1220	"NT: Remote & Central" => 108,
1221	"QLD: Brisbane" => 75,
1222	"QLD: Gold Coast" => 78,
1223	"QLD: Regional" => 79,
1224	"QLD: Remote & Central" => 114,
1225	"SA: Adelaide" => 81,
1226	"SA: Renmark" => 82,
1227	"SA: Riverland" => 83,
1228	"SA: South East SA" => 85,
1229	"SA: Spencer Gulf" => 86,
1230	"SA: Remote & Central" => 107,
1231	"Tasmania" => 88,
1232	"VIC: Melbourne" => 94,
1233	"VIC: Geelong" => 93,
1234	"VIC: Eastern Victoria" => 90,
1235	"VIC: Mildura/Sunraysia" => 95,
1236	"VIC: Western Victoria" => 98,
1237	"WA: Perth" => 101,
1238	"WA: Regional" => 102
1239	};
1240
1241	print "\nConfiguring.\n\n" .
1242	"Select your region:\n";
1243	foreach (sort keys %$REGIONS)
1244	{
1245	printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
1246	}
1247	$region = ask_choice("Enter region code:", "94", values %$REGIONS);
1248
1249	print "\nFetching channel information... ";
1250
1251	my @channellist = get_channels();
1252
1253	print "done.\n\n" .
1254	"For each channel you want guide data for, enter an XMLTV id\n" .
1255	"of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
1256	"guide data for this channel, just press Enter.\n\n" .
1257	"Please don't subscribe to unneeded channels.\n\nChannels:\n";
1258	$channels = {};
1259	my $line;
1260	foreach (@channellist)
1261	{
1262	$line = ask(" \"$_\"? ");
1263	$channels->{$_} = $line if ($line);
1264	}
1265
1266	print "\nHigh Definition TV (HDTV)\n".
1267	"Most Australian TV networks broadcast at least some\n".
1268	"programmes in HDTV each week, but for the most part\n".
1269	"either upsample SD to HD or play a rolling demonstration\n".
1270	"HD clip when they don't have the programme in HD format.\n\n".
1271	"If you have a HDTV capable system and are interested in\n".
1272	"having Shepherd's postprocessors populate HDTV content\n".
1273	"then Shepherd will need to know the XMLTV IDs for the HD\n".
1274	"channels also.\n";
1275	if (ask_boolean("\nDo you wish to include HDTV channels?")) {
1276	print "\nFor each channel you want guide data for, enter an XMLTV id\n" .
1277	"of your choice (e.g. \"sevenhd.free.au\"). If you don't need\n" .
1278	"guide data for this channel, just press Enter.\n\n";
1279
1280	$opt_channels = {};
1281	foreach (@channellist)
1282	{
1283	next if (($_ =~ /ABC2/i) \|\| ($_ =~ /SBS News/i) \|\| ($_ =~ /31/));
1284	$_ .= "HD";
1285	$line = ask(" \"$_\"? ");
1286	$opt_channels->{$_} = $line if ($line);
1287	}
1288	}
1289
1290
1291	print "\nWould you like to transition seamlessly from your current grabber?\n\n".
1292	"Different data sources can have different names for the same show. For\n".
1293	"example, one grabber might call a show \"Spicks & Specks\" while another\n".
1294	"calls it \"Spicks and Specks\". These differences can make MythTV think\n".
1295	"they're actually different shows.\n\n".
1296	ucfirst($progname) . " is able to merge these differences so that it always\n".
1297	"presents shows with a consistent name, no matter where it actually sourced\n".
1298	"show data from. If you'd like, it can also rename shows so they're consistent\n".
1299	"with whichever grabber you've been using until now.\n\n".
1300	"The advantage of this is that you should get a smoother transition to\n".
1301	ucfirst($progname) . ", with no shows changing names and no need to re-create\n".
1302	"any recording rules. The main disadvantage is that if your previous grabber\n".
1303	"used an inferior data source -- i.e. it sometimes has typos or less\n".
1304	"informative program names -- then you'll continue to see these.\n\n".
1305	"If you were using one of the following grabbers previously AND you want\n".
1306	ucfirst($progname) . " to use that grabber's program names, select it here.\n\n";
1307
1308	my $def = "Do not transition; just use best quality titles";
1309	my %transition = ( "ltd (aka tv_grab_au, versions 1,30, 1.40 or 1.41)" => "yahoo7widget,abc2_website",
1310	"OzTivo" => 'oztivo',
1311	"Rex" => 'rex',
1312	"JRobbo" => 'jrobbo' );
1313	my $pref = ask_choice("Transition from grabber?", $def,
1314	$def, keys %transition);
1315	$pref_title_source = $transition{$pref};
1316
1317	print "\n";
1318	show_channels();
1319	unless(ask_boolean("\nCreate configuration file?"))
1320	{
1321	print "Aborting configuration.\n";
1322	exit 0;
1323	}
1324
1325	write_config_file();
1326	write_channels_file();
1327
1328	print "Checking if any components require configuration.\n\n";
1329	&check;
1330
1331	print "Finished configuring.\n\n";
1332
1333	status();
1334
1335	print "\nShepherd is installed into $CWD.\n\n" .
1336	"Run it as: $CWD/shepherd\n\n".
1337	"MythTV users may wish to create the following symlink, by " .
1338	"doing this (as root):\n" .
1339	" \"ln -s $CWD/$progname /usr/bin/tv_grab_au\".\n\n";
1340
1341	if ($invoked ne get_full_path(query_filename('shepherd','application')))
1342	{
1343	print "You may safely delete $invoked.\n\n";
1344	}
1345	elsif ((defined $ENV{shepherd_restart}) && ($ENV{shepherd_restart} ne $invoked))
1346	{
1347	print "You may safely delete $ENV{shepherd_restart}.\n\n";
1348	}
1349
1350	unless (ask_boolean("\nGrab data now?"))
1351	{
1352	exit 0;
1353	}
1354	}
1355
1356	sub get_channels
1357	{
1358	my @date = localtime;
1359	my $page = fetch_file(
1360	"http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1361	($date[5] + 1900) . "-$date[4]-$date[3]");
1362	my @channellist;
1363	while ($page =~ /<tr class=rtb><td class=rth><a .?>(.?)<\/a>/g)
1364	{
1365	push @channellist, $1;
1366	}
1367	return @channellist;
1368	}
1369
1370	# -----------------------------------------
1371	# Subs: Status & Help
1372	# -----------------------------------------
1373
1374	sub show_config
1375	{
1376	&log("\nConfiguration\n".
1377	"-------------\n" .
1378	"Config file: $config_file\n" .
1379	"Debug mode : " . is_set($debug) . "\n" .
1380	"Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1381	"Region ID : $region\n");
1382	show_channels();
1383	&log("\n");
1384	status();
1385	&log("\n");
1386	}
1387
1388	sub show_channels
1389	{
1390	&log("Subscribed channels:\n");
1391	&log(" $_ -> $channels->{$_}\n") for sort keys %$channels;
1392	&log("Optional (HDTV) channels:\n");
1393	&log(" $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
1394	}
1395
1396	sub is_set
1397	{
1398	my $arg = shift;
1399	return $arg ? "Yes" : "No";
1400	}
1401
1402	sub pretty_print
1403	{
1404	my ($p, $len) = @_;
1405	my $spaces = ' ' x (79-$len);
1406	my $ret = "";
1407
1408	while (length($p) > 0) {
1409	if (length($p) <= $len) {
1410	$ret .= $p;
1411	$p = "";
1412	} else {
1413	# find a space to the left of cutoff
1414	my $len2 = $len;
1415	while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
1416	$len2--;
1417	}
1418	if ($len2 == 0) {
1419	# no space - just print it with cutoff
1420	$ret .= substr($p,0,$len);
1421	$p = substr($p,$len,(length($p)-$len));
1422	} else {
1423	# print up to space
1424	$ret .= substr($p,0,$len2);
1425	$p = substr($p,($len2+1),(length($p)-$len2+1));
1426	}
1427	# print whitespace
1428	$ret .= "\n".$spaces;
1429	}
1430	}
1431	return $ret;
1432	}
1433
1434	sub status
1435	{
1436	&log("\nThe following plugins are known:\n",
1437	" Type Name Version Description\n".
1438	" -------- -------------- ------- ----------------------------------------------\n");
1439
1440	foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) {
1441	&log((sprintf " %-8s %-15s%7s %46s\n",
1442	substr($components->{$_}->{type},0,8),
1443	length($_) > 15 ? substr($_,0,13).".." : $_,
1444	($components->{$_}->{ver} ? substr($components->{$_}->{ver},0,7) : "unknown"),
1445	(defined $components->{$_}->{config}->{desc} ?
1446	pretty_print($components->{$_}->{config}->{desc},46) : "")));
1447	}
1448	&log("\n");
1449
1450	&log("Grabbers, listed in order of quality:\n".
1451	" Enabled/\n".
1452	" Grabber Qual Ready Last Run Status\n" .
1453	" -------------- ---- ----- ---------- -----------------------------------------\n");
1454	my %qual_table = ( 3 => "Best", 2 => "Good", 1 => "Avg" );
1455	foreach (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
1456	my $h = $components->{$_};
1457	&log((sprintf " %-15s%-4s %1s/%1s %11s %s\n",
1458	length($_) > 15 ? substr($_,0,13).".." : $_,
1459	$qual_table{($h->{config}->{quality})},
1460	$h->{disabled} ? 'N' : 'Y',
1461	$h->{ready} ? 'Y' : 'N',
1462	$h->{lastdata} ? POSIX::strftime("%a%d%b%y", localtime($h->{lastdata})) : 'never',
1463	$h->{laststatus} ? pretty_print($h->{laststatus},41) : ''));
1464	}
1465
1466	&log("\n".
1467	" Enabled/\n".
1468	" Reconciler Ready Last Run Status\n" .
1469	" -------------- ----- ---------- ----------------------------------------------\n");
1470	foreach (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
1471	my $h = $components->{$_};
1472	&log((sprintf " %-15s %1s/%1s %11s %s\n",
1473	length($_) > 15 ? substr($_,0,13).".." : $_,
1474	$h->{disabled} ? 'N' : 'Y',
1475	$h->{ready} ? 'Y' : 'N',
1476	$h->{lastdata} ? POSIX::strftime("%a%d%b%y", localtime($h->{lastdata})) : 'never',
1477	$h->{laststatus} ? pretty_print($h->{laststatus},46) : ''));
1478	}
1479
1480	&log("\n".
1481	" Enabled/\n".
1482	" Postprocessor Ready Last Run Status\n" .
1483	" -------------- ----- ---------- ----------------------------------------------\n");
1484	foreach (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
1485	my $h = $components->{$_};
1486	&log((sprintf " %-15s %1s/%1s %11s %s\n",
1487	length($_) > 15 ? substr($_,0,13).".." : $_,
1488	$h->{disabled} ? 'N' : 'Y',
1489	$h->{ready} ? 'Y' : 'N',
1490	$h->{lastdata} ? POSIX::strftime("%a%d%b%y", localtime($h->{lastdata})) : 'never',
1491	$h->{laststatus} ? pretty_print($h->{laststatus},46) : ''));
1492	}
1493	&log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
1494	&log("\n");
1495	}
1496
1497	sub capabilities
1498	{
1499	print "baseline\nmanualconfig\n";
1500	exit 0;
1501	}
1502
1503	sub description
1504	{
1505	print "Australia\n";
1506	exit 0;
1507	}
1508
1509	sub help
1510	{
1511	print q{Command-line options:
1512	--help Display this message
1513	--version Display version
1514	--status Display status of various components
1515
1516	--configure Setup
1517	--show-config Display setup details
1518	--show-channels Display subscribed channels
1519
1520	--disable <s> Don't ever use grabber/postprocessor <s>
1521	--enable <s> Okay, use it again then
1522	--uninstall <s> Remove a disabled grabber/postprocessor
1523
1524	--noupdate Don't update; just grab data
1525	--update Update only; don't grab data
1526
1527	--update-version Update major version
1528
1529	--check Check status of all components, configure if necessary
1530	--pending List pending installs, if any
1531
1532	--debug Print lots of debugging messages
1533	--quiet Don't print anything except errors
1534	--nolog Don't write a logfile
1535
1536	--setmirror <s> Set URL <s> as primary location to check for updates
1537	--setpreftitle <s> Set preferred 'title' source as grabber <s>
1538	--clearpreftitle Clear preferred 'title' source
1539	--reset Remove all previous title translation data
1540	};
1541	exit 0;
1542	}
1543
1544
1545	# -----------------------------------------
1546	# Subs: override handlers for standard perl.
1547	# -----------------------------------------
1548
1549	# ugly hack. please don't try this at home kids!
1550	sub my_die {
1551	my ($arg,@rest) = @_;
1552	my ($pack,$file,$line,$sub) = caller(0);
1553
1554	# check if we are in an eval()
1555	if ($^S) {
1556	printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
1557	} else {
1558	printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
1559	if ($arg) {
1560	CORE::die($arg,@rest);
1561	} else {
1562	CORE::die(join("",@rest));
1563	}
1564	}
1565	}
1566
1567
1568	# -----------------------------------------
1569	# Subs: Grabbing
1570	# -----------------------------------------
1571
1572	sub grab_data
1573	{
1574	my $used_grabbers = 0;
1575	&log("\nGrabber stage.\n");
1576
1577	&analyze_plugin_data("",1);
1578
1579	while (my $grabber = choose_grabber())
1580	{
1581	$grabber_found_all_data = 0;
1582	$used_grabbers++;
1583
1584	&log("\nSHEPHERD: Using grabber: ($used_grabbers) $grabber\n");
1585
1586	my $output = "$CWD/grabbers/$grabber/output.xmltv";
1587
1588	my $comm = "$CWD/grabbers/$grabber/$grabber " .
1589	"--region $region " .
1590	"--output $output";
1591
1592	# Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
1593	# that we need. Category 2 grabbers are requested to get everything, since there's
1594	# very little cost in grabbing that extra data, and we can use it in the reconciler
1595	# to verify that everything looks OK.
1596	if (query_config($grabber, 'category') == 1)
1597	{
1598	&log("$grabber is Category 1: grabbing timeslice.\n") if ($debug);
1599
1600	record_requested_chandays($grabber, $timeslice);
1601
1602	if ($timeslice->{start} != 0)
1603	{
1604	$comm .= " " .
1605	query_config($grabber, 'option_days_offset') .
1606	" " .
1607	$timeslice->{start};
1608	}
1609
1610	my $n = $timeslice->{stop} + 1;
1611	if ($timeslice->{start} != 0
1612	and
1613	!query_config($grabber, 'option_offset_eats_days'))
1614	{
1615	$n -= $timeslice->{start};
1616	}
1617	$comm .= " " .
1618	query_config($grabber, 'option_days') .
1619	" " .
1620	$n;
1621
1622	# Write a temporary channels file specifying only the channels we want
1623	my $tmpchans;
1624	foreach (@{$timeslice->{chans}})
1625	{
1626	$tmpchans->{$_} = $channels->{$_};
1627	}
1628	my $tmpcf = "$CWD/channels.conf.tmp";
1629	write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
1630	$comm .= " --channels_file $tmpcf";
1631	}
1632	else
1633	{
1634	&log("$grabber is category 2: grabbing everything.\n") if ($debug);
1635	$comm .= " --days $days" if ($days);
1636	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
1637	$comm .= " --channels_file $channels_file";
1638	}
1639
1640	if ((defined $plugin_data->{tor_pid}) &&
1641	(query_config($grabber, 'option_anon_socks'))) {
1642	$comm .= " ".query_config($grabber, 'option_anon_socks')." ".$plugin_data->{tor_address};
1643	}
1644
1645	$comm .= " --debug" if ($debug);
1646	$comm .= " @ARGV" if (@ARGV);
1647
1648	my $retval = 0;
1649	my $component_start = time;
1650	if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
1651	&log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
1652	&log("SHEPHERD: would have called: $comm\n") if ($debug);
1653	} else {
1654	&log("SHEPHERD: Excuting command: $comm\n");
1655	chdir "$CWD/grabbers/$grabber/";
1656	$retval = call_prog($grabber,$comm,0,(query_config($grabber,'max_runtime')*60));
1657	chdir $CWD;
1658	}
1659	my $component_duration = time - $component_start;
1660
1661	if ($retval != 0) {
1662	&log("grabber returned with non-zero return code $retval: assuming it failed.\n");
1663	$components->{$grabber}->{laststatus} = "failed with return code $retval";
1664	$components->{$grabber}->{consecutive_failures}++;
1665	&add_pending_message($grabber,"FAIL", $retval, $component_start, $component_duration,
1666	$components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
1667	next;
1668	}
1669
1670	# soak up the data we just collected
1671	&soak_up_data($grabber, $output, "grabber");
1672	$components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
1673
1674	if ($plugin_data->{$grabber}->{valid}) {
1675	$components->{$grabber}->{lastdata} = time;
1676	delete $components->{$grabber}->{consecutive_failures}
1677	if (defined $components->{$grabber}->{consecutive_failures});
1678	&add_pending_message($grabber,"SUCCESS", $retval, $component_start, $component_duration,
1679	$components->{$grabber}->{ver});
1680	} else {
1681	$components->{$grabber}->{laststatus} = "failed (invalid XMLTV)";
1682	$components->{$grabber}->{consecutive_failures}++;
1683	&add_pending_message($grabber,"FAIL", 0, $component_start, $component_duration,
1684	$components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
1685	}
1686
1687	# check to see if we have all the data we want
1688	$grabber_found_all_data = &analyze_plugin_data("analysis of all grabbers so far");
1689
1690	# Record what we grabbed from cacheable C1 grabbers
1691	if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
1692	{
1693	my $missing_before = convert_dayhash_to_list($missing);
1694	my $missing_after = convert_dayhash_to_list(detect_missing_data());
1695	my $list = List::Compare->new($missing_before, $missing_after);
1696	my @grabbed = $list->get_symmetric_difference();
1697	&log("Grabbed: " . join (', ', @grabbed) . ".\n") if ($debug);
1698	record_cached($grabber, @grabbed);
1699	write_config_file();
1700	}
1701
1702	last if ($grabber_found_all_data);
1703	}
1704
1705
1706	if ($used_grabbers == 0)
1707	{
1708	&log("No valid grabbers installed/enabled!\n");
1709	return;
1710	}
1711
1712	unless ($grabber_found_all_data)
1713	{
1714	&log("SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n");
1715	return;
1716	}
1717	}
1718
1719	# -----------------------------------------
1720	# Subs: Intelli-random grabber selection
1721	# -----------------------------------------
1722
1723	sub choose_grabber
1724	{
1725	if (defined $gscore) # Reset score hash
1726	{
1727	foreach (keys %$gscore)
1728	{
1729	$gscore->{$_} = 0;
1730	}
1731	}
1732	else # Create score hash
1733	{
1734	foreach (query_grabbers())
1735	{
1736	unless ($components->{$_}->{disabled})
1737	{
1738	$gscore->{$_} = 0;
1739	if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
1740	{
1741	$gscore->{$_ . ' [cache]'} = 0;
1742	}
1743	}
1744	}
1745	}
1746
1747	$missing = detect_missing_data();
1748	$timeslice = find_best_timeslice();
1749
1750	if ($debug)
1751	{
1752	&log((sprintf "Best timeslice: day%s of channels %s (%d chandays).\n",
1753	($timeslice->{start} == $timeslice->{stop} ?
1754	" $timeslice->{start}" :
1755	"s $timeslice->{start} - $timeslice->{stop}"),
1756	join(', ', @{$timeslice->{chans}}),
1757	$timeslice->{chandays}));
1758	}
1759
1760	my $total = score_grabbers();
1761
1762	if ($debug)
1763	{
1764	&log("Grabber selection:\n");
1765	foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
1766	{
1767	next if ($_ =~ /\[cache\]/);
1768
1769	my $score = $gscore->{$_};
1770	my $cscore = $gscore->{"$_ [cache]"};
1771	my $cstr = $cscore ? "(inc. $cscore cache pts)" : "";
1772
1773	if ($opt->{randomize})
1774	{
1775	&log((sprintf "%15s %6.1f%% %9s %s\n",
1776	$_,
1777	($total ? 100* $score / $total : 0),
1778	"$score pts",
1779	$cstr));
1780	}
1781	else
1782	{
1783	&log(sprintf("%15s %4s pts %s\n",
1784	$_,
1785	$score,
1786	$cstr));
1787	}
1788	}
1789	}
1790
1791	return undef unless ($total);
1792
1793	# Select a grabber
1794
1795	# If the user has specified a pref_title_source -- i.e. he is
1796	# transitioning from a known grabber -- then we make sure it
1797	# has run at least once, to build the list of title translations.
1798	if ($pref_title_source)
1799	{
1800	my @prefs = split(/,/, $pref_title_source);
1801	foreach my $grabber (@prefs)
1802	{
1803	unless ($components->{$grabber}->{lastdata})
1804	{
1805	&log("Need to build title translation list for transitional grabber $grabber.\n");
1806	return select_grabber($grabber, $gscore) if ($gscore->{$grabber});
1807	&log("WARNING: Can't run $grabber to build title translation list!\n");
1808	}
1809	}
1810	}
1811
1812	# Either do it randomly based on scores, or just return the
1813	# highest-scoring grabber, depending on whether --randomize has
1814	# been used.
1815
1816	my $r = int(rand($total));
1817	my $c = 0;
1818	my $best;
1819
1820	foreach my $grabber (keys %$gscore)
1821	{
1822	next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
1823	if ($opt->{randomize})
1824	{
1825	if ($r >= $c and $r < ($c + $gscore->{$grabber}))
1826	{
1827	return select_grabber($grabber, $gscore);
1828	}
1829	$c += $gscore->{$grabber};
1830	}
1831	else
1832	{
1833	if (!$best or $gscore->{$grabber} > $gscore->{$best})
1834	{
1835	$best = $grabber;
1836	}
1837	}
1838	}
1839
1840	if ($opt->{randomize} or !$best)
1841	{
1842	die "ERROR: failed to choose grabber.";
1843	}
1844	return select_grabber($best, $gscore);
1845	}
1846
1847	sub select_grabber
1848	{
1849	my ($grabber, $gscore) = @_;
1850
1851	&log("Selected $grabber.\n") if ($debug);
1852	if (query_config($grabber, 'category') == 2)
1853	{
1854	# We might want to run C1 grabbers multiple times
1855	# to grab various timeslices, but not C2 grabbers,
1856	# which should get everything at once.
1857	delete $gscore->{$grabber};
1858	}
1859	return $grabber;
1860	}
1861
1862	# Grabbers earn 1 point for each slot or chanday they can fill.
1863	# This score is multiplied if the grabber:
1864	# * is a category 2 grabber (i.e. fast/cheap)
1865	# * is a category 1 grabber that has the data we want in a cache
1866	# * can supply high-quality data
1867	# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
1868	sub score_grabbers
1869	{
1870	my ($score, $total, $day, $catbonus, $dqbonus, $mult, $key);
1871
1872	my $bestdq = 0;
1873
1874	# Compare C2 grabbers against the raw missing file, because we'll get
1875	# everything. But compare C1 grabbers against the timeslice, because we'll
1876	# only ask them for a slice. This goes for the [cache] and regular C1s.
1877	foreach my $grabber (keys %$gscore)
1878	{
1879	# for each slot, say whether we can fill it or not -- that is,
1880	# whether we support this channel and this day #.
1881
1882	my $hits = 0;
1883	my $cat = query_config($grabber, 'category');
1884	my $dq = query_config($grabber, 'quality');
1885
1886	if ($cat == 1)
1887	{
1888	$key = cut_down_missing($grabber);
1889	# &log("Grabber $grabber is Category 1: comparing capability to best timeslice.\n") if ($debug);
1890	}
1891	else
1892	{
1893	$key = $missing;
1894	# &log("Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n") if ($debug);
1895	}
1896
1897	if ($grabber =~ /\[cache\]/)
1898	{
1899	$hits = find_cache_hits($grabber, $key);
1900	}
1901	else
1902	{
1903	foreach my $day (sort keys %$key)
1904	{
1905	my $val = supports_day($grabber, $day);
1906	next unless ($val);
1907	# &log("Day $day:") if ($debug);
1908	foreach my $ch (@{$key->{$day}})
1909	{
1910	if (supports_channel($grabber, $ch, $day))
1911	{
1912	# &log(" $ch") if ($debug);
1913	$hits += $val;
1914	}
1915	}
1916	# &log("\n") if $debug;
1917	$hits = 1 if ($hits > 0 and $hits < 1);
1918	}
1919	}
1920
1921	my $catbonus = 1;
1922	$catbonus = 3 if ($cat == 2);
1923	if ($grabber =~ /\[cache\]/)
1924	{
1925	# Bonus is on a sliding scale between 1 and 2 depending on
1926	# % of required data in cache
1927	$catbonus += $hits / $timeslice->{chandays};
1928	}
1929
1930	my $dqbonus = 2 ** ($dq-1);
1931
1932	my $mult = $dq ** $catbonus;
1933
1934	my $score = int($hits * $mult);
1935
1936	if ($debug)
1937	{
1938	my $str = sprintf "Grabber %s can supply %d chandays",
1939	$grabber, $hits;
1940	if ($hits)
1941	{
1942	$str .= sprintf " at x%.1f (cat: %d, DQ: %d): %d pts",
1943	$mult,
1944	$cat,
1945	$dq,
1946	$score;
1947	}
1948	&log("$str.\n");
1949	}
1950
1951	if ($score and query_config($grabber, 'option_anon_socks') and !defined $plugin_data->{tor_pid})
1952	{
1953	&log("Grabber $grabber needs Tor to run efficiently: reducing score.\n") if ($debug);
1954	$score = int($score/10)+1;
1955	}
1956
1957	$gscore->{$grabber} += $score;
1958	$total += $score;
1959	if ($grabber =~ /\[cache\]/)
1960	{
1961	$gscore->{query_name($grabber)} += $score;
1962	}
1963
1964	if ($score and $dq > $bestdq)
1965	{
1966	$bestdq = $dq;
1967	}
1968	}
1969
1970	# Eliminate grabbers of data quality 1 if there are any better-quality
1971	# alternatives when using randomize.
1972	if ($opt->{randomize})
1973	{
1974	foreach (keys %$gscore)
1975	{
1976	if ($gscore->{$_}
1977	and
1978	query_config($_, 'quality') == 1
1979	and
1980	$bestdq > 1)
1981	{
1982	$total -= $gscore->{$_};
1983	$gscore->{$_} = 0;
1984	&log("Zeroing grabber $_ due to low data quality.\n") if ($debug);
1985	}
1986	}
1987	}
1988
1989	return $total;
1990	}
1991
1992	# Return 1 if the grabber can provide data for this channel, else 0.
1993	sub supports_channel
1994	{
1995	my ($grabber, $ch, $day) = @_;
1996
1997	my $mdpc = query_config($grabber, 'max_days_per_chan');
1998	if ($mdpc)
1999	{
2000	if ($mdpc->{$ch})
2001	{
2002	return ($mdpc->{$ch} > $day);
2003	}
2004	}
2005
2006	my $channels_supported = query_config($grabber, 'channels');
2007	unless (defined $channels_supported)
2008	{
2009	&log("WARNING: Grabber $grabber has no channel support " .
2010	"specified in config.\n");
2011	$channels_supported = '';
2012	}
2013
2014	return 1 unless ($channels_supported); # Empty string means we support all
2015
2016	$ch =~ s/ /_/g;
2017	my $match = ($channels_supported =~ /\b$ch\b/);
2018	my $exceptions = ($channels_supported =~/^-/);
2019	return ($match != $exceptions);
2020	}
2021
2022	# Return 0 if the grabber can't provide data for this day,
2023	# 1 if it can reliably, and 0.5 if it can unreliably.
2024	#
2025	# Note that a max_days of 7 means the grabber can retrieve data for
2026	# today plus 6 days.
2027	sub supports_day
2028	{
2029	my ($grabber, $day) = @_;
2030
2031	return 0 unless ($day < query_config($grabber, 'max_days'));
2032	return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
2033	return 1;
2034	}
2035
2036	sub find_cache_hits
2037	{
2038	my ($grabber, $key) = @_;
2039
2040	$grabber = query_name($grabber);
2041
2042	return 0 unless ($components->{$grabber}->{cached});
2043
2044	my $hits = 0;
2045
2046	foreach my $day (keys %$key)
2047	{
2048	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2049	foreach my $ch (@{$key->{$day}})
2050	{
2051	$hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
2052	}
2053	}
2054	return $hits;
2055	}
2056
2057	# Build a dayhash of what channel/day data we're currently missing.
2058	# I think granularity of one day is good for now; could possibly be
2059	# made more fine-grained if we think grabbers will support that.
2060	sub detect_missing_data
2061	{
2062	my $m = { };
2063
2064	my $chandays = 0;
2065	foreach my $ch (keys %$channels)
2066	{
2067	# is this channel missing too much data?
2068	unless ($channel_data->{$ch}->{analysis}->{data_ok}) {
2069	# not ok - record which days are bad
2070	foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) {
2071	push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
2072	}
2073	}
2074	}
2075
2076	foreach my $day (keys %$m)
2077	{
2078	$m->{$day} = [ sort @{$m->{$day}} ];
2079	$chandays += scalar(@{$m->{$day}}) if ($debug);
2080	}
2081
2082	if ($debug)
2083	{
2084	&log("Need data for days " . join(", ", sort keys %$m) .
2085	" ($chandays chandays).\n");
2086	}
2087	return $m;
2088	}
2089
2090	# Find the largest timeslice in the current $missing dayhash; i.e.
2091	# something like "Days 4 - 6 of ABC and SBS." This works by iterating
2092	# through the days and looking for overlaps where consecutive days
2093	# want the same channels.
2094	sub find_best_timeslice
2095	{
2096	my ($overlap, $a);
2097	my $slice = { 'chandays' => 0 };
2098
2099	foreach my $day (0 .. $days-1)
2100	{
2101	consider_slice($slice, $day, $day, @{$missing->{$day}});
2102	$overlap = $missing->{$day};
2103	foreach my $nextday (($day + 1) .. $days-1)
2104	{
2105	last unless ($missing->{$nextday});
2106	$a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
2107	last unless ($a and @{$a});
2108	consider_slice($slice, $day, $nextday, @{$a});
2109	$overlap = $a;
2110	}
2111	}
2112	return $slice;
2113	}
2114
2115	sub consider_slice
2116	{
2117	my ($slice, $startday, $stopday, @chans) = @_;
2118
2119	my $challenger = ($stopday - $startday + 1) * scalar(@chans);
2120	return unless ($challenger > $slice->{chandays});
2121
2122	# We have a winner!
2123	$slice->{start} = $startday;
2124	$slice->{stop} = $stopday;
2125	$slice->{chans} = [ @chans ];
2126	$slice->{chandays} = $challenger;
2127	}
2128
2129	# Record what a cacheable C1 grabber has just retrieved for us,
2130	# so we know next time that this data can be grabbed quickly.
2131	sub record_cached
2132	{
2133	my ($grabber, @grabbed) = @_;
2134
2135	&log("Recording cache for grabber $grabber.\n") if ($debug);
2136
2137	my $gcache = $components->{$grabber}->{cached};
2138	$gcache = [ ] unless ($gcache);
2139	my @newcache;
2140	my $today = strftime("%Y%m%d", localtime);
2141
2142	# remove old chandays
2143	foreach my $chanday (@$gcache)
2144	{
2145	$chanday =~ /(\d+):(.*)/;
2146	if ($1 >= $today)
2147	{
2148	push (@newcache, $chanday);
2149	}
2150	}
2151
2152	# record new chandays
2153	foreach my $chanday (@grabbed)
2154	{
2155	push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
2156	}
2157	$components->{$grabber}->{cached} = [ @newcache ];
2158	}
2159
2160	# Takes a dayhash and returns it as a list like this:
2161	# ( "20061018:ABC", "20061018:Seven", ... )
2162	sub convert_dayhash_to_list
2163	{
2164	my $h = shift;
2165
2166	my @ret;
2167	foreach my $day (keys %$h)
2168	{
2169	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2170	foreach my $ch (@{$h->{$day}})
2171	{
2172	push (@ret, "$date:$ch");
2173	}
2174	}
2175	@ret = sort @ret;
2176	return \@ret;
2177	}
2178
2179	# If we're about to re-try a grabber, make sure that we're not asking
2180	# it for the same data. That is, prevent a broken C1 grabber causing
2181	# an infinite loop.
2182	sub record_requested_chandays
2183	{
2184	my ($grabber, $slice) = @_;
2185
2186	&log("Recording timeslice request; will not request these chandays " .
2187	"from $grabber again.\n") if ($debug);
2188
2189	my @requested;
2190	for my $day ($slice->{start} .. $slice->{stop})
2191	{
2192	foreach my $ch (@{$slice->{chans}})
2193	{
2194	push @requested, "$day:$ch";
2195	}
2196	}
2197	if ($grabbed->{$grabber})
2198	{
2199	push @{$grabbed->{$grabber}}, @requested;
2200	}
2201	else
2202	{
2203	$grabbed->{$grabber} = [ @requested ];
2204	}
2205	}
2206
2207	# If this grabber has been called previously, remove those chandays
2208	# from the current request -- we don't want to ask it over and over
2209	# for a timeslice that it has already failed to provide.
2210	sub cut_down_missing
2211	{
2212	my $grabber = shift;
2213
2214	$grabber = query_name($grabber);
2215	my $dayhash = {};
2216
2217	# Take the timeslice and expand it to a dayhash, while pruning
2218	# any chandays that have previously been requested from this
2219	# grabber.
2220	foreach my $day ($timeslice->{start} .. $timeslice->{stop})
2221	{
2222	my @chans;
2223	foreach my $ch (@{$timeslice->{chans}})
2224	{
2225	unless ($grabbed->{$grabber} and grep(/$day:$ch/, @{$grabbed->{$grabber}}))
2226	{
2227	push (@chans, $ch)
2228	}
2229	}
2230	$dayhash->{$day} = [ @chans ] if (@chans);
2231	}
2232
2233	return $dayhash;
2234	}
2235
2236	# -----------------------------------------
2237	# Subs: Analyzing data
2238	# -----------------------------------------
2239
2240	# interpret xmltv data from this grabber/postprocessor
2241	sub soak_up_data
2242	{
2243	my ($plugin, $output, $plugintype) = @_;
2244
2245	if (! -r $output) {
2246	&log("SHEPHERD: Warning: plugin '$plugin' output file '$output' does not exist\n");
2247	return;
2248	}
2249
2250	my $this_plugin = $plugin_data->{$plugin};
2251	&log("SHEPHERD: Started parsing XMLTV from '$plugin' in '$output' .. any errors below are from parser:\n");
2252	eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
2253	&log("SHEPHERD: Completed XMLTV parsing from '$plugin'\n");
2254
2255	if (!($this_plugin->{xmltv})) {
2256	&log("WARNING: Plugin $plugin didn't seem to return any valid XMLTV!\n");
2257	return;
2258	}
2259
2260	$this_plugin->{valid} = 1;
2261	$this_plugin->{output_filename} = $output;
2262	$components_used .= " + ".$plugin."(v".$components->{$plugin}->{ver}.")";
2263
2264	my $xmltv = $this_plugin->{xmltv};
2265	my ($encoding, $credits, $chan, $progs) = @$xmltv;
2266	$this_plugin->{total_duration} = 0;
2267	$this_plugin->{programmes} = 0;
2268	$this_plugin->{progs_with_invalid_date} = 0; # explicitly track unparsable dates
2269	$this_plugin->{progs_too_long} = 0; # explicitly track exxcessive programme durations
2270	$this_plugin->{progs_with_unknown_channel} = 0; # explicitly track unknown channels
2271
2272	my $seen_channels_with_data = 0;
2273
2274	#
2275	# first iterate through all programmes and see if there are any channels we don't know about
2276	#
2277	my %chan_xml_list;
2278	foreach my $ch (sort keys %{$channels}) {
2279	$chan_xml_list{($channels->{$ch})} = 1;
2280	}
2281	foreach my $prog (@$progs) {
2282	if (!defined $chan_xml_list{($prog->{channel})}) {
2283	$this_plugin->{progs_with_unknown_channel}++;
2284	&log((sprintf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel}));
2285	$chan_xml_list{($prog->{channel})} = 1; # so we warn only once
2286	}
2287	}
2288
2289	# iterate thru channels
2290	foreach my $ch (sort keys %{$channels}) {
2291	my $seen_progs_on_this_channel = 0;
2292
2293	# iterate thru programmes per channel
2294	foreach my $prog (@$progs) {
2295	next if ($prog->{channel} ne $channels->{$ch});
2296
2297	my $t1 = &parse_xmltv_date($prog->{start});
2298	my $t2 = &parse_xmltv_date($prog->{stop});
2299
2300	if (!$t1 \|\| !$t2) {
2301	&log((sprintf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
2302	$plugin,(!$t1 ? $prog->{start} : $prog->{stop}))) if (!$this_plugin->{progs_with_invalid_date});
2303	$this_plugin->{progs_with_invalid_date}++;
2304	next;
2305	}
2306
2307	my $this_duration = $t2 - $t1;
2308	if ($this_duration > $policy{max_programme_length}) {
2309	&log((sprintf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
2310	$plugin, int($policy{max_programme_length} / 3600),
2311	int(($policy{max_programme_length} % 3600) / 60)))
2312	if (!$this_plugin->{progs_too_long});
2313	$this_plugin->{progs_too_long}++;
2314	next;
2315	}
2316
2317	# store plugin-specific stats
2318	$this_plugin->{programmes}++;
2319	$this_plugin->{total_duration} += $this_duration;
2320	$seen_progs_on_this_channel++;
2321	$this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
2322	$this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
2323	$this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
2324	$this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
2325
2326	# store channel-specific stats
2327	$channel_data->{$ch}->{programmes}++;
2328	$channel_data->{$ch}->{total_duration} += $this_duration;
2329
2330	# programme is outside the timeslots we are interested in.
2331	next if ($t1 > $policy{endtime});
2332	next if ($t2 < $policy{starttime});
2333
2334	# store timeslot info
2335	my $start_slotnum = 0;
2336	$start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
2337	if ($t1 >= $policy{starttime});
2338
2339	my $end_slotnum = ($policy{num_timeslots}-1);
2340	$end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
2341	if ($t2 < $policy{endtime});
2342
2343	&log((sprintf "DEBUG: ch '%s' prog start '%s' stop '%s' storing into timeslots %d-%d (%s-%s)\n",
2344	$ch, $prog->{start}, $prog->{stop}, $start_slotnum, $end_slotnum,
2345	POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($start_slotnum * $policy{timeslot_size}))),
2346	POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($end_slotnum * $policy{timeslot_size})))))
2347	if $policy{timeslot_debug};
2348
2349	# add this programme into the global timeslots table for this channel
2350	foreach my $slotnum ($start_slotnum..$end_slotnum) {
2351	$channel_data->{$ch}->{timeslots}[$slotnum]++;
2352	}
2353	}
2354
2355	$seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
2356	}
2357
2358	# print some stats about what we saw!
2359	&log((sprintf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
2360	ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
2361	int($this_plugin->{total_duration} / 86400), # days
2362	int(($this_plugin->{total_duration} % 86400) / 3600), # hours
2363	int(($this_plugin->{total_duration} % 3600) / 60), # mins
2364	int($this_plugin->{total_duration} % 60), # sec
2365	(defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
2366	(defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '')));
2367
2368	$this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
2369	$seen_channels_with_data, $this_plugin->{programmes},
2370	int($this_plugin->{total_duration} / 3600),
2371	(defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
2372	(defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
2373
2374	$plugin_data->{$plugin} = $this_plugin;
2375	}
2376
2377
2378	# analyze grabber data - do we have all the data we want?
2379	sub analyze_plugin_data
2380	{
2381	my ($analysistype,$quiet) = @_;
2382	&log("SHEPHERD: $analysistype:\n") unless $quiet;
2383
2384	my $total_channels = 0;
2385
2386	my $overall_data_ok = 1; # until proven otherwise
2387
2388	# iterate across each channel
2389	foreach my $ch (sort keys %{$channels}) {
2390	$total_channels++;
2391
2392	my $data;
2393	my $lastpol = "";
2394	$data->{data_ok} = 1; # unless proven otherwise
2395	$data->{have} = 0;
2396	$data->{missing} = 0;
2397
2398	for my $slotnum (0..($policy{num_timeslots}-1)) {
2399	my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
2400
2401	# work out day number of when this bucket is.
2402	# number from 0 onwards. (i.e. today=0).
2403	# for a typical 7 day grabber this will actually mean 8 days of data (0-7)
2404	# with days 0 and 7 truncated to half-days
2405	my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
2406
2407	if (!defined $data->{day}->[$day]) {
2408	$data->{day}->[$day]->{num} = $day;
2409	$data->{day}->[$day]->{have} = 0;
2410	$data->{day}->[$day]->{missing} = 0;
2411	$data->{day}->[$day]->{missing_peak} = 0;
2412	$data->{day}->[$day]->{missing_nonpeak} = 0;
2413	$data->{day}->[$day]->{missing_other} = 0;
2414
2415	$data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
2416
2417	# day changed, dump any 'already_missing' data
2418	&dump_already_missing($data);
2419	}
2420
2421	# we have programming data for this bucket. great! process next bucket
2422	if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
2423	($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) {
2424
2425	# if we have missing data queued up, push it now
2426	&dump_already_missing($data);
2427
2428	&dump_already_missing_period($data->{day}->[$day],$lastpol)
2429	if ($lastpol ne "");
2430
2431	$data->{day}->[$day]->{have} += $policy{timeslot_size};
2432	$data->{have} += $policy{timeslot_size};
2433	next;
2434	}
2435
2436	# we don't have programming for this channel for this bucket
2437	&log((sprintf "DEBUG: missing timeslot data for ch '%s' bucket %d (%s)\n",
2438	$ch, $slotnum, POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($slotnum * $policy{timeslot_size})))))
2439	if $policy{timeslot_debug};
2440
2441	# some grabbers take HOURS to run. if this bucket (missing data) is for
2442	# a time period now in the past, then don't include it
2443	next if (($bucket_start_offset + $policy{starttime}) < time);
2444
2445	# work out the localtime of when this bucket is
2446	my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
2447
2448	# store details of where we are missing data
2449	if (!defined $data->{already_missing}) {
2450	$data->{already_missing} = sprintf "#%d/%02d:%02d",
2451	$day,
2452	int($bucket_seconds_offset / 3600),
2453	int(($bucket_seconds_offset % 3600) / 60);
2454	}
2455	$data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
2456
2457	$data->{day}->[$day]->{missing} += $policy{timeslot_size};
2458	$data->{missing} += $policy{timeslot_size};
2459
2460	# work out what policy missing data for this bucket fits into
2461	my $pol;
2462	if (($bucket_seconds_offset >= $policy{peak_start}) &&
2463	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
2464	$pol = "peak";
2465	} elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
2466	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
2467	$pol = "nonpeak";
2468	} else {
2469	$pol = "other";
2470	}
2471
2472	&dump_already_missing_period($data->{day}->[$day],$lastpol)
2473	if (($lastpol ne $pol) && ($lastpol ne ""));
2474
2475	$lastpol = $pol;
2476
2477	$data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
2478
2479	$data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
2480	if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
2481	$data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
2482
2483	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
2484	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
2485	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
2486	$data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
2487	$overall_data_ok = 0 if ($data->{data_ok} == 0);
2488	}
2489
2490	# finished all timeslots in this channel.
2491	# if we have missing data queued up, push it now
2492	&dump_already_missing($data);
2493
2494	# fill in any last missing period data
2495	foreach my $day (@{($data->{day})}) {
2496	&dump_already_missing_period($day,"peak");
2497	&dump_already_missing_period($day,"nonpeak");
2498	&dump_already_missing_period($day,"other");
2499	}
2500
2501	my $statusstring = sprintf " > ch %s: %s programming: %s\n",
2502	$ch, pretty_duration($data->{have}),
2503	$data->{data_ok} ? "PASS (within thresholds)" : "FAIL, missing data over policy threshold:";
2504
2505	# display per-day missing data statistics
2506	foreach my $day (@{($data->{day})}) {
2507	unless ($day->{day_ok}) {
2508	$statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": ";
2509
2510	# do we have any data for this day?
2511	$statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
2512	if (($day->{missing_peak}) && ($day->{missing_peak} > $policy{peak_max_missing}));
2513
2514	$statusstring .= sprintf "%snon-peak %s",
2515	($day->{missing_peak} ? " / " : ""),
2516	join(", ",(@{($day->{missing_nonpeak_table})}))
2517	if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak} > $policy{nonpeak_max_missing}));
2518
2519	$statusstring .= sprintf "%sother %s",
2520	(($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
2521	join(", ",(@{($day->{missing_other_table})}))
2522	if (($day->{missing_other}) && ($day->{missing_other} > $policy{other_max_missing}));
2523
2524	$statusstring .= "\n";
2525	}
2526	}
2527	&log($statusstring) unless $quiet;
2528
2529	delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
2530	$channel_data->{$ch}->{analysis} = $data;
2531	}
2532
2533	&log((sprintf " > OVERALL: %s\n", ($overall_data_ok ? "PASS" : "FAIL"))) unless $quiet;
2534
2535	return $overall_data_ok; # return 1 for good, 0 for need more
2536	}
2537
2538	# helper routine for filling in 'missing_all' array
2539	sub dump_already_missing
2540	{
2541	my $d = shift;
2542	if (defined $d->{already_missing}) {
2543	$d->{already_missing} .= sprintf "-%02d:%02d",
2544	int($d->{already_missing_last} / 3600),
2545	int(($d->{already_missing_last} % 3600) / 60)
2546	if (defined $d->{already_missing_last});
2547	push(@{($d->{missing_all})}, $d->{already_missing});
2548	delete $d->{already_missing};
2549	delete $d->{already_missing_last};
2550	}
2551	}
2552
2553	# helper routine for filling in per-day missing data
2554	# specific to peak/nonpeak/other
2555	sub dump_already_missing_period
2556	{
2557	my ($d,$p) = @_;
2558	my $startvar = "already_missing_".$p."_start";
2559	my $stopvar = "already_missing_".$p."_stop";
2560
2561	if (defined $d->{$startvar}) {
2562	push(@{($d->{"missing_".$p."_table"})},
2563	sprintf "%02d:%02d-%02d:%02d",
2564	int($d->{$startvar} / 3600),
2565	int(($d->{$startvar} % 3600) / 60),
2566	int($d->{$stopvar} / 3600),
2567	int(($d->{$stopvar} % 3600) / 60));
2568	delete $d->{$startvar};
2569	delete $d->{$stopvar};
2570	}
2571	}
2572
2573	# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
2574	# and indication of whether the duration is over its threshold or not
2575	sub pretty_duration
2576	{
2577	my ($d,$crit) = @_;
2578	my $s = "";
2579	$s .= sprintf "%dd",int($d / (606024)) if ($d >= (606024));
2580	$s .= sprintf "%dh",int(($d % (606024)) / (6060)) if (($d % (606024)) >= (6060));
2581	$s .= sprintf "%dm",int(($d % (6060)) / 60) if (($d % (6060)) >= 60);
2582	$s .= "no" if ($s eq "");
2583
2584	if (defined $crit) {
2585	$s .= "[!]" if ($d > $crit);
2586	}
2587	return $s;
2588	}
2589
2590	# work out date range we are expecting data to be in
2591	sub calc_date_range
2592	{
2593	# work out GMT offset - we only do this once
2594	if (!$gmt_offset) {
2595	# work out our gmt offset
2596	my $tzstring = strftime("%z", localtime(time));
2597
2598	$gmt_offset = (6060) int(substr($tzstring,1,2)); # hr
2599	$gmt_offset += (60 * int(substr($tzstring,3,2))); # min
2600	$gmt_offset *= -1 if (substr($tzstring,0,1) eq "-"); # +/-
2601	}
2602
2603	$policy{starttime} = time;
2604
2605	# set endtime as per $days less 1 day + hours left today
2606	$policy{endtime} = $policy{starttime} + ((606024)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
2607
2608	# normalize starttime to beginning of next bucket
2609	$policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
2610
2611	# work out how many seconds into a day our first bucket starts
2612	$policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
2613
2614	# normalize endtime to end of previous bucket
2615	$policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
2616
2617	# if we are working with an --offset, apply it now.
2618	$policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
2619
2620	# work out number of buckets
2621	$policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
2622
2623	&log((sprintf "DEBUG: policy settings: starttime=%d, endtime=%d, first_bucket_offset=%d, gmt_offset=%d, strftime_tz=%s\n",
2624	$policy{starttime}, $policy{endtime}, $policy{first_bucket_offset}, $gmt_offset,
2625	(strftime("%z", localtime(time)))))
2626	if ($policy{timeslot_debug});
2627	}
2628
2629
2630	# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
2631	# rather than the various other perl implementation which treat it as being in UTC/GMT
2632	sub parse_xmltv_date
2633	{
2634	my $datestring = shift;
2635	my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
2636	my $tz_offset = 0;
2637
2638	if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
2639	($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);
2640	($t[6],$t[7],$t[8]) = (-1,-1,-1);
2641
2642	# if input data has a timezone offset, then offset by that
2643	if ($datestring =~ /\+(\d{2})(\d{2})/) {
2644	$tz_offset = $gmt_offset - (($1(6060)) + ($2*60));
2645	} elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
2646	$tz_offset = $gmt_offset + (($1(6060)) + ($2*60));
2647	}
2648
2649	my $e = mktime(@t);
2650	return ($e+$tz_offset) if ($e > 1);
2651	}
2652	return undef;
2653	}
2654
2655	# -----------------------------------------
2656	# Subs: Reconciling data
2657	# -----------------------------------------
2658
2659	# for all the data we have, try to pick the best bits!
2660	sub reconcile_data
2661	{
2662	&log("\nReconciling data:\n\n");
2663
2664	my $num_grabbers = 0;
2665	my $input_files = "";
2666	my @input_file_list;
2667
2668	# when reconciling & postprocessing, increase the thresholds of how much
2669	# missing data we permit.
2670	# generally, if a postprocessor or reconciler breaks, it'll return
2671	# no data rather than 'most' data.
2672	$policy{peak_max_missing} *= 3;
2673	$policy{nonpeak_max_missing} *= 1.5;
2674	$policy{other_max_missing} *= 3;
2675
2676	&log("Preferred title preferences from '$pref_title_source'\n")
2677	if ((defined $pref_title_source) &&
2678	($plugin_data->{$pref_title_source}) &&
2679	($plugin_data->{$pref_title_source}->{valid}));
2680
2681	&log("Preference for whose data we prefer as follows:\n");
2682	foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
2683	if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
2684	$num_grabbers++;
2685	&log((sprintf " %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename}));
2686
2687	$input_files .= $plugin_data->{$proggy}->{output_filename}." ";
2688	push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
2689	}
2690	}
2691
2692	if ($num_grabbers == 0) {
2693	die "Nothing to reconcile! There is no valid grabber data!\n";
2694	}
2695
2696	foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
2697	next if ($components->{$reconciler}->{disabled});
2698	next if (!$components->{$reconciler}->{ready});
2699
2700	$reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
2701
2702	if ((!$reconciler_found_all_data) && ($grabber_found_all_data)) {
2703	# urgh. this reconciler did a bad bad thing ...
2704	&log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
2705	} else {
2706	&log("SHEPHERD: Data from reconciler $reconciler looks good\n");
2707	$input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
2708	}
2709
2710	last if ($input_postprocess_file ne "");
2711	}
2712
2713	if ($input_postprocess_file eq "") {
2714	# no reconcilers worked!!
2715	&log("SHEPHERD: WARNING: No reconcilers seemed to work! Falling back to concatenating the data together!\n");
2716
2717	my %w_args = ();
2718	$input_postprocess_file = "$CWD/input_preprocess.xmltv";
2719	my $fh = new IO::File ">$input_postprocess_file" \|\| die "could not open $input_postprocess_file for writing: $!\n";
2720	%w_args = (OUTPUT => $fh);
2721	XMLTV::catfiles(\%w_args, @input_file_list);
2722	}
2723	}
2724
2725
2726	# -----------------------------------------
2727	# Subs: Postprocessing
2728	# -----------------------------------------
2729
2730	sub postprocess_data
2731	{
2732	# for our first postprocessor, we feed it ALL of the XMLTV files we have
2733	# as each postprocessor runs, we feed in the output from the previous one
2734	# Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
2735	# reverts back to the previous postprocessor if it was shown to be bad
2736
2737	# first time around: feed in reconciled data ($input_postprocess_file)
2738
2739	&log("\nPostprocessing stage:\n");
2740
2741	foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
2742	next if ($components->{$postprocessor}->{disabled});
2743	next if (!$components->{$postprocessor}->{ready});
2744
2745	my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
2746
2747	if ($found_all_data) {
2748	# accept what this postprocessor did to our output ...
2749	&log("SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n");
2750	$input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
2751	delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
2752	next;
2753	}
2754
2755	# urgh. this postprocessor did a bad bad thing ...
2756	&log("SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n");
2757
2758	if (defined $components->{$postprocessor}->{conescutive_failures}) {
2759	$components->{$postprocessor}->{conescutive_failures}++;
2760	} else {
2761	$components->{$postprocessor}->{conescutive_failures} = 1;
2762	}
2763	}
2764	}
2765
2766
2767	# -----------------------------------------
2768	# Subs: Postprocessing/Reconciler helpers
2769	# -----------------------------------------
2770
2771	sub call_data_processor
2772	{
2773	my ($data_processor_type, $data_processor_name, $input_files) = @_;
2774
2775	&log("\nSHEPHERD: Using $data_processor_type: $data_processor_name\n");
2776
2777	my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
2778	my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
2779	$comm .= " --region $region" .
2780	" --channels_file $channels_file" .
2781	" --output $output";
2782	$comm .= " --days $days" if ($days);
2783	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
2784	$comm .= " --debug" if ($debug);
2785	$comm .= " @ARGV" if (@ARGV);
2786
2787	$comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
2788	if (($data_processor_type eq "reconciler") &&
2789	(defined $pref_title_source) &&
2790	($plugin_data->{$pref_title_source}) &&
2791	($plugin_data->{$pref_title_source}->{valid}));
2792
2793	$comm .= " $input_files";
2794	&log("SHEPHERD: Excuting command: $comm\n");
2795
2796	my $component_start = time;
2797	my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
2798	chdir $dir;
2799	my $retval = call_prog($data_processor_name,$comm,0,(query_config($data_processor_name,'max_runtime')*60));
2800	chdir $CWD;
2801	my $component_duration = time - $component_start;
2802
2803	if ($retval != 0) {
2804	&log("$data_processor_type returned with non-zero return code $retval: assuming it failed.\n");
2805	$components->{$data_processor_name}->{laststatus} = "failed with return code $retval";
2806	$components->{$data_processor_name}->{consecutive_failures}++;
2807	&add_pending_message($data_processor_name,"FAIL", $retval, $component_start, $component_duration,
2808	$components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
2809	return 0;
2810	}
2811
2812	#
2813	# soak up the data we just collected and check it
2814	# YES - these are the SAME routines we used in the previous 'grabber' phase
2815	# but the difference here is that we clear out our 'channel_data' beforehand
2816	# so we can independently analyze the impact of this postprocessor.
2817	# if it clearly returns bad data, don't use that data (go back one step) and
2818	# flag the postprocessor as having failed. after 3 consecutive failures, disable it
2819	#
2820
2821	# clear out channel_data
2822	foreach my $ch (keys %{$channels}) {
2823	delete $channel_data->{$ch};
2824	}
2825
2826	# process and analyze it!
2827	&soak_up_data($data_processor_name, $output, $data_processor_type);
2828	my $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name");
2829
2830	if ($have_all_data) {
2831	$components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
2832	$components->{$data_processor_name}->{lastdata} = time;
2833	delete $components->{$data_processor_name}->{consecutive_failures}
2834	if (defined $components->{$data_processor_name}->{consecutive_failures});
2835	&add_pending_message($data_processor_name,"SUCCESS", $retval, $component_start, $component_duration,
2836	$components->{$data_processor_name}->{ver});
2837	} else {
2838	$components->{$data_processor_name}->{laststatus} = "missing data: ".$plugin_data->{$data_processor_name}->{laststatus};
2839	$components->{$data_processor_name}->{consecutive_failures}++;
2840	&add_pending_message($data_processor_name,"FAIL", $retval, $component_start, $component_duration,
2841	$components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
2842	}
2843
2844	return $have_all_data;
2845	}
2846
2847
2848	sub output_data
2849	{
2850	# $input_postprocess_file contains our final output
2851	# send it to whereever --output told us to!
2852
2853	my $output_filename = "$CWD/output.xmltv";
2854	$output_filename = $opt->{output} if ($opt->{output});
2855
2856	my %writer_args = ( encoding => 'ISO-8859-1' );
2857	my $fh = new IO::File(">$output_filename") \|\|
2858	die "can't open $output_filename for writing: $!";
2859	$writer_args{OUTPUT} = $fh;
2860
2861	$writer = new XMLTV::Writer(%writer_args);
2862	$writer->start( {
2863	'source-info-name' => "$progname v".$components->{$progname}->{ver},
2864	'generator-info-name' => $components_used } );
2865
2866	XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb,
2867	\&output_data_programme_cb, $input_postprocess_file);
2868	$writer->end();
2869
2870	&add_pending_message("shepherd", "STATUS", $sysid, $starttime, (time-$starttime), $gmt_offset, $components_used);
2871	&log("Final output stored in $output_filename.\n");
2872	}
2873
2874	sub output_data_channel_cb
2875	{
2876	my $c = shift;
2877	$writer->write_channel($c);
2878	}
2879
2880	sub output_data_programme_cb
2881	{
2882	my $prog=shift;
2883	$writer->write_programme($prog);
2884	}
2885
2886	# -----------------------------------------
2887	# Subs: Tor support
2888	# -----------------------------------------
2889
2890	sub start_tor
2891	{
2892	# do we have any components requesting the use of tor?
2893	my $want_tor = 0;
2894	foreach (query_grabbers()) {
2895	unless ($components->{$_}->{disabled}) {
2896	$want_tor++ if (query_config($_, 'option_anon_socks'));
2897	}
2898	}
2899
2900	return if ($want_tor == 0);
2901
2902	# try to find tor
2903	my $searchpath = ".:".$ENV{PATH};
2904	my $found_tor;
2905	foreach my $dir (split(/:/,$searchpath)) {
2906	if (-x "$dir/tor") {
2907	$found_tor = "$dir/tor";
2908	last;
2909	}
2910	}
2911
2912	if (!defined $found_tor) {
2913	&log("\nWARNING: $want_tor components wanted to use Tor but could not find it.\n");
2914	&log("This may cause data collection to run slower than it otherwise would.\n");
2915	return;
2916	}
2917
2918	&log("\nStarting Tor ($found_tor) in the background (wanted by $want_tor components).\n");
2919	my $pid = fork;
2920	if (!defined $pid) {
2921	# failed
2922	&log("Failed to start $found_tor: $!\n");
2923	return;
2924	} elsif ($pid > 0) {
2925	# parent
2926	sleep 2; # wait a few seconds for Tor to start
2927
2928	# test that it is running
2929	if (!kill 0, $pid) {
2930	&log("Tor doesn't seem to be running on pid $pid anymore, ignoring Tor option.\n");
2931	} else {
2932	&log("Tor appears to have successfully started (pid $pid).\n");
2933	$plugin_data->{tor_address} = "127.0.0.1:9050";
2934	$plugin_data->{tor_pid} = $pid;
2935	}
2936	} else {
2937	# child
2938	exec $found_tor "MaxCircuitDirtiness 30 SocksListenAddress 127.0.0.1:9050";
2939	exit(1); # we won't reach this
2940	}
2941	}
2942
2943
2944	sub stop_tor
2945	{
2946	if (defined $plugin_data->{tor_pid}) {
2947	# INTR sig stops tor
2948	kill 2,$plugin_data->{tor_pid};
2949	}
2950	}

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 324

Download in other formats: