Context Navigation

shepherd @ 392

Revision 392, 88.0 kB (checked in by lincoln, 6 years ago)
fix some cosmetics - not worth a version bump
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 392

Download in other formats: