Context Navigation

shepherd @ 440

Revision 440, 99.4 kB (checked in by lincoln, 6 years ago)
better --list-chan-names - actually works now
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	my $progname = 'shepherd';
4	my $version = '0.4.34';
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	push @channellist, $cn;
1529	}
1530	else
1531	{
1532	foreach $rq (@{$clist->{$cn}})
1533	{
1534	push @channellist, "$cn $rq";
1535	}
1536	}
1537	}
1538	return @channellist;
1539	}
1540
1541	# -----------------------------------------
1542	# Subs: Status & Help
1543	# -----------------------------------------
1544
1545	sub show_config
1546	{
1547	&log("\nConfiguration\n".
1548	"-------------\n" .
1549	"Config file: $config_file\n" .
1550	"Debug mode : " . is_set($debug) . "\n" .
1551	"Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1552	"Region ID : $region\n");
1553	show_channels();
1554	&log("\n");
1555	status();
1556	&log("\n");
1557	}
1558
1559	sub show_channels
1560	{
1561	&log("Subscribed channels:\n");
1562	&log(" $_ -> $channels->{$_}\n") for sort keys %$channels;
1563	&log("Optional (HDTV) channels:\n");
1564	&log(" $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
1565	}
1566
1567	sub is_set
1568	{
1569	my $arg = shift;
1570	return $arg ? "Yes" : "No";
1571	}
1572
1573	sub pretty_print
1574	{
1575	my ($p, $len) = @_;
1576	my $spaces = ' ' x (79-$len);
1577	my $ret = "";
1578
1579	while (length($p) > 0) {
1580	if (length($p) <= $len) {
1581	$ret .= $p;
1582	$p = "";
1583	} else {
1584	# find a space to the left of cutoff
1585	my $len2 = $len;
1586	while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
1587	$len2--;
1588	}
1589	if ($len2 == 0) {
1590	# no space - just print it with cutoff
1591	$ret .= substr($p,0,$len);
1592	$p = substr($p,$len,(length($p)-$len));
1593	} else {
1594	# print up to space
1595	$ret .= substr($p,0,$len2);
1596	$p = substr($p,($len2+1),(length($p)-$len2+1));
1597	}
1598	# print whitespace
1599	$ret .= "\n".$spaces;
1600	}
1601	}
1602	return $ret;
1603	}
1604
1605	sub pretty_date
1606	{
1607	my $t = shift;
1608
1609	return "- " unless $t;
1610
1611	my @lt = localtime($t);
1612	my @ltnow = localtime();
1613	if (time - $t > 15768000) # 6 months or older
1614	{
1615	return POSIX::strftime("%d-%b-%y", @lt); # eg 18-Mar-05
1616	}
1617	if (time - $t < 43200 # less than 12 hours ago
1618	or
1619	($lt[4] == $ltnow[4] and $lt[3] == $ltnow[3])) # today
1620	{
1621	return POSIX::strftime("%l:%M%P ", @lt); # eg 10:45pm
1622	}
1623	return POSIX::strftime("%a %d-%b", @lt); # eg Mon 25-Dec
1624	}
1625
1626	sub desc
1627	{
1628	my $lasttype = '';
1629	my %qual_table = ( 3 => "Excellent", 2 => "Good", 1 => "Poor" );
1630
1631	foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components})
1632	{
1633	if ($lasttype ne $components->{$_}->{type})
1634	{
1635	$lasttype = $components->{$_}->{type};
1636	&log("\n* " . uc($lasttype) . "S *\n");
1637	}
1638	&log("\n$_ v$components->{$_}->{ver}" .
1639	"\n* " . pretty_print(query_config($_, 'desc'), 77) . "\n");
1640	if ($lasttype eq 'grabber')
1641	{
1642	&log("* Data Quality: " . $qual_table{query_config($_, 'quality')} . "\n");
1643	&log("* Speed: " . (query_config($_, 'category') == 1 ? "Slow" : "Fast") . "\n");
1644	my $ch = query_config($_, 'channels');
1645	$ch = "All" if ($ch eq '');
1646	$ch = "All except $1" if ($ch =~ /^\-(.*)/);
1647	&log("* Channels: $ch\n");
1648	my $d1 = query_config($_, 'max_days');
1649	my $d2 = query_config($_, 'max_reliable_days');
1650	&log("* Days: " . ($d1 == $d2 ? $d1 : "$d2 to $d1") . "\n");
1651	}
1652	}
1653	}
1654
1655	sub status
1656	{
1657	foreach my $ctype ('grabber', 'reconciler', 'postprocessor')
1658	{
1659	&log("\n " .
1660	($ctype eq 'grabber' ?
1661	" Enabled/\n".
1662	sprintf(" %-17s Version Ready Last Run Status", ucfirst($ctype))
1663	: ucfirst($ctype)) .
1664	"\n -------------- ---------- ----- ---------- -----------------------------------\n");
1665	foreach (sort (query_component_type($ctype)))
1666	{
1667	my $h = $components->{$_};
1668	&log(sprintf " %-15s%10s %1s/%1s %11s %s\n",
1669	length($_) > 15 ? substr($_,0,13).".." : $_,
1670	$h->{ver},
1671	$h->{disabled} ? 'N' : 'Y',
1672	$h->{ready} ? 'Y' : 'N',
1673	pretty_date($h->{lastdata}),
1674	$h->{laststatus} ? pretty_print($h->{laststatus},35) : '');
1675	}
1676	}
1677	&log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
1678	}
1679
1680	sub capabilities
1681	{
1682	print "baseline\nmanualconfig\n";
1683	exit 0;
1684	}
1685
1686	sub description
1687	{
1688	print "Australia\n";
1689	exit 0;
1690	}
1691
1692	sub help
1693	{
1694	print q{Command-line options:
1695	--help Display this message
1696	--version Display version
1697	--status Display status of various components
1698	--desc Display detailed status of components
1699
1700	--configure Setup
1701	--show-config Display setup details
1702	--show-channels Display subscribed channels
1703
1704	--disable <s> Don't ever use grabber/postprocessor <s>
1705	--enable <s> Okay, use it again then
1706	--uninstall <s> Remove a disabled grabber/postprocessor
1707
1708	--noupdate Don't update; just grab data
1709	--update Update only; don't grab data
1710
1711	--update-version Update major version
1712
1713	--check Check status of all components, configure if necessary
1714	--pending List pending installs, if any
1715
1716	--nonotify Block reporting of anonymous usage statistics
1717
1718	--debug Print lots of debugging messages
1719	--quiet Don't print anything except errors
1720	--nolog Don't write a logfile
1721
1722	--setmirror <s> Set URL <s> as primary location to check for updates
1723	--setpreftitle <s> Set preferred 'title' source as grabber <s>
1724	--clearpreftitle Clear preferred 'title' source
1725	--reset Remove all previous title translation data
1726	};
1727	exit 0;
1728	}
1729
1730
1731	# -----------------------------------------
1732	# Subs: override handlers for standard perl.
1733	# -----------------------------------------
1734
1735	# ugly hack. please don't try this at home kids!
1736	sub my_die {
1737	my ($arg,@rest) = @_;
1738	my ($pack,$file,$line,$sub) = caller(0);
1739
1740	# check if we are in an eval()
1741	if ($^S) {
1742	printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
1743	} else {
1744	printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
1745	if ($arg) {
1746	CORE::die($arg,@rest);
1747	} else {
1748	CORE::die(join("",@rest));
1749	}
1750	}
1751	}
1752
1753
1754	# -----------------------------------------
1755	# Subs: Grabbing
1756	# -----------------------------------------
1757
1758	sub grab_data
1759	{
1760	my $used_grabbers = 0;
1761	&log("\nGrabber stage.\n");
1762
1763	&analyze_plugin_data("",1,$progname);
1764
1765	while (my $grabber = choose_grabber())
1766	{
1767	$grabber_found_all_data = 0;
1768	$used_grabbers++;
1769
1770	&log("\nSHEPHERD: Using grabber: ($used_grabbers) $grabber\n");
1771
1772	my $output = "$CWD/grabbers/$grabber/output.xmltv";
1773
1774	my $comm = "$CWD/grabbers/$grabber/$grabber " .
1775	"--region $region " .
1776	"--output $output";
1777
1778	# Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
1779	# that we need. Category 2 grabbers are requested to get everything, since there's
1780	# very little cost in grabbing that extra data, and we can use it in the reconciler
1781	# to verify that everything looks OK.
1782	if (query_config($grabber, 'category') == 1)
1783	{
1784	&log("$grabber is Category 1: grabbing timeslice.\n") if ($debug);
1785
1786	record_requested_chandays($grabber, $timeslice);
1787
1788	if ($timeslice->{start} != 0)
1789	{
1790	$comm .= " " .
1791	query_config($grabber, 'option_days_offset') .
1792	" " .
1793	$timeslice->{start};
1794	}
1795
1796	my $n = $timeslice->{stop} + 1;
1797	if ($timeslice->{start} != 0
1798	and
1799	!query_config($grabber, 'option_offset_eats_days'))
1800	{
1801	$n -= $timeslice->{start};
1802	}
1803	$comm .= " " .
1804	query_config($grabber, 'option_days') .
1805	" " .
1806	$n;
1807
1808	# Write a temporary channels file specifying only the channels we want
1809	my $tmpchans;
1810	foreach (@{$timeslice->{chans}})
1811	{
1812	$tmpchans->{$_} = $channels->{$_};
1813	}
1814	my $tmpcf = "$CWD/channels.conf.tmp";
1815	write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
1816	$comm .= " --channels_file $tmpcf";
1817	}
1818	else
1819	{
1820	&log("$grabber is category 2: grabbing everything.\n") if ($debug);
1821	$comm .= " --days $days" if ($days);
1822	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
1823	$comm .= " --channels_file $channels_file";
1824	}
1825
1826	if ((defined $plugin_data->{tor_pid}) &&
1827	(query_config($grabber, 'option_anon_socks'))) {
1828	$comm .= " ".query_config($grabber, 'option_anon_socks')." ".$plugin_data->{tor_address};
1829	}
1830
1831	$comm .= " --debug" if ($debug);
1832	$comm .= " @ARGV" if (@ARGV);
1833
1834	my $retval = 0;
1835	my $msg;
1836	my $component_start = time;
1837	if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
1838	&log("SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n");
1839	&log("SHEPHERD: would have called: $comm\n") if ($debug);
1840	} else {
1841	&log("SHEPHERD: Excuting command: $comm\n");
1842	chdir "$CWD/grabbers/$grabber/";
1843	($retval,$msg) = call_prog($grabber,$comm,0,(query_config($grabber,'max_runtime')*60));
1844	chdir $CWD;
1845	}
1846	my $component_duration = time - $component_start;
1847
1848	if ($retval) {
1849	&log("Grabber exited with non-zero code $retval: assuming it failed.\n" .
1850	"Last message: \"$msg\"\n");
1851	$components->{$grabber}->{laststatus} = "Failed (code $retval)";
1852	$components->{$grabber}->{consecutive_failures}++;
1853	&add_pending_message($grabber,"FAIL", $retval.":".$msg, $component_start, $component_duration,
1854	$components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
1855	next;
1856	}
1857
1858	# soak up the data we just collected
1859	&soak_up_data($grabber, $output, "grabber");
1860	$components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
1861
1862	if ($plugin_data->{$grabber}->{valid}) {
1863	$components->{$grabber}->{lastdata} = time;
1864	delete $components->{$grabber}->{consecutive_failures}
1865	if (defined $components->{$grabber}->{consecutive_failures});
1866	&add_pending_message($grabber,"SUCCESS", $retval, $component_start, $component_duration,
1867	$components->{$grabber}->{ver});
1868	} else {
1869	$components->{$grabber}->{laststatus} = "failed (invalid XMLTV)";
1870	$components->{$grabber}->{consecutive_failures}++;
1871	&add_pending_message($grabber,"FAIL", 0, $component_start, $component_duration,
1872	$components->{$grabber}->{ver}, $components->{$grabber}->{consecutive_failures});
1873	}
1874
1875	# analyze the data that this grabber returned
1876	# (useful to detect individual components going bad and report them upstream)
1877	&analyze_plugin_data($grabber,1,$grabber);
1878
1879	# check to see if we have all the data we want
1880	$grabber_found_all_data = &analyze_plugin_data("analysis of all grabbers so far",0,$progname);
1881
1882	# Record what we grabbed from cacheable C1 grabbers
1883	if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
1884	{
1885	my $missing_before = convert_dayhash_to_list($missing);
1886	my $missing_after = convert_dayhash_to_list(detect_missing_data());
1887	my $list = List::Compare->new($missing_before, $missing_after);
1888	my @grabbed = $list->get_symmetric_difference();
1889	&log("Grabbed: " . join (', ', @grabbed) . ".\n") if ($debug);
1890	record_cached($grabber, @grabbed);
1891	write_config_file();
1892	}
1893
1894	last if ($grabber_found_all_data);
1895	}
1896
1897
1898	if ($used_grabbers == 0)
1899	{
1900	&log("No valid grabbers installed/enabled!\n");
1901	return;
1902	}
1903
1904	unless ($grabber_found_all_data)
1905	{
1906	&log("SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n");
1907	return;
1908	}
1909	}
1910
1911	# -----------------------------------------
1912	# Subs: Intelli-random grabber selection
1913	# -----------------------------------------
1914
1915	sub choose_grabber
1916	{
1917	if (defined $gscore) # Reset score hash
1918	{
1919	foreach (keys %$gscore)
1920	{
1921	$gscore->{$_} = 0;
1922	}
1923	}
1924	else # Create score hash
1925	{
1926	foreach (query_grabbers())
1927	{
1928	unless ($components->{$_}->{disabled})
1929	{
1930	$gscore->{$_} = 0;
1931	if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
1932	{
1933	$gscore->{$_ . ' [cache]'} = 0;
1934	}
1935	}
1936	}
1937	}
1938
1939	$missing = detect_missing_data();
1940	$timeslice = find_best_timeslice();
1941
1942	if ($debug)
1943	{
1944	&log((sprintf "Best timeslice: day%s of channels %s (%d chandays).\n",
1945	($timeslice->{start} == $timeslice->{stop} ?
1946	" $timeslice->{start}" :
1947	"s $timeslice->{start} - $timeslice->{stop}"),
1948	join(', ', @{$timeslice->{chans}}),
1949	$timeslice->{chandays}));
1950	}
1951
1952	my $total = score_grabbers();
1953
1954	if ($debug)
1955	{
1956	&log("Grabber selection:\n");
1957	foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
1958	{
1959	next if ($_ =~ /\[cache\]/);
1960
1961	my $score = $gscore->{$_};
1962	my $cscore = $gscore->{"$_ [cache]"};
1963	my $cstr = $cscore ? "(inc. $cscore cache pts)" : "";
1964
1965	if ($opt->{randomize})
1966	{
1967	&log((sprintf "%15s %6.1f%% %9s %s\n",
1968	$_,
1969	($total ? 100* $score / $total : 0),
1970	"$score pts",
1971	$cstr));
1972	}
1973	else
1974	{
1975	&log(sprintf("%15s %4s pts %s\n",
1976	$_,
1977	$score,
1978	$cstr));
1979	}
1980	}
1981	}
1982
1983	if ($opt->{grabwith})
1984	{
1985	my @a = split(/,/, $opt->{grabwith});
1986	my $g;
1987	while ($g = shift @a)
1988	{
1989	$opt->{grabwith} = (@a ? join(',', @a) : undef);
1990	&log("\nObeying --grabwith option: selecting grabber \"$g\".\n");
1991	if ($components->{$g} and $components->{$g}->{type} eq 'grabber')
1992	{
1993	return select_grabber($g, $gscore);
1994	}
1995	&log("Not a grabber: \"$g\".\n");
1996	}
1997	}
1998
1999	return undef unless ($total);
2000
2001	# If the user has specified a pref_title_source -- i.e. he is
2002	# transitioning from a known grabber -- then we make sure it
2003	# has run at least once, to build the list of title translations.
2004	if ($pref_title_source)
2005	{
2006	my @prefs = split(/,/, $pref_title_source);
2007	foreach my $grabber (@prefs)
2008	{
2009	unless ($components->{$grabber}->{lastdata})
2010	{
2011	&log("Need to build title translation list for transitional grabber $grabber.\n");
2012	return select_grabber($grabber, $gscore) if ($gscore->{$grabber});
2013	&log("WARNING: Can't run $grabber to build title translation list!\n");
2014	}
2015	}
2016	}
2017
2018	# If run with --randomize, then rather than always selecting the highest-scoring
2019	# grabber first we'll make a weighted random selection.
2020	if ($opt->{randomize})
2021	{
2022	my $r = int(rand($total));
2023	my $c = 0;
2024	foreach my $grabber (keys %$gscore)
2025	{
2026	next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
2027	if ($r >= $c and $r < ($c + $gscore->{$grabber}))
2028	{
2029	return select_grabber($grabber, $gscore);
2030	}
2031	$c += $gscore->{$grabber};
2032	}
2033	die "ERROR: failed to choose grabber.";
2034	}
2035
2036	# Choose grabber with best score. If there are multiple grabbers with the
2037	# best score, randomly select one of them.
2038	my @sorted = sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore;
2039	my @candidates = ( $sorted[0] );
2040	my $c = 1;
2041	while ($gscore->{$sorted[$c]} == $gscore->{$sorted[0]})
2042	{
2043	push @candidates, $sorted[$c] unless ($sorted[$c] =~ /\[cache\]/);
2044	$c++;
2045	}
2046	return select_grabber($candidates[0], $gscore) unless (@candidates > 1);
2047
2048	print "Multiple grabbers with best score: @candidates.\n" if ($debug);
2049	return select_grabber($candidates[int(rand(scalar(@candidates)))], $gscore);
2050	}
2051
2052	sub select_grabber
2053	{
2054	my ($grabber, $gscore) = @_;
2055
2056	&log("Selected $grabber.\n") if ($debug);
2057	if (query_config($grabber, 'category') == 2)
2058	{
2059	# We might want to run C1 grabbers multiple times
2060	# to grab various timeslices, but not C2 grabbers,
2061	# which should get everything at once.
2062	delete $gscore->{$grabber};
2063	}
2064	return $grabber;
2065	}
2066
2067	# Grabbers earn 1 point for each slot or chanday they can fill.
2068	# This score is multiplied if the grabber:
2069	# * is a category 2 grabber (i.e. fast/cheap)
2070	# * is a category 1 grabber that has the data we want in a cache
2071	# * can supply high-quality data
2072	# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
2073	sub score_grabbers
2074	{
2075	my ($score, $total, $day, $catbonus, $dqbonus, $mult, $key);
2076
2077	my $bestdq = 0;
2078
2079	# Compare C2 grabbers against the raw missing file, because we'll get
2080	# everything. But compare C1 grabbers against the timeslice, because we'll
2081	# only ask them for a slice. This goes for the [cache] and regular C1s.
2082	foreach my $grabber (keys %$gscore)
2083	{
2084	# for each slot, say whether we can fill it or not -- that is,
2085	# whether we support this channel and this day #.
2086
2087	my $hits = 0;
2088	my $cat = query_config($grabber, 'category');
2089	my $dq = query_config($grabber, 'quality');
2090
2091	if ($cat == 1)
2092	{
2093	$key = cut_down_missing($grabber);
2094	# &log("Grabber $grabber is Category 1: comparing capability to best timeslice.\n") if ($debug);
2095	}
2096	else
2097	{
2098	$key = $missing;
2099	# &log("Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n") if ($debug);
2100	}
2101
2102	if ($grabber =~ /\[cache\]/)
2103	{
2104	$hits = find_cache_hits($grabber, $key);
2105	}
2106	else
2107	{
2108	foreach my $day (sort keys %$key)
2109	{
2110	my $val = supports_day($grabber, $day);
2111	next unless ($val);
2112	# &log("Day $day:") if ($debug);
2113	foreach my $ch (@{$key->{$day}})
2114	{
2115	if (supports_channel($grabber, $ch, $day))
2116	{
2117	# &log(" $ch") if ($debug);
2118	$hits += $val;
2119	}
2120	}
2121	# &log("\n") if $debug;
2122	$hits = 1 if ($hits > 0 and $hits < 1);
2123	}
2124	}
2125
2126	my $catbonus = 1;
2127	$catbonus = 3 if ($cat == 2);
2128	if ($grabber =~ /\[cache\]/)
2129	{
2130	# Bonus is on a sliding scale between 1 and 2 depending on
2131	# % of required data in cache
2132	$catbonus += $hits / $timeslice->{chandays};
2133	}
2134
2135	my $dqbonus = 2 ** ($dq-1);
2136
2137	my $mult = $dq ** $catbonus;
2138
2139	my $score = int($hits * $mult);
2140
2141	if ($debug)
2142	{
2143	my $str = sprintf "Grabber %s can supply %d chandays",
2144	$grabber, $hits;
2145	if ($hits)
2146	{
2147	$str .= sprintf " at x%.1f (cat: %d, DQ: %d): %d pts",
2148	$mult,
2149	$cat,
2150	$dq,
2151	$score;
2152	}
2153	&log("$str.\n");
2154	}
2155
2156	if ($score and query_config($grabber, 'option_anon_socks') and !defined $plugin_data->{tor_pid})
2157	{
2158	&log("Grabber $grabber needs Tor to run efficiently: reducing score.\n") if ($debug);
2159	$score = int($score/10)+1;
2160	}
2161
2162	$gscore->{$grabber} += $score;
2163	$total += $score;
2164	if ($grabber =~ /\[cache\]/)
2165	{
2166	$gscore->{query_name($grabber)} += $score;
2167	}
2168
2169	if ($score and $dq > $bestdq)
2170	{
2171	$bestdq = $dq;
2172	}
2173	}
2174
2175	# Eliminate grabbers of data quality 1 if there are any better-quality
2176	# alternatives. (Only need to do this with 'randomize' option, since otherwise
2177	# we will always pick the highest score.)
2178	if ($opt->{randomize})
2179	{
2180	foreach (keys %$gscore)
2181	{
2182	if (query_config($_, 'quality') == 1 and $bestdq > 1)
2183	{
2184	$total -= $gscore->{$_};
2185	$gscore->{$_} = 0;
2186	&log("Zeroing grabber $_ due to low data quality.\n") if ($debug);
2187	}
2188	}
2189	}
2190
2191	return $total;
2192	}
2193
2194	# Return 1 if the grabber can provide data for this channel, else 0.
2195	sub supports_channel
2196	{
2197	my ($grabber, $ch, $day) = @_;
2198
2199	my $mdpc = query_config($grabber, 'max_days_per_chan');
2200	if ($mdpc)
2201	{
2202	if ($mdpc->{$ch})
2203	{
2204	return ($mdpc->{$ch} > $day);
2205	}
2206	}
2207
2208	my $channels_supported = query_config($grabber, 'channels');
2209	unless (defined $channels_supported)
2210	{
2211	&log("WARNING: Grabber $grabber has no channel support " .
2212	"specified in config.\n");
2213	$channels_supported = '';
2214	}
2215
2216	return 1 unless ($channels_supported); # Empty string means we support all
2217
2218	$ch =~ s/ /_/g;
2219	my $match = ($channels_supported =~ /\b$ch\b/);
2220	my $exceptions = ($channels_supported =~/^-/);
2221	return ($match != $exceptions);
2222	}
2223
2224	# Return 0 if the grabber can't provide data for this day,
2225	# 1 if it can reliably, and 0.5 if it can unreliably.
2226	#
2227	# Note that a max_days of 7 means the grabber can retrieve data for
2228	# today plus 6 days.
2229	sub supports_day
2230	{
2231	my ($grabber, $day) = @_;
2232
2233	return 0 unless ($day < query_config($grabber, 'max_days'));
2234	return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
2235	return 1;
2236	}
2237
2238	sub find_cache_hits
2239	{
2240	my ($grabber, $key) = @_;
2241
2242	$grabber = query_name($grabber);
2243
2244	return 0 unless ($components->{$grabber}->{cached});
2245
2246	my $hits = 0;
2247
2248	foreach my $day (keys %$key)
2249	{
2250	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2251	foreach my $ch (@{$key->{$day}})
2252	{
2253	$hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
2254	}
2255	}
2256	return $hits;
2257	}
2258
2259	# Build a dayhash of what channel/day data we're currently missing.
2260	# I think granularity of one day is good for now; could possibly be
2261	# made more fine-grained if we think grabbers will support that.
2262	sub detect_missing_data
2263	{
2264	my $m = { };
2265
2266	my $chandays = 0;
2267	foreach my $ch (keys %$channels)
2268	{
2269	# is this channel missing too much data?
2270	unless ($channel_data->{$ch}->{analysis}->{data_ok}) {
2271	# not ok - record which days are bad
2272	foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) {
2273	push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
2274	}
2275	}
2276	}
2277
2278	foreach my $day (keys %$m)
2279	{
2280	$m->{$day} = [ sort @{$m->{$day}} ];
2281	$chandays += scalar(@{$m->{$day}}) if ($debug);
2282	}
2283
2284	if ($debug)
2285	{
2286	&log("Need data for days " . join(", ", sort keys %$m) .
2287	" ($chandays chandays).\n");
2288	}
2289	return $m;
2290	}
2291
2292	# Find the largest timeslice in the current $missing dayhash; i.e.
2293	# something like "Days 4 - 6 of ABC and SBS." This works by iterating
2294	# through the days and looking for overlaps where consecutive days
2295	# want the same channels.
2296	sub find_best_timeslice
2297	{
2298	my ($overlap, $a);
2299	my $slice = { 'chandays' => 0 };
2300
2301	foreach my $day (0 .. $days-1)
2302	{
2303	consider_slice($slice, $day, $day, @{$missing->{$day}});
2304	$overlap = $missing->{$day};
2305	foreach my $nextday (($day + 1) .. $days-1)
2306	{
2307	last unless ($missing->{$nextday});
2308	$a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
2309	last unless ($a and @{$a});
2310	consider_slice($slice, $day, $nextday, @{$a});
2311	$overlap = $a;
2312	}
2313	}
2314	return $slice;
2315	}
2316
2317	sub consider_slice
2318	{
2319	my ($slice, $startday, $stopday, @chans) = @_;
2320
2321	my $challenger = ($stopday - $startday + 1) * scalar(@chans);
2322	return unless ($challenger > $slice->{chandays});
2323
2324	# We have a winner!
2325	$slice->{start} = $startday;
2326	$slice->{stop} = $stopday;
2327	$slice->{chans} = [ @chans ];
2328	$slice->{chandays} = $challenger;
2329	}
2330
2331	# Record what a cacheable C1 grabber has just retrieved for us,
2332	# so we know next time that this data can be grabbed quickly.
2333	sub record_cached
2334	{
2335	my ($grabber, @grabbed) = @_;
2336
2337	&log("Recording cache for grabber $grabber.\n") if ($debug);
2338
2339	my $gcache = $components->{$grabber}->{cached};
2340	$gcache = [ ] unless ($gcache);
2341	my @newcache;
2342	my $today = strftime("%Y%m%d", localtime);
2343
2344	# remove old chandays
2345	foreach my $chanday (@$gcache)
2346	{
2347	$chanday =~ /(\d+):(.*)/;
2348	if ($1 >= $today)
2349	{
2350	push (@newcache, $chanday);
2351	}
2352	}
2353
2354	# record new chandays
2355	foreach my $chanday (@grabbed)
2356	{
2357	push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
2358	}
2359	$components->{$grabber}->{cached} = [ @newcache ];
2360	}
2361
2362	# Takes a dayhash and returns it as a list like this:
2363	# ( "20061018:ABC", "20061018:Seven", ... )
2364	sub convert_dayhash_to_list
2365	{
2366	my $h = shift;
2367
2368	my @ret;
2369	foreach my $day (keys %$h)
2370	{
2371	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
2372	foreach my $ch (@{$h->{$day}})
2373	{
2374	push (@ret, "$date:$ch");
2375	}
2376	}
2377	@ret = sort @ret;
2378	return \@ret;
2379	}
2380
2381
2382	# If we're about to re-try a grabber, make sure that we're not asking
2383	# it for the same data. That is, prevent a broken C1 grabber causing
2384	# an infinite loop.
2385	sub record_requested_chandays
2386	{
2387	my ($grabber, $slice) = @_;
2388
2389	&log("Recording timeslice request; will not request these chandays " .
2390	"from $grabber again.\n") if ($debug);
2391
2392	my @requested;
2393	for my $day ($slice->{start} .. $slice->{stop})
2394	{
2395	foreach my $ch (@{$slice->{chans}})
2396	{
2397	push @requested, "$day:$ch";
2398	$plugin_data->{$grabber}->{requested_data}->{$ch}[$day] = 1;
2399	&log(" requesting ch $ch on day $day\n") if ($debug);
2400	}
2401	}
2402	if ($grabbed->{$grabber})
2403	{
2404	push @{$grabbed->{$grabber}}, @requested;
2405	}
2406	else
2407	{
2408	$grabbed->{$grabber} = [ @requested ];
2409	}
2410	}
2411
2412	# If this grabber has been called previously, remove those chandays
2413	# from the current request -- we don't want to ask it over and over
2414	# for a timeslice that it has already failed to provide.
2415	sub cut_down_missing
2416	{
2417	my $grabber = shift;
2418
2419	$grabber = query_name($grabber);
2420	my $dayhash = {};
2421
2422	# Take the timeslice and expand it to a dayhash, while pruning
2423	# any chandays that have previously been requested from this
2424	# grabber.
2425	foreach my $day ($timeslice->{start} .. $timeslice->{stop})
2426	{
2427	my @chans;
2428	foreach my $ch (@{$timeslice->{chans}})
2429	{
2430	unless ($grabbed->{$grabber} and grep(/$day:$ch/, @{$grabbed->{$grabber}}))
2431	{
2432	push (@chans, $ch)
2433	}
2434	}
2435	$dayhash->{$day} = [ @chans ] if (@chans);
2436	}
2437
2438	return $dayhash;
2439	}
2440
2441	# -----------------------------------------
2442	# Subs: Analyzing data
2443	# -----------------------------------------
2444
2445	# interpret xmltv data from this grabber/postprocessor
2446	sub soak_up_data
2447	{
2448	my ($plugin, $output, $plugintype) = @_;
2449
2450	if (! -r $output) {
2451	&log("SHEPHERD: Warning: plugin '$plugin' output file '$output' does not exist\n");
2452	return;
2453	}
2454
2455	my $this_plugin = $plugin_data->{$plugin};
2456	&log("SHEPHERD: Started parsing XMLTV from '$plugin' in '$output' .. any errors below are from parser:\n");
2457	eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
2458	&log("SHEPHERD: Completed XMLTV parsing from '$plugin'\n");
2459
2460	if (!($this_plugin->{xmltv})) {
2461	&log("WARNING: Plugin $plugin didn't seem to return any valid XMLTV!\n");
2462	return;
2463	}
2464
2465	$this_plugin->{valid} = 1;
2466	$this_plugin->{output_filename} = $output;
2467	$components_used .= " + ".$plugin."(v".$components->{$plugin}->{ver}.")";
2468
2469	my $xmltv = $this_plugin->{xmltv};
2470	my ($encoding, $credits, $chan, $progs) = @$xmltv;
2471	$this_plugin->{total_duration} = 0;
2472	$this_plugin->{programmes} = 0;
2473	$this_plugin->{progs_with_invalid_date} = 0; # explicitly track unparsable dates
2474	$this_plugin->{progs_too_long} = 0; # explicitly track exxcessive programme durations
2475	$this_plugin->{progs_with_unknown_channel} = 0; # explicitly track unknown channels
2476
2477	my $seen_channels_with_data = 0;
2478
2479	#
2480	# first iterate through all programmes and see if there are any channels we don't know about
2481	#
2482	my %chan_xml_list;
2483	foreach my $ch (sort keys %{$channels}) {
2484	$chan_xml_list{($channels->{$ch})} = 1;
2485	}
2486	foreach my $prog (@$progs) {
2487	if (!defined $chan_xml_list{($prog->{channel})}) {
2488	$this_plugin->{progs_with_unknown_channel}++;
2489	&log((sprintf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel}));
2490	$chan_xml_list{($prog->{channel})} = 1; # so we warn only once
2491	}
2492	}
2493
2494	# iterate thru channels
2495	foreach my $ch (sort keys %{$channels}) {
2496	my $seen_progs_on_this_channel = 0;
2497
2498	# iterate thru programmes per channel
2499	foreach my $prog (@$progs) {
2500	next if ($prog->{channel} ne $channels->{$ch});
2501
2502	my $t1 = &parse_xmltv_date($prog->{start});
2503	my $t2 = &parse_xmltv_date($prog->{stop});
2504
2505	if (!$t1 \|\| !$t2) {
2506	&log((sprintf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
2507	$plugin,(!$t1 ? $prog->{start} : $prog->{stop}))) if (!$this_plugin->{progs_with_invalid_date});
2508	$this_plugin->{progs_with_invalid_date}++;
2509	next;
2510	}
2511
2512	my $this_duration = $t2 - $t1;
2513	if (($this_duration > $policy{max_programme_length}) &&
2514	($prog->{title}->[0]->[0] !~ /close/i)) {
2515	&log((sprintf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
2516	$plugin, int($policy{max_programme_length} / 3600),
2517	int(($policy{max_programme_length} % 3600) / 60)))
2518	if (!$this_plugin->{progs_too_long});
2519	$this_plugin->{progs_too_long}++;
2520	next;
2521	}
2522
2523	# store plugin-specific stats
2524	$this_plugin->{programmes}++;
2525	$this_plugin->{total_duration} += $this_duration;
2526	$seen_progs_on_this_channel++;
2527	$this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
2528	$this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
2529	$this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
2530	$this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
2531
2532	# store channel-specific stats
2533	$channel_data->{$ch}->{programmes}++;
2534	$channel_data->{$ch}->{total_duration} += $this_duration;
2535
2536	# programme is outside the timeslots we are interested in.
2537	next if ($t1 > $policy{endtime});
2538	next if ($t2 < $policy{starttime});
2539
2540	# store timeslot info
2541	my $start_slotnum = 0;
2542	$start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
2543	if ($t1 >= $policy{starttime});
2544
2545	my $end_slotnum = ($policy{num_timeslots}-1);
2546	$end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
2547	if ($t2 < $policy{endtime});
2548
2549	&log((sprintf "DEBUG: ch '%s' prog start '%s' stop '%s' storing into timeslots %d-%d (%s-%s)\n",
2550	$ch, $prog->{start}, $prog->{stop}, $start_slotnum, $end_slotnum,
2551	POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($start_slotnum * $policy{timeslot_size}))),
2552	POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($end_slotnum * $policy{timeslot_size})))))
2553	if $policy{timeslot_debug};
2554
2555	# add this programme into the global and per-plugin timeslots table for this channel
2556	foreach my $slotnum ($start_slotnum..$end_slotnum) {
2557	$channel_data->{$ch}->{timeslots}[$slotnum]++;
2558	$this_plugin->{timeslots}->{$ch}[$slotnum]++;
2559	}
2560	}
2561
2562	$seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
2563	}
2564
2565	# print some stats about what we saw!
2566	&log((sprintf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
2567	ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
2568	int($this_plugin->{total_duration} / 86400), # days
2569	int(($this_plugin->{total_duration} % 86400) / 3600), # hours
2570	int(($this_plugin->{total_duration} % 3600) / 60), # mins
2571	int($this_plugin->{total_duration} % 60), # sec
2572	(defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
2573	(defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '')));
2574
2575	$this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
2576	$seen_channels_with_data, $this_plugin->{programmes},
2577	int($this_plugin->{total_duration} / 3600),
2578	(defined $this_plugin->{earliest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
2579	(defined $this_plugin->{latest_data_seen} ? POSIX::strftime("%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
2580
2581	$plugin_data->{$plugin} = $this_plugin;
2582	}
2583
2584
2585	# analyze grabber data - do we have all the data we want?
2586	# this can analyze either the cumulative data from ALL plugins ($analysistype="shepherd")
2587	# or can analyze the data from one specific plugin
2588
2589	sub analyze_plugin_data
2590	{
2591	my ($analysisname,$quiet,$analysistype) = @_;
2592	&log("SHEPHERD: $analysisname:\n") unless $quiet;
2593
2594	my $total_channels = 0;
2595	my $plugin_epoch_missing_data = "";
2596	my $overall_data_ok = 1; # until proven otherwise
2597
2598	# iterate across each channel
2599	foreach my $ch (sort keys %{$channels}) {
2600
2601	# if we're analyzing data for a grabber and it doesn't support this channel, skip it
2602	if (($analysistype ne $progname) &&
2603	($components->{$analysistype}->{type} eq "grabber") &&
2604	(supports_channel($analysistype,$ch,1) == 0)) {
2605	&log((sprintf "DEBUG: analysis of channel %s for plugin %s skipped since plugin doesn't support channel\n",
2606	$ch, $analysistype)) if ($debug);
2607	next;
2608	}
2609
2610	$total_channels++;
2611
2612	my $data;
2613	my $lastpol = "";
2614	$data->{data_ok} = 1; # unless proven otherwise
2615	$data->{have} = 0;
2616	$data->{missing} = 0;
2617
2618	for my $slotnum (0..($policy{num_timeslots}-1)) {
2619	my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
2620
2621	# work out day number of when this bucket is.
2622	# number from 0 onwards. (i.e. today=0).
2623	# for a typical 7 day grabber this will actually mean 8 days of data (0-7)
2624	# with days 0 and 7 truncated to half-days
2625	my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
2626
2627	if (!defined $data->{day}->[$day]) {
2628	$data->{day}->[$day]->{num} = $day;
2629	$data->{day}->[$day]->{have} = 0;
2630	$data->{day}->[$day]->{missing} = 0;
2631	$data->{day}->[$day]->{missing_peak} = 0;
2632	$data->{day}->[$day]->{missing_nonpeak} = 0;
2633	$data->{day}->[$day]->{missing_other} = 0;
2634
2635	$data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
2636
2637	# day changed, dump any 'already_missing' data
2638	&dump_already_missing($data);
2639	}
2640
2641	# we have programming data for this bucket. great! process next bucket
2642	if ((($analysistype eq $progname) &&
2643	(defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
2644	($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) \|\|
2645	(($analysistype ne $progname) &&
2646	(defined $plugin_data->{$analysistype}->{timeslots}->{$ch}[$slotnum]) &&
2647	($plugin_data->{$analysistype}->{timeslots}->{$ch}[$slotnum] > 0))) {
2648	# if we have missing data queued up, push it now
2649	&dump_already_missing($data);
2650	&dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
2651
2652	$data->{day}->[$day]->{have} += $policy{timeslot_size};
2653	$data->{have} += $policy{timeslot_size};
2654	next;
2655	}
2656
2657	# some grabbers take HOURS to run. if this bucket (missing data) is for
2658	# a time period now in the past, then don't include it
2659	next if (($bucket_start_offset + $policy{starttime}) < time);
2660
2661	# we don't have programming for this channel for this bucket
2662	&log((sprintf "DEBUG: missing timeslot data for ch '%s' bucket %d (%s)\n",
2663	$ch, $slotnum, POSIX::strftime("%a%e%b%H:%M", localtime($policy{starttime}+($slotnum * $policy{timeslot_size})))))
2664	if $policy{timeslot_debug};
2665
2666
2667	if (($analysistype ne $progname) && ($components->{$analysistype}->{type} eq "grabber")) {
2668	# if we're analyzing data for a grabber and it doesn't have data for this
2669	# channel on this day, don't record it as missing data if:
2670	# 1. its beyond 'max_reliable_days' for this grabber
2671	# 2. we didn't _request_ the data for this channel/day (C1 grabbers)
2672	# 3. grabber can't supply this channel (C2 grabbers)
2673
2674	my $ignore_missing = 0; # don't ignore missing unless proven otherwise
2675
2676	# 1. ignore if it exceeds 'max_reliable_days' for this grabber
2677	if (supports_day($analysistype,$day) != 1) {
2678	$ignore_missing++;
2679	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to max_reliable_days\n",
2680	$analysistype, $ch, $day)) if ($policy{timeslot_debug});
2681	}
2682
2683	# 2. ignore if we did request data for channel/day (C1 grabbers)
2684	if ((query_config($analysistype, 'category') == 1) &&
2685	(!defined $plugin_data->{$analysistype}->{requested_data}->{$ch}[$day])) {
2686	$ignore_missing++;
2687	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not requested\n",
2688	$analysistype, $ch, $day)) if ($policy{timeslot_debug});
2689	}
2690
2691	# 3. ignore if this grabber can't supply this channel (C2 grabbers)
2692	if ((query_config($analysistype, 'category') == 2) &&
2693	(supports_channel($analysistype,$ch,$day) == 0)) {
2694	$ignore_missing++;
2695	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to cannot-supply\n",
2696	$analysistype, $ch, $day)) if ($policy{timeslot_debug});
2697	}
2698
2699	if ($ignore_missing > 0) {
2700	# if we have missing data queued up, push it now
2701	&dump_already_missing($data);
2702	&dump_already_missing_period($data->{day}->[$day],$lastpol) if ($lastpol ne "");
2703	next;
2704	}
2705	}
2706
2707
2708	if (($analysistype ne $progname) && ($components->{$analysistype}->{type} ne "grabber")) {
2709	# if we're analyzing data for a reconciler/postprocessor and it doesn't have
2710	# data for a timeslot, only record that as an error if the source data _was_
2711	# previously available in the 'overall' data
2712
2713	if ((!defined $channel_data->{$ch}->{timeslots}[$slotnum]) \|\|
2714	($channel_data->{$ch}->{timeslots}[$slotnum] == 0)) {
2715	&log((sprintf "DEBUG: analysis of plugin '%s' skipping missing data channel '%s' for day %d due to not-in-overall-data\n",
2716	$analysistype, $ch, $day)) if ($policy{timeslot_debug});
2717	next;
2718	}
2719	}
2720
2721	# work out the localtime of when this bucket is
2722	my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
2723
2724	# store details of where we are missing data
2725	if (!defined $data->{already_missing}) {
2726	$data->{already_missing} = sprintf "#%d/%02d:%02d",
2727	$day,
2728	int($bucket_seconds_offset / 3600),
2729	int(($bucket_seconds_offset % 3600) / 60);
2730	$data->{already_missing_epoch} = $policy{starttime} + $bucket_start_offset;
2731	}
2732	$data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
2733	$data->{already_missing_last_epoch} = $policy{starttime} + $bucket_start_offset;
2734
2735	$data->{day}->[$day]->{missing} += $policy{timeslot_size};
2736	$data->{missing} += $policy{timeslot_size};
2737
2738	# work out what policy missing data for this bucket fits into
2739	my $pol;
2740	if (($bucket_seconds_offset >= $policy{peak_start}) &&
2741	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
2742	$pol = "peak";
2743	} elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
2744	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
2745	$pol = "nonpeak";
2746	} else {
2747	$pol = "other";
2748	}
2749
2750	&dump_already_missing_period($data->{day}->[$day],$lastpol)
2751	if (($lastpol ne $pol) && ($lastpol ne ""));
2752
2753	$lastpol = $pol;
2754
2755	$data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
2756
2757	$data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
2758	if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
2759	$data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
2760
2761	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
2762	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
2763	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
2764	$data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
2765	$overall_data_ok = 0 if ($data->{data_ok} == 0);
2766	}
2767
2768	# finished all timeslots in this channel.
2769	# if we have missing data queued up, push it now
2770	&dump_already_missing($data);
2771
2772	# fill in any last missing period data
2773	foreach my $day (@{($data->{day})}) {
2774	&dump_already_missing_period($day,"peak");
2775	&dump_already_missing_period($day,"nonpeak");
2776	&dump_already_missing_period($day,"other");
2777	}
2778
2779	my $statusstring = sprintf " > ch %s: %s programming: %s\n",
2780	$ch, pretty_duration($data->{have}),
2781	$data->{data_ok} ? "PASS (within thresholds)" : "FAIL, missing data over policy threshold:";
2782
2783	# display per-day missing data statistics
2784	foreach my $day (@{($data->{day})}) {
2785	unless ($day->{day_ok}) {
2786	$statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": ";
2787
2788	# do we have any data for this day?
2789	$statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
2790	if (($day->{missing_peak}) && ($day->{missing_peak} > $policy{peak_max_missing}));
2791
2792	$statusstring .= sprintf "%snon-peak %s",
2793	($day->{missing_peak} ? " / " : ""),
2794	join(", ",(@{($day->{missing_nonpeak_table})}))
2795	if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak} > $policy{nonpeak_max_missing}));
2796
2797	$statusstring .= sprintf "%sother %s",
2798	(($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
2799	join(", ",(@{($day->{missing_other_table})}))
2800	if (($day->{missing_other}) && ($day->{missing_other} > $policy{other_max_missing}));
2801
2802	$statusstring .= "\n";
2803	}
2804	}
2805	&log($statusstring) unless $quiet;
2806	$data->{statusstring} = $statusstring;
2807	$plugin_epoch_missing_data .= sprintf "%s:%s\t",$ch,$data->{missing_all_epoch} if (defined $data->{missing_all_epoch});
2808
2809	if ($analysistype eq $progname) {
2810	delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
2811	$channel_data->{$ch}->{analysis} = $data;
2812	} else {
2813	delete $plugin_data->{$analysistype}->{analysis}->{$ch} if (defined $plugin_data->{$analysistype}->{analysis}->{$ch});
2814	$plugin_data->{$analysistype}->{analysis}->{$ch} = $data;
2815	}
2816	}
2817
2818	&log((sprintf " > OVERALL: %s\n", ($overall_data_ok ? "PASS" : "FAIL"))) unless $quiet;
2819
2820	if ($plugin_epoch_missing_data eq '') {
2821	# clear any previously-set missing data flag
2822	delete $pending_messages->{$analysistype}->{MISSING_DATA};
2823	} else {
2824	# flag any missing data
2825	&add_pending_message($analysistype, 'MISSING_DATA', $plugin_epoch_missing_data);
2826	}
2827
2828	return $overall_data_ok; # return 1 for good, 0 for need more
2829	}
2830
2831	# helper routine for filling in 'missing_all' array
2832	sub dump_already_missing
2833	{
2834	my $d = shift;
2835	if (defined $d->{already_missing}) {
2836	$d->{already_missing} .= sprintf "-%02d:%02d",
2837	int($d->{already_missing_last} / 3600),
2838	int(($d->{already_missing_last} % 3600) / 60)
2839	if (defined $d->{already_missing_last});
2840	push(@{($d->{missing_all})}, $d->{already_missing});
2841
2842	$d->{already_missing_epoch} .= sprintf "-%d",$d->{already_missing_last_epoch};
2843	$d->{missing_all_epoch} .= "," if (defined $d->{missing_all_epoch});
2844	$d->{missing_all_epoch} .= $d->{already_missing_epoch};
2845
2846	delete $d->{already_missing};
2847	delete $d->{already_missing_last};
2848
2849	delete $d->{already_missing_epoch};
2850	delete $d->{already_missing_last_epoch};
2851	}
2852	}
2853
2854	# helper routine for filling in per-day missing data
2855	# specific to peak/nonpeak/other
2856	sub dump_already_missing_period
2857	{
2858	my ($d,$p) = @_;
2859	my $startvar = "already_missing_".$p."_start";
2860	my $stopvar = "already_missing_".$p."_stop";
2861
2862	if (defined $d->{$startvar}) {
2863	push(@{($d->{"missing_".$p."_table"})},
2864	sprintf "%02d:%02d-%02d:%02d",
2865	int($d->{$startvar} / 3600),
2866	int(($d->{$startvar} % 3600) / 60),
2867	int($d->{$stopvar} / 3600),
2868	int(($d->{$stopvar} % 3600) / 60));
2869	delete $d->{$startvar};
2870	delete $d->{$stopvar};
2871	}
2872	}
2873
2874	# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
2875	# and indication of whether the duration is over its threshold or not
2876	sub pretty_duration
2877	{
2878	my ($d,$crit) = @_;
2879	my $s = "";
2880	$s .= sprintf "%dd",int($d / (606024)) if ($d >= (606024));
2881	$s .= sprintf "%dh",int(($d % (606024)) / (6060)) if (($d % (606024)) >= (6060));
2882	$s .= sprintf "%dm",int(($d % (6060)) / 60) if (($d % (6060)) >= 60);
2883	$s .= "no" if ($s eq "");
2884
2885	if (defined $crit) {
2886	$s .= "[!]" if ($d > $crit);
2887	}
2888	return $s;
2889	}
2890
2891	# work out date range we are expecting data to be in
2892	sub calc_date_range
2893	{
2894
2895	$policy{starttime} = time;
2896
2897	# set endtime as per $days less 1 day + hours left today
2898	$policy{endtime} = $policy{starttime} + ((606024)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
2899
2900	# normalize starttime to beginning of next bucket
2901	$policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
2902
2903	# work out how many seconds into a day our first bucket starts
2904	$policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
2905
2906	# normalize endtime to end of previous bucket
2907	$policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
2908
2909	# if we are working with an --offset, apply it now.
2910	$policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
2911
2912	# work out number of buckets
2913	$policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
2914
2915	&log((sprintf "DEBUG: policy settings: starttime=%d, endtime=%d, first_bucket_offset=%d, gmt_offset=%d, strftime_tz=%s\n",
2916	$policy{starttime}, $policy{endtime}, $policy{first_bucket_offset}, $gmt_offset,
2917	(strftime("%z", localtime(time)))))
2918	if ($policy{timeslot_debug});
2919	}
2920
2921	sub calc_gmt_offset
2922	{
2923	# work out GMT offset - we only do this once
2924	if (!$gmt_offset) {
2925	# work out our gmt offset
2926	my $tzstring = strftime("%z", localtime(time));
2927
2928	$gmt_offset = (6060) int(substr($tzstring,1,2)); # hr
2929	$gmt_offset += (60 * int(substr($tzstring,3,2))); # min
2930	$gmt_offset *= -1 if (substr($tzstring,0,1) eq "-"); # +/-
2931	}
2932	}
2933
2934	# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
2935	# rather than the various other perl implementation which treat it as being in UTC/GMT
2936	sub parse_xmltv_date
2937	{
2938	my $datestring = shift;
2939	my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
2940	my $tz_offset = 0;
2941
2942	if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
2943	($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);
2944	($t[6],$t[7],$t[8]) = (-1,-1,-1);
2945
2946	# if input data has a timezone offset, then offset by that
2947	if ($datestring =~ /\+(\d{2})(\d{2})/) {
2948	$tz_offset = $gmt_offset - (($1(6060)) + ($2*60));
2949	} elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
2950	$tz_offset = $gmt_offset + (($1(6060)) + ($2*60));
2951	}
2952
2953	my $e = mktime(@t);
2954	return ($e+$tz_offset) if ($e > 1);
2955	}
2956	return undef;
2957	}
2958
2959	# -----------------------------------------
2960	# Subs: Reconciling data
2961	# -----------------------------------------
2962
2963	# for all the data we have, try to pick the best bits!
2964	sub reconcile_data
2965	{
2966	&log("\nReconciling data:\n\n");
2967
2968	my $num_grabbers = 0;
2969	my $input_files = "";
2970	my @input_file_list;
2971
2972	# when reconciling & postprocessing, increase the thresholds of how much
2973	# missing data we permit.
2974	# generally, if a postprocessor or reconciler breaks, it'll return
2975	# no data rather than 'most' data.
2976	$policy{peak_max_missing} *= 3;
2977	$policy{nonpeak_max_missing} *= 1.5;
2978	$policy{other_max_missing} *= 3;
2979
2980	&log("Preferred title preferences from '$pref_title_source'\n")
2981	if ((defined $pref_title_source) &&
2982	($plugin_data->{$pref_title_source}) &&
2983	($plugin_data->{$pref_title_source}->{valid}));
2984
2985	&log("Preference for whose data we prefer as follows:\n");
2986	foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
2987	if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
2988	$num_grabbers++;
2989	&log((sprintf " %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename}));
2990
2991	$input_files .= $plugin_data->{$proggy}->{output_filename}." ";
2992	push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
2993	}
2994	}
2995
2996	if ($num_grabbers == 0) {
2997	&log("ERROR! Nothing to reconcile! No valid grabber data!\n");
2998	return;
2999	}
3000
3001	foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
3002	next if ($components->{$reconciler}->{disabled});
3003	next if (!$components->{$reconciler}->{ready});
3004
3005	$reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
3006
3007	if ((!$reconciler_found_all_data) && ($grabber_found_all_data)) {
3008	# urgh. this reconciler did a bad bad thing ...
3009	&log("SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n");
3010	} else {
3011	&log("SHEPHERD: Data from reconciler $reconciler looks good\n");
3012	$input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
3013	}
3014
3015	last if ($input_postprocess_file ne "");
3016	}
3017
3018	if ($input_postprocess_file eq "") {
3019	# no reconcilers worked!!
3020	&log("SHEPHERD: WARNING: No reconcilers seemed to work! Falling back to concatenating the data together!\n");
3021
3022	my %w_args = ();
3023	$input_postprocess_file = "$CWD/input_preprocess.xmltv";
3024	my $fh = new IO::File ">$input_postprocess_file" \|\| die "could not open $input_postprocess_file for writing: $!\n";
3025	%w_args = (OUTPUT => $fh);
3026	XMLTV::catfiles(\%w_args, @input_file_list);
3027	}
3028	}
3029
3030
3031	# -----------------------------------------
3032	# Subs: Postprocessing
3033	# -----------------------------------------
3034
3035	sub postprocess_data
3036	{
3037	# for our first postprocessor, we feed it ALL of the XMLTV files we have
3038	# as each postprocessor runs, we feed in the output from the previous one
3039	# Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
3040	# reverts back to the previous postprocessor if it was shown to be bad
3041
3042	# first time around: feed in reconciled data ($input_postprocess_file)
3043
3044	&log("\nPostprocessing stage:\n");
3045
3046	foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
3047	next if ($components->{$postprocessor}->{disabled});
3048	next if (!$components->{$postprocessor}->{ready});
3049
3050	my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
3051
3052	if ($found_all_data) {
3053	# accept what this postprocessor did to our output ...
3054	&log("SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n");
3055	$input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
3056	delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
3057	next;
3058	}
3059
3060	# urgh. this postprocessor did a bad bad thing ...
3061	&log("SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n");
3062
3063	if (defined $components->{$postprocessor}->{conescutive_failures}) {
3064	$components->{$postprocessor}->{conescutive_failures}++;
3065	} else {
3066	$components->{$postprocessor}->{conescutive_failures} = 1;
3067	}
3068	}
3069	}
3070
3071
3072	# -----------------------------------------
3073	# Subs: Postprocessing/Reconciler helpers
3074	# -----------------------------------------
3075
3076	sub call_data_processor
3077	{
3078	my ($data_processor_type, $data_processor_name, $input_files) = @_;
3079
3080	&log("\nSHEPHERD: Using $data_processor_type: $data_processor_name\n");
3081
3082	my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
3083	my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
3084	$comm .= " --region $region" .
3085	" --channels_file $channels_file" .
3086	" --output $output";
3087	$comm .= " --days $days" if ($days);
3088	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
3089	$comm .= " --debug" if ($debug);
3090	$comm .= " @ARGV" if (@ARGV);
3091
3092	$comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
3093	if (($data_processor_type eq "reconciler") &&
3094	(defined $pref_title_source) &&
3095	($plugin_data->{$pref_title_source}) &&
3096	($plugin_data->{$pref_title_source}->{valid}));
3097
3098	$comm .= " $input_files";
3099	&log("SHEPHERD: Excuting command: $comm\n");
3100
3101	my $component_start = time;
3102	my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
3103	chdir $dir;
3104	my ($retval,$msg) = call_prog($data_processor_name,$comm,0,(query_config($data_processor_name,'max_runtime')*60));
3105	chdir $CWD;
3106	my $component_duration = time - $component_start;
3107
3108	if ($retval) {
3109	&log("$data_processor_type exited with non-zero code $retval: assuming it failed.\n" .
3110	"Last message: $msg\n");
3111	$components->{$data_processor_name}->{laststatus} = "Failed ($retval)";
3112	$components->{$data_processor_name}->{consecutive_failures}++;
3113	&add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
3114	$components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
3115	return 0;
3116	}
3117
3118	#
3119	# soak up the data we just collected and check it
3120	# YES - these are the SAME routines we used in the previous 'grabber' phase
3121	# but the difference here is that we clear out our 'channel_data' beforehand
3122	# so we can independently analyze the impact of this postprocessor.
3123	# if it clearly returns bad data, don't use that data (go back one step) and
3124	# flag the postprocessor as having failed. after 3 consecutive failures, disable it
3125	#
3126
3127	# clear out channel_data
3128	foreach my $ch (keys %{$channels}) {
3129	delete $channel_data->{$ch};
3130	}
3131
3132	# process and analyze it!
3133	&soak_up_data($data_processor_name, $output, $data_processor_type);
3134
3135	my $have_all_data = 0;
3136	if ((defined $plugin_data->{$data_processor_name}) &&
3137	(defined $plugin_data->{$data_processor_name}->{valid})) {
3138	$have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name",0,$data_processor_name);
3139	}
3140
3141	if ($have_all_data) {
3142	$components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
3143	$components->{$data_processor_name}->{lastdata} = time;
3144	delete $components->{$data_processor_name}->{consecutive_failures}
3145	if (defined $components->{$data_processor_name}->{consecutive_failures});
3146	&add_pending_message($data_processor_name,"SUCCESS", $retval, $component_start, $component_duration,
3147	$components->{$data_processor_name}->{ver});
3148	} else {
3149	$components->{$data_processor_name}->{laststatus} = "missing data: ".$plugin_data->{$data_processor_name}->{laststatus};
3150	$components->{$data_processor_name}->{consecutive_failures}++;
3151	&add_pending_message($data_processor_name,"FAIL", $retval.":".$msg, $component_start, $component_duration,
3152	$components->{$data_processor_name}->{ver}, $components->{$data_processor_name}->{consecutive_failures});
3153	}
3154
3155	return $have_all_data;
3156	}
3157
3158
3159	sub output_data
3160	{
3161	# $input_postprocess_file contains our final output
3162	# send it to whereever --output told us to!
3163
3164	my $output_filename = "$CWD/output.xmltv";
3165	$output_filename = $opt->{output} if ($opt->{output});
3166
3167	my %writer_args = ( encoding => 'ISO-8859-1' );
3168	my $fh = new IO::File(">$output_filename") \|\|
3169	die "can't open $output_filename for writing: $!";
3170	$writer_args{OUTPUT} = $fh;
3171
3172	$writer = new XMLTV::Writer(%writer_args);
3173	$writer->start( {
3174	'source-info-name' => "$progname v".$components->{$progname}->{ver},
3175	'generator-info-name' => $components_used } );
3176
3177	XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb,
3178	\&output_data_programme_cb, $input_postprocess_file);
3179	$writer->end();
3180
3181	&log("Final output stored in $output_filename.\n");
3182	}
3183
3184	sub output_data_channel_cb
3185	{
3186	my $c = shift;
3187	$writer->write_channel($c);
3188	}
3189
3190	sub output_data_programme_cb
3191	{
3192	my $prog=shift;
3193	$writer->write_programme($prog);
3194	}
3195
3196	# -----------------------------------------
3197	# Subs: Tor support
3198	# -----------------------------------------
3199
3200	sub start_tor
3201	{
3202	# do we have any components requesting the use of tor?
3203	my $want_tor = 0;
3204	foreach (query_grabbers()) {
3205	unless ($components->{$_}->{disabled}) {
3206	$want_tor++ if (query_config($_, 'option_anon_socks'));
3207	}
3208	}
3209
3210	return if ($want_tor == 0);
3211
3212	# try to find tor
3213	my $searchpath = ".:/usr/sbin:".$ENV{PATH};
3214	my $found_tor;
3215	foreach my $dir (split(/:/,$searchpath)) {
3216	if ((-x "$dir/tor") && (-f "$dir/tor")) {
3217	$found_tor = "$dir/tor";
3218	last;
3219	}
3220	}
3221
3222	if (!defined $found_tor) {
3223	&log("\nWARNING: $want_tor components wanted to use Tor but could not find it.\n");
3224	&log("This may cause data collection to run slower than it otherwise would.\n");
3225	return;
3226	}
3227
3228	# we'll run our own local copy of Tor exclusively for shepherd
3229	my $tordir = $CWD."/tor";
3230	if (!-d $tordir) {
3231	if (!mkdir $tordir) {
3232	&log("\nWARNING: Could not create $tordir, Tor not started!\n");
3233	&log("This may cause data collection to run slower than it otherwise would.\n");
3234	return;
3235	}
3236	}
3237
3238	&log("\nStarting Tor ($found_tor) in the background (wanted by $want_tor components).\n");
3239	my $pid = fork;
3240	if (!defined $pid) {
3241	# failed
3242	&log("Failed to start $found_tor: $!\n");
3243	return;
3244	} elsif ($pid > 0) {
3245	# parent
3246	sleep 2; # wait a few seconds for Tor to start
3247
3248	# test that it is running
3249	if (!kill 0, $pid) {
3250	&log("Tor doesn't seem to be running on pid $pid anymore, ignoring Tor option.\n");
3251	} else {
3252	&log("Tor appears to have successfully started (pid $pid).\n");
3253	$plugin_data->{tor_address} = "127.0.0.1:9051";
3254	$plugin_data->{tor_pid} = $pid;
3255	}
3256	} else {
3257	# child
3258	exec $found_tor,"SocksListenAddress","127.0.0.1:9051","MaxCircuitDirtiness","30","DataDirectory",$tordir;
3259	exit(1); # we won't reach this
3260	}
3261	}
3262
3263
3264	sub stop_tor
3265	{
3266	if (defined $plugin_data->{tor_pid}) {
3267	# INTR sig stops tor
3268	kill 2,$plugin_data->{tor_pid};
3269	}
3270	}
3271
3272	sub test_tor
3273	{
3274	&start_tor;
3275	return if (!defined $plugin_data->{tor_pid}); # no components require it
3276
3277	&log("\nSome components want to use Tor.\n".
3278	"Testing that it is working by connecting to www.google.com via Tor...\n\n");
3279
3280	sleep 10;
3281
3282	use LWP::Protocol::http;
3283	my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
3284
3285	# override LWP::Protocol::http's _new_socket method with our own
3286	local($^W) = 0;
3287	*LWP::Protocol::http::_new_socket = \&socks_new_socket;
3288
3289	# test that it works
3290	my $retries = 0;
3291	my $data;
3292	while ($retries < 10) {
3293	$retries++;
3294	&log("Connecting to www.google.com (try $retries) ... ");
3295	$data = &fetch_file("http://www.google.com/");
3296	last if (($data) && ($data =~ /Google/i));
3297
3298	sleep 10;
3299	}
3300
3301	if (($data) && ($data =~ /Google/i)) {
3302	&log("\nSUCCESS.\nTor appears to be working!\n");
3303	} else {
3304	&log("Tor doesn't appear to be working. Suggest you look into this!\n");
3305	}
3306
3307	*LWP::Protocol::http::_new_socket = $orig_new_socket;
3308	&stop_tor;
3309
3310	sleep 2;
3311	}
3312
3313	##############################################################################
3314	# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
3315
3316	sub socks_new_socket
3317	{
3318	my($self, $host, $port, $timeout) = @_;
3319
3320	my ($socks_ip,$socks_port) = split(/:/,$plugin_data->{tor_address});
3321
3322	local($^W) = 0; # IO::Socket::INET can be noisy
3323	my $sock = $self->socket_class->new(
3324	PeerAddr => $socks_ip,
3325	PeerPort => $socks_port,
3326	Proto => 'tcp');
3327
3328	unless ($sock) {
3329	# IO::Socket::INET leaves additional error messages in $@
3330	$@ =~ s/^.*?: //;
3331	&log("Can't connect to $host:$port ($@)\n");
3332	return undef;
3333	}
3334
3335	# perl 5.005's IO::Socket does not have the blocking method.
3336	eval { $sock->blocking(0); };
3337
3338	# establish connectivity with socks server - SOCKS4A protocol
3339	print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
3340	(pack 'x') .
3341	$host . (pack 'x');
3342
3343	my $received = "";
3344	my $timeout_time = time + $timeout;
3345	while ($sock->sysread($received, 8) && (length($received) < 8) ) {
3346	select(undef, undef, undef, 0.25);
3347	last if ($timeout_time < time);
3348	}
3349
3350	if ($timeout_time < time) {
3351	&log("Timeout ($timeout) while connecting via SOCKS server\n");
3352	return $sock;
3353	}
3354
3355	my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
3356	&log("Connection via SOCKS4A server rejected or failed\n") if ($req_status == 0x5b);
3357	&log("Connection via SOCKS4A server because client is not running identd\n") if ($req_status == 0x5c);
3358	&log("Connection via SOCKS4A server because client's identd could not confirm the user\n") if ($req_status == 0x5d);
3359
3360	$sock;
3361	}
3362
3363	##############################################################################

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 440

Download in other formats: