Context Navigation

reconciler_mk2 @ 72

Revision 72, 54.3 kB (checked in by lincoln, 7 years ago)
seperate out reconciler to be standalone and commit first working standalone reconciler!
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	# "reconciler mk2": shepherd XMLTV data reconciler
4	# * to be used as a postprocessor for XMLTV data
5	# * takes the output from multiple XMLTV sources and combines them
6	# (hopefully taking the best data from each)
7	# * can be used in conjunction with 'shepherd' XMLTV reconciler or standalone (pipe-through)
8	# * can be used in conjunction with 'shepherd' channels.conf channels_file (but not necessary
9	# if input XMLTV grabbers populate <channel>..</channel> section properly
10	# * no configuration necessary
11	#
12	# changelog:
13	# 0.01 07aug06 initial version
14	# 0.02 11aug06 complete rewrite, new algorithms, seperate out from shepherd
15	# 0.03 15aug06 first committed
16
17	#
18	# reconciles programme listings using the following logic:
19	# sort programmes into per-channel and per-timeslot
20	# for each channel:
21	# 1. for programmes with a common start & stop time, evaluate them to see
22	# if they are the same programme using fuzzy title matching.
23	# use "majority voting" to decide which programme wins if titles differ.
24	# 2. for programmes that start within 10 minutes of each other, try to
25	# see if they are the same programme (fuzzy title matching), merging
26	# data between them
27	# 3. as a tie-breaker, prefer data based on order of grabber data we are
28	# fed. i.e. first data file takes preference over second data file, etc.
29	#
30	# other features:
31	# - will automatically split titles with "title: subtitle" into "title" and
32	# "subtitle" (controlled via $reclogic{min_title_for_colon_title_split})
33	# - will try to match "same titles" (including fuzzy title matching) for
34	# duplicate programmes within 10 minutes (or whatever
35	# $reclogic{fuzzy_match_title_time_window} is set to)
36	# - will automatically move start/stop times (up to a max of 5 minutes or whatever
37	# $reclogic{max_prog_length_for_rejig} is set to) whenever programming
38	# overlaps occur. logic for when-to-delete versus when-to-cutoff are
39	# controlled via $reclogic{min_prog_length_for_delete_cutoff} and
40	# $reclogic{delete_window_smaller_than_prog_window_threshold}
41	# - will remove all timezones from data (can be disabled by removing setting
42	# $reclogic{always_rewrite_start_stop_without_timezone}
43
44
45	# processing uses the following tables:
46	#
47	# order in which we read datafiles:
48	# number of datafiles: $in->{num_datafiles);
49	# order of datafiles: $in->{datafile_order}->[n] = $proggy;
50	# map datafile-to-grabber: $in->{datafile}->{$datafile} = $proggy;
51	# map grabber-to-datafile: $in->{data}->{$proggy}->{file} = $datafile;
52	# grabber version: $in->{data}->{$proggy}->{version} = $version;
53	#
54	# channels list:
55	# channel list: $in->{channels}->{$chan}->{lang}->{$lang} = $desc
56	#
57	# programme tables:
58	# $in->{tree}->{$chan}->{"start:stop"}->{progs}->[n]
59	# $in->{tree}->{$chan}->{"start:stop"}->{numprogs}
60	# $in->{total_progs}->{$chan}
61	# $in->{total_progs_in}->{$chan}, $in->{total_progs_out}->{$chan}
62	#
63	# misc tables:
64	# encoding we are using: $in->{encoding}
65	# where we sourced data from: $in->{sources}
66	# duplicate checking: $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}
67	# channel list: $in->{channels}->{$chan}->{$lang} = $desc
68
69
70	use strict;
71	$\| = 1;
72	BEGIN { *CORE::GLOBAL::die = \&my_die; }
73
74	my $progname = "reconciler_mk2";
75	my $version = "0.03_15aug06";
76
77	use LWP::UserAgent;
78	use Time::HiRes qw(gettimeofday tv_interval);
79	use XMLTV;
80	use XMLTV::ProgressBar;
81	use POSIX qw(strftime mktime);
82	use Getopt::Long;
83	use HTML::TreeBuilder;
84	use Data::Dumper;
85	use Compress::Zlib;
86	use DateTime::Format::Strptime;
87	use Cwd;
88
89	#### reconciler settings ####
90	my %reclogic;
91
92	### *******************************************************************************
93	### * NOTE: all of these can be overridden through a (site local) config file *
94	### *******************************************************************************
95	### Doing that is HIGHLY PREFERABLE to CHANGING THIS FILE!
96	### remember that Shepherd may upgrade this automatically from time-to-time,
97	### causing any changes here to be LOST!
98
99	#
100	# reconciler logic settings
101	#
102
103	# delete_window_smaller_than_prog_window_threshold:
104	$reclogic{delete_window_smaller_than_prog_window_threshold} = (5*60); # 5 mins each side
105
106	# min_prog_length_for_delete_cutoff:
107	$reclogic{min_prog_length_for_delete_cutoff} = (10*60); # prog needs to be at least 10 mins if we're cutting back
108
109	# max_prog_length_for_rejig:
110	$reclogic{max_prog_length_for_rejig} = (10*60); # allow programme times to be changed by at-most 10 mins
111
112	$reclogic{fuzzy_match_title_time_window} = (10*60); # attempt title matches within +/- 10 min window
113
114	# always rewrite XMLTV 'start' & 'stop', removing timezone
115	$reclogic{always_rewrite_start_stop_without_timezone} = 1;
116
117	# when we have a title with a ": " in the middle but no subtitle, split
118	# the title into "title: subtitle" provided title & subtitle are each at least
119	# 5 characters long
120	$reclogic{min_title_for_colon_title_split} = 5;
121
122	# don't accept programmes that last for longer than 8 hours.
123	$reclogic{max_programme_length} = (8 * 60 * 60); # 8 hours
124
125
126	#
127	# warning messages
128	#
129
130	$reclogic{warn_on_encoding_differences} = 0; # don't warn on encoding differences between XMLTV files
131	$reclogic{warn_on_no_title} = 1; # do warn on programme with no title
132	$reclogic{warn_on_no_channel} = 1; # do warn on programme with no channel
133	$reclogic{warn_on_unknown_channel} = 1; # do warn on programme with unknown channel
134	$reclogic{warn_on_invalid_time_in_prog} = 1; # do warn on programme with bad time format
135	$reclogic{warn_on_overlapping_programmes_always} = 0; # don't warn on all overlapping programmes from same source
136	$reclogic{warn_on_overlapping_programmes_for_different_title} = 1; # do warn on overlapping programmes from same source with different names
137	$reclogic{warn_on_invalid_time_in_prog} = 1; # do warn on a programme with a duration that is too long
138
139	#
140	# debug messages
141	#
142
143	$reclogic{debug_parse_time} = 0; # don't show debugging when parsing input time
144	$reclogic{debug_reconcile} = 0; # don't show reconciler logic
145	$reclogic{debug_reconcile_pass1} = 0; # don't show verbose pass 1 reconciler logic
146	$reclogic{debug_reconcile_pass2} = 0; # don't show verbose pass 2 reconciler logic
147	$reclogic{debug_add_logic} = 0; # don't show add logic debugging messages
148	$reclogic{debug_add_logic_verbose} = 0; # don't show add logic verbose debugging messages
149	$reclogic{debug_delete_logic} = 0; # don't show delete logic debugging messages
150	$reclogic{debug_show_nonmatching_title_alternatives} = 0; # don't show non-matching alternative debugging messages
151	$reclogic{debug_find_prog_to_add} = 0; # don't show add_multiple logic debugging messages
152	$reclogic{debug_print_programme_list} = 0; # don't show programme listings while writing
153	$reclogic{debug_subtitle_derived_from_title} = 0; # don't show subtitles mapped from titles
154
155	#### end reconciler settings ####
156
157
158	#
159	# some initial cruft
160	#
161
162	my $script_start_time = [gettimeofday];
163	my %stats;
164	my $datafile;
165	my $channels;
166	my $in = { };
167	my $out = { };
168	my $w;
169
170	my %amp;
171	BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
172
173	my @strptime;
174	$strptime[0] = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M %z");
175	$strptime[1] = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M%S %z");
176	$strptime[2] = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M");
177	# $strptime[3] = new DateTime::Format::Strptime( pattern => "%Y%m%d%H%M%S");
178
179	#
180	# parse command line
181	#
182
183	my $opt = { };
184	$opt->{output_file} = cwd()."/".$progname.".xmltv";
185	$opt->{log_file} = cwd()."/".$progname.".log";
186	$opt->{alt_title_file} = cwd()."/".$progname.".alt_title.log";
187	$opt->{lang} = "en";
188
189	GetOptions(
190	'region=i' => \$opt->{region}, # silently ignored
191	'days=i' => \$opt->{days}, # silently ignored
192	'offset=i' => \$opt->{offset}, # silently ignored
193	'timezone=s' => \$opt->{timezone}, # silently ignored
194
195	'channels_file=s' => \$opt->{channels_file},
196	'config-file=s' => \$opt->{config_file},
197	'log=s' => \$opt->{log_file},
198	'alt-title-file=s' => \$opt->{alt_title_file},
199	'output=s' => \$opt->{output_file},
200	'debug+' => \$opt->{debug},
201	'lang=s' => \$opt->{lang},
202	'option=s' => \%reclogic,
203
204	'print_listing' => \$reclogic{debug_print_programme_list},
205
206	'help' => \$opt->{help},
207	'verbose' => \$opt->{help},
208	'list_options' => \$opt->{help},
209	'version' => \$opt->{version},
210	'ready' => \$opt->{ready},
211	'desc' => \$opt->{desc},
212	'v' => \$opt->{version});
213
214	printf "%s v%s\n",$progname,$version;
215
216	if ($opt->{version} \|\| $opt->{desc} \|\| $opt->{help} \|\| $opt->{ready} \|\| $opt->{configure} \|\| $opt->{output_file} eq "") {
217	printf "A reconciler for multiple XMLTV data sources.\n" if $opt->{desc};
218	printf "$progname is ready for operation.\n" if ($opt->{ready});
219
220	printf "No --output file specified.\n" if ($opt->{output_file} eq "");
221
222	if ($opt->{help} \|\| $opt->{output_file} eq "") {
223	print<<EOF
224
225	usage: $0 [options] {FILE(s)}
226
227	Supported options include:
228	--ready verify that '$progname' is ready for operation
229
230	--lang={lang} set language to {lang} (default: $opt->{lang})
231	--channels_file={file} use channels file to augment list of channels (default: don't)
232	--output={file} send final XMLTV output to {file} (default: $opt->{output_file})
233	--debug enable debugging
234
235	--print_listing print out programme listing of chosen programs
236
237	--config-file={file} config file for default overrides (default: none)
238	--log={file} write (detailed) log file in {file} (default: $opt->{log_file})
239	--alt-title-file={file} write details of possible alternate titles into {file} (default: $opt->{alt_title_file})
240
241	--list_options list all possible options
242	--option {opt}={val} set option {opt} to value {val}
243	EOF
244	;
245	foreach my $key (sort keys %reclogic) {
246	if (($key =~ /^warn_on_/) \|\| ($key =~ /^debug_/)) {
247	my $thiskey = sprintf "%s=%d",$key,($reclogic{$key} ? 0 : 1);
248	printf " --option %-30s %sable %s '%s' (default: %s)\n", $thiskey, ($reclogic{$key} ? "dis" : "en"),
249	($key =~ /^warn_on/ ? "warning" : "debug"), $key, ($reclogic{$key} ? "do" : "don't");
250	} else {
251	my $thiskey = $key."={val}";
252	printf " --option %-30s set '%s' to {val} (default: %s)\n",$thiskey,$key,$reclogic{$key};
253	}
254	}
255	}
256	exit(0);
257	}
258
259	@ARGV = ('-') if not @ARGV;
260
261	# go go go!
262	open(LOG_FILE,">$opt->{log_file}") \|\| die "can't open log file $opt->{log_file} for writing: $!\n";
263	open(ALT_TITLE_FILE,">$opt->{alt_title_file}") \|\| die "can't open alt-title-file $opt->{alt_title_file} for writing: $!\n";
264
265	&log(1,(sprintf "started: %s%soutput %s",
266	($opt->{channels_file} ? "channels in $opt->{channels_file}, " : ""),
267	($opt->{config_file} ? "default overrides in $opt->{config_file}, " : ""),
268	($opt->{output_file})));
269	&log(1,(sprintf " logging to %s, alternate titles to %s",$opt->{log_file},$opt->{alt_title_file}));
270
271	printf ALT_TITLE_FILE "$progname $version\n";
272	printf ALT_TITLE_FILE "This log file contains lists of what title matches were attempted (but didn't match).\n";
273	printf ALT_TITLE_FILE "The intent of this is to keep a log that we can (hopefully) interpret in order to\n";
274	printf ALT_TITLE_FILE "improve the alternateTitle() logic.\n\n";
275
276	&override_settings;
277
278	&read_config_file($opt->{config_file}) if ($opt->{config_file});
279
280	&fill_in_channels if ($opt->{channels_file});
281
282	foreach my $file (@ARGV) {
283	$datafile = $file;
284	&log(1,(sprintf "Parsing: %s",($datafile eq "-" ? "(from-stdin, hit control-D to finiah)" : $datafile)));
285
286	eval { XMLTV::parsefiles_callback(\&encoding_cb, \&credits_cb, \&channel_cb, \&programme_cb, $datafile); };
287	}
288
289	&start_writer;
290	&write_channels;
291
292	&reconcile;
293
294	&write_programmes;
295	$w->end();
296
297	&print_stats;
298
299	close(LOG_FILE);
300	close(ALT_TITLE_FILE);
301
302	exit(0);
303
304	######################################################################################################
305	# read settings
306
307	sub read_config_file
308	{
309	my $file = shift;
310	die "file $file could not be read. aborting.\n" if (!(-r $file));
311	local (@ARGV, $/) = ($file);
312	no warnings 'all'; eval <>; die "$@" if $@;
313	}
314
315
316	######################################################################################################
317	# debug is actually always enabled (with default settings).
318	# --debug will turn on all debugging!
319
320	sub override_settings
321	{
322	foreach my $key (sort keys %reclogic) {
323	if ($key !~ /^debug_/) {
324	if ($key =~ /^warn_on_/) {
325	&log(1,(sprintf "warning %s is %s",$key,($reclogic{$key} ? "enabled" : "disabled; enable with --option $key")));
326	} else {
327	&log(1,(sprintf "%s is set to %s",$key,$reclogic{$key}));
328	&log(1,(sprintf " override using config-file option: %s\{%s\}=%s;","reclogic",$key,$reclogic{$key}));
329	}
330	}
331	}
332
333	foreach my $key (sort keys %reclogic) {
334	if ($key =~ /^debug_/) {
335	$reclogic{$key} = 1 if ($opt->{debug});
336	&log(1,(sprintf "debug setting %s is %s",$key,($reclogic{$key} ? "enabled" : "disabled; enable with --option $key")));
337	}
338	}
339	}
340
341	######################################################################################################
342	# we use our own die() routing to circumvent die() within eval statements where we are
343	# calling the standard XMLTV::parsefiles.
344	# this prevents bad XML from causing the reconciler to completely fail.
345
346	# ugly hack. please don't try this at home kids!
347
348	sub my_die {
349	my ($arg,@rest) = @_;
350	my ($pack,$file,$line,$sub) = caller(1);
351
352	# check if we are in an eval()
353	if ($^S) {
354	printf STDERR " caught a die() within eval{} from file $file line $line\n";
355	} else {
356	if (!ref($arg)) {
357	printf STDERR "DIE at line %d in file %s\n",$line,$file;
358	CORE::die(join("",@rest));
359	} else {
360	CORE::die($arg,@rest);
361	}
362	}
363	}
364
365	######################################################################################################
366	# if we are supplied a channels_file, then fill in channels we know about from that.
367	# this is useful because some grabbers (e.g. oztivo) don't supply a <channels></channels>
368	# section at the top of their xmltv - and if they happen to be the first grabber,
369	# this causes issues with programmes with no (known) channel
370
371	sub fill_in_channels
372	{
373	&read_config_file($opt->{channels_file});
374
375	foreach my $ch (sort keys %{$channels}) {
376	my $id = $channels->{$ch};
377
378	$in->{channels}->{$id}->{lang}->{($opt->{lang})} = $ch;
379	$in->{channels}->{$id}->{pref_desc} = $ch;
380	$in->{total_progs}->{$id} = 0;
381	$in->{total_progs_in}->{$id} = 0;
382	$in->{total_progs_out}->{$id} = 0;
383	}
384	}
385
386	######################################################################################################
387
388	sub log
389	{
390	my ($log_to_screen,$entry) = @_;
391	printf STDERR "%s [%d] %s\n",$progname, time,$entry if ($log_to_screen);
392	printf LOG_FILE "%s [%d] %s\n",$progname, time,$entry;
393	}
394
395	######################################################################################################
396
397	sub print_stats
398	{
399	printf STDERR "%s v%s [%d] completed in %0.2f seconds",$progname, $version, time, tv_interval($script_start_time);
400	foreach my $key (sort keys %stats) {
401	printf STDERR ",\n\t%d %s", $stats{$key},$key;
402	}
403	printf STDERR ".\n";
404	}
405
406	######################################################################################################
407	# descend a structure and clean up various things, including stripping
408	# leading/trailing spaces in strings, translations of html stuff etc
409	# -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
410
411	sub cleanup {
412	my $x = shift;
413	if (ref $x eq "REF") { cleanup($_) }
414	elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x }
415	elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
416	elsif (defined $$x) {
417	$$x =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
418	# $$x =~ s/[^\x20-\x7f]/ /g;
419	$$x =~ s/(^\s+\|\s+$)//g;
420	}
421	}
422
423	######################################################################################################
424	# original alternativeTitles() from XMLTV::IMDB, this one knows about even more translations..
425
426	sub alternativeTitles($)
427	{
428	my $title=shift;
429	my @titles;
430
431	push(@titles, $title); # seed with original title
432
433	# try "&" -> "and" conversion ('Spicks & Specks' => 'Spicks and Specks')
434	if ( $title=~m/\&/o ) {
435	my $t=$title;
436	push(@titles, $t) while ( $t=~s/(\s)\&(\s)/$1and$2/o );
437	}
438
439	# try the "and" -> "&" conversion ('Spicks and Specks' => 'Spicks & Specks')
440	if ( $title=~m/\sand\s/io ) {
441	my $t=$title;
442	push(@titles, $t) while ( $t=~s/(\s)and(\s)/$1\&$2/io );
443	}
444
445	# 'Barney Friends' => 'Barney & Friends'
446	foreach my $t (@titles) {
447	if ($t =~ /^(.) (.)$/) {
448	push(@titles,"$1 & $2");
449	}
450	}
451
452	# 'Barney Friends' => 'Barney - Friends'
453	foreach my $t (@titles) {
454	if ($t =~ /^(.) (.)$/) {
455	push(@titles,"$1 - $2");
456	}
457	}
458
459	# "Creflo A. Dollar, Jr" => "Creflo A Dollar"
460	# "House, M.D." => "House"
461	foreach my $t (@titles) {
462	push(@titles,"$1") if ($t =~ /^(.*), Jr$/);
463	push(@titles,"$1") if ($t =~ /^(.*), M\.D\.$/);
464	}
465
466	# "quotes" -> quotes
467	foreach my $t (@titles) {
468	push(@titles,$1) if ( $t =~ /^\"(.*)\"$/);
469	}
470
471	# remove full stops - e.g. will translate 'Dr. Dog.' to 'Dr Dog.' and 'Dr Dog'
472	foreach my $t (@titles) {
473	if ($t =~ /\./) {
474	my @new_titles;
475	push(@new_titles, $t) while ( $t=~s/(.)\.(.)/$1$2/io );
476	push(@titles,@new_titles);
477	}
478	}
479
480	# remove dashes
481	foreach my $t (@titles) {
482	if ($t =~ /\-/) {
483	my @new_titles;
484	push(@new_titles, $t) while ( $t=~s/(.)\-(.)/$1$2/io );
485	push(@titles,@new_titles);
486	}
487	}
488
489	# # strip 's: "MASH" => "MASH";
490	foreach my $t (@titles) {
491	if ($t =~ /\*/) {
492	my @new_titles;
493	push(@new_titles, $t) while ( $t=~s/(.)\(.*)/$1$2/io );
494	push(@titles,@new_titles);
495	}
496	}
497
498	# remove !s
499	foreach my $t (@titles) {
500	if ($t =~ /\'/) {
501	my @new_titles;
502	push(@new_titles, $t) while ( $t=~s/(.)\'(.)/$1$2/io );
503	push(@titles,@new_titles);
504	}
505	}
506
507	# remove :s
508	foreach my $t (@titles) {
509	if ($t =~ /:/) {
510	my @new_titles;
511	push(@new_titles, $t) while ( $t=~s/(.):(.)/$1$2/io );
512	push(@titles,@new_titles);
513	}
514	}
515
516	# remove apostrophies
517	foreach my $t (@titles) {
518	if ($t =~ /\!/) {
519	my @new_titles;
520	push(@new_titles, $t) while ( $t=~s/(.)!(.)/$1$2/io );
521	push(@titles,@new_titles);
522	}
523	}
524
525	# remove commas
526	foreach my $t (@titles) {
527	if ($t =~ /\,/) {
528	my @new_titles;
529	push(@new_titles, $t) while ( $t=~s/(.)\,(.)/$1$2/io );
530	push(@titles,@new_titles);
531	}
532	}
533
534	# strip text after !s provided we have at least one word
535	# e.g. will fix 'Jakers! The Adventures of Piggley Winks' to match 'Jakers'
536	# or 'Jakers! The Adventures of Piggley Winks' to match 'The Adventures of Piggley Winks'
537	foreach my $t (@titles) {
538	if ($t =~ /! /) {
539	my @t2 = split(/! /,$t);
540	push(@titles, @t2);
541	}
542	}
543
544	# 'Message Stick (Shorts)' => 'Message Stick'
545	# 'Behind The News (5 Min)' => 'Behind the News'
546	# 'Behind The News (5 Min)' => 'Behind the News 5 Min'
547	foreach my $t (@titles) {
548	if ($t =~ /(.+)$(.+)$$/) {
549	my $t2 = $1;
550	my $t3 = $1.$2;
551	$t2 =~ s/(^\s+\|\s+$)//g; # strip leading/trailing spaces
552	$t3 =~ s/(^\s+\|\s+$)//g; # strip leading/trailing spaces
553	push(@titles,$t2);
554	push(@titles,$t3);
555	}
556	}
557
558	# 'Family Story: The Longest Season' => 'Family Story'
559	foreach my $t (@titles) {
560	if ($t =~ /: /) {
561	my @t2 = split(/: /,$t);
562	push(@titles, @t2);
563	}
564	}
565
566	# 'Family Story The Longest Season' => 'Family Story: The Longest Season'
567	foreach my $t (@titles) {
568	if ($t =~ / /) {
569	my @t2 = split(/ /,$t);
570	push(@titles, @t2);
571	}
572	}
573
574	# #39; -> ' ('He's Having A Baby' => 'He\'s Having a Baby')
575	foreach my $t (@titles) {
576	my $t2 = $t;
577	$t2 =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
578	push(@titles,$t2) if ($t2 ne $t);
579	}
580
581	# 'Head 2 Head' => 'Head To Head'
582	foreach my $t (@titles) {
583	push(@titles, "$1 to $2") if ($t =~ /(.) 2 (.)/);
584	}
585
586	# remove leading 'The':
587	# "Iron Chef" alternatives "The Iron Chef"
588	# "The Newshour with Jim Lehrer" alternative "Newshour with Jim Lehrer"
589	foreach my $t (@titles) {
590	push(@titles,"$1") if ($t =~ /^The (.*)$/);
591	}
592
593	# strip "With [..]" if at least 10 chars before With
594	# "The 7.30 Report With Kerry O'brien" alternatives "The 7.30 Report"
595	# "Seven News With Peter Mitchell" alternatives "Seven News"
596	# "Today Tonight With Naomi Robson" alternatives "Today Tonight"
597	foreach my $t (@titles) {
598	if ($t =~/^(.) [Ww]ith (.)$/) {
599	my $t2 = $1;
600	push (@titles, $t2) if (length($t2) >= 10);
601	}
602	}
603
604	# Place the articles last
605	# 'The Daily Show' => 'Daily Show, The'
606	foreach (@titles) {
607	if ( m/^(The\|A\|Une\|Les\|Los\|Las\|L\'\|Le\|La\|El\|Das\|De\|Het\|Een)\s+(.*)$/io ) {
608	my $t=$_;
609	$t=~s/^(The\|A\|Une\|Les\|Los\|Las\|L\'\|Le\|La\|El\|Das\|De\|Het\|Een)\s+(.*)$/$2, $1/iog;
610	push(@titles, $t);
611	}
612	}
613
614	#foreach my $t (@titles) { printf "alternativeTitles: alternative \"$t\"\n"; }
615
616	return(@titles);
617	}
618
619	######################################################################################################
620
621	sub encoding_cb( $ )
622	{
623	my $e = shift;
624	#printf "got encoding ".Dumper($e);
625	$in->{encoding} = $e if (!$in->{encoding});
626
627	&log($reclogic{warn_on_encoding_differences},
628	(sprintf"WARNING: encoding '%s' from %s different from %s",$e,$datafile,$in->{encoding}))
629	if ($in->{encoding} ne $e);
630	}
631
632	######################################################################################################
633
634	sub credits_cb( $ )
635	{
636	my $c = shift;
637	#printf "got credits ".Dumper($c);
638
639	my ($proggy, $version) = split(/ /,$c->{'generator-info-name'}) if $c->{'generator-info-name'};
640
641	$proggy = $datafile if (!defined $proggy);
642	$version = "" if (!defined $version);
643
644	$in->{data}->{$proggy}->{file} = $datafile;
645	$in->{datafile}->{$datafile} = $proggy;
646	$in->{data}->{$proggy}->{version} = $version;
647
648	if (!defined $in->{num_datafiles}) {
649	$in->{num_datafiles} = 0;
650	$in->{sources} = "$proggy";
651	} else {
652	$in->{sources} .= ",$proggy";
653	}
654
655	$in->{datafile_order}->[($in->{num_datafiles})] = $proggy;
656	$in->{num_datafiles}++;
657	}
658
659	######################################################################################################
660
661	sub channel_cb( $ )
662	{
663	my $c = shift;
664	#printf "got channel ".Dumper($c);
665
666	my $chan = $c->{id};
667	my %chan_lang;
668
669	if (defined $c->{'display-name'} && defined $c->{'display-name'}->[0]) {
670	foreach my $ch_block ($c->{'display-name'}->[0]) {
671	my ($desc,$lang) = ($ch_block->[0],$ch_block->[1]);
672	$lang = $opt->{lang} if (!defined $lang);
673	$desc = "unknown" if (!defined $desc);
674
675	if (!defined $in->{channels}->{$chan}) {
676	$in->{channels}->{$chan}->{lang}->{$lang} = $desc;
677	$in->{total_progs}->{$chan} = 0;
678	$in->{total_progs_in}->{$chan} = 0;
679	$in->{total_progs_out}->{$chan} = 0;
680	} else {
681	$in->{channels}->{$chan}->{lang}->{$lang} = $desc
682	if (!defined $in->{channels}->{$chan}->{lang}->{$lang});
683	}
684
685	$in->{channels}->{$chan}->{pref_desc} = $desc
686	if (!defined $in->{channels}->{$chan}->{pref_desc});
687	}
688	}
689	}
690
691	######################################################################################################
692
693	sub programme_cb( $ )
694	{
695	my $prog=shift;
696	# print "got programme from $datafile: ".Dumper($prog);
697
698	# make sure programme has a title
699	if (!defined $prog->{title} \|\| !defined $prog->{title}->[0]) {
700	&log($reclogic{warn_on_no_title},(sprintf "WARNING: programme with no title in %s; ignored.", $datafile));
701	$stats{bad_programme_no_title}++;
702	return;
703	}
704	my $prog_title = $prog->{title}->[0]->[0];
705	my $prog_subtitle;
706	$prog_subtitle = $prog->{'sub-title'}->[0]->[0] if (defined $prog->{'sub-title'} && $prog->{'sub-title'}->[0] && $prog->{'sub-title'}->[0]->[0]);
707
708	# make sure programme has a channel
709	if (!defined $prog->{channel}) {
710	&log($reclogic{warn_on_no_channel},(sprintf "WARNING: programme '%s' had no channel information; ignored.", $prog_title));
711	$stats{bad_programme_no_channel}++;
712	return;
713	}
714	my $prog_chan = $prog->{channel};
715
716	# make sure we know about this channel
717	if (!defined $in->{channels}->{$prog_chan}) {
718	&log($reclogic{warn_on_unknown_channel},(sprintf "WARNING: programme '%s' had unknown channel \"%s\"; ignored.", $prog_title, $prog_chan));
719	$stats{bad_programme_unknown_channel}++;
720	return;
721	}
722
723	my $source = $datafile;
724	# $source = $in->{datafile}->{$datafile} if (defined $in->{datafile}->{$datafile});
725
726	# work out epoch times
727	#printf "got start '%s' stop '%s'\n",$prog->{start},$prog->{stop};
728	my $t1, my $t2;
729	foreach my $stime (@strptime) {
730	$t1 = $stime->parse_datetime($prog->{start});
731	$t2 = $stime->parse_datetime($prog->{stop});
732
733	&log($reclogic{debug_parse_time},
734	(sprintf " prog \"%s\" on chan \"%s\" start %s end %s, duration %d, file %s",
735	$prog_title, $prog_chan, (strftime "%a%e%b%H:%M", localtime($t1->epoch)),
736	(strftime "%a%e%b%H%M", localtime($t2->epoch)), ($t2->epoch - $t1->epoch), $source)) if ($t1 && $t2);
737
738	last if ($t1 && $t2);
739	}
740	if (!$t1 \|\| !$t2) {
741	&log($reclogic{warn_on_invalid_time_in_prog},
742	(sprintf "WARNING: programme '%s' on channel '%s' from %s had invalid start (%s) or stop (%s) time; ignored.",
743	$prog_title, $prog_chan, $datafile, ($prog->{start} ? $prog->{start} : "undef"),
744	($prog->{stop} ? $prog->{stop} : "undef")));
745	$stats{bad_programme_invalid_times}++;
746	return;
747	}
748
749	if (($t2->epoch - $t1->epoch) > $reclogic{max_programme_length}) {
750	&log($reclogic{warn_on_invalid_time_in_prog},
751	(sprintf "WARNING: programme '%s' on channel '%s' from %s had a programme duration (%d) that exceeded max_programme_length (%d): start '%s' stop '%s'; ignored.\n",
752	$prog_title, $prog_chan, $datafile, ($t2->epoch - $t1->epoch), $reclogic{max_programme_length},
753	($prog->{start} ? $prog->{start} : "undef"), ($prog->{stop} ? $prog->{stop} : "undef")));
754	$stats{bad_programme_duration_too_long}++;
755	return;
756	}
757
758	$prog->{start_epoch} = $t1->epoch;
759	$prog->{stop_epoch} = $t2->epoch;
760	$prog->{grabber} = $source;
761	$prog->{grabber_num} = ($in->{num_datafiles}-1);
762	my $prog_key = sprintf "%d:%d",$t1->epoch,$t2->epoch;
763
764	# if there is a ": " in title and no subtitle, split title into "title: subtitle"
765	# provided each of title/subtitle will be at least $reclogic{min_title_for_colon_title_split}
766	# characters
767	if (!defined $prog_subtitle) {
768	my ($title1,$title2) = split(/: /,$prog_title);
769
770	if (($title1) && ($title2) &&
771	(length($title1) >= $reclogic{min_title_for_colon_title_split}) &&
772	(length($title2) >= $reclogic{min_title_for_colon_title_split})) {
773	&log($reclogic{debug_subtitle_derived_from_title},
774	(sprintf "split title \"%s\" into title \"%s\" subtitle \"%s\" since over min_title_for_colon_title_split (%d)",
775	$prog_title, $title1, $title2, $reclogic{min_title_for_colon_title_split}));
776	$stats{derived_subtitle_from_title}++;
777
778	$prog_title = $title1;
779	$prog->{title}->[0]->[0] = $title1;
780
781	$prog_subtitle = $title2;
782	$prog->{'sub-title'}->[0]->[0] = $title2;
783	$prog->{'sub-title'}->[0]->[1] = $prog->{'title'}->[0]->[1];
784	}
785
786	}
787
788	# check to see if this grabber has supplied a programme with this start/stop on this
789	# channel already. if there is, whinge about it & drop the duplicate
790	if (defined $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}) {
791	# record statistic but don't print error message if programme names actually match
792	my $warn = (($reclogic{warn_on_overlapping_programmes_always}) \|\|
793	(($reclogic{warn_on_overlapping_programmes_for_different_title}) &&
794	($prog_title ne $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key})));
795	&log($warn,(sprintf "WARNING: file contained more than one programme in same timeslot: channel '%s' start %s, stop %s, programs \"%s\" and \"%s\"; ignored.",
796	$prog_chan,
797	(strftime "%a %e %b %H:%M",localtime($t1->epoch)),
798	(strftime "%H:%M",localtime($t2->epoch)),
799	$prog_title,
800	$in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}));
801	$stats{bad_programme_duplicate_times}++;
802	return;
803	}
804	$in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key} = $prog_title;
805
806
807	#
808	# store each programme in a tree. the tree looks like:
809	# $in->{tree}->{$chan}->{$progkey}->{progs}->[n]
810	# $in->{tree}->{$chan}->{$progkey}->{numprogs}
811	#
812
813	my $prognum = 0;
814	$prognum = $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs}
815	if (defined $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs});
816	$in->{tree}->{$prog_chan}->{$prog_key}->{progs}->[$prognum] = $prog;
817	$prognum++;
818	$in->{tree}->{$prog_chan}->{$prog_key}->{numprogs} = $prognum;
819
820	$in->{total_progs}->{$prog_chan}++;
821	$in->{total_progs_in}->{$prog_chan}++;
822	}
823
824	######################################################################################################
825	# open output file, write encoding + credits headings
826
827	sub start_writer
828	{
829	my %writer_args = ( encoding => $in->{encoding} );
830	my $fh = new IO::File(">$opt->{output_file}") \|\| die "can't open $opt->{output_file}: $!";
831	$writer_args{OUTPUT} = $fh;
832	$w = new XMLTV::Writer(%writer_args);
833	$w->start( { 'generator-info-name' => "$progname $version", 'source-info-name' => $in->{sources} } );
834	}
835
836	######################################################################################################
837	# write out our channels
838
839	sub write_channels
840	{
841	foreach my $chan_id (sort keys %{($in->{channels})}) {
842	my $this_chan = $in->{channels}->{$chan_id};
843
844	my $lang_list, my $num_langs = 0;
845	foreach my $lang (keys %{($this_chan->{lang})}) {
846	$lang_list->[$num_langs]->[0] = $this_chan->{lang}->{$lang};
847	$lang_list->[$num_langs]->[1] = $lang;
848	$num_langs++;
849	}
850
851	$w->write_channel( { 'id' => $chan_id, 'display-name' => $lang_list } );
852	}
853	}
854
855	######################################################################################################
856	# write out our programmes
857
858	sub write_programmes
859	{
860	foreach my $chan_id (sort keys %{($in->{channels})}) {
861	foreach my $prog_key (sort keys %{($out->{$chan_id})}) {
862	my $prog = $out->{$chan_id}->{$prog_key};
863	my $progname = sprintf "%s%s",
864	$prog->{title}->[0]->[0],
865	($prog->{subtitle} ? ": $prog->{subtitle}->[0]->[0]" : "");
866
867	printf "%-10s %s - %s: %-30s {src %s}\n",
868	$in->{channels}->{$chan_id}->{pref_desc},
869	(strftime "%a%e%b %H:%M", localtime($prog->{start_epoch})),
870	(strftime "%H:%M", localtime($prog->{stop_epoch})),
871	$progname,
872	$prog->{datasources}
873	if ($reclogic{debug_print_programme_list});
874
875	delete $prog->{start_epoch} if (defined $prog->{start_epoch});
876	delete $prog->{stop_epoch} if (defined $prog->{stop_epoch});
877	delete $prog->{datasources} if (defined $prog->{datasources});
878
879	&cleanup($prog);
880	$w->write_programme($prog);
881	}
882	}
883	}
884
885	######################################################################################################
886	# insert a programme into our reconciled list
887	# - if fed multiple programmes for the one slot, choose attributes from all of them
888
889	sub add_one_programme
890	{
891	my($chan_id,$num_matching,$m) = @_;
892	&log($reclogic{debug_add_logic},
893	(sprintf "add_one_programme: adding programme %s-%s \"%s\" with data from %d programmes",
894	(strftime "%a %e %b %H:%M",localtime(($m->[0]->{start_epoch}))),
895	(strftime "%H:%M",localtime(($m->[0]->{stop_epoch}))),
896	$m->[0]->{title}->[0]->[0], $num_matching));
897
898	my $newprog;
899	my $chan = $m->[0]->{channel};
900	my $starttime = $m->[0]->{start_epoch};
901
902	# always take start/stop/channel from first choice
903
904	if ($reclogic{always_rewrite_start_stop_without_timezone}) {
905	$newprog->{start} = strftime "%Y%m%d%H%M", localtime($m->[0]->{start_epoch});
906	$newprog->{stop} = strftime "%Y%m%d%H%M", localtime($m->[0]->{stop_epoch});
907	} else {
908	$newprog->{start} = $m->[0]->{start};
909	$newprog->{stop} = $m->[0]->{stop};
910	}
911	$newprog->{start_epoch} = $m->[0]->{start_epoch};
912	$newprog->{stop_epoch} = $m->[0]->{stop_epoch};
913	$newprog->{channel} = $chan;
914
915	$newprog->{datasources} = "";
916	for my $i (0..($num_matching-1)) {
917	$newprog->{datasources} .= sprintf "%s%d",($newprog->{datasources} ne "" ? "," : ""),$m->[$i]->{grabber_num};
918
919	# (1) merge in attributes which are simple scalars
920	foreach my $field ('date', 'length') {
921	$newprog->{$field} = $m->[$i]->{$field}
922	if ((!defined $newprog->{$field}) && (defined $m->[$i]->{$field}) && ($m->[$i]->{$field} ne ""));
923	}
924
925	# (2) merge in attributes which are simple arrays
926	foreach my $field ('url', 'star-rating') {
927	if (defined $m->[$i]->{$field}) {
928	my %existing_hash;
929	my $num_existing = 0;
930
931	# pick up existing entries
932	if (defined $newprog->{$field}) {
933	my $existing_entries = $newprog->{$field};
934	foreach my $entry (@$existing_entries) {
935	$existing_hash{$entry} = 1;
936	$num_existing++;
937	}
938	}
939
940	my $new_entries = $m->[$i]->{$field};
941	foreach my $entry (@$new_entries) {
942	if ((!defined $existing_hash{$entry}) && ($entry ne "")) {
943	$existing_hash{$entry} = 1;
944	$newprog->{$field}->[$num_existing] = $entry;
945	$num_existing++;
946	}
947	}
948	}
949	}
950
951	# (3) merge in attributes which are [val,lang] pairs, [val,val] or [val,val,val]
952	foreach my $field ('title', 'sub-title', 'desc', 'language', 'orig-language',
953	'category', 'country', 'premiere', 'last-chance', 'episode-num', 'rating') {
954	my $num_added = 0;
955	my %lang_added;
956
957	# pick up existing entries already there
958	if (defined $newprog->{$field}) {
959	my $existing_entries = $newprog->{$field};
960	foreach my $entry (@$existing_entries) {
961	my $val = $entry->[0];
962	my $lang = $entry->[1];
963	$lang = "BLANK" if (!$lang);
964	$lang_added{$lang} = $val;
965	$num_added++;
966	}
967	}
968
969	# augment them with any new data
970	if (defined $m->[$i]->{$field}) {
971	my $new_entries = $m->[$i]->{$field};
972	foreach my $entry (@$new_entries) {
973	my $val = $entry->[0];
974	my $lang = $entry->[1];
975
976	if ($field eq "episode-num") {
977	$lang = "onscreen" if (!$lang);
978	} elsif ($field eq "rating") {
979	$lang = "BLANK" if (!$lang);
980	} else {
981	$lang = $opt->{lang} if (!$lang);
982	}
983
984	if (!defined $lang_added{$lang}) {
985	$lang_added{$lang} = $val;
986	$newprog->{$field}->[$num_added]->[0] = $val;
987
988	if ($lang eq "BLANK") {
989	$newprog->{$field}->[$num_added]->[1] = undef;
990	} else {
991	$newprog->{$field}->[$num_added]->[1] = $lang;
992	}
993
994	if ($field eq "rating") {
995	$newprog->{$field}->[$num_added]->[2] = $entry->[2];
996	}
997
998	$num_added++;
999	}
1000	}
1001	}
1002	}
1003
1004	# (4) merge in attributes which are {hash}->{hash}->[array]
1005	foreach my $field ('credits') {
1006	foreach my $field2 ('director','actor','writer','adapter','producer','presenter','commentator','guest') {
1007	my $num_added = 0;
1008	my %entries;
1009
1010	# pick up existing entries we already have
1011	if (defined $newprog->{$field}->{$field2}) {
1012	my $existing_entries = $newprog->{$field}->{$field2};
1013	foreach my $entry (@$existing_entries) {
1014	$entries{$entry} = 1;
1015	$num_added++;
1016	}
1017	}
1018
1019	# augment with new data
1020	if (defined $m->[$i]->{$field}->{$field2}) {
1021	my $new_entries = $m->[$i]->{$field}->{$field2};
1022	foreach my $entry (@$new_entries) {
1023	if (($entry ne "") && (!defined $entries{$entry})) {
1024	$newprog->{$field}->{$field2}->[$num_added] = $entry;
1025	$entries{$entry} = 1;
1026	$num_added++;
1027	}
1028	}
1029	}
1030	}
1031	}
1032
1033	# (5) merge in attributes which are by name with no values, or values we don't care to interpret
1034	foreach my $field ('new', 'subtitles') {
1035	if ((!defined $newprog->{$field}) && (defined $m->[$i]->{$field})) {
1036	$newprog->{$field} = $m->[$i]->{$field};
1037	}
1038	}
1039
1040	# (6) merge in attributes which are {hash}->{hash}=val
1041	foreach my $field ('video', 'audio', 'subtitles') {
1042	my %entries;
1043
1044	# pick up existing entries we already have
1045	if (defined $newprog->{$field}) {
1046	my $existing_entries = $newprog->{$field};
1047	foreach my $entry (keys %{$existing_entries}) {
1048	$entries{$entry} = $newprog->{$field}->{$entry};
1049	}
1050	}
1051
1052	# augment with new data
1053	if (defined $m->[$i]->{$field}) {
1054	my $new_entries = $m->[$i]->{$field};
1055	foreach my $entry (keys %{$new_entries}) {
1056	if (($entry ne "") && (!defined $entries{$entry})) {
1057	$newprog->{$field}->{$entry} = $m->[$i]->{$field}->{$entry};
1058	$entries{$entry} = $m->[$i]->{$field}->{$entry};
1059	}
1060	}
1061	}
1062	}
1063
1064	# ignored attributes:
1065	# icon
1066	# previously-shown
1067	}
1068
1069	if (defined $out->{$chan}->{$starttime}) {
1070	&log(1,(sprintf "ERROR: already have a programme on channel \"%s\" scheduled for %s! bug!",
1071	$chan, (strftime "%a %e %b %H:%M",localtime($starttime))));
1072	} else {
1073	$out->{$chan}->{$starttime} = $newprog;
1074	$in->{total_progs_out}->{($newprog->{channel})}++;
1075	}
1076	}
1077
1078	######################################################################################################
1079	# remove all programming data for this channel where programming is between start/stop times
1080
1081	sub delete_overlapping_programmes
1082	{
1083	my($chan_id,$del_start,$del_stop) = @_;
1084
1085	&log($reclogic{debug_delete_logic},
1086	(sprintf "delete_overlapping_programmes: called to delete within %s-%s on chan %s",
1087	(strftime "%a%e%b%H:%M", localtime($del_start)), (strftime "%a%e%b%H:%M", localtime($del_stop)),
1088	$in->{channels}->{$chan_id}->{pref_desc}));
1089
1090	# remove programming between $del_start and $del_stop
1091	foreach my $prog_key ( keys %{($in->{tree}->{$chan_id})} ) {
1092	for my $i (0..($in->{tree}->{$chan_id}->{$prog_key}->{numprogs}-1)) {
1093	my $delete_this = 0;
1094	my $prog_start = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch};
1095	my $prog_stop = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch};
1096	my $prog_title = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{title}->[0]->[0];
1097	my $prog_grabber = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{grabber_num};
1098
1099	if (($prog_start >= $del_start) && ($prog_stop <= $del_stop)) {
1100	#
1101	# prog entirely within window - delete it
1102	#
1103
1104	$delete_this = 1;
1105	&log($reclogic{debug_delete_logic},
1106	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - within window",
1107	$prog_title, (strftime "%a%e%b %H:%M", localtime($prog_start)),
1108	(strftime "%H:%M", localtime($prog_stop)), $prog_grabber));
1109	} elsif (($prog_start < $del_start) && ($prog_stop > $del_stop)) {
1110	#
1111	# looks very bogus. starts before our delete window and ends after our delete window.
1112	# there is no "right" action here - try to apply some heuristics
1113	#
1114
1115	if ((($prog_start + $reclogic{delete_window_smaller_than_prog_window_threshold}) >= $del_start) &&
1116	(($prog_stop - $reclogic{delete_window_smaller_than_prog_window_threshold}) <= $del_stop)) {
1117	#
1118	# if programme is within -/+5 minutes (default) for both start/end of delete window
1119	# then delete it
1120	#
1121
1122	$delete_this = 1;
1123	&log($reclogic{debug_delete_logic},
1124	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - within window +/- delete_window_smaller_than_prog_window_threshold (%d)",
1125	$prog_title, (strftime "%a%e%b %H:%M", localtime($prog_start)),
1126	(strftime "%H:%M", localtime($prog_stop)), $prog_grabber,
1127	$reclogic{delete_window_smaller_than_prog_window_threshold}));
1128	$stats{prog_del_overwindow_close_enough}++;
1129	} else {
1130	#
1131	# rather than deleting it, try to cut back either the stop or bring forward the start
1132	#
1133
1134	my $before_del_start = $del_start - $prog_start;
1135	my $after_del_stop = $prog_stop - $del_stop;
1136
1137	if (($before_del_start <= $reclogic{min_prog_length_for_delete_cutoff}) &&
1138	($after_del_stop <= $reclogic{min_prog_length_for_delete_cutoff})) {
1139	#
1140	# programme would be too short if we did that. delete it
1141	#
1142	$delete_this = 1;
1143	&log($reclogic{debug_delete_logic},
1144	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating start/stop would result in under min_prog_length_for_delete_cutoff (%d)",
1145	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1146	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1147	$reclogic{min_prog_length_for_delete_cutoff}));
1148	$stats{prog_del_overwindow_too_short}++;
1149	} else {
1150	if ($before_del_start > $after_del_stop) {
1151	#
1152	# cut off end
1153	#
1154	&log($reclogic{debug_delete_logic},
1155	(sprintf " - updating \"%s\" (%s-%s, grabber %d) - pulled back stop time because less time after cut window than before (%d before, %d after). prog now %s-%s",
1156	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1157	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1158	$before_del_start, $after_del_stop,
1159	(strftime "%a%e%b%H:%M", localtime($prog_start)),
1160	(strftime "%a%e%b%H:%M", localtime($del_start))));
1161	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch} = $del_start;
1162	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop} = strftime "%Y%m%d%H%M",localtime($del_start);
1163	$stats{prog_del_overwindow_cut_end}++;
1164	} else {
1165	#
1166	# cut off beginning
1167	#
1168	&log($reclogic{debug_delete_logic},
1169	(sprintf " - updating \"%s\" (%s-%s, grabber %d) - pushed forward start time because less time before cut window than after (%d before, %d after). prog now %s-%s",
1170	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1171	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1172	$before_del_start, $after_del_stop,
1173	(strftime "%a%e%b%H:%M", localtime($del_stop)),
1174	(strftime "%a%e%b%H:%M", localtime($prog_stop))));
1175	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch} = $del_stop;
1176	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start} = strftime "%Y%m%d%H%M",localtime($del_stop);
1177	$stats{prog_del_overwindow_culled_start}++;
1178	}
1179	}
1180	}
1181	} elsif (($prog_start < $del_stop) && ($prog_stop > $del_stop)) {
1182	#
1183	# programme starts within window but ends outside of it.
1184	#
1185	if (($del_stop - $prog_start) > $reclogic{max_prog_length_for_rejig}) {
1186	# would cut off too much programme - delete it
1187	$delete_this = 1;
1188	&log($reclogic{debug_delete_logic},
1189	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating start would lose more than max_prog_length_for_rejig (%d)",
1190	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1191	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1192	$reclogic{max_prog_length_for_rejig}));
1193	$stats{prog_del_too_much_culled_from_start}++;
1194	} else {
1195	&log($reclogic{debug_delete_logic},
1196	(sprintf " - updating \"%s\" (%s-%s, grabber %d) - pushed forward start time because under max_prog_length_for_rejig (%d). prog now %s-%s",
1197	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1198	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1199	$reclogic{max_prog_length_for_rejig},
1200	(strftime "%a%e%b%H:%M", localtime($del_stop)),
1201	(strftime "%a%e%b%H:%M", localtime($prog_stop))));
1202	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch} = $del_stop;
1203	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start} = strftime "%Y%m%d%H%M",localtime($del_stop);
1204	$stats{prog_del_start_cull_ok}++;
1205	}
1206	} elsif (($prog_start < $del_start) && ($prog_stop > $del_start)) {
1207	#
1208	# programme starts outside window but ends within it.
1209	#
1210	if (($prog_stop - $del_start) > $reclogic{max_prog_length_for_rejig}) {
1211	# would cut off too much programme - delete it
1212	$delete_this = 1;
1213	&log($reclogic{debug_delete_logic},
1214	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating stop would lose more than max_prog_length_for_rejig (%d)",
1215	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1216	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1217	$reclogic{max_prog_length_for_rejig}));
1218	$stats{prog_del_too_much_cut_from_end}++;
1219	} else {
1220	&log($reclogic{debug_delete_logic},
1221	(sprintf " - updating \"%s\" (%s-%s, grabber %d) - pulled back stop time due to under max_prog_length_for_rejig (%d). prog now %s-%s",
1222	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1223	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1224	$reclogic{max_prog_length_for_rejig},
1225	(strftime "%a%e%b%H:%M", localtime($prog_start)),
1226	(strftime "%a%e%b%H:%M", localtime($del_start))));
1227	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch} = $del_start;
1228	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop} = strftime "%Y%m%d%H%M",localtime($del_start);
1229	$stats{prog_del_end_cut_ok}++;
1230	}
1231	}
1232
1233	if ($delete_this) {
1234	delete $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i];
1235	$in->{tree}->{$chan_id}->{$prog_key}->{numprogs}--;
1236	$in->{total_progs}->{$chan_id}--;
1237	$i--;
1238	}
1239	}
1240
1241	# if no progs left in group, delete entire group
1242	if ($in->{tree}->{$chan_id}->{$prog_key}->{numprogs} == 0) {
1243	# delete entire group
1244	delete $in->{tree}->{$chan_id}->{$prog_key};
1245	}
1246	}
1247	}
1248
1249	######################################################################################################
1250	# when given multiple programmes matching same timeslot, compare titles of them to see if
1251	# they are the same programme.
1252	# - if the same programme, insert them.
1253	# - if different programmes, select our preferred one to insert.
1254
1255	sub find_prog_to_add
1256	{
1257	my ($chan_id,$numprogs,$log_check_matching,$prog_list) = @_;
1258
1259	#
1260	# find out what titles match, store results
1261	#
1262
1263	&log($reclogic{debug_find_prog_to_add},
1264	(sprintf "find_prog_to_add: slot on channel %s has %d programmes to choose from.",
1265	$chan_id,$numprogs));
1266
1267	my @match_count;
1268	my $data_match;
1269	my $highest_num_matches_slot = 0;
1270
1271	for my $i (0..($numprogs-1)) {
1272	my $primary_title = $prog_list->[$i]{title}->[0]->[0];
1273	my @primary_titles = alternativeTitles($primary_title);
1274	$match_count[$i] = 0;
1275
1276	for my $j (0..($numprogs-1)) {
1277	next if ($i == $j);
1278	my $compare_title = $prog_list->[$j]->{title}->[0]->[0];
1279	my @compare_titles = alternativeTitles($compare_title);
1280
1281	foreach my $alt (@primary_titles) {
1282	foreach my $alt2 (@compare_titles) {
1283	&log($reclogic{debug_find_prog_to_add},
1284	(sprintf "find_prog_to_add: comparing %d to %d: \"%s\" to \"%s\" ...",
1285	$i,$j,$alt,$alt2));
1286	if (lc($alt) eq lc($alt2)) {
1287	$data_match->[$i]->[$j] = 1;
1288	$match_count[$i]++;
1289	&log($reclogic{debug_find_prog_to_add},
1290	(sprintf "find_prog_to_add: -> %d++ (\"%s\") matched %d (\"%s\") with \"%s\" and \"%s\"",
1291	$i, $primary_title, $j, $compare_title, $alt, $alt2));
1292	goto JUMPOUT_MATCH;
1293	}
1294	}
1295	}
1296	JUMPOUT_MATCH:
1297	}
1298
1299	$highest_num_matches_slot = $i if ($match_count[$i] > $match_count[$highest_num_matches_slot]);
1300	}
1301
1302	&log($reclogic{debug_find_prog_to_add},
1303	(sprintf "find_prog_to_add: grabber %d wins for this slot with %d matches.",
1304	$highest_num_matches_slot,$match_count[$highest_num_matches_slot]));
1305
1306	my $matching_progs, my $num_matching_progs = 1;
1307	if ($match_count[$highest_num_matches_slot] == 0) {
1308	my $prog = $prog_list->[0];
1309	if (($numprogs > 1) && ($log_check_matching)) {
1310	#
1311	# no data matched - log this for further inspection
1312	#
1313	my $alternate_titles = sprintf "channel %s timeslot %s-%s, preferred grabber %d\n",
1314	$in->{channels}->{$chan_id}->{pref_desc},
1315	(strftime "%a %e %b %H:%M",localtime(($prog->{start_epoch}))),
1316	(strftime "%H:%M",localtime(($prog->{stop_epoch}))),
1317	$prog->{grabber_num};
1318
1319	for my $i (0..($numprogs-1)) {
1320	my $this_prog = $prog_list->[$i];
1321	$alternate_titles .= sprintf " #%d. \"%s\" {src %s}\n",
1322	$this_prog->{grabber_num}, $this_prog->{title}->[0]->[0], $this_prog->{grabber};
1323
1324	my $seen = 0;
1325	foreach my $alt_title (alternativeTitles($this_prog->{title}->[0]->[0])) {
1326	$seen++;
1327	$alternate_titles .= sprintf" also tried alternate: \"%s\"\n",$alt_title if ($seen > 1);
1328	}
1329	}
1330
1331	&log($reclogic{debug_show_nonmatching_title_alternatives}, $alternate_titles);
1332	printf ALT_TITLE_FILE "%s\n\n",$alternate_titles;
1333	}
1334
1335	# add entry from our preferred grabber
1336	$matching_progs->[0] = $prog;
1337	} else {
1338	# add entry from our multiple grabbers
1339	$stats{rec_start_stop_title_match}++;
1340	$matching_progs->[0] = $prog_list->[$highest_num_matches_slot];
1341	for my $i (0..($numprogs-1)) {
1342	if ($data_match->[$highest_num_matches_slot]->[$i]) {
1343	&log($reclogic{debug_find_prog_to_add},
1344	(sprintf "find_prog_to_add: - augmenting with data from grabber %d\n",$i));
1345	$matching_progs->[$num_matching_progs] = $prog_list->[$i];
1346	$num_matching_progs++;
1347	}
1348	}
1349	}
1350	&add_one_programme($chan_id,$num_matching_progs,$matching_progs);
1351
1352	# remove all programming data for this channel which overlaps with this (inserted) programme
1353	&delete_overlapping_programmes($chan_id,$matching_progs->[0]->{start_epoch},$matching_progs->[0]->{stop_epoch});
1354	}
1355
1356	######################################################################################################
1357
1358	sub reconcile
1359	{
1360
1361	#
1362	# loop through channels
1363	# (chan_id)
1364	#
1365
1366	foreach my $chan_id (sort keys %{($in->{channels})}) {
1367	my $this_chan = $in->{channels}->{$chan_id};
1368
1369	#
1370	# (1) look for programmes within the same timeslot
1371	# if at least 2 grabbers say a programme starts/ends at the
1372	# same time & have a similar title, use that
1373	#
1374
1375	&log($reclogic{debug_reconcile},
1376	(sprintf "reconcile: channel '%s': pass 1: %d programmes remaining",
1377	$in->{channels}->{$chan_id}->{pref_desc}, $in->{total_progs}->{$chan_id}));
1378
1379	# 1a. gather up programming timeslots
1380	foreach my $prog_key (
1381	sort { $in->{tree}->{$chan_id}->{$a}->{numprogs} <=> $in->{tree}->{$chan_id}->{$b}->{numprogs} }
1382	keys %{($in->{tree}->{$chan_id})} ) {
1383	next if (!defined $in->{tree}->{$chan_id}->{$prog_key});
1384	my $num_progs_in_slot = $in->{tree}->{$chan_id}->{$prog_key}->{numprogs};
1385
1386	# 1b. at least 2 programs in the same timeslot - try to add it if titles match
1387	if ($num_progs_in_slot > 1) {
1388	my $this_prog_start = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{start_epoch};
1389	my $this_prog_stop = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{stop_epoch};
1390
1391	&log($reclogic{debug_reconcile_pass1},
1392	(sprintf "reconcile: %d programs between %s - %s",
1393	$num_progs_in_slot, (strftime "%a %e %b %H:%M",localtime($this_prog_start)),
1394	(strftime "%H:%M",localtime($this_prog_stop))));
1395
1396	$stats{rec_start_stop_match}++;
1397	&find_prog_to_add($chan_id,$num_progs_in_slot,1,$in->{tree}->{$chan_id}->{$prog_key}->{progs});
1398	}
1399	}
1400
1401	#
1402	# (2) look for programmes within similar (but not exact) timeslots
1403	# but with same name. use timeslot from the "higher preference"
1404	# grabber
1405	#
1406
1407	my $done = 0, my $preferred_grabber = 0;
1408	while (($in->{total_progs}->{$chan_id} > 0) && (!$done)) {
1409	&log($reclogic{debug_reconcile},
1410	(sprintf "reconcile: channel '%s': pass 2: %d programmes remaining, preferring grabber %d",
1411	$in->{channels}->{$chan_id}->{pref_desc}, $in->{total_progs}->{$chan_id}, $preferred_grabber));
1412
1413	# 2a. find first programme from preferred grabber
1414	my @prog_keys = sort { $in->{tree}->{$chan_id}->{$a} <=> $in->{tree}->{$chan_id}->{$b} } keys %{($in->{tree}->{$chan_id})};
1415	foreach my $prog_key (@prog_keys) {
1416	next if (!defined $in->{tree}->{$chan_id}->{$prog_key});
1417	next if ($in->{tree}->{$chan_id}->{$prog_key}->{numprogs} == 0);
1418	next if ($in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{grabber_num} != $preferred_grabber);
1419
1420	# got a programme from our preferred grabber
1421	my $found_prog = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0];
1422	my $start_window = $found_prog->{start_epoch} - $reclogic{fuzzy_match_title_time_window};
1423	my $stop_window = $found_prog->{stop_epoch} + $reclogic{fuzzy_match_title_time_window};
1424
1425	my $matched_progs;
1426	$matched_progs->[0] = $found_prog;
1427	my $num_matched_progs = 1;
1428
1429	&log($reclogic{debug_reconcile_pass2},
1430	(sprintf "reconcile: (%d to go) chose programme for %s-%s: \"%s\", looking for alternatives between %s-%s",
1431	$in->{total_progs}->{$chan_id},
1432	(strftime "%a %e %b %H:%M",localtime($found_prog->{start_epoch})),
1433	(strftime "%H:%M",localtime($found_prog->{stop_epoch})), $found_prog->{title}->[0]->[0],
1434	(strftime "%H:%M",localtime($start_window)),
1435	(strftime "%H:%M",localtime($stop_window))));
1436
1437	foreach my $prog_key2 ( sort { $in->{tree}->{$chan_id}->{$a} <=> $in->{tree}->{$chan_id}->{$b} } keys %{($in->{tree}->{$chan_id})} ) {
1438	next if ($in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{grabber_num} != $preferred_grabber);
1439	next if ($prog_key2 eq $prog_key);
1440
1441	my $numprogs = $in->{tree}->{$chan_id}->{$prog_key2}->{numprogs};
1442	for my $i (0..($numprogs-1)) {
1443	my $check_prog = $in->{tree}->{$chan_id}->{$prog_key2}->{progs}->[$i];
1444
1445	# match programmes which _start_ within the timewindow (but not necessarily end!)
1446	if (($check_prog->{start_epoch} >= $start_window) && ($check_prog->{start_epoch} < $stop_window)) {
1447	$matched_progs->[$num_matched_progs] = $check_prog;
1448	$num_matched_progs++;
1449
1450	&log($reclogic{debug_reconcile_pass2},
1451	(sprintf "reconcile: found alternative prog: %s-%s, \"%s\"",
1452	(strftime "%a%e%b %H:%M",localtime($check_prog->{start_epoch})),
1453	(strftime "%H:%M",localtime($check_prog->{stop_epoch})),
1454	$check_prog->{title}->[0]->[0]));
1455	}
1456	}
1457	}
1458
1459	&find_prog_to_add($chan_id,$num_matched_progs,0,$matched_progs);
1460	}
1461
1462	&log($reclogic{debug_reconcile},
1463	(sprintf "reconcile: still have %d programmes left, switching preferred grabbers",
1464	$in->{total_progs}->{$chan_id}))
1465	if ($in->{total_progs}->{$chan_id} > 0);
1466
1467	$preferred_grabber++;
1468	$done = 1 if ($preferred_grabber == $in->{num_datafiles});
1469	}
1470
1471	&log(1,(sprintf "Reconciled \"%s\" (%s): %d input programmes reconciled into %d output programmes",
1472	$in->{channels}->{$chan_id}->{pref_desc}, $chan_id, $in->{total_progs_in}->{$chan_id}, $in->{total_progs_out}->{$chan_id}));
1473	}
1474	}

Note: See TracBrowser for help on using the browser.

Context Navigation

root/reconcilers/reconciler_mk2 @ 72

Download in other formats: