Context Navigation

shepherd @ 369

Revision 369, 87.6 kB (checked in by max, 7 years ago)
No point logging setup commands
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 369

Download in other formats: