Context Navigation

dog @ 233

Revision 233, 47.4 kB (checked in by max, 7 years ago)
Undo changeset [231], apparently my_die() is needed in dog after all.
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	my $myprogname = 'dog';
4	my $progname = 'shepherd';
5	my $version = '0.3.3';
6
7	# 'dog'
8	# "Shepherd"
9	# A wrapper for various Aussie TV guide data grabbers
10	#
11	# Use --help for command-line options.
12	#
13	# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
14	# make one cohesive reliable data set. It works by calling a series of
15	# scripts that grab data from a large variety of sources, and then
16	# analysing the resulting XML data sets and determining which of the many
17	# is the most reliable.
18
19	# Shepherd runs in 4 passes:
20	# pass 1: (app/shepherd) Checks that all components are up-to-date, auto-
21	# updates if not.
22	# Passes control onto shepherd
23	# pass 2: (engine/dog) calls grabbers to fill in missing data
24	# pass 3: (engine/dog) calls reconciler to reconcile overlapping data
25	# and normalize programme titles to our preferred title
26	# pass 4: (engine/dog) calls postprocessors to postprocess data
27	# (e.g. flag HDTV programmes, augment with IMDb etc.)
28
29	# Changelog:
30	# 0.3.1 : split 'dog' into its own engine
31
32	BEGIN { *CORE::GLOBAL::die = \&my_die; }
33
34	use strict;
35	no strict 'refs';
36
37	use LWP::UserAgent;
38	use Getopt::Long;
39	use Data::Dumper;
40	use XMLTV;
41	use POSIX qw(strftime mktime);
42	use Date::Manip;
43	use Algorithm::Diff;
44	use List::Compare;
45
46	# ---------------------------------------------------------------------------
47	# --- Global Variables
48	# ---------------------------------------------------------------------------
49
50	my @options = @ARGV;
51
52	# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
53	# it will try /opt/shepherd/ instead.
54	my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
55	-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
56	chdir($CWD);
57
58	#### analyzer settings ####
59	# the following thresholds are used to control whether we keep calling grabbers or
60	# not.
61
62	my %policy;
63	$policy{timeslot_size} = (5 * 60); # 5 minute slots
64
65	# PEAK timeslots -
66	# between 4.30pm and 11.30pm every day, only allow a maximum of
67	# 15 minutes "programming data" missing
68	# if there is more than this, we will continue asking grabbers for more
69	# programming on this channel
70	$policy{peak_max_missing} = 15*60; # up to 15 mins max allowed missing
71	$policy{peak_start} = (16(6060))+(30*60); # 4.30pm
72	$policy{peak_stop} = (23(6060))+(30*60); # 11.30pm
73
74	# NON-PEAK timeslots -
75	# between midnight and 6.15am every day, only allow up to 6 hours missing
76	# if there is more than this, we will continue asking grabbers for more
77	# programming on this channel
78	$policy{nonpeak_max_missing} = 6(6060); # up to 6 hours can be missing
79	$policy{nonpeak_start} = 0; # midnight
80	$policy{nonpeak_stop} = (6(6060))+(15*60); # 6.15am
81
82	# all other timeslots - (6.15am-4.30pm, 11.30pm-midnight)
83	# allow up to 60 minutes maximum missing programming
84	$policy{other_max_missing} = 60*60; # up to 60 mins max allowed missing
85
86	# if a postprocessor failed 5 times in a row, automatically disable it
87	$policy{postprocessor_disable_failure_threshold} = 5;
88
89	# don't accept programmes that last for longer than 8 hours.
90	$policy{max_programme_length} = (8 * 60 * 60); # 8 hours
91
92	#### end analyzer section ####
93
94	my $opt = { };
95	my $pref_title_source;
96	my $mirror_site;
97	my $debug = 0;
98	my $components = { };
99	my $gscore;
100	my $region;
101	my $channels;
102	my $opt_channels;
103	my $config_file = "$CWD/$progname.conf";
104	my $channels_file = "$CWD/channels.conf";
105	my $days = 7;
106	my $missing;
107	my $timeslice;
108	my $grabbed;
109	my $gmt_offset;
110	my $grabber_found_all_data;
111	my $writer;
112	my $components_used = "";
113
114	# postprocessing
115	my $langs = [ 'en' ];
116	my $plugin_data = { };
117	my $channel_data = { };
118	my $reconciler_found_all_data;
119	my $input_postprocess_file = "";
120
121	# OBSOLETE: will be removed
122	my $preferred;
123	my $title_translation_table;
124	my $pref_order;
125
126	# ---------------------------------------------------------------------------
127	# --- Setup
128	# ---------------------------------------------------------------------------
129
130	# Any options Shepherd doesn't understand, we'll pass to the grabber(s)
131	Getopt::Long::Configure(qw/pass_through/);
132	&get_command_line_options;
133
134	if ($opt->{version}) { print "$version\n"; exit 0; } # This is horrible
135	$\| = 1;
136	print ucfirst($myprogname) . " v$version\n\n";
137
138	exit 0 if ($opt->{version});
139	die "run tv_grab_au --help for details.\n" if ($opt->{help});
140
141	&read_config_file;
142	&read_channels_file;
143
144	# ---------------------------------------------------------------------------
145	# --- Go!
146	# ---------------------------------------------------------------------------
147
148	&calc_date_range;
149	&grab_data;
150	&reconcile_data;
151	&postprocess_data;
152	&output_data;
153	&write_config_file;
154
155	# ---------------------------------------------------------------------------
156	# --- Subroutines
157	# ---------------------------------------------------------------------------
158
159	# -----------------------------------------
160	# Subs: Grabbing
161	# -----------------------------------------
162
163	sub grab_data
164	{
165	my $used_grabbers = 0;
166
167	printf "\nGrabber stage.\n";
168
169	&analyze_plugin_data("",1);
170
171	while (my $grabber = choose_grabber())
172	{
173	$grabber_found_all_data = 0;
174	$used_grabbers++;
175
176	$components->{$grabber}->{laststatus} = "unknown";
177
178	printf "\nSHEPHERD: Using grabber: (%d) %s\n", $used_grabbers, $grabber;
179
180	my $output = "$CWD/grabbers/$grabber/output.xmltv";
181
182	my $comm = "$CWD/grabbers/$grabber/$grabber " .
183	"--region $region " .
184	"--output $output";
185
186	# Category 1 grabbers (i.e. slow ones) are requested to only fetch the timeslice
187	# that we need. Category 2 grabbers are requested to get everything, since there's
188	# very little cost in grabbing that extra data, and we can use it in the reconciler
189	# to verify that everything looks OK.
190	if (query_config($grabber, 'category') == 1)
191	{
192	printf "$grabber is Category 1: grabbing timeslice.\n" if ($debug);
193
194	record_requested_chandays($grabber, $timeslice);
195
196	if ($timeslice->{start} != 0)
197	{
198	$comm .= " " .
199	query_config($grabber, 'option_days_offset') .
200	" " .
201	$timeslice->{start};
202	}
203
204	my $n = $timeslice->{stop} + 1;
205	if ($timeslice->{start} != 0
206	and
207	!query_config($grabber, 'option_offset_eats_days'))
208	{
209	$n -= $timeslice->{start};
210	}
211	$comm .= " " .
212	query_config($grabber, 'option_days') .
213	" " .
214	$n;
215
216	# Write a temporary channels file specifying only the channels we want
217	my $tmpchans;
218	foreach (@{$timeslice->{chans}})
219	{
220	$tmpchans->{$_} = $channels->{$_};
221	}
222	my $tmpcf = "$CWD/channels.conf.tmp";
223	write_file($tmpcf, 'temporary channels', [ $tmpchans ], [ 'channels' ]);
224	$comm .= " --channels_file $tmpcf";
225	}
226	else
227	{
228	printf "$grabber is category 2: grabbing everything.\n" if ($debug);
229	$comm .= " --days $days" if ($days);
230	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
231	$comm .= " --channels_file $channels_file";
232	}
233	$comm .= " --debug" if ($debug);
234	$comm .= " @ARGV" if (@ARGV);
235
236	my $retval = 0;
237	if ((defined $opt->{dontcallgrabbers}) && ($opt->{dontcallgrabbers})) {
238	printf "SHEPHERD: not calling grabber because of --dontcallgrabbers option, but will instead use existing $output\n";
239	printf "SHEPHERD: would have called: $comm\n" if ($debug);
240	} else {
241	printf "SHEPHERD: Excuting command: $comm\n";
242	chdir "$CWD/grabbers/$grabber/";
243	$retval = call_prog($comm);
244	chdir $CWD;
245	}
246
247	if ($retval != 0) {
248	printf "grabber returned with non-zero return code $retval: assuming it failed.\n";
249	next;
250	}
251
252	# soak up the data we just collected
253	&soak_up_data($grabber, $output, "grabber");
254	$components->{$grabber}->{laststatus} = $plugin_data->{$grabber}->{laststatus};
255	$components->{$grabber}->{lastdata} = time if ($plugin_data->{$grabber}->{valid});
256
257	# check to see if we have all the data we want
258	$grabber_found_all_data = &analyze_plugin_data("analysis of all grabbers so far");
259
260	# Record what we grabbed from cacheable C1 grabbers
261	if (query_config($grabber, 'category') == 1 and query_config($grabber, 'cache'))
262	{
263	my $missing_before = convert_dayhash_to_list($missing);
264	my $missing_after = convert_dayhash_to_list(detect_missing_data());
265	my $list = List::Compare->new($missing_before, $missing_after);
266	my @grabbed = $list->get_symmetric_difference();
267	printf "Grabbed: " . join (', ', @grabbed) . ".\n" if ($debug);
268	record_cached($grabber, @grabbed);
269	write_config_file();
270	}
271
272	last if ($grabber_found_all_data);
273	}
274
275
276	if ($used_grabbers == 0)
277	{
278	printf "No valid grabbers installed/enabled!\n";
279	return;
280	}
281
282	unless ($grabber_found_all_data)
283	{
284	printf "SHEPHERD: Ran through ALL grabbers but still missing data!!! :(\n";
285	return;
286	}
287	}
288
289	# -----------------------------------------
290	# Subs: Intelli-random grabber selection
291	# -----------------------------------------
292
293	sub choose_grabber
294	{
295	if (defined $gscore) # Reset score hash
296	{
297	foreach (keys %$gscore)
298	{
299	$gscore->{$_} = 0;
300	}
301	}
302	else # Create score hash
303	{
304	foreach (query_grabbers())
305	{
306	unless ($components->{$_}->{disabled})
307	{
308	$gscore->{$_} = 0;
309	if (query_config($_, 'category') == 1 and query_config($_, 'cache'))
310	{
311	$gscore->{$_ . ' [cache]'} = 0;
312	}
313	}
314	}
315	}
316
317	$missing = detect_missing_data();
318	$timeslice = find_best_timeslice();
319
320	if ($debug)
321	{
322	printf "Best timeslice: day%s of channels %s (%d chandays).\n",
323	($timeslice->{start} == $timeslice->{stop} ?
324	" $timeslice->{start}" :
325	"s $timeslice->{start} - $timeslice->{stop}"),
326	join(', ', @{$timeslice->{chans}}),
327	$timeslice->{chandays};
328	}
329
330	my $total = score_grabbers();
331
332	if ($debug)
333	{
334	printf "Grabber selection:\n";
335	foreach (sort { $gscore->{$b} <=> $gscore->{$a} } keys %$gscore)
336	{
337	next if ($_ =~ /\[cache\]/);
338
339	my $score = $gscore->{$_};
340	my $cscore = $gscore->{"$_ [cache]"};
341	my $cstr = $cscore ? "(inc. $cscore cache pts)" : "";
342
343	if ($opt->{randomize})
344	{
345	printf "%15s %6.1f%% %9s %s\n",
346	$_,
347	($total ? 100* $score / $total : 0),
348	"$score pts",
349	$cstr;
350	}
351	else
352	{
353	printf "%15s %4s pts %s\n",
354	$_,
355	$score,
356	$cstr;
357	}
358	}
359	}
360
361	return undef unless ($total);
362
363	# Select a grabber
364
365	# If the user has specified a pref_title_source -- i.e. he is
366	# transitioning from a known grabber -- then we make sure it
367	# has run at least once, to build the list of title translations.
368	if ($pref_title_source)
369	{
370	my @prefs = split(/,/, $pref_title_source);
371	foreach my $grabber (@prefs)
372	{
373	unless ($components->{$grabber}->{lastdata})
374	{
375	printf "Need to build title translation list for transitional grabber $grabber.\n";
376	return select_grabber($grabber, $gscore) if ($gscore->{$grabber});
377	printf "WARNING: Can't run $grabber to build title translation list!\n";
378	}
379	}
380	}
381
382	# Either do it randomly based on scores, or just return the
383	# highest-scoring grabber, depending on whether --randomize has
384	# been used.
385
386	my $r = int(rand($total));
387	my $c = 0;
388	my $best;
389
390	foreach my $grabber (keys %$gscore)
391	{
392	next if (!$gscore->{$grabber} or $grabber =~ /\[cache\]/);
393	if ($opt->{randomize})
394	{
395	if ($r >= $c and $r < ($c + $gscore->{$grabber}))
396	{
397	return select_grabber($grabber, $gscore);
398	}
399	$c += $gscore->{$grabber};
400	}
401	else
402	{
403	if (!$best or $gscore->{$grabber} > $gscore->{$best})
404	{
405	$best = $grabber;
406	}
407	}
408	}
409
410	if ($opt->{randomize} or !$best)
411	{
412	die "ERROR: failed to choose grabber.";
413	}
414	return select_grabber($best, $gscore);
415	}
416
417	sub select_grabber
418	{
419	my ($grabber, $gscore) = @_;
420
421	printf "Selected $grabber.\n" if ($debug);
422	if (query_config($grabber, 'category') == 2)
423	{
424	# We might want to run C1 grabbers multiple times
425	# to grab various timeslices, but not C2 grabbers,
426	# which should get everything at once.
427	delete $gscore->{$grabber};
428	}
429	return $grabber;
430	}
431
432	# Grabbers earn 1 point for each slot or chanday they can fill.
433	# This score is multiplied if the grabber:
434	# * is a category 2 grabber (i.e. fast/cheap)
435	# * is a category 1 grabber that has the data we want in a cache
436	# * can supply high-quality data
437	# Very low quality grabbers score 0 unless we need them; i.e. they're backups.
438	sub score_grabbers
439	{
440	my ($score, $total, $day, $catbonus, $dqbonus, $mult, $key);
441
442	my $bestdq = 0;
443
444	# Compare C2 grabbers against the raw missing file, because we'll get
445	# everything. But compare C1 grabbers against the timeslice, because we'll
446	# only ask them for a slice. This goes for the [cache] and regular C1s.
447	foreach my $grabber (keys %$gscore)
448	{
449	# for each slot, say whether we can fill it or not -- that is,
450	# whether we support this channel and this day #.
451
452	my $hits = 0;
453	my $cat = query_config($grabber, 'category');
454	my $dq = query_config($grabber, 'quality');
455
456	if ($cat == 1)
457	{
458	$key = cut_down_missing($grabber);
459	# printf "Grabber $grabber is Category 1: comparing capability to best timeslice.\n" if ($debug);
460	}
461	else
462	{
463	$key = $missing;
464	# printf "Grabber $grabber is Category 2: comparing capability to all wanted channels and days.\n" if ($debug);
465	}
466
467	if ($grabber =~ /\[cache\]/)
468	{
469	$hits = find_cache_hits($grabber, $key);
470	}
471	else
472	{
473	foreach my $day (sort keys %$key)
474	{
475	my $val = supports_day($grabber, $day);
476	next unless ($val);
477	# printf "Day $day:" if ($debug);
478	foreach my $ch (@{$key->{$day}})
479	{
480	if (supports_channel($grabber, $ch, $day))
481	{
482	# printf " $ch" if ($debug);
483	$hits += $val;
484	}
485	}
486	# printf "\n" if $debug;
487	$hits = 1 if ($hits > 0 and $hits < 1);
488	}
489	}
490
491	my $catbonus = 1;
492	$catbonus = 3 if ($cat == 2);
493	if ($grabber =~ /\[cache\]/)
494	{
495	# Bonus is on a sliding scale between 1 and 2 depending on
496	# % of required data in cache
497	$catbonus += $hits / $timeslice->{chandays};
498	}
499
500	my $dqbonus = 2 ** ($dq-1);
501
502	my $mult = $dq ** $catbonus;
503
504	my $score = int($hits * $mult);
505
506	if ($debug)
507	{
508	my $str = sprintf "Grabber %s can supply %d chandays",
509	$grabber, $hits;
510	if ($hits)
511	{
512	$str .= sprintf " at x%.1f (cat: %d, DQ: %d): %d pts",
513	$mult,
514	$cat,
515	$dq,
516	$score;
517	}
518	printf "$str.\n";
519	}
520
521	$gscore->{$grabber} += $score;
522	$total += $score;
523	if ($grabber =~ /\[cache\]/)
524	{
525	$gscore->{query_name($grabber)} += $score;
526	}
527
528	if ($score and $dq > $bestdq)
529	{
530	$bestdq = $dq;
531	}
532	}
533
534	# Eliminate grabbers of data quality 1 if there are any better-quality
535	# alternatives when using randomize.
536	if ($opt->{randomize})
537	{
538	foreach (keys %$gscore)
539	{
540	if ($gscore->{$_}
541	and
542	query_config($_, 'quality') == 1
543	and
544	$bestdq > 1)
545	{
546	$total -= $gscore->{$_};
547	$gscore->{$_} = 0;
548	printf "Zeroing grabber $_ due to low data quality.\n" if ($debug);
549	}
550	}
551	}
552
553	return $total;
554	}
555
556	# Return 1 if the grabber can provide data for this channel, else 0.
557	sub supports_channel
558	{
559	my ($grabber, $ch, $day) = @_;
560
561	my $mdpc = query_config($grabber, 'max_days_per_chan');
562	if ($mdpc)
563	{
564	if ($mdpc->{$ch})
565	{
566	return ($mdpc->{$ch} > $day);
567	}
568	}
569
570	my $channels_supported = query_config($grabber, 'channels');
571	unless (defined $channels_supported)
572	{
573	printf "WARNING: Grabber $grabber has no channel support " .
574	"specified in config.\n";
575	$channels_supported = '';
576	}
577
578	return 1 unless ($channels_supported); # Empty string means we support all
579
580	$ch =~ s/ /_/g;
581	my $match = ($channels_supported =~ /\b$ch\b/);
582	my $exceptions = ($channels_supported =~/^-/);
583	return ($match != $exceptions);
584	}
585
586	# Return 0 if the grabber can't provide data for this day,
587	# 1 if it can reliably, and 0.5 if it can unreliably.
588	#
589	# Note that a max_days of 7 means the grabber can retrieve data for
590	# today plus 6 days.
591	sub supports_day
592	{
593	my ($grabber, $day) = @_;
594
595	return 0 unless ($day < query_config($grabber, 'max_days'));
596	return 0.5 if ($day >= query_config($grabber, 'max_reliable_days'));
597	return 1;
598	}
599
600	sub find_cache_hits
601	{
602	my ($grabber, $key) = @_;
603
604	$grabber = query_name($grabber);
605
606	return 0 unless ($components->{$grabber}->{cached});
607
608	my $hits = 0;
609
610	foreach my $day (keys %$key)
611	{
612	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
613	foreach my $ch (@{$key->{$day}})
614	{
615	$hits++ if (grep(/^$date:$ch$/, @{$components->{$grabber}->{cached}}));
616	}
617	}
618	return $hits;
619	}
620
621	# Build a dayhash of what channel/day data we're currently missing.
622	# I think granularity of one day is good for now; could possibly be
623	# made more fine-grained if we think grabbers will support that.
624	sub detect_missing_data
625	{
626	my $m = { };
627
628	my $chandays = 0;
629	foreach my $ch (keys %$channels)
630	{
631	# is this channel missing too much data?
632	unless ($channel_data->{$ch}->{analysis}->{data_ok}) {
633	# not ok - record which days are bad
634	foreach my $day (@{($channel_data->{$ch}->{analysis}->{day})}) {
635	push(@{($m->{($day->{num})})}, $ch) unless ($day->{day_ok});
636	}
637	}
638	}
639
640	foreach my $day (keys %$m)
641	{
642	$m->{$day} = [ sort @{$m->{$day}} ];
643	$chandays += scalar(@{$m->{$day}}) if ($debug);
644	}
645
646	if ($debug)
647	{
648	printf "Need data for days " . join(", ", sort keys %$m) .
649	" ($chandays chandays).\n";
650	}
651	return $m;
652	}
653
654	# Find the largest timeslice in the current $missing dayhash; i.e.
655	# something like "Days 4 - 6 of ABC and SBS." This works by iterating
656	# through the days and looking for overlaps where consecutive days
657	# want the same channels.
658	sub find_best_timeslice
659	{
660	my ($overlap, $a);
661	my $slice = { 'chandays' => 0 };
662
663	foreach my $day (0 .. $days-1)
664	{
665	consider_slice($slice, $day, $day, @{$missing->{$day}});
666	$overlap = $missing->{$day};
667	foreach my $nextday (($day + 1) .. $days-1)
668	{
669	last unless ($missing->{$nextday});
670	$a = Algorithm::Diff::LCS($overlap, $missing->{$nextday});
671	last unless ($a and @{$a});
672	consider_slice($slice, $day, $nextday, @{$a});
673	$overlap = $a;
674	}
675	}
676	return $slice;
677	}
678
679	sub consider_slice
680	{
681	my ($slice, $startday, $stopday, @chans) = @_;
682
683	my $challenger = ($stopday - $startday + 1) * scalar(@chans);
684	return unless ($challenger > $slice->{chandays});
685
686	# We have a winner!
687	$slice->{start} = $startday;
688	$slice->{stop} = $stopday;
689	$slice->{chans} = [ @chans ];
690	$slice->{chandays} = $challenger;
691	}
692
693	# Record what a cacheable C1 grabber has just retrieved for us,
694	# so we know next time that this data can be grabbed quickly.
695	sub record_cached
696	{
697	my ($grabber, @grabbed) = @_;
698
699	printf "Recording cache for grabber $grabber.\n" if ($debug);
700
701	my $gcache = $components->{$grabber}->{cached};
702	$gcache = [ ] unless ($gcache);
703	my @newcache;
704	my $today = strftime("%Y%m%d", localtime);
705
706	# remove old chandays
707	foreach my $chanday (@$gcache)
708	{
709	$chanday =~ /(\d+):(.*)/;
710	if ($1 >= $today)
711	{
712	push (@newcache, $chanday);
713	}
714	}
715
716	# record new chandays
717	foreach my $chanday (@grabbed)
718	{
719	push (@newcache, $chanday) unless (grep(/^$chanday$/, @newcache));
720	}
721	$components->{$grabber}->{cached} = [ @newcache ];
722	}
723
724	# Takes a dayhash and returns it as a list like this:
725	# ( "20061018:ABC", "20061018:Seven", ... )
726	sub convert_dayhash_to_list
727	{
728	my $h = shift;
729
730	my @ret;
731	foreach my $day (keys %$h)
732	{
733	my $date = substr(DateCalc("today", "+ $day days"), 0, 8);
734	foreach my $ch (@{$h->{$day}})
735	{
736	push (@ret, "$date:$ch");
737	}
738	}
739	@ret = sort @ret;
740	return \@ret;
741	}
742
743	# If we're about to re-try a grabber, make sure that we're not asking
744	# it for the same data. That is, prevent a broken C1 grabber causing
745	# an infinite loop.
746	sub record_requested_chandays
747	{
748	my ($grabber, $slice) = @_;
749
750	printf "Recording timeslice request; will not request these chandays " .
751	"from $grabber again.\n" if ($debug);
752
753	my @requested;
754	for my $day ($slice->{start} .. $slice->{stop})
755	{
756	foreach my $ch (@{$slice->{chans}})
757	{
758	push @requested, "$day:$ch";
759	}
760	}
761	if ($grabbed->{$grabber})
762	{
763	push @{$grabbed->{$grabber}}, @requested;
764	}
765	else
766	{
767	$grabbed->{$grabber} = [ @requested ];
768	}
769	}
770
771	# If this grabber has been called previously, remove those chandays
772	# from the current request -- we don't want to ask it over and over
773	# for a timeslice that it has already failed to provide.
774	sub cut_down_missing
775	{
776	my $grabber = shift;
777
778	$grabber = query_name($grabber);
779	my $dayhash = {};
780
781	# Take the timeslice and expand it to a dayhash, while pruning
782	# any chandays that have previously been requested from this
783	# grabber.
784	foreach my $day ($timeslice->{start} .. $timeslice->{stop})
785	{
786	my @chans;
787	foreach my $ch (@{$timeslice->{chans}})
788	{
789	unless ($grabbed->{$grabber} and grep(/$day:$ch/, @{$grabbed->{$grabber}}))
790	{
791	push (@chans, $ch)
792	}
793	}
794	$dayhash->{$day} = [ @chans ] if (@chans);
795	}
796
797	return $dayhash;
798	}
799
800	# -----------------------------------------
801	# Subs: Analyzing data
802	# -----------------------------------------
803
804	# interpret xmltv data from this grabber/postprocessor
805	sub soak_up_data
806	{
807	my ($plugin, $output, $plugintype) = @_;
808
809	if (! -r $output) {
810	printf "SHEPHERD: Warning: plugin '%s' output file '%s' does not exist\n",$plugin,$output;
811	return;
812	}
813
814	my $this_plugin = $plugin_data->{$plugin};
815	printf "SHEPHERD: Started parsing XMLTV from '%s' in '%s' .. any errors below are from parser:\n",$plugin,$output;
816	eval { $this_plugin->{xmltv} = XMLTV::parsefiles($output); };
817	printf "SHEPHERD: Completed XMLTV parsing from '%s'\n",$plugin;
818
819	if (!($this_plugin->{xmltv})) {
820	printf "WARNING: Plugin $plugin didn't seem to return any valid XMLTV!\n";
821	return;
822	}
823
824	$this_plugin->{valid} = 1;
825	$this_plugin->{output_filename} = $output;
826	$components_used .= " + ".$plugin."(v".$components->{$plugin}->{ver}.")";
827
828	my $xmltv = $this_plugin->{xmltv};
829	my ($encoding, $credits, $chan, $progs) = @$xmltv;
830	$this_plugin->{total_duration} = 0;
831	$this_plugin->{programmes} = 0;
832	$this_plugin->{progs_with_invalid_date} = 0; # explicitly track unparsable dates
833	$this_plugin->{progs_too_long} = 0; # explicitly track exxcessive programme durations
834	$this_plugin->{progs_with_unknown_channel} = 0; # explicitly track unknown channels
835
836	my $seen_channels_with_data = 0;
837
838	#
839	# first iterate through all programmes and see if there are any channels we don't know about
840	#
841	my %chan_xml_list;
842	foreach my $ch (sort keys %{$channels}) {
843	$chan_xml_list{($channels->{$ch})} = 1;
844	}
845	foreach my $prog (@$progs) {
846	if (!defined $chan_xml_list{($prog->{channel})}) {
847	$this_plugin->{progs_with_unknown_channel}++;
848	printf " - WARNING: plugin '%s' returned data for unknown channel '%s': ignored.\n",$plugin,$prog->{channel};
849	$chan_xml_list{($prog->{channel})} = 1; # so we warn only once
850	}
851	}
852
853	# iterate thru channels
854	foreach my $ch (sort keys %{$channels}) {
855	my $seen_progs_on_this_channel = 0;
856
857	# iterate thru programmes per channel
858	foreach my $prog (@$progs) {
859	next if ($prog->{channel} ne $channels->{$ch});
860
861	my $t1 = &parse_xmltv_date($prog->{start});
862	my $t2 = &parse_xmltv_date($prog->{stop});
863
864	if (!$t1 \|\| !$t2) {
865	printf " - WARNING: plugin '%s' returned programme data with invalid timestamp format: \"%s\": can't parse.\n",
866	$plugin,(!$t1 ? $prog->{start} : $prog->{stop}) if (!$this_plugin->{progs_with_invalid_date});
867	$this_plugin->{progs_with_invalid_date}++;
868	next;
869	}
870
871	my $this_duration = $t2 - $t1;
872	if ($this_duration > $policy{max_programme_length}) {
873	printf " - WARNING: plugin '%s' returned programme data with duration exceeding limit (%dh%dm): ignored.\n",
874	$plugin, int($policy{max_programme_length} / 3600),
875	int(($policy{max_programme_length} % 3600) / 60)
876	if (!$this_plugin->{progs_too_long});
877	$this_plugin->{progs_too_long}++;
878	next;
879	}
880
881	# store plugin-specific stats
882	$this_plugin->{programmes}++;
883	$this_plugin->{total_duration} += $this_duration;
884	$seen_progs_on_this_channel++;
885	$this_plugin->{earliest_data_seen} = $t1 if (!defined $this_plugin->{earliest_data_seen});
886	$this_plugin->{earliest_data_seen} = $t1 if ($t1 < $this_plugin->{earliest_data_seen});
887	$this_plugin->{latest_data_seen} = $t2 if (!defined $this_plugin->{latest_data_seen});
888	$this_plugin->{latest_data_seen} = $t2 if ($t2 > $this_plugin->{latest_data_seen});
889
890	# store channel-specific stats
891	$channel_data->{$ch}->{programmes}++;
892	$channel_data->{$ch}->{total_duration} += $this_duration;
893
894	# programme is outside the timeslots we are interested in.
895	next if ($t1 > $policy{endtime});
896	next if ($t2 < $policy{starttime});
897
898	# store timeslot info
899	my $start_slotnum = 0;
900	$start_slotnum = int(($t1 - $policy{starttime}) / $policy{timeslot_size})
901	if ($t1 >= $policy{starttime});
902
903	my $end_slotnum = ($policy{num_timeslots}-1);
904	$end_slotnum = int(($t2 - $policy{starttime}) / $policy{timeslot_size})
905	if ($t2 < $policy{endtime});
906
907	# add this programme into the global timeslots table for this channel
908	foreach my $slotnum ($start_slotnum..$end_slotnum) {
909	$channel_data->{$ch}->{timeslots}[$slotnum]++;
910	}
911	}
912
913	$seen_channels_with_data++ if ($seen_progs_on_this_channel > 0);
914	}
915
916	# print some stats about what we saw!
917	printf "SHEPHERD: %s '%s' returned data for %d channels, %d programmes, %dd%02dh%02dm%02ds duration, %s%s\n",
918	ucfirst($plugintype), $plugin, $seen_channels_with_data, $this_plugin->{programmes},
919	int($this_plugin->{total_duration} / 86400), # days
920	int(($this_plugin->{total_duration} % 86400) / 3600), # hours
921	int(($this_plugin->{total_duration} % 3600) / 60), # mins
922	int($this_plugin->{total_duration} % 60), # sec
923	(defined $this_plugin->{earliest_data_seen} ? (strftime "%a %e %b %H:%M - ", localtime($this_plugin->{earliest_data_seen})) : 'no data'),
924	(defined $this_plugin->{latest_data_seen} ? (strftime "%a %e %b %H:%M", localtime($this_plugin->{latest_data_seen})) : '');
925
926	$this_plugin->{laststatus} = sprintf "%dch/%dpr/%dhrs %s-%s",
927	$seen_channels_with_data, $this_plugin->{programmes},
928	int($this_plugin->{total_duration} / 3600),
929	(defined $this_plugin->{earliest_data_seen} ? (strftime "%a%d%b", localtime($this_plugin->{earliest_data_seen})) : 'no'),
930	(defined $this_plugin->{latest_data_seen} ? (strftime "%a%d%b", localtime($this_plugin->{latest_data_seen})) : 'data');
931
932	$plugin_data->{$plugin} = $this_plugin;
933	}
934
935
936	# analyze grabber data - do we have all the data we want?
937	sub analyze_plugin_data
938	{
939	my ($analysistype,$quiet) = @_;
940	printf "SHEPHERD: $analysistype:\n" unless $quiet;
941
942	my $total_channels = 0;
943
944	my $overall_data_ok = 1; # until proven otherwise
945
946	# iterate across each channel
947	foreach my $ch (sort keys %{$channels}) {
948	$total_channels++;
949
950	my $data;
951	my $lastpol = "";
952	$data->{data_ok} = 1; # unless proven otherwise
953	$data->{have} = 0;
954	$data->{missing} = 0;
955
956	for my $slotnum (0..($policy{num_timeslots}-1)) {
957	my $bucket_start_offset = ($slotnum * $policy{timeslot_size});
958
959	# work out day number of when this bucket is.
960	# number from 0 onwards. (i.e. today=0).
961	# for a typical 7 day grabber this will actually mean 8 days of data (0-7)
962	# with days 0 and 7 truncated to half-days
963	my $day = int(($bucket_start_offset + $policy{first_bucket_offset}) / 86400);
964
965	if (!defined $data->{day}->[$day]) {
966	$data->{day}->[$day]->{num} = $day;
967	$data->{day}->[$day]->{have} = 0;
968	$data->{day}->[$day]->{missing} = 0;
969	$data->{day}->[$day]->{missing_peak} = 0;
970	$data->{day}->[$day]->{missing_nonpeak} = 0;
971	$data->{day}->[$day]->{missing_other} = 0;
972
973	$data->{day}->[$day]->{day_ok} = 1; # until proven otherwise
974
975	# day changed, dump any 'already_missing' data
976	&dump_already_missing($data);
977	}
978
979	# we have programming data for this bucket. great! process next bucket
980	if ((defined $channel_data->{$ch}->{timeslots}[$slotnum]) &&
981	($channel_data->{$ch}->{timeslots}[$slotnum] > 0)) {
982
983	# if we have missing data queued up, push it now
984	&dump_already_missing($data);
985
986	&dump_already_missing_period($data->{day}->[$day],$lastpol)
987	if ($lastpol ne "");
988
989	$data->{day}->[$day]->{have} += $policy{timeslot_size};
990	$data->{have} += $policy{timeslot_size};
991	next;
992	}
993
994	# we don't have programming for this channel for this bucket
995
996	# some grabbers take HOURS to run. if this bucket (missing data) is for
997	# a time period now in the past, then don't include it
998	next if (($bucket_start_offset + $policy{starttime}) < time);
999
1000	# work out the localtime of when this bucket is
1001	my $bucket_seconds_offset = ($bucket_start_offset + $policy{first_bucket_offset}) % 86400;
1002
1003	# store details of where we are missing data
1004	if (!defined $data->{already_missing}) {
1005	$data->{already_missing} = sprintf "#%d/%02d:%02d",
1006	$day,
1007	int($bucket_seconds_offset / 3600),
1008	int(($bucket_seconds_offset % 3600) / 60);
1009	}
1010	$data->{already_missing_last} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
1011
1012	$data->{day}->[$day]->{missing} += $policy{timeslot_size};
1013	$data->{missing} += $policy{timeslot_size};
1014
1015	# work out what policy missing data for this bucket fits into
1016	my $pol;
1017	if (($bucket_seconds_offset >= $policy{peak_start}) &&
1018	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{peak_stop})) {
1019	$pol = "peak";
1020	} elsif (($bucket_seconds_offset >= $policy{nonpeak_start}) &&
1021	(($bucket_seconds_offset+$policy{timeslot_size}) <= $policy{nonpeak_stop})) {
1022	$pol = "nonpeak";
1023	} else {
1024	$pol = "other";
1025	}
1026
1027	&dump_already_missing_period($data->{day}->[$day],$lastpol)
1028	if (($lastpol ne $pol) && ($lastpol ne ""));
1029
1030	$lastpol = $pol;
1031
1032	$data->{day}->[$day]->{"missing_".$pol} += $policy{timeslot_size};
1033
1034	$data->{day}->[$day]->{"already_missing_".$pol."_start"} = $bucket_seconds_offset
1035	if (!defined $data->{day}->[$day]->{"already_missing_".$pol."_start"});
1036	$data->{day}->[$day]->{"already_missing_".$pol."_stop"} = $bucket_seconds_offset + $policy{timeslot_size} - 1;
1037
1038	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_peak} > $policy{peak_max_missing});
1039	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_nonpeak} > $policy{nonpeak_max_missing});
1040	$data->{day}->[$day]->{day_ok} = 0 if ($data->{day}->[$day]->{missing_other} > $policy{other_max_missing});
1041	$data->{data_ok} = 0 if ($data->{day}->[$day]->{day_ok} == 0);
1042	$overall_data_ok = 0 if ($data->{data_ok} == 0);
1043	}
1044
1045	# finished all timeslots in this channel.
1046	# if we have missing data queued up, push it now
1047	&dump_already_missing($data);
1048
1049	# fill in any last missing period data
1050	foreach my $day (@{($data->{day})}) {
1051	&dump_already_missing_period($day,"peak");
1052	&dump_already_missing_period($day,"nonpeak");
1053	&dump_already_missing_period($day,"other");
1054	}
1055
1056	my $statusstring = sprintf " > ch %s: %s programming: %s\n",
1057	$ch, pretty_duration($data->{have}),
1058	$data->{data_ok} ? "PASS (within thresholds)" : "FAIL, missing data over policy threshold:";
1059
1060	# display per-day missing data statistics
1061	foreach my $day (@{($data->{day})}) {
1062	unless ($day->{day_ok}) {
1063	$statusstring .= sprintf "\t".(strftime("%a %e %b",localtime($policy{starttime}+($day->{num}*86400)))).": ";
1064
1065	# do we have any data for this day?
1066	$statusstring .= "peak ".join(", ",(@{($day->{missing_peak_table})}))
1067	if (($day->{missing_peak}) && ($day->{missing_peak} > $policy{peak_max_missing}));
1068
1069	$statusstring .= sprintf "%snon-peak %s",
1070	($day->{missing_peak} ? " / " : ""),
1071	join(", ",(@{($day->{missing_nonpeak_table})}))
1072	if (($day->{missing_nonpeak}) && ($day->{missing_nonpeak} > $policy{nonpeak_max_missing}));
1073
1074	$statusstring .= sprintf "%sother %s",
1075	(($day->{missing_peak} + $day->{missing_nonpeak}) > 0 ? " / " : ""),
1076	join(", ",(@{($day->{missing_other_table})}))
1077	if (($day->{missing_other}) && ($day->{missing_other} > $policy{other_max_missing}));
1078
1079	$statusstring .= "\n";
1080	}
1081	}
1082	printf $statusstring unless $quiet;
1083
1084	delete $channel_data->{$ch}->{analysis} if (defined $channel_data->{$ch}->{analysis});
1085	$channel_data->{$ch}->{analysis} = $data;
1086	}
1087
1088	printf " > OVERALL: %s\n", ($overall_data_ok ? "PASS" : "FAIL") unless $quiet;
1089
1090	return $overall_data_ok; # return 1 for good, 0 for need more
1091	}
1092
1093	# helper routine for filling in 'missing_all' array
1094	sub dump_already_missing
1095	{
1096	my $d = shift;
1097	if (defined $d->{already_missing}) {
1098	$d->{already_missing} .= sprintf "-%02d:%02d",
1099	int($d->{already_missing_last} / 3600),
1100	int(($d->{already_missing_last} % 3600) / 60)
1101	if (defined $d->{already_missing_last});
1102	push(@{($d->{missing_all})}, $d->{already_missing});
1103	delete $d->{already_missing};
1104	delete $d->{already_missing_last};
1105	}
1106	}
1107
1108	# helper routine for filling in per-day missing data
1109	# specific to peak/nonpeak/other
1110	sub dump_already_missing_period
1111	{
1112	my ($d,$p) = @_;
1113	my $startvar = "already_missing_".$p."_start";
1114	my $stopvar = "already_missing_".$p."_stop";
1115
1116	if (defined $d->{$startvar}) {
1117	push(@{($d->{"missing_".$p."_table"})},
1118	sprintf "%02d:%02d-%02d:%02d",
1119	int($d->{$startvar} / 3600),
1120	int(($d->{$startvar} % 3600) / 60),
1121	int($d->{$stopvar} / 3600),
1122	int(($d->{$stopvar} % 3600) / 60));
1123	delete $d->{$startvar};
1124	delete $d->{$stopvar};
1125	}
1126	}
1127
1128	# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
1129	# and indication of whether the duration is over its threshold or not
1130	sub pretty_duration
1131	{
1132	my ($d,$crit) = @_;
1133	my $s = "";
1134	$s .= sprintf "%dd",int($d / (606024)) if ($d >= (606024));
1135	$s .= sprintf "%dh",int(($d % (606024)) / (6060)) if (($d % (606024)) >= (6060));
1136	$s .= sprintf "%dm",int(($d % (6060)) / 60) if (($d % (6060)) >= 60);
1137	$s .= "no" if ($s eq "");
1138
1139	if (defined $crit) {
1140	$s .= "[!]" if ($d > $crit);
1141	}
1142	return $s;
1143	}
1144
1145	# work out date range we are expecting data to be in
1146	sub calc_date_range
1147	{
1148	# work out GMT offset - we only do this once
1149	if (!$gmt_offset) {
1150	# work out our gmt offset
1151	my @l = localtime(43200), my @g = gmtime(43200);
1152	$gmt_offset = (($l[2] - $g[2])(6060)) + (($l[1] - $g[1])*60);
1153	}
1154
1155	$policy{starttime} = time;
1156
1157	# set endtime as per $days less 1 day + hours left today
1158	$policy{endtime} = $policy{starttime} + ((606024)*($days-1)) + (86400 - (($policy{starttime} + $gmt_offset) % 86400));
1159
1160	# normalize starttime to beginning of next bucket
1161	$policy{starttime} += ($policy{timeslot_size} - ($policy{starttime} % $policy{timeslot_size}));
1162
1163	# work out how many seconds into a day our first bucket starts
1164	$policy{first_bucket_offset} = ($policy{starttime} + $gmt_offset) % 86400;
1165
1166	# normalize endtime to end of previous bucket
1167	$policy{endtime} -= ($policy{endtime} % $policy{timeslot_size});
1168
1169	# if we are working with an --offset, apply it now.
1170	$policy{starttime} += (86400 * $opt->{offset}) if ($opt->{offset});
1171
1172	# work out number of buckets
1173	$policy{num_timeslots} = ($policy{endtime} - $policy{starttime}) / $policy{timeslot_size};
1174	}
1175
1176
1177	# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
1178	# rather than the various other perl implementation which treat it as being in UTC/GMT
1179	sub parse_xmltv_date
1180	{
1181	my $datestring = shift;
1182	my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
1183	my $tz_offset = 0;
1184
1185	if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
1186	($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);
1187	($t[6],$t[7],$t[8]) = (-1,-1,-1);
1188
1189	# if input data has a timezone offset, then offset by that
1190	if ($datestring =~ /\+(\d{2})(\d{2})/) {
1191	$tz_offset = $gmt_offset - (($1(6060)) + ($2*60));
1192	} elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
1193	$tz_offset = $gmt_offset + (($1(6060)) + ($2*60));
1194	}
1195
1196	my $e = mktime(@t);
1197	return ($e+$tz_offset) if ($e > 1);
1198	}
1199	return undef;
1200	}
1201
1202	# -----------------------------------------
1203	# Subs: Reconciling data
1204	# -----------------------------------------
1205
1206	# for all the data we have, try to pick the best bits!
1207	sub reconcile_data
1208	{
1209	printf "\nReconciling data:\n\n";
1210
1211	my $num_grabbers = 0;
1212	my $input_files = "";
1213	my @input_file_list;
1214
1215	printf "Preferred title preferences from '$pref_title_source'\n"
1216	if ((defined $pref_title_source) &&
1217	($plugin_data->{$pref_title_source}) &&
1218	($plugin_data->{$pref_title_source}->{valid}));
1219
1220	printf "Preference for whose data we prefer as follows:\n";
1221	foreach my $proggy (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
1222	if ((!$components->{$proggy}->{disabled}) && ($plugin_data->{$proggy}) && ($plugin_data->{$proggy}->{valid})) {
1223	$num_grabbers++;
1224	printf " %d. %s (%s)\n", $num_grabbers, $proggy, $plugin_data->{$proggy}->{output_filename};
1225
1226	$input_files .= $plugin_data->{$proggy}->{output_filename}." ";
1227	push(@input_file_list,$plugin_data->{$proggy}->{output_filename});
1228	}
1229	}
1230
1231	if ($num_grabbers == 0) {
1232	die "Nothing to reconcile! There is no valid grabber data!\n";
1233	}
1234
1235	foreach my $reconciler (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
1236	next if ($components->{$reconciler}->{disabled});
1237	next if (!$components->{$reconciler}->{ready});
1238
1239	$reconciler_found_all_data = &call_data_processor("reconciler",$reconciler,$input_files);
1240
1241	if ((!$reconciler_found_all_data) && ($grabber_found_all_data)) {
1242	# urgh. this reconciler did a bad bad thing ...
1243	printf "SHEPHERD: XML data from reconciler $reconciler appears bogus, will try to use another reconciler\n";
1244	} else {
1245	printf "SHEPHERD: Data from reconciler $reconciler looks good\n";
1246	$input_postprocess_file = $plugin_data->{$reconciler}->{output_filename};
1247	}
1248
1249	last if ($input_postprocess_file ne "");
1250	}
1251
1252	if ($input_postprocess_file eq "") {
1253	# no reconcilers worked!!
1254	printf "SHEPHERD: WARNING: No reconcilers seemed to work! Falling back to concatenating the data together!\n";
1255
1256	my %w_args = ();
1257	$input_postprocess_file = "$CWD/input_preprocess.xmltv";
1258	my $fh = new IO::File ">$input_postprocess_file" \|\| die "could not open $input_postprocess_file for writing: $!\n";
1259	%w_args = (OUTPUT => $fh);
1260	XMLTV::catfiles(\%w_args, @input_file_list);
1261	}
1262	}
1263
1264
1265	# -----------------------------------------
1266	# Subs: Postprocessing
1267	# -----------------------------------------
1268
1269	sub postprocess_data
1270	{
1271	# for our first postprocessor, we feed it ALL of the XMLTV files we have
1272	# as each postprocessor runs, we feed in the output from the previous one
1273	# Shepherd checks the "completeness" of the data that comes out of a postprocessor & automatically
1274	# reverts back to the previous postprocessor if it was shown to be bad
1275
1276	# first time around: feed in reconciled data ($input_postprocess_file)
1277
1278	printf "\nPostprocessing stage:\n";
1279
1280	foreach my $postprocessor (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
1281	next if ($components->{$postprocessor}->{disabled});
1282	next if (!$components->{$postprocessor}->{ready});
1283
1284	my $found_all_data = call_data_processor("postprocessor",$postprocessor,$input_postprocess_file);
1285
1286	if ($found_all_data) {
1287	# accept what this postprocessor did to our output ...
1288	printf "SHEPHERD: accepting output from postprocessor $postprocessor, feeding it into next stage\n";
1289	$input_postprocess_file = $plugin_data->{$postprocessor}->{output_filename};
1290	delete $components->{$postprocessor}->{conescutive_failures} if (defined $components->{$postprocessor}->{conescutive_failures});
1291	next;
1292	}
1293
1294	# urgh. this postprocessor did a bad bad thing ...
1295	printf "SHEPHERD: XML data from postprocessor $postprocessor rejected, using XML from previous stage\n";
1296
1297	if (defined $components->{$postprocessor}->{conescutive_failures}) {
1298	$components->{$postprocessor}->{conescutive_failures}++;
1299	} else {
1300	$components->{$postprocessor}->{conescutive_failures} = 1;
1301	}
1302	printf "SHEPHERD: Postprocessor \"%s\" has now failed %d times in a row. %d more and it will be automatically disabled.\n",
1303	$postprocessor,
1304	$components->{$postprocessor}->{conescutive_failures},
1305	($policy{postprocessor_disable_failure_threshold} - $components->{$postprocessor}->{conescutive_failures});
1306
1307	if ($components->{$postprocessor}->{conescutive_failures} >= $policy{postprocessor_disable_failure_threshold}) {
1308	printf "SHEPHERD: Disabling Postprocessor \"$postprocessor\".\n";
1309	$components->{$postprocessor}->{disabled} = 1;
1310	}
1311	}
1312	}
1313
1314
1315	# -----------------------------------------
1316	# Subs: Postprocessing/Reconciler helpers
1317	# -----------------------------------------
1318
1319	sub call_data_processor
1320	{
1321	my ($data_processor_type, $data_processor_name, $input_files) = @_;
1322
1323	$components->{$data_processor_name}->{lastdata} = time;
1324	$components->{$data_processor_name}->{laststatus} = "unknown";
1325
1326	printf "\nSHEPHERD: Using %s: %s\n",$data_processor_type,$data_processor_name;
1327
1328	my $output = sprintf "%s/%ss/%s/output.xmltv",$CWD,$data_processor_type,$data_processor_name;
1329	my $comm = sprintf "%s/%ss/%s/%s",$CWD,$data_processor_type,$data_processor_name,$data_processor_name;
1330	$comm .= " --region $region" .
1331	" --channels_file $channels_file" .
1332	" --output $output";
1333	$comm .= " --days $days" if ($days);
1334	$comm .= " --offset $opt->{offset}" if ($opt->{offset});
1335	$comm .= " --debug" if ($debug);
1336	$comm .= " @ARGV" if (@ARGV);
1337
1338	$comm .= " --preftitle ".$plugin_data->{$pref_title_source}->{output_filename}
1339	if (($data_processor_type eq "reconciler") &&
1340	(defined $pref_title_source) &&
1341	($plugin_data->{$pref_title_source}) &&
1342	($plugin_data->{$pref_title_source}->{valid}));
1343
1344	$comm .= " $input_files";
1345	printf "SHEPHERD: Excuting command: $comm\n";
1346
1347	my $dir = sprintf "%s/%ss/%s/",$CWD,$data_processor_type,$data_processor_name;
1348	chdir $dir;
1349	my $retval = call_prog($comm);
1350	chdir $CWD;
1351
1352	if ($retval != 0) {
1353	printf "$data_processor_type returned with non-zero return code $retval: assuming it failed.\n";
1354	return 0;
1355	}
1356
1357	#
1358	# soak up the data we just collected and check it
1359	# YES - these are the SAME routines we used in the previous 'grabber' phase
1360	# but the difference here is that we clear out our 'channel_data' beforehand
1361	# so we can independently analyze the impact of this postprocessor.
1362	# if it clearly returns bad data, don't use that data (go back one step) and
1363	# flag the postprocessor as having failed. after 3 consecutive failures, disable it
1364	#
1365
1366	# clear out channel_data
1367	foreach my $ch (keys %{$channels}) {
1368	delete $channel_data->{$ch};
1369	}
1370
1371	# process and analyze it!
1372	&soak_up_data($data_processor_name, $output, $data_processor_type);
1373	my $have_all_data = &analyze_plugin_data("$data_processor_type $data_processor_name");
1374
1375	$components->{$data_processor_name}->{laststatus} = $plugin_data->{$data_processor_name}->{laststatus};
1376
1377	return $have_all_data;
1378	}
1379
1380
1381	sub output_data
1382	{
1383	# $input_postprocess_file contains our final output
1384	# send it to whereever --output told us to!
1385
1386	my $output_filename = "$CWD/output.xmltv";
1387	$output_filename = $opt->{output} if ($opt->{output});
1388
1389	my %writer_args = ( encoding => 'ISO-8859-1' );
1390	my $fh = new IO::File(">$output_filename") \|\|
1391	die "can't open $output_filename for writing: $!";
1392	$writer_args{OUTPUT} = $fh;
1393
1394	$writer = new XMLTV::Writer(%writer_args);
1395	$writer->start( {
1396	'source-info-name' => "$progname v".$components->{$progname}->{ver},
1397	'generator-info-name' =>
1398	$progname."(v".$components->{$progname}->{ver}.") + ".
1399	$myprogname."(v".$version.")".$components_used} );
1400
1401	XMLTV::parsefiles_callback(undef, undef, \&output_data_channel_cb,
1402	\&output_data_programme_cb, $input_postprocess_file);
1403	$writer->end();
1404
1405	printf "Final output stored in $output_filename.\n";
1406	}
1407
1408	sub output_data_channel_cb
1409	{
1410	my $c = shift;
1411	$writer->write_channel($c);
1412	}
1413
1414	sub output_data_programme_cb
1415	{
1416	my $prog=shift;
1417	$writer->write_programme($prog);
1418	}
1419
1420	# -----------------------------------------
1421	# Subs: Utilities
1422	# -----------------------------------------
1423	#
1424
1425	sub query_grabbers
1426	{
1427	my ($conf, $val) = @_;
1428	return query_component_type('grabber',$conf,$val);
1429	}
1430
1431	sub query_reconcilers
1432	{
1433	return query_component_type('reconciler');
1434	}
1435
1436	sub query_postprocessors
1437	{
1438	return query_component_type('postprocessor');
1439	}
1440
1441	sub query_component_type
1442	{
1443	my ($progtype,$conf,$val) = @_;
1444
1445	my @ret = ();
1446	foreach (keys %$components)
1447	{
1448	if ($components->{$_}->{type} eq $progtype) {
1449	if (defined $conf) {
1450	push (@ret, $_) if (query_config($_,$conf) eq $val);
1451	} else {
1452	push (@ret, $_);
1453	}
1454	}
1455	}
1456	return @ret;
1457	}
1458
1459	sub query_name
1460	{
1461	my $str = shift;
1462	if ($str =~ /(.*) \[cache\]/)
1463	{
1464	return $1;
1465	}
1466	return $str;
1467	}
1468
1469	sub query_config
1470	{
1471	my ($grabber, $key) = @_;
1472
1473	$grabber = query_name($grabber);
1474	return undef unless ($components->{$grabber});
1475	return $components->{$grabber}->{config}->{$key};
1476	}
1477
1478	sub call_prog
1479	{
1480	my $prog = shift;
1481	if (!(open(PROG,"$prog\|"))) {
1482	printf "warning: couldn't exec \"$prog\": $!\n";
1483	return -1;
1484	}
1485	while(<PROG>) {
1486	print $_;
1487	}
1488	close(PROG);
1489
1490	if ($? == -1) {
1491	printf "Failed to execute prog: $!\n";
1492	return -1;
1493	} elsif ($? & 127) {
1494	printf "prog died with signal %d, %s coredump\n",
1495	($? & 127), (($? & 128) ? "with" : "without");
1496	return $?;
1497	} else {
1498	printf "prog exited with value %d\n", ($? >> 8) if ($debug or $?);
1499	return ($? >> 8);
1500	}
1501	}
1502
1503	# -----------------------------------------
1504	# Subs: Setup
1505	# -----------------------------------------
1506
1507	sub read_config_file
1508	{
1509	read_file($config_file, 'configuration');
1510	}
1511
1512	sub read_channels_file
1513	{
1514	read_file($channels_file, 'channels');
1515	}
1516
1517	sub read_file
1518	{
1519	my $fn = shift;
1520	my $name = shift;
1521
1522	print "Reading $name file: $fn\n";
1523	unless (-r $fn)
1524	{
1525	unless ($opt->{configure})
1526	{
1527	print "\nNo $name file found.\n" .
1528	ucfirst($progname) . " must be configured: " .
1529	"configuring now.\n\n";
1530	$opt->{'configure'} = 1;
1531	}
1532	return;
1533	}
1534	local (@ARGV, $/) = ($fn);
1535	no warnings 'all';
1536	eval <>;
1537	if ($@ and !$opt->{configure})
1538	{
1539	warn "\nERROR in $name file! Details:\n$@";
1540	print "You may wish to CTRL-C and fix this.\n\nContinuing anyway in:";
1541	foreach (1 .. 5)
1542	{
1543	print " " . (6 - $_);
1544	sleep 1;
1545	}
1546	print "\n";
1547	}
1548	}
1549
1550	sub write_config_file
1551	{
1552	write_file($config_file, 'configuration',
1553	[$region, $pref_title_source, $mirror_site, $components ],
1554	["region", "pref_title_source", "mirror_site", "components" ]);
1555	}
1556
1557	sub write_channels_file
1558	{
1559	write_file($channels_file, 'channels',
1560	[ $channels, $opt_channels ],
1561	[ 'channels', 'opt_channels' ]);
1562	}
1563
1564	sub write_file
1565	{
1566	my ($fn, $name, $vars, $varnames) = @_;
1567	open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
1568	print FN Data::Dumper->Dump($vars, $varnames);
1569	close FN;
1570	print "Wrote $name file $fn.\n" if ($debug);
1571	}
1572
1573	sub get_command_line_options
1574	{
1575	GetOptions($opt, qw( help
1576	dontcallgrabbers
1577	version
1578	debug
1579	days=i
1580	offset=i
1581	output=s
1582	randomize
1583	));
1584	$debug = $opt->{debug};
1585	$days = $opt->{days} if ($opt->{days});
1586	}
1587
1588	# -----------------------------------------
1589	# Subs: override handlers for standard perl.
1590	# -----------------------------------------
1591
1592	# ugly hack. please don't try this at home kids!
1593	sub my_die {
1594	my ($arg,@rest) = @_;
1595	my ($pack,$file,$line,$sub) = caller(0);
1596
1597	# check if we are in an eval()
1598	if ($^S) {
1599	printf " shepherd caught a die() within eval{} from file $file line $line\n";
1600	} else {
1601	printf "\nDIE: line %d in file %s\n",$line,$file;
1602	if ($arg) {
1603	CORE::die($arg,@rest);
1604	} else {
1605	CORE::die(join("",@rest));
1606	}
1607	}
1608	}

Note: See TracBrowser for help on using the browser.

Context Navigation

root/engines/dog @ 233

Download in other formats: