Context Navigation

shepherd @ 609

Revision 609, 125.3 kB (checked in by max, 6 years ago)
No time test necessary when run with --dontcallgrabbers
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 609

Download in other formats: