Context Navigation

shepherd @ 373

Revision 373, 87.8 kB (checked in by max, 6 years ago)
Don't try to upgrade manually disabled components
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 373

Download in other formats: