Context Navigation

shepherd @ 571

Revision 571, 116.1 kB (checked in by lincoln, 6 years ago)
added --set-icons to populate channel icon graphics
Property svn:executable set to ``*

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 571

Download in other formats: