Context Navigation

shepherd @ 323

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 323

Download in other formats: