Context Navigation

shepherd @ 568

Revision 568, 111.4 kB (checked in by max, 6 years ago)

Remove old output files from components before invoking.

Important in case a naughty component fails with 0 exit status;
we don't want to read their old data as new.

Property svn:executable set to *

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 568

Download in other formats: