Context Navigation

shepherd @ 454

Revision 454, 99.9 kB (checked in by max, 6 years ago)
Per-region grabber support
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 454

Download in other formats: