Context Navigation

shepherd @ 495

Revision 495, 105.4 kB (checked in by max, 6 years ago)
Report multiple usage of same grabber correctly; report missing data per component correctly; report minutes of data grabbed
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 495

Download in other formats: