Context Navigation

reconciler_mk2 @ 1026

Revision 1026, 82.0 kB (checked in by paul, 5 years ago)
reconciler_mk2: skip title translation for sport and at least 70 minutes long
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 07oct06 initial version
14	# 0.02 11oct06 complete rewrite, new algorithms, seperate out from shepherd
15	# 0.03 15oct06 first committed
16	# 0.04 17oct06 bug fix: use our own parse_xmltv_date, Date::Manip seems broken
17	# bug fix: correctly parse some XMLTV rare fields
18	# 0.05 17oct06 enhancement: compress logfiles automatically since they are quite large
19	# 0.06 17oct06 enhancement: name mapping based on previously learnt names
20	# 0.07 19oct06 turn down debugging
21	# 0.08 20oct06 improved preference-title rewriter, more debugging to logfile
22	# 0.09 24oct06 --preftitle support
23	# 0.15 26nov06 reworked the title translations a bit
24	# - now only stores preferred titles when it has seen more than once
25	# - keeps last 30 days titles (indexed by time-of-day/day-of-week)
26	# as back history for alternate titles when switching grabbers
27
28	#
29	# reconciles programme listings using the following logic:
30	# sort programmes into per-channel and per-timeslot
31	# for each channel:
32	# 1. for programmes with a common start & stop time, evaluate them to see
33	# if they are the same programme using fuzzy title matching.
34	# use "majority voting" to decide which programme wins if titles differ.
35	# 2. for programmes that start within 10 minutes of each other, try to
36	# see if they are the same programme (fuzzy title matching), merging
37	# data between them
38	# 3. as a tie-breaker, prefer data based on order of grabber data we are
39	# fed. i.e. first data file takes preference over second data file, etc.
40	#
41	# other features:
42	# - will automatically split titles with "title: subtitle" into "title" and
43	# "subtitle" (controlled via $reclogic{max_length_for_colon_title_split} and
44	# $reclogic{min_title_for_colon_title_split})
45	# - will try to match "same titles" (including fuzzy title matching) for
46	# duplicate programmes within 10 minutes (or whatever
47	# $reclogic{fuzzy_match_title_time_window} is set to)
48	# - will automatically move start/stop times (up to a max of 5 minutes or whatever
49	# $reclogic{max_prog_length_for_rejig} is set to) whenever programming
50	# overlaps occur. logic for when-to-delete versus when-to-cutoff are
51	# controlled via $reclogic{min_prog_length_for_delete_cutoff} and
52	# $reclogic{delete_window_smaller_than_prog_window_threshold}
53	# - will remove all timezones from data (can be disabled by removing setting
54	# $reclogic{always_rewrite_start_stop_without_timezone}
55
56
57	# processing uses the following tables:
58	#
59	# order in which we read datafiles:
60	# number of datafiles: $in->{num_datafiles);
61	# order of datafiles: $in->{datafile_order}->[n] = $proggy;
62	# map datafile-to-grabber: $in->{datafile}->{$datafile} = $proggy;
63	# map grabber-to-datafile: $in->{data}->{$proggy}->{file} = $datafile;
64	# grabber version: $in->{data}->{$proggy}->{version} = $version;
65	#
66	# channels list:
67	# channel list: $in->{channels}->{$chan}->{lang}->{$lang} = $desc
68	#
69	# programme tables:
70	# $in->{tree}->{$chan}->{"start:stop"}->{progs}->[n]
71	# $in->{tree}->{$chan}->{"start:stop"}->{numprogs}
72	# $in->{total_progs}->{$chan}
73	# $in->{total_progs_in}->{$chan}, $in->{total_progs_out}->{$chan}
74	#
75	# misc tables:
76	# encoding we are using: $in->{encoding}
77	# where we sourced data from: $in->{sources}
78	# duplicate checking: $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}
79	# channel list: $in->{channels}->{$chan}->{$lang} = $desc
80	#
81	# used translations $in->{used_translations}->{$xlate_to}->{num}=count
82	# $in->{used_translations}->{$xlate_to}->{from}->{$xlate_from}=count
83
84	# history of title preferences uses the following (cache-based) data:
85	# $title_xlate_table->{"$primary_title"}->{seen_in_primary} = count
86	# $title_xlate_table->{"$primary_title"}->{last_seen_in_primary} = time
87	# $title_xlate_table->{"$primary_title"}->{translated} = count
88	# $title_xlate_table->{"$primary_title"}->{translation} = title
89	# $title_xlate_table->{"$primary_title"}->{alternate}->{"$alt_title"}->{secondary}->{"$source"} = count
90	# $title_xlate_table->{"$primary_title"}->{alternate}->{"$alt_title"}->{last_seen_in_secondary} = time
91	# $title_xlate_table->{"$primary_title"}->{same}->{"$source"} = count
92
93	use strict;
94	$\| = 1;
95	BEGIN { *CORE::GLOBAL::die = \&my_die; }
96
97	my $progname = "reconciler_mk2";
98	my $version = "0.37";
99
100	use LWP::UserAgent;
101	use XMLTV;
102	use POSIX qw(strftime mktime);
103	use Getopt::Long;
104	use Data::Dumper;
105	use Compress::Zlib;
106	use Storable;
107
108	#### reconciler settings ####
109	my %reclogic;
110
111	### *******************************************************************************
112	### * NOTE: all of these can be overridden through a (site local) config file *
113	### *******************************************************************************
114	### Doing that is HIGHLY PREFERABLE to CHANGING THIS FILE!
115	### remember that Shepherd may upgrade this automatically from time-to-time,
116	### causing any changes here to be LOST!
117
118	#
119	# reconciler logic settings
120	#
121
122	# delete_window_smaller_than_prog_window_threshold:
123	$reclogic{delete_window_smaller_than_prog_window_threshold} = (5*60); # 5 mins each side
124
125	# min_prog_length_for_delete_cutoff:
126	$reclogic{min_prog_length_for_delete_cutoff} = (10*60); # prog needs to be at least 10 mins if we're cutting back
127
128	# max_prog_length_for_rejig:
129	$reclogic{max_prog_length_for_rejig} = (10*60); # allow programme times to be changed by at-most 10 mins
130
131	$reclogic{fuzzy_match_title_time_window} = (20*60); # attempt title matches within +/- 20 min window
132
133	# always rewrite XMLTV 'start' & 'stop', removing timezone
134	$reclogic{always_rewrite_start_stop_without_timezone} = 1;
135
136	# add channels from data sources that we don't have in our channels.conf
137	$reclogic{always_add_new_channels} = 0; # don't
138
139	# if its on a freetv channel without a subtitle and a possible series
140	# (not a movie (less then or equal to $reclogic{max_length_for_colon_title_split} minutes)) and
141	# there is a ": " in title, split title into "title: subtitle"
142	# if each of title/subtitle will be at least $reclogic{min_title_for_colon_title_split} characters
143	$reclogic{max_length_for_colon_title_split} = (70*60);
144	$reclogic{min_title_for_colon_title_split} = 5;
145
146	# sanity check: don't accept insanely long programmes
147	$reclogic{max_programme_length} = (12 * 60 * 60); # 12 hours
148	$reclogic{max_programme_length_opt_channels} = (18 * 60 * 60); # 18 hours
149
150	# skip title translation for these categories and at least this long
151	@{$reclogic{title_xlate_skip_categories}} = ("sport");
152	$reclogic{title_xlate_skip_categories_min_programme_length} = (70 * 60); # 70 minutes
153
154	# store a preferred title only if we have at least 1 alternative
155	$reclogic{title_xlate_table_min_alt_progs} = 1;
156
157	# keep up to 30 days of title history
158	$reclogic{title_history} = 30;
159
160	# matching of history titles requires programme start within 20 minutes and duration within 10%
161	$reclogic{title_history_start_fuzzy_match_window} = (20*60); # seconds
162	$reclogic{title_history_duration_fuzzy_match_percent} = 10; # percent
163
164
165
166	#
167	# warning messages
168	#
169
170	$reclogic{warn_on_encoding_differences} = 0; # don't warn on encoding differences between XMLTV files
171	$reclogic{warn_on_no_title} = 1; # do warn on programme with no title
172	$reclogic{warn_on_no_channel} = 1; # do warn on programme with no channel
173	$reclogic{warn_on_unknown_channel} = 1; # do warn on programme with unknown channel
174	$reclogic{warn_on_invalid_time_in_prog} = 1; # do warn on programme with bad time format
175	$reclogic{warn_on_overlapping_programmes_always} = 0; # don't warn on all overlapping programmes from same source
176	$reclogic{warn_on_overlapping_programmes_for_different_title} = 1; # do warn on overlapping programmes from same source with different names
177	$reclogic{warn_on_invalid_time_in_prog} = 1; # do warn on a programme with a duration that is too long
178	$reclogic{warn_on_tba_prog} = 1; # do warn on encountering To Be Advised shows
179
180	#
181	# debug messages
182	#
183
184	$reclogic{debug_parse_time} = 0; # don't show debugging when parsing input time
185	$reclogic{debug_reconcile} = 0; # don't show reconciler logic
186	$reclogic{debug_reconcile_pass1} = 0; # don't show verbose pass 1 reconciler logic
187	$reclogic{debug_reconcile_pass2} = 0; # don't show verbose pass 2 reconciler logic
188	$reclogic{debug_add_logic} = 0; # don't show add logic debugging messages
189	$reclogic{debug_add_logic_verbose} = 0; # don't show add logic verbose debugging messages
190	$reclogic{debug_add_logic_name_xlate} = 0; # don't show add logic title translation messages
191	$reclogic{debug_delete_logic} = 0; # don't show delete logic debugging messages
192	$reclogic{debug_show_nonmatching_title_alternatives} = 0; # don't show non-matching alternative debugging messages
193	$reclogic{debug_find_prog_to_add} = 0; # don't show add_multiple logic debugging messages
194	$reclogic{debug_find_prog_to_add_verbose} = 0; # don't show add_multiple logic verbose debugging messages
195	$reclogic{debug_print_programme_list} = 0; # don't show programme listings while writing
196	$reclogic{debug_subtitle_derived_from_title} = 0; # don't show subtitles mapped from titles
197
198	#### end reconciler settings ####
199
200
201	#
202	# some initial cruft
203	#
204
205	my $script_start_time = time;
206	my %stats;
207	my $datafile;
208	my $channels, my $opt_channels;
209	my $in = { };
210	my $out = { };
211	my $w;
212	my $gmt_offset;
213
214	my $setting_override;
215	my %cli_override;
216	my $title_xlate_table; # cached
217	my $title_history; # cached
218
219	my %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } );
220
221
222	#
223	# parse command line
224	#
225
226	my $opt = { };
227	$opt->{output_file} = "output.xmltv";
228	$opt->{old_config_file} = $progname.".config";
229	$opt->{config_file} = $progname.".storable.config";
230	$opt->{log_file} = $progname.".log";
231	$opt->{alt_title_file} = $progname.".alt_title.log";
232	$opt->{lang} = "en";
233
234	GetOptions(
235	'region=i' => \$opt->{region}, # silently ignored
236	'days=i' => \$opt->{days}, # silently ignored
237	'offset=i' => \$opt->{offset}, # silently ignored
238	'timezone=s' => \$opt->{timezone}, # silently ignored
239
240	'channels_file=s' => \$opt->{channels_file},
241	'preftitle=s' => \$opt->{preftitle},
242	'old-config-file=s' => \$opt->{old_config_file},
243	'config-file=s' => \$opt->{config_file},
244	'log=s' => \$opt->{log_file},
245	'alt-title-file=s' => \$opt->{alt_title_file},
246	'output=s' => \$opt->{output_file},
247	'debug+' => \$opt->{debug},
248	'lang=s' => \$opt->{lang},
249	'option=s' => \%cli_override,
250
251	'no-log' => \$opt->{nolog},
252
253	'print_listing' => \$reclogic{debug_print_programme_list},
254	'dump_config' => \$opt->{dump_config},
255
256	'help' => \$opt->{help},
257	'verbose' => \$opt->{help},
258	'list_options' => \$opt->{help},
259	'version' => \$opt->{version},
260	'ready' => \$opt->{ready},
261	'desc' => \$opt->{desc},
262	'v' => \$opt->{version});
263
264	printf "%s v%s\n",$progname,$version;
265
266	if ($opt->{version} \|\| $opt->{desc} \|\| $opt->{help} \|\| $opt->{ready} \|\| $opt->{configure} \|\| $opt->{output_file} eq "") {
267	printf "A reconciler for multiple XMLTV data sources.\n" if $opt->{desc};
268	printf "$progname is ready for operation.\n" if ($opt->{ready});
269
270	printf "No --output file specified.\n" if ($opt->{output_file} eq "");
271
272	if ($opt->{help} \|\| $opt->{output_file} eq "") {
273	print<<EOF
274
275	usage: $0 [options] {FILE(s)}
276
277	Supported options include:
278	--ready verify that '$progname' is ready for operation
279
280	--lang={lang} set language to {lang} (default: $opt->{lang})
281	--channels_file={file} use channels file to augment list of channels (default: don't)
282	--output={file} send final XMLTV output to {file} (default: $opt->{output_file})
283	--debug enable ALL debugging
284
285	--print_listing print out programme listing of chosen programs
286
287	--config-file={file} config file for default overrides (default: none)
288	--log={file} write (detailed) log file in {file} (default: $opt->{log_file})
289	--alt-title-file={file} write details of possible alternate titles into {file} (default: $opt->{alt_title_file})
290
291	--list_options list all possible options
292	--option {opt}={val} set option {opt} to value {val}
293	EOF
294	;
295	foreach my $key (sort keys %reclogic) {
296	if (($key =~ /^warn_on_/) \|\| ($key =~ /^debug_/)) {
297	my $thiskey = sprintf "%s=%d",$key,($reclogic{$key} ? 0 : 1);
298	printf " --option %-30s %sable %s (default: %s)\n", $thiskey, ($reclogic{$key} ? "dis" : "en"),
299	$key, ($reclogic{$key} ? "do" : "don't");
300	} else {
301	my $thiskey = $key."={val}";
302	printf " --option %-30s set %s to {val} (default: %s)\n",$thiskey,$key,$reclogic{$key};
303	}
304	}
305	}
306	printf "\n";
307	exit(0);
308	}
309
310	# go go go!
311	unless ($opt->{nolog}) {
312	&rotate_logfiles;
313	open(LOG_FILE,">$opt->{log_file}") \|\| die "can't open log file $opt->{log_file} for writing: $!\n";
314	}
315
316	&log(1,(sprintf "started: %s%s%soutput %s",
317	($opt->{channels_file} ? "channels in $opt->{channels_file}, " : ""),
318	($opt->{config_file} ? "config in $opt->{config_file}, " : ""),
319	($opt->{preftitle} ? "preferred titles from $opt->{preftitle}, " : ""),
320	($opt->{output_file})));
321	&log(1,"logging to $opt->{log_file}") unless $opt->{nolog};
322	&log(1,"alternate titles to $opt->{alt_title_file}") unless $opt->{nolog};
323
324	# convert from old Data::Dumper to newer Storable config file
325	if ((defined $opt->{old_config_file}) && (-r $opt->{old_config_file})) {
326	&read_config_file($opt->{old_config_file},0) if ($opt->{old_config_file});
327	&write_config_file;
328	unlink($opt->{old_config_file});
329	}
330
331	&read_storable_file($opt->{config_file}) if ($opt->{config_file});
332	&show_settings;
333
334	&fill_in_channels if ($opt->{channels_file});
335
336	foreach my $file (@ARGV) {
337	$datafile = $file;
338	&log(1,(sprintf "parsing: %s",($datafile eq "-" ? "(from-stdin, hit control-D to finiah)" : $datafile)));
339
340	eval { XMLTV::parsefiles_callback(\&encoding_cb, \&credits_cb, \&channel_cb, \&programme_cb, $datafile); };
341	}
342
343	&start_writer;
344	&write_channels;
345
346	my $grabber_order = "", my $grabber_num = 0;
347	foreach my $data (@{($in->{datafile_order})}) {
348	$grabber_order .= sprintf "%s(%d)%s",
349	($grabber_num > 0 ? ", " : ""), $grabber_num, $data;
350	$grabber_num++;
351	}
352	&log(1,"reconciling with the following data-source preference: $grabber_order");
353
354	&reconcile;
355
356	&write_programmes;
357	$w->end();
358
359	unless ($opt->{nolog}) {
360	# compress older logfile
361	compress_file($opt->{log_file}.".1");
362	compress_file($opt->{alt_title_file}.".1");
363	}
364
365	&write_config_file if ($opt->{config_file});
366	&print_stats;
367
368	unless ($opt->{nolog}) {
369	close(LOG_FILE);
370	&write_alt_title_log;
371	}
372
373	exit(0);
374
375	######################################################################################################
376	# read settings (used for old config file and shepherd .conf files)
377
378	sub read_config_file
379	{
380	my($file,$die_on_failure) = @_;
381	if (!(-r $file)) {
382	die "file $file could not be read. aborting.\n" if $die_on_failure;
383	return;
384	}
385	local (@ARGV, $/) = ($file);
386	no warnings 'all'; eval <>; die "$@" if $@;
387	}
388
389	######################################################################################################
390	# used for reconciler new style config file
391
392	sub read_storable_file
393	{
394	my($file,$die_on_failure) = @_;
395	if (!(-r $file)) {
396	die "file $file could not be read. aborting.\n" if $die_on_failure;
397	return;
398	}
399
400	my $store;
401	eval { $store = Storable::retrieve($file); };
402	if ($@) {
403	&log(1,"Error reading $file: $@");
404	}
405
406	$setting_override = $store->{settings_override};
407	$title_xlate_table = $store->{title_xlate_table};
408	$title_history = $store->{title_history};
409
410	if (defined $opt->{dump_config}) {
411	print Dumper($store);
412	exit(0);
413	}
414	}
415
416	######################################################################################################
417
418	sub write_config_file
419	{
420	# age out old titles (default is to keep for 30 days as per $reclogic{title_history})
421	for my $cache_key (keys %{$title_history}) {
422	my ($starttime, $duration, $channel, $grabber) = split(/,/,$cache_key);
423	if ($starttime < (time-(86400*$reclogic{title_history}))) {
424	delete $title_history->{$cache_key};
425	$stats{expired_old_titles}++;
426	}
427	}
428
429	my $store;
430	$store->{settings_override} = $setting_override;
431	$store->{title_xlate_table} = $title_xlate_table;
432	$store->{title_history} = $title_history;
433
434	eval { Storable::store($store, $opt->{config_file}); };
435	if ($@) {
436	&log(1, "WARNING: Unable to update configuration file: $@");
437	} else {
438	&log(1,(sprintf "updated configuration file %s.\n",$opt->{config_file}));
439	}
440	}
441
442	######################################################################################################
443	# debug is actually always enabled (with default settings).
444	# --debug will turn on all debugging!
445
446	sub show_settings
447	{
448	foreach my $key (sort keys %reclogic) {
449	$reclogic{$key} = $setting_override->{$key} if (defined $setting_override->{$key});
450	$reclogic{$key} = $cli_override{$key} if (defined $cli_override{$key});
451	}
452
453	my $enabled_warnings = "";
454	my $enabled_debug = "";
455
456	foreach my $key (sort keys %reclogic) {
457	if ($key !~ /^debug_/) {
458	if ($key =~ /^warn_on_/) {
459	$enabled_warnings .= sprintf "%s%s",
460	($enabled_warnings ne "" ? ", " : ""),$key if ($reclogic{$key});
461	} elsif ($key =~ /^debug_/) {
462	$reclogic{$key} = 1 if ($opt->{debug});
463	$enabled_debug .= sprintf "%s%s",
464	($enabled_debug ne "" ? ", " : ""),$key if ($reclogic{$key});
465	} else {
466	# only print out setting if it was overridden
467	&log(1,(sprintf "%s was set to non-default %s via config-file option",$key,$reclogic{$key}))
468	if (defined $setting_override->{$key});
469	&log(1,(sprintf "%s was set to non-default %s via command-line option",$key,$reclogic{$key}))
470	if (defined $cli_override{$key});
471	}
472	}
473	}
474
475	&log(1,"warnings printed for: $enabled_warnings") if ($enabled_warnings ne "");
476	&log(1,"debug messages printed for: $enabled_debug") if ($enabled_debug ne "");
477	}
478
479	######################################################################################################
480	# we use our own die() routing to circumvent die() within eval statements where we are
481	# calling the standard XMLTV::parsefiles.
482	# this prevents bad XML from causing the reconciler to completely fail.
483
484	# ugly hack. please don't try this at home kids!
485
486	sub my_die {
487	my ($arg,@rest) = @_;
488	my ($pack,$file,$line,$sub) = caller(0);
489
490	# check if we are in an eval()
491	if ($^S) {
492	printf " caught a die() within eval{} from file $file line $line\n";
493	} else {
494	if (!ref($arg)) {
495	CORE::die("DIE at line $line in file $file ERROR: $arg" . join("",@rest));
496	} else {
497	CORE::die($arg,@rest);
498	}
499	}
500	}
501
502	######################################################################################################
503
504	sub rotate_logfiles
505	{
506	# keep last 4 log files
507	foreach my $file ($opt->{log_file}, $opt->{alt_title_file}) {
508	my $num;
509	for ($num = 4; $num > 0; $num--) {
510	my $f1 = sprintf "%s.%d.gz",$file,$num;
511	my $f2 = sprintf "%s.%d.gz",$file,$num+1;
512	unlink($f2);
513	rename($f1,$f2);
514	}
515
516	my $f2 = sprintf "%s.1",$file;
517	rename($file,$f2);
518	}
519	}
520
521	######################################################################################################
522
523	sub compress_file
524	{
525	my $infile = shift;
526	my $outfile = sprintf "%s.gz",$infile;
527	my $gz;
528
529	if (!(open(INFILE,"<$infile"))) {
530	warn "could not open file $infile for reading: $!\n";
531	return;
532	}
533
534	if (!($gz = gzopen($outfile,"wb"))) {
535	warn "could not open file $outfile for writing: $!\n";
536	return;
537	}
538
539	while (<INFILE>) {
540	my $byteswritten = $gz->gzwrite($_);
541	if ($byteswritten == 0) {
542	warn "error writing to compressed file: error $gz->gzerror";
543	}
544	}
545	close(INFILE);
546	$gz->gzclose();
547	unlink($infile);
548	}
549
550	######################################################################################################
551	# if we are supplied a channels_file, then fill in channels we know about from that.
552	# this is useful because some grabbers (e.g. oztivo) don't supply a <channels></channels>
553	# section at the top of their xmltv - and if they happen to be the first grabber,
554	# this causes issues with programmes with no (known) channel
555
556	sub fill_in_channels
557	{
558	&read_config_file($opt->{channels_file},1);
559
560	foreach my $ch (sort keys %{$channels}) {
561	&fill_channel($ch, $channels->{$ch});
562	}
563	foreach my $ch (sort keys %{$opt_channels}) {
564	&fill_channel($ch, $opt_channels->{$ch});
565	}
566
567	}
568
569	######################################################################################################
570
571	sub fill_channel
572	{
573	my ($ch, $id) = @_;
574
575	$in->{channels}->{$id}->{lang}->{($opt->{lang})} = $ch;
576	$in->{channels}->{$id}->{pref_desc} = $ch;
577	$in->{total_progs}->{$id} = 0;
578	$in->{total_progs_in}->{$id} = 0;
579	$in->{total_progs_out}->{$id} = 0;
580	}
581
582	######################################################################################################
583
584	sub log
585	{
586	my ($log_level,$entry) = @_;
587	printf "%s [%d] %s\n",$progname, time,$entry if ($log_level);
588	#printf LOG_FILE "%s [%d] %s\n",$progname, time,$entry if (($log_level) && (!$opt->{nolog}));
589	printf LOG_FILE "%s [%d] %s\n",$progname, time,$entry unless ($opt->{nolog});
590	}
591
592	######################################################################################################
593
594	sub print_stats
595	{
596	printf "STATS: %s v%s completed in %d seconds",$progname, $version, (time - $script_start_time);
597	foreach my $key (sort keys %stats) {
598	printf ", %d %s", $stats{$key},$key;
599	}
600	printf ".\n";
601	}
602
603	######################################################################################################
604	# descend a structure and clean up various things, including stripping
605	# leading/trailing spaces in strings, translations of html stuff etc
606	# -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
607
608	sub cleanup {
609	my $x = shift;
610	if (ref $x eq "REF") { cleanup($_) }
611	elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x }
612	elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
613	elsif (defined $$x) {
614	$$x =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
615	# $$x =~ s/[^\x20-\x7f]/ /g;
616	$$x =~ s/(^\s+\|\s+$)//g;
617	}
618	}
619
620	######################################################################################################
621
622	# strptime type date parsing - BUT - if no timezone is present, treat time as being in localtime
623	# rather than the various other perl implementation which treat it as being in UTC/GMT
624	sub parse_xmltv_date
625	{
626	my $datestring = shift;
627	my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
628	my $tz_offset = 0;
629
630	# work out GMT offset - we only do this once
631	if (!$gmt_offset) {
632	my $tzstring = strftime("%z", localtime(time));
633
634	$gmt_offset = (6060) int(substr($tzstring,1,2)); # hr
635	$gmt_offset += (60 * int(substr($tzstring,3,2))); # min
636	$gmt_offset *= -1 if (substr($tzstring,0,1) eq "-"); # +/-
637	}
638
639	if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
640	($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);
641	($t[6],$t[7],$t[8]) = (-1,-1,-1);
642
643	# if input data has a timezone offset, then offset by that
644	if ($datestring =~ /\+(\d{2})(\d{2})/) {
645	$tz_offset = $gmt_offset - (($1(6060)) + ($2*60));
646	} elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
647	$tz_offset = $gmt_offset + (($1(6060)) + ($2*60));
648	}
649
650	my $e = mktime(@t);
651	return ($e+$tz_offset) if ($e > 1);
652	}
653	return undef;
654	}
655
656	######################################################################################################
657
658	sub write_alt_title_log
659	{
660	if (!(open(ALT_TITLE_FILE,">$opt->{alt_title_file}"))) {
661	warn "can't open alt-title-file $opt->{alt_title_file} for writing: $!\n";
662	return;
663	}
664
665	printf ALT_TITLE_FILE "$progname $version\n";
666
667	printf ALT_TITLE_FILE "\n==========================================================================================================\n\n";
668	printf ALT_TITLE_FILE "(1) The following list shows title translations that were used:\n\n";
669
670	printf ALT_TITLE_FILE " Times Preferred Title (translated to) Translated from Times\n";
671	printf ALT_TITLE_FILE " ----- -------------------------------- ------------------------------ -----\n";
672	my $u = $in->{used_translations};
673	foreach my $xlate_to (sort { $u->{$b}->{num} <=> $u->{$a}->{num} } keys %{$u}) {
674	printf ALT_TITLE_FILE " %5d %-32s", $u->{$xlate_to}->{num},$xlate_to;
675
676	my $u2 = $u->{$xlate_to}->{from};
677	my $num = 0;
678	foreach my $xlate_from (sort { $u2->{$a} <=> $u2->{$b} } keys %{$u2}) {
679	printf ALT_TITLE_FILE "%s %-30s %5d\n",
680	($num > 0 ? " " : ""),
681	$xlate_from, $u2->{$xlate_from};
682	$num++;
683	}
684	}
685
686	printf ALT_TITLE_FILE "\n==========================================================================================================\n\n";
687	printf ALT_TITLE_FILE "(2) The following table lists ALL the translations we have stored:\n\n";
688	printf ALT_TITLE_FILE "+Preferred title (xlate to) xlate_ preferred title seen in source (times)\n";
689	printf ALT_TITLE_FILE "-Alternate title (xlate from) times alternate title seen in source (times)\n";
690	printf ALT_TITLE_FILE " ---------------------------------- ------- --------------------------------------------------------------\n";
691
692	foreach my $xlate_to (sort { $title_xlate_table->{$b}->{translated} <=> $title_xlate_table->{$a}->{translated} } keys %{$title_xlate_table}) {
693	printf ALT_TITLE_FILE "+%-34s %7d ",
694	substr("\"".$title_xlate_table->{$xlate_to}->{translation}."\"",0,34),
695	$title_xlate_table->{$xlate_to}->{translated};
696
697	foreach my $source (sort { $title_xlate_table->{$xlate_to}->{same}->{$b} <=> $title_xlate_table->{$xlate_to}->{same}->{$a} }
698	keys %{($title_xlate_table->{$xlate_to}->{same})}) {
699	printf ALT_TITLE_FILE " %s(%d)", $source, $title_xlate_table->{$xlate_to}->{same}->{$source};
700	}
701	printf ALT_TITLE_FILE "\n";
702
703	foreach my $xlate_from (sort keys %{($title_xlate_table->{$xlate_to}->{alternate})}) {
704	my $last_xlated = (time - $title_xlate_table->{$xlate_to}->{alternate}->{$xlate_from}->{last_seen_in_secondary});
705	my $last_xlated_desc;
706	if ($last_xlated < (246060)) {
707	$last_xlated_desc = sprintf "-%dhrs",int($last_xlated/(246060));
708	} elsif ($last_xlated < (72460*60)) {
709	$last_xlated_desc = sprintf "-%ddays",int($last_xlated/(246060));
710	} else {
711	$last_xlated_desc = sprintf "-%dwks",int($last_xlated/(72460*60));
712	}
713
714	printf ALT_TITLE_FILE "-%-34s %7s ",substr("\"".$xlate_from."\"",0,34),$last_xlated_desc;
715
716	foreach my $source (sort { $title_xlate_table->{$xlate_to}->{alternate}->{$xlate_from}->{secondary}->{$a} <=>
717	$title_xlate_table->{$xlate_to}->{alternate}->{$xlate_from}->{secondary}->{$b} }
718	keys %{($title_xlate_table->{$xlate_to}->{alternate}->{$xlate_from}->{secondary})}) {
719	printf ALT_TITLE_FILE " %s(%d)", $source, $title_xlate_table->{$xlate_to}->{alternate}->{$xlate_from}->{secondary}->{$source};
720	}
721	printf ALT_TITLE_FILE "\n";
722	}
723	printf ALT_TITLE_FILE "\n";
724	}
725
726	printf ALT_TITLE_FILE "\n==========================================================================================================\n\n";
727	printf ALT_TITLE_FILE "(3) The following list shows timeslots where NO titles matched.\n\n";
728	printf ALT_TITLE_FILE " i.e. if we had 3 grabbers providing data for this timeslot,\n";
729	printf ALT_TITLE_FILE " the reconciler saw 3 programmes that it considered to be\n";
730	printf ALT_TITLE_FILE " different. (if 2 were the same and one was different, it wouldn't\n";
731	printf ALT_TITLE_FILE " show up in this list.)\n\n";
732	printf ALT_TITLE_FILE " The intent of this list is to keep a log that we can (hopefully)\n";
733	printf ALT_TITLE_FILE " interpret to improve the canonicalizeTitles_match() logic.\n\n";
734	print ALT_TITLE_FILE $in->{alt_title_mismatches} if (defined $in->{alt_title_mismatches});
735
736	close(ALT_TITLE_FILE);
737	}
738
739	######################################################################################################
740	# The two supplied program titles match well enough that we should consider them to identify the same
741	# program. The approach we use is check that every word in the shorter title has a corresponding
742	# (nearly) identical word in the longer title. This handles grabbers that shorten program titles,
743	# such as from "House, MD" to "House." It als ignores word order altogether, since different
744	# grabbers often change word order around. Finally, we allow the shorter title to join together
745	# two adjacent words from the longer title.
746
747	sub canonicalizeTitles_match
748	{
749	my $word1 = canonicalizeTitle(shift);
750	my $word2 = canonicalizeTitle(shift);
751	my @longer;
752	my @shorter;
753
754	if (length($word1) > length($word2)) {
755	@longer = split(/\s+/, $word1);
756	@shorter = split(/\s+/, $word2);
757	} else {
758	@shorter = split(/\s+/, $word1);
759	@longer = split(/\s+/, $word2);
760	}
761
762	WORD: for my $word (@shorter) {
763	for(my $i=0; $i < @longer; ++$i) {
764	if (forgivingMatch($longer[$i], $word)) {
765	splice(@longer,$i,1);
766	next WORD;
767	} elsif ($i+1 < @longer &&
768	$word eq "$longer[$i]$longer[$i+1]") {
769	splice(@longer,$i,2);
770	next WORD;
771	}
772	}
773	return(0);
774	}
775
776	return(0) if (match_stoplist_override($word1, $word2));
777	return(1);
778	}
779
780	# lookup table of special case name matches
781	my %alternatives = ( one => "1",
782	two => "2",
783	to => "2",
784	too => "2",
785	three => "3",
786	four => "4",
787	for => "4",
788	five => "5",
789	six => "6",
790	seven => "7",
791	eight => "8",
792	nine => "9"
793	);
794
795	##############################################################################
796	# Are the two arguments "close enough" to being identical strings that they
797	# should be considered the same word? Differences we are willing to overlook
798	# include a single character transposition, insertion/deletion, or replacement
799	# in words of 3 or more characters. We also have a table of special cases that
800	# consider digits to be identical to their names, and also to common homonyms
801	# of their names (eg, "2" for "too").
802
803	sub forgivingMatch
804	{
805	my $word1 = shift;
806	my $word2 = shift;
807
808	# exact match
809	return 1 if $word1 eq $word2;
810	# they match according to our alternatives lookup table
811	return 1 if $alternatives{$word1} && $alternatives{$word1} eq $word2 \|\|
812	$alternatives{$word2} && $alternatives{$word2} eq $word1;
813	# irreconcilable differences
814	return 0 if abs(length($word1) - length($word2)) > 1 \|\|
815	length($word1) < 3;
816
817	my @list1 = split(//,$word1);
818	my @list2 = split(//,$word2);
819	my $i = 0;
820	my $j = 0;
821
822	# find first difference
823	while ($i < @list1 && $j < @list2 && $list1[$i] eq $list2[$j]) {
824	++$i; ++$j;
825	}
826	if ($i+1 < @list1 && $j+1 < @list2) {
827	# at least 2 chars to go in both words
828	if ($list1[$i+1] eq $list2[$j] && $list1[$i] eq $list2[$j+1]) {
829	# step over transposed characters
830	$i += 2;
831	$j += 2;
832	} elsif ($list1[$i+1] eq $list2[$j]) {
833	# step over extra character inserted into @list1
834	$i += 2;
835	++$j;
836	} elsif ($list1[$i] eq $list2[$j+1]) {
837	# steop over extra character inserted into @list2
838	++$i;
839	$j += 2;
840	} else {
841	# step over single character difference
842	++$i;
843	++$j;
844	}
845	# we forgave one difference; now do rest of strings match exactly?
846	while ($i < @list1 && $j < @list2 && $list1[$i] eq $list2[$j]) {
847	++$i; ++$j;
848	}
849	return($i == @list1 && $j == @list2);
850	} elsif ($i == @list1 \|\| $j == @list2) {
851	# only difference is one word has one extra letter, or last char
852	# of each word differ. That's still only one one-char difference
853	return(1);
854	}
855	}
856
857	##############################################################################
858	# Cleanup small ideosyncracies in a title that might make it harder to match.
859	# For now this just fixes up html entities and ampersands, normalizes whitepace,
860	# removes punctuation, and lowercases everything.
861
862	sub canonicalizeTitle
863	{
864	my $title=shift;
865	$title =~ s/^\s+//;
866	$title =~ s/\s+$//;
867	$title =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
868	$title =~ s/ \& / and /g;
869	$title =~ s/[^ a-zA-Z0-9]//g;
870	$title =~ s/\s+/ /;
871	return(lc($title));
872	}
873
874	######################################################################################################
875	# used to override what would otherwise be canonical matches
876	# returns 1 if they should NOT match
877
878	sub match_stoplist_override
879	{
880	my ($word1, $word2) = @_;
881
882	# if the left-hand-side programme matches the right-hand-side, ensure the
883	# alternate programme ALSO matches the right-hand-side
884	my $canonical_stop_list_exceptions = {
885	'Law.*Order' => [ "Criminal", "SVU", "Special", "Trial" ],
886	'(CSI\|Crime.Scene.Investigation).:' => [ ":.Crime", "NY", "N.Y", "New", "Miami" ]
887	};
888
889	foreach my $stop1 (keys %$canonical_stop_list_exceptions) {
890	#printf "checking word1 ($word1) against stoplist stop1 ($stop1) ..\n";
891	if ($word1 =~ /^$stop1/i) {
892	#printf " word1 ($word1) contains stop1 ($stop1)\n";
893	foreach my $stop2 (@{($canonical_stop_list_exceptions->{$stop1})}) {
894	#printf " checking whether word1 ($word1) contains stop2 ($stop2)\n";
895	if ($word1 =~ /$stop2/i) {
896	#printf " word1 ($word1) contains stop2 ($stop2)\n";
897	if ($word2 !~ /$stop2/i) {
898	#printf " word2 ($word2) doesn't contain stop2 ($stop2). rejecting match!\n";
899	return 1;
900	}
901	}
902	#printf " checking whether word2 ($word2) contains stop2 ($stop2)\n";
903	if ($word2 =~ /$stop2/i) {
904	#printf " word2 ($word2) contains stop2 ($stop2)\n";
905	if ($word1 !~ /$stop2/i) {
906	#printf " word1 ($word1) doesn't contain stop2 ($stop2). rejecting match!\n";
907	return 1;
908	}
909	}
910	}
911	}
912	}
913
914	return 0;
915	}
916
917	######################################################################################################
918
919	sub encoding_cb( $ )
920	{
921	my $e = shift;
922	#printf "got encoding ".Dumper($e);
923	$in->{encoding} = $e if (!$in->{encoding});
924
925	&log($reclogic{warn_on_encoding_differences},
926	(sprintf"WARNING: encoding '%s' from %s different from %s",$e,$datafile,$in->{encoding}))
927	if ($in->{encoding} ne $e);
928	}
929
930	######################################################################################################
931
932	sub credits_cb( $ )
933	{
934	my $c = shift;
935	#printf "got credits ".Dumper($c);
936
937	my ($proggy, $version);
938
939	if ($c->{'generator-info-name'}) {
940	if ($c->{'generator-info-name'} =~ /\s?(\S+)\s[v]?([\d\.]+)/) {
941	($proggy, $version) = ($1,$2);
942	}
943	}
944
945	$proggy = $datafile if (!defined $proggy);
946	$version = "" if (!defined $version);
947
948	$in->{data}->{$proggy}->{file} = $datafile;
949	$in->{datafile}->{$datafile} = $proggy;
950	$in->{data}->{$proggy}->{version} = $version;
951
952	if (!defined $in->{num_datafiles}) {
953	$in->{num_datafiles} = 0;
954	$in->{sources} = "$proggy";
955	} else {
956	$in->{sources} .= ",$proggy";
957	}
958
959	$in->{data}->{titlepref} = $in->{num_datafiles}
960	if ((defined $opt->{preftitle}) && ($datafile eq $opt->{preftitle}));
961
962	$in->{datafile_order}->[($in->{num_datafiles})] = $proggy;
963	$in->{num_datafiles}++;
964	}
965
966	######################################################################################################
967
968	sub channel_cb( $ )
969	{
970	my $c = shift;
971	#printf "got channel ".Dumper($c);
972
973	my $chan = $c->{id};
974	my %chan_lang;
975
976	# only add this channel if $reclogic{always_add_new_channels} is set
977	if ((!defined $in->{channels}->{$chan}) && (!$reclogic{always_add_new_channels})) {
978	&log($reclogic{warn_on_unknown_channel},(sprintf "WARNING: channel '%s' from file \"%s\" not in channels.conf; ignored.", $chan, $datafile));
979	$stats{ignored_unknown_channel}++;
980	return;
981	}
982
983	if (defined $c->{'display-name'} && defined $c->{'display-name'}->[0]) {
984	foreach my $ch_block ($c->{'display-name'}->[0]) {
985	my ($desc,$lang) = ($ch_block->[0],$ch_block->[1]);
986	$lang = $opt->{lang} if (!defined $lang);
987	$desc = "unknown" if (!defined $desc);
988
989	if (!defined $in->{channels}->{$chan}) {
990	$in->{channels}->{$chan}->{lang}->{$lang} = $desc;
991	$in->{total_progs}->{$chan} = 0;
992	$in->{total_progs_in}->{$chan} = 0;
993	$in->{total_progs_out}->{$chan} = 0;
994	} else {
995	$in->{channels}->{$chan}->{lang}->{$lang} = $desc
996	if (!defined $in->{channels}->{$chan}->{lang}->{$lang});
997	}
998
999	$in->{channels}->{$chan}->{pref_desc} = $desc
1000	if (!defined $in->{channels}->{$chan}->{pref_desc});
1001	}
1002	}
1003	}
1004
1005	######################################################################################################
1006
1007	sub programme_cb( $ )
1008	{
1009	my $prog=shift;
1010	# print "got programme from $datafile: ".Dumper($prog);
1011
1012	# make sure programme has a title
1013	if (!defined $prog->{title} \|\| !defined $prog->{title}->[0]) {
1014	&log($reclogic{warn_on_no_title},(sprintf "WARNING: programme with no title in %s; ignored.", $datafile));
1015	$stats{bad_programme_no_title}++;
1016	return;
1017	}
1018	my $prog_title = $prog->{title}->[0]->[0];
1019	my $prog_subtitle;
1020	$prog_subtitle = $prog->{'sub-title'}->[0]->[0] if (defined $prog->{'sub-title'} && $prog->{'sub-title'}->[0] && $prog->{'sub-title'}->[0]->[0]);
1021
1022	# make sure programme has a channel
1023	if (!defined $prog->{channel}) {
1024	&log($reclogic{warn_on_no_channel},(sprintf "WARNING: programme '%s' had no channel information; ignored.", $prog_title));
1025	$stats{bad_programme_no_channel}++;
1026	return;
1027	}
1028	my $prog_chan = $prog->{channel};
1029
1030	# make sure we know about this channel
1031	if (!defined $in->{channels}->{$prog_chan}) {
1032	&log($reclogic{warn_on_unknown_channel},(sprintf "WARNING: programme '%s' had unknown channel \"%s\"; ignored.", $prog_title, $prog_chan));
1033	$stats{bad_programme_unknown_channel}++;
1034	return;
1035	}
1036
1037	my $source = $in->{datafile}->{$datafile};
1038
1039	# work out epoch times
1040	my $t1 = &parse_xmltv_date($prog->{start});
1041	my $t2 = &parse_xmltv_date($prog->{stop});
1042
1043	if (!$t1 \|\| !$t2) {
1044	&log($reclogic{warn_on_invalid_time_in_prog},
1045	(sprintf "WARNING: programme '%s' on channel '%s' from %s had invalid start (%s) or stop (%s) time; ignored.",
1046	$prog_title, $prog_chan, $datafile, ($prog->{start} ? $prog->{start} : "undef"),
1047	($prog->{stop} ? $prog->{stop} : "undef")));
1048	$stats{bad_programme_invalid_times}++;
1049	return;
1050	}
1051
1052	&log($reclogic{debug_parse_time},
1053	(sprintf " prog \"%s\" on chan \"%s\" start %s end %s, duration %d, file %s",
1054	$prog_title, $prog_chan, (strftime "%a%e%b%H:%M", localtime($t1)),
1055	(strftime "%a%e%b%H%M", localtime($t2)), ($t2 - $t1), $source)) if ($t1 && $t2);
1056
1057	# skip if on a freetv channel and too long OR extra long provided title isn't 'close'
1058	if (((defined $channels->{$in->{channels}->{$prog_chan}->{pref_desc}} &&
1059	(($t2 - $t1) > $reclogic{max_programme_length})) \|\|
1060	(($t2 - $t1) > $reclogic{max_programme_length_opt_channels})) &&
1061	($prog_title !~ /\bclose\b/i)) {
1062	&log($reclogic{warn_on_invalid_time_in_prog},
1063	(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.",
1064	$prog_title, $prog_chan, $datafile, ($t2-$t1), $reclogic{max_programme_length},
1065	($prog->{start} ? $prog->{start} : "undef"), ($prog->{stop} ? $prog->{stop} : "undef")));
1066	$stats{bad_programme_duration_too_long}++;
1067	return;
1068	}
1069
1070	# skip if 'To Be Advised' or 'TBA'
1071	if ($prog_title =~ /^to be advised$/i or $prog_title =~ /^tba$/i)
1072	{
1073	&log($reclogic{warn_on_tba_prog},
1074	(sprintf "WARNING: ignoring TBA programme '%s' on channel '%s' from %s: start '%s' stop '%s'; ignored.",
1075	$prog_title, $prog_chan, $datafile,
1076	($prog->{start} ? $prog->{start} : "undef"),
1077	($prog->{stop} ? $prog->{stop} : "undef")));
1078	return;
1079	}
1080
1081	$prog->{start_epoch} = $t1;
1082	$prog->{stop_epoch} = $t2;
1083	$prog->{grabber} = $source;
1084	$prog->{grabber_num} = ($in->{num_datafiles}-1);
1085	my $prog_key = sprintf "%d:%d",$t1,$t2;
1086
1087	# if its on a freetv channel without a subtitle and a possible series
1088	# (not a movie (less then or equal to 70 minutes)) and
1089	# there is a ": " in title, split title into "title: subtitle"
1090	# if each of title/subtitle will be at least $reclogic{min_title_for_colon_title_split} characters
1091	if (defined $channels->{$in->{channels}->{$prog_chan}->{pref_desc}} && !defined $prog_subtitle &&
1092	(($t2 - $t1) <= $reclogic{max_length_for_colon_title_split})) {
1093	my ($title1,$title2) = split(/: /,$prog_title,2);
1094
1095	if (($title1) && ($title2) &&
1096	(length($title1) >= $reclogic{min_title_for_colon_title_split}) &&
1097	(length($title2) >= $reclogic{min_title_for_colon_title_split})) {
1098	&log($reclogic{debug_subtitle_derived_from_title},
1099	(sprintf "split title \"%s\" into title \"%s\" subtitle \"%s\" since over min_title_for_colon_title_split (%d)",
1100	$prog_title, $title1, $title2, $reclogic{min_title_for_colon_title_split}));
1101	$stats{derived_subtitle_from_title}++;
1102
1103	$prog_title = $title1;
1104	$prog->{title}->[0]->[0] = $title1;
1105
1106	$prog_subtitle = $title2;
1107	$prog->{'sub-title'}->[0]->[0] = $title2;
1108	$prog->{'sub-title'}->[0]->[1] = $prog->{'title'}->[0]->[1];
1109	}
1110
1111	}
1112
1113	# check to see if this grabber has supplied a programme with this start/stop on this
1114	# channel already. if there is, whinge about it & drop the duplicate
1115	if (defined $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}) {
1116	# record statistic but don't print error message if programme names actually match
1117	my $warn = (($reclogic{warn_on_overlapping_programmes_always}) \|\|
1118	(($reclogic{warn_on_overlapping_programmes_for_different_title}) &&
1119	($prog_title ne $in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key})));
1120	&log($warn,(sprintf "WARNING: file contained more than one programme in same timeslot: channel '%s' start %s, stop %s, programs \"%s\" and \"%s\"; ignored.",
1121	$prog_chan,
1122	(strftime "%a%e%b%H:%M",localtime($t1)),
1123	(strftime "%a%e%b%H:%M",localtime($t2)),
1124	$prog_title,
1125	$in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key}));
1126	$stats{bad_programme_duplicate_times}++;
1127	return;
1128	}
1129	$in->{dupcheck}->{$source}->{$prog_chan}->{$prog_key} = $prog_title;
1130
1131
1132	#
1133	# store each programme in a tree. the tree looks like:
1134	# $in->{tree}->{$chan}->{$progkey}->{progs}->[n]
1135	# $in->{tree}->{$chan}->{$progkey}->{numprogs}
1136	#
1137
1138	my $prognum = 0;
1139	$prognum = $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs}
1140	if (defined $in->{tree}->{$prog_chan}->{$prog_key}->{numprogs});
1141	$in->{tree}->{$prog_chan}->{$prog_key}->{progs}->[$prognum] = $prog;
1142	$prognum++;
1143	$in->{tree}->{$prog_chan}->{$prog_key}->{numprogs} = $prognum;
1144
1145	$in->{total_progs}->{$prog_chan}++;
1146	$in->{total_progs_in}->{$prog_chan}++;
1147	}
1148
1149	######################################################################################################
1150	# open output file, write encoding + credits headings
1151
1152	sub start_writer
1153	{
1154	my %writer_args = ( encoding => $in->{encoding} );
1155	my $fh = new IO::File(">$opt->{output_file}") \|\| die "can't open $opt->{output_file}: $!";
1156	$writer_args{OUTPUT} = $fh;
1157	$w = new XMLTV::Writer(%writer_args);
1158	$w->start( { 'generator-info-name' => "$progname $version", 'source-info-name' => $in->{sources} } );
1159	}
1160
1161	######################################################################################################
1162	# write out our channels
1163
1164	sub write_channels
1165	{
1166	foreach my $chan_id (sort keys %{($in->{channels})}) {
1167	my $this_chan = $in->{channels}->{$chan_id};
1168
1169	my $lang_list, my $num_langs = 0;
1170	foreach my $lang (keys %{($this_chan->{lang})}) {
1171	$lang_list->[$num_langs]->[0] = $this_chan->{lang}->{$lang};
1172	$lang_list->[$num_langs]->[1] = $lang;
1173	$num_langs++;
1174	}
1175
1176	$w->write_channel( { 'id' => $chan_id, 'display-name' => $lang_list } );
1177	}
1178	}
1179
1180	######################################################################################################
1181	# write out our programmes
1182
1183	sub write_programmes
1184	{
1185	foreach my $chan_id (sort keys %{($in->{channels})}) {
1186	foreach my $prog_key (sort keys %{($out->{$chan_id})}) {
1187	my $prog = $out->{$chan_id}->{$prog_key};
1188	my $progname = sprintf "%s%s",
1189	$prog->{title}->[0]->[0],
1190	($prog->{subtitle} ? ": $prog->{subtitle}->[0]->[0]" : "");
1191
1192	printf "%-10s %s - %s: %-30s {src %s}\n",
1193	$in->{channels}->{$chan_id}->{pref_desc},
1194	(strftime "%a%e%b%H:%M", localtime($prog->{start_epoch})),
1195	(strftime "%a%e%b%H:%M", localtime($prog->{stop_epoch})),
1196	$progname,
1197	$prog->{datasources}
1198	if ($reclogic{debug_print_programme_list});
1199
1200	delete $prog->{start_epoch} if (defined $prog->{start_epoch});
1201	delete $prog->{stop_epoch} if (defined $prog->{stop_epoch});
1202	delete $prog->{datasources} if (defined $prog->{datasources});
1203
1204	&cleanup($prog);
1205	$w->write_programme($prog);
1206	}
1207	}
1208	}
1209
1210	######################################################################################################
1211	# all logic associated with choosing the preferred title of a programme
1212	# (uses past-seen choices to set preferences)
1213
1214	sub choose_title
1215	{
1216	my ($num_matching,$m) = @_;
1217	my @titles, my @titles_from;
1218	my $num_titles = 0;
1219	my $channel = $m->[0]->{channel};
1220	my $title_start = $m->[0]->{start_epoch};
1221	my $title_duration = $m->[0]->{stop_epoch} - $m->[0]->{start_epoch};
1222
1223	# 0. first gather title from "preferred grabber" if we have it for
1224	# this programme
1225	if (defined $in->{data}->{titlepref}) {
1226	for my $i (0..($num_matching-1)) {
1227	if (($m->[$i]->{grabber_num} == $in->{data}->{titlepref}) &&
1228	(defined $m->[$i]->{title})) {
1229	foreach my $found_t (@{($m->[$i]->{title})}) {
1230	my $t = $found_t->[0];
1231	my $l = $found_t->[1];
1232
1233	if ((!defined $l) \|\| (lc($l) eq lc($opt->{lang}))) {
1234	$titles[$num_titles] = $t;
1235	$titles_from[$num_titles] = $m->[$i]->{grabber};
1236	$num_titles++;
1237	}
1238	}
1239	}
1240	}
1241	}
1242
1243	# 1. gather a list of all titles we have for our preferred language
1244	# there are stored in the @titles array in "quality" order
1245	for my $i (0..($num_matching-1)) {
1246	if (defined $m->[$i]->{title}) {
1247	next if ((defined $in->{data}->{titlepref}) &&
1248	($m->[$i]->{grabber_num} == $in->{data}->{titlepref}));
1249
1250	foreach my $found_t (@{($m->[$i]->{title})}) {
1251	my $t = $found_t->[0];
1252	my $l = $found_t->[1];
1253
1254	if ((!defined $l) \|\| (lc($l) eq lc($opt->{lang}))) {
1255	$titles[$num_titles] = $t;
1256	$titles_from[$num_titles] = $m->[$i]->{grabber};
1257	$num_titles++;
1258	}
1259	}
1260	}
1261	}
1262
1263	# 2. no titles in our language? return with the first title we saw
1264	if ($num_titles == 0) {
1265	my $title = $m->[0]->{title}->[0]->[0];
1266	my $lang = $m->[0]->{title}->[0]->[1];
1267
1268	&log($reclogic{debug_choose_title},(sprintf
1269	"choose_title: no titles in lang %s found; using first title \"%s\" in lang %s",
1270	$opt->{lang}, $title, (defined $lang ? $lang : "(undef)")));
1271	return ($title, $lang);
1272	}
1273
1274	# if 70 minutes or longer and category sport return best title
1275	if ($title_duration >= $reclogic{title_xlate_skip_categories_min_programme_length}) {
1276	for my $i (0..($num_matching-1)) {
1277	if (defined $m->[$i]->{title} && defined $m->[$i]->{category}) {
1278	foreach my $found_c (@{($m->[$i]->{category})}) {
1279	my $c = $found_c->[0];
1280	next if ($c eq '');
1281
1282	foreach my $skip_c (@{$reclogic{title_xlate_skip_categories}}) {
1283	if (lc($c) eq lc($skip_c)) {
1284	&log($reclogic{debug_choose_title},(sprintf
1285	"choose_title: not using xlate table; using best title \"%s\" because category \"%s\" and length %d minutes", $titles[0], $skip_c, $title_duration/60));
1286	return ($titles[0], $opt->{lang});
1287	}
1288	}
1289	}
1290	}
1291	}
1292	}
1293
1294	# 3. do we already have any titles in our list here in our 'preferred title' list?
1295	my $found_index = -1;
1296	foreach my $i (0..$num_titles) {
1297	if (defined $title_xlate_table->{(lc($titles[$i]))}) {
1298	$found_index = $i;
1299	last;
1300	}
1301	}
1302
1303	# 4. found our preferred title. use that.
1304	if ($found_index != -1) {
1305	my $key = lc($titles[$found_index]);
1306	my $title = $title_xlate_table->{$key}->{translation};
1307
1308	&log($reclogic{debug_choose_title},(sprintf
1309	"choose_title: existing preferred title \"%s\" matched with title \"%s\" from grabber %s (index %d)",
1310	$title, $titles[$found_index], $titles_from[$found_index], $found_index));
1311
1312	# update stats on use
1313	$title_xlate_table->{$key}->{seen_in_primary}++;
1314	$title_xlate_table->{$key}->{last_seen_in_primary} = time;
1315
1316	# update 'seen' stats for alternatives
1317	foreach my $i (0..($num_titles-1)) {
1318	my $key2 = $titles[$i]; # don't actually store in lower-case..
1319	my $source = $titles_from[$i];
1320
1321	if (lc($key) eq lc($key2)) {
1322	# store where we have seen the same title
1323	$title_xlate_table->{$key}->{same}->{$source}++;
1324	} else {
1325	# store all alternatives for this title
1326	$title_xlate_table->{$key}->{alternate}->{$key2}->{secondary}->{$source}++;
1327	$title_xlate_table->{$key}->{alternate}->{$key2}->{last_seen_in_secondary} = time;
1328	}
1329	}
1330
1331	return ($title, $opt->{lang});
1332	}
1333
1334	# 5. didn't find this title in our preferred title list.
1335	# see if it is an alternate name
1336	foreach my $i (0..($num_titles-1)) {
1337	my $title = $titles[$i]; # don't actually convert to lowercase..
1338
1339	# FUTURE MAYBE: this is a linear search.
1340	# if it grows too much consider a schema change to make it better
1341
1342	foreach my $key (keys %{($title_xlate_table)}) {
1343	foreach my $key2 (keys %{($title_xlate_table->{$key}->{alternate})}) {
1344	if (lc($key2) eq lc($title)) {
1345	my $xlated_to = $title_xlate_table->{$key}->{translation};
1346	my $xlated_from = $titles[$i];
1347
1348	# check that its a real match
1349	if (match_stoplist_override($xlated_from, $xlated_to)) {
1350	&log($reclogic{debug_choose_title},
1351	"choose_title: match_stoplist_override: \"$xlated_from\" does not match \"$xlated_to\"");
1352	next;
1353	}
1354
1355	# matched alternate!
1356	$title_xlate_table->{$key}->{translated}++;
1357	$in->{used_translations}->{$xlated_to}->{num}++;
1358	$in->{used_translations}->{$xlated_to}->{from}->{$xlated_from}++;
1359
1360	&log($reclogic{debug_choose_title},(sprintf
1361	"choose_title: title \"%s\" (idx %d grabber %s) matched previously-seen alternate title for \"%s\"",
1362	$xlated_from, $i, $titles_from[$i], $xlated_to));
1363
1364	# update 'seen' stats for alternatives
1365	foreach my $j (0..($num_titles-1)) {
1366	my $key2a = $titles[$j]; # don't store in lowercase
1367	my $source = $titles_from[$j];
1368
1369	if ($key eq lc($key2a)) {
1370	# store where we have seen the same title
1371	$title_xlate_table->{$key}->{same}->{$source}++;
1372	} else {
1373	# store all alternatives for this title
1374	$title_xlate_table->{$key}->{alternate}->{$key2a}->{secondary}->{$source}++;
1375	$title_xlate_table->{$key}->{alternate}->{$key2a}->{last_seen_in_secondary} = time;
1376	}
1377	}
1378
1379	# return primary translation for this found alternative
1380	return ($xlated_to, $opt->{lang});
1381	}
1382	}
1383	}
1384	}
1385
1386	my $seen_in_primary = time;
1387
1388	# 6. look back through our history of programmes to see if we can fuzzy match
1389	# this title to a previously-seen title
1390	for my $title_cache_key (keys %{$title_history}) {
1391	my ($th_starttime, $th_duration, $th_channel, $th_grabber) = split(/,/,$title_cache_key);
1392
1393	# has to be on same channel
1394	next if ($channel ne $th_channel);
1395
1396	# has to be on the same day of the week
1397	next if ((int($th_starttime / 86400) % 7) != (int($title_start / 86400) % 7));
1398
1399	# duration has to be within 10% ($reclogic{title_history_duration_fuzzy_match_percent})
1400	next if ($title_duration > ($th_duration * (1 + ($reclogic{title_history_duration_fuzzy_match_percent} / 100))));
1401	next if ($title_duration < ($th_duration * (1 - ($reclogic{title_history_duration_fuzzy_match_percent} / 100))));
1402
1403	# start time has to be within 20 minutes ($reclogic{title_history_start_fuzzy_match_window})
1404	my $th_starttime_day = $th_starttime % (7*86400);
1405	my $title_start_day = $title_start % (7*86400);
1406	next if ($title_start_day > ($th_starttime_day + $reclogic{title_history_start_fuzzy_match_window}));
1407	next if ($title_start_day < ($th_starttime_day - $reclogic{title_history_start_fuzzy_match_window}));
1408
1409	# within window - check title
1410	foreach my $i (0..($num_titles-1)) {
1411	# grabber has to be different
1412	next if ($th_grabber eq $titles_from[$i]);
1413
1414	# check match
1415	my $match = canonicalizeTitles_match($title_history->{$title_cache_key},$titles[$i]);
1416	&log($reclogic{debug_choose_title},(sprintf "choose_title: title \"%s\" (from %s) %s title_history \"%s\" (from %s)",
1417	$titles[$i], $titles_from[$i], ($match == 1 ? "IS THE SAME AS" : "did not match"),
1418	$title_history->{$title_cache_key}, $th_grabber));
1419
1420	if ($match) {
1421	# match - add it to the front of our titles list!
1422	$num_titles++;
1423	unshift(@titles, $title_history->{$title_cache_key});
1424	unshift(@titles_from, $th_grabber);
1425	$seen_in_primary = $th_starttime;
1426	last;
1427	}
1428	}
1429	}
1430
1431	my $preferred_title = $titles[0];
1432
1433	# 7. don't create a preferred title for this unless we have met our threshold for title_xlate_table_min_alt_progs
1434	if (($num_titles-1) < $reclogic{title_xlate_table_min_alt_progs}) {
1435	&log($reclogic{debug_choose_title},(sprintf
1436	"choose_title: title \"%s\" not added as a preferred title due to title_xlate_table_min_alt_progs (%d)",
1437	$preferred_title, $reclogic{title_xlate_table_min_alt_progs}));
1438	return ($preferred_title, $opt->{lang});
1439	}
1440
1441	# 8. wasn't an alternate name
1442	# add it as a preferred name
1443
1444	my $key = lc($preferred_title);
1445	$title_xlate_table->{$key}->{seen_in_primary} = 1;
1446	$title_xlate_table->{$key}->{last_seen_in_primary} = $seen_in_primary;
1447	$title_xlate_table->{$key}->{translated} = 0;
1448	$title_xlate_table->{$key}->{translation} = $preferred_title;
1449	$title_xlate_table->{$key}->{same}->{$titles_from[0]} = 1;
1450
1451	foreach my $i (1..($num_titles-1)) {
1452	my $key2 = $titles[$i];
1453	my $source = $titles_from[$i];
1454
1455	if (lc($key2) eq $key) {
1456	$title_xlate_table->{$key}->{same}->{$source}++;
1457	} else {
1458	$title_xlate_table->{$key}->{alternate}->{$key2}->{secondary}->{$source} = 1;
1459	$title_xlate_table->{$key}->{alternate}->{$key2}->{last_seen_in_secondary} = time;
1460	}
1461	}
1462
1463	&log($reclogic{debug_choose_title},(sprintf
1464	"choose_title: added title \"%s\" as a preferred title (grabber %s)",
1465	$preferred_title, $titles_from[0]));
1466
1467	return ($preferred_title, $opt->{lang});
1468	}
1469
1470	######################################################################################################
1471	# insert a programme into our reconciled list
1472	# - if fed multiple programmes for the one slot, choose attributes from all of them
1473
1474	sub add_one_programme
1475	{
1476	my($chan_id,$title,$title_lang,$num_matching,$m) = @_;
1477	&log($reclogic{debug_add_logic},
1478	(sprintf "add_one_programme: adding programme %s-%s \"%s\" with data from %d programmes",
1479	(strftime "%a%e%b%H:%M",localtime(($m->[0]->{start_epoch}))),
1480	(strftime "%a%e%b%H:%M",localtime(($m->[0]->{stop_epoch}))),
1481	$title, $num_matching));
1482
1483	my $newprog;
1484	my $chan = $m->[0]->{channel};
1485	my $starttime = $m->[0]->{start_epoch};
1486	my $have_xlated_title = 0;
1487
1488	# always take start/stop/channel from first choice
1489
1490	if ($reclogic{always_rewrite_start_stop_without_timezone}) {
1491	$newprog->{start} = strftime "%Y%m%d%H%M00", localtime($m->[0]->{start_epoch});
1492	$newprog->{stop} = strftime "%Y%m%d%H%M00", localtime($m->[0]->{stop_epoch});
1493	} else {
1494	$newprog->{start} = $m->[0]->{start};
1495	$newprog->{stop} = $m->[0]->{stop};
1496	}
1497	$newprog->{start_epoch} = $m->[0]->{start_epoch};
1498	$newprog->{stop_epoch} = $m->[0]->{stop_epoch};
1499	$newprog->{channel} = $chan;
1500	$newprog->{title}->[0] = [ $title, $title_lang ];
1501
1502	# add this programme to our title_history
1503	my $title_history_key = sprintf "%d,%d,%s,%s",
1504	$newprog->{start_epoch},
1505	($newprog->{stop_epoch}-$newprog->{start_epoch}),
1506	$newprog->{channel}, $m->[0]->{grabber};
1507	$title_history->{$title_history_key} = $title;
1508
1509	# fill in programme fields and attributes
1510	$newprog->{datasources} = "";
1511	for my $i (0..($num_matching-1)) {
1512	$newprog->{datasources} .= sprintf "%s%d",($newprog->{datasources} ne "" ? "," : ""),$m->[$i]->{grabber_num};
1513
1514	# (1) merge in attributes which are simple scalars
1515	foreach my $field ('date', 'length') {
1516	if ((!defined $newprog->{$field}) &&
1517	(defined $m->[$i]->{$field}) &&
1518	($m->[$i]->{$field} ne "")) {
1519	$newprog->{$field} = $m->[$i]->{$field};
1520	&log($reclogic{debug_add_logic},
1521	(sprintf " - added field %s from #%d (%s) value %s",
1522	$field,$m->[$i]->{grabber_num},$m->[$i]->{grabber},$newprog->{$field}));
1523	}
1524	}
1525
1526	# (2) merge in attributes which are simple arrays
1527	foreach my $field ('url', 'star-rating', 'premiere', 'last-chance', 'language', 'orig-language') {
1528	if (defined $m->[$i]->{$field}) {
1529	my %existing_hash;
1530	my $num_existing = 0;
1531
1532	# pick up existing entries
1533	if (defined $newprog->{$field}) {
1534	my $existing_entries = $newprog->{$field};
1535	foreach my $entry (@$existing_entries) {
1536	$existing_hash{$entry} = 1;
1537	$num_existing++;
1538	}
1539	}
1540
1541	my $new_entries = $m->[$i]->{$field};
1542	foreach my $entry (@$new_entries) {
1543	if ((!defined $existing_hash{$entry}) && ($entry ne "")) {
1544	$existing_hash{$entry} = 1;
1545	$newprog->{$field}->[$num_existing] = $entry;
1546	$num_existing++;
1547
1548	&log($reclogic{debug_add_logic},
1549	(sprintf " - added field %s from #%d (%s) value %s",
1550	$field,$m->[$i]->{grabber_num},$m->[$i]->{grabber},$entry));
1551	}
1552	}
1553	}
1554	}
1555
1556	# (3) merge in attributes which are [val,lang] pairs, [val,val] or [val,val,val]
1557	# note: while 'title' is here, this is simply to pick up titles in any
1558	# additional languages; the primary (preferred) title has already been
1559	# set via the choose_title() routine
1560	foreach my $field ('title', 'sub-title', 'desc', 'category', 'country', 'episode-num', 'rating') {
1561	my $num_added = 0;
1562	my %lang_added;
1563
1564	# pick up existing entries already there
1565	if (defined $newprog->{$field}) {
1566	my $existing_entries = $newprog->{$field};
1567	foreach my $entry (@$existing_entries) {
1568	my $val = $entry->[0];
1569	my $lang = $entry->[1];
1570	$lang = "BLANK" if (!$lang);
1571	push(@{$lang_added{$lang}}, $val);
1572	$num_added++;
1573	}
1574	}
1575
1576	# augment them with any new data
1577	if (defined $m->[$i]->{$field}) {
1578	my $new_entries = $m->[$i]->{$field};
1579	foreach my $entry (@$new_entries) {
1580	my $val = $entry->[0];
1581	my $lang = $entry->[1];
1582
1583	if ($field eq "episode-num") {
1584	$lang = "onscreen" if (!$lang);
1585	} elsif ($field eq "rating") {
1586	$lang = "BLANK" if (!$lang);
1587	} else {
1588	$lang = $opt->{lang} if (!$lang);
1589	}
1590
1591	# special-case for some categories:
1592	# 'premiere' - don't pass it on but instead set premiere field.
1593	# 'en' - (as in language: en) - just strip
1594	# duplicate - just strip
1595	if ($field eq 'category') {
1596	if ($val eq "premiere") {
1597	$newprog->{premiere}->[0] = "premiere" if (!defined $newprog->{premiere});
1598	&log($reclogic{debug_add_logic}," - set 'premiere' because of category");
1599	next;
1600	} elsif ($val eq "en") {
1601	&log($reclogic{debug_add_logic}," - stripped 'en' category");
1602	next;
1603	} elsif (defined $lang_added{$lang} && grep($_ eq $val, @{$lang_added{$lang}})) {
1604	&log($reclogic{debug_add_logic}," - stripped duplicate category");
1605	next;
1606	}
1607	}
1608
1609	if ((!defined $lang_added{$lang}) \|\| ($field eq 'category') \|\| ($field eq 'country')) {
1610	push(@{$lang_added{$lang}}, $val);
1611
1612	$newprog->{$field}->[$num_added]->[0] = $val;
1613
1614	&log($reclogic{debug_add_logic},
1615	(sprintf " - added field %s(%s) from #%d (%s) value %s",
1616	$field,($lang ne "BLANK" ? $lang : ""),$m->[$i]->{grabber_num},$m->[$i]->{grabber},$val));
1617
1618	if ($lang eq "BLANK") {
1619	$newprog->{$field}->[$num_added]->[1] = undef;
1620	} else {
1621	$newprog->{$field}->[$num_added]->[1] = $lang;
1622	}
1623
1624	if ($field eq "rating") {
1625	$newprog->{$field}->[$num_added]->[2] = $entry->[2];
1626	}
1627
1628	$num_added++;
1629	}
1630	}
1631	}
1632	}
1633
1634	# (4) merge in attributes which are {hash}->{hash}->[array]
1635	foreach my $field ('credits') {
1636	foreach my $field2 ('director','actor','writer','adapter','producer','presenter','commentator','guest') {
1637	my $num_added = 0;
1638	my %entries;
1639
1640	# pick up existing entries we already have
1641	if (defined $newprog->{$field}->{$field2}) {
1642	my $existing_entries = $newprog->{$field}->{$field2};
1643	foreach my $entry (@$existing_entries) {
1644	$entries{$entry} = 1;
1645	$num_added++;
1646	}
1647	}
1648
1649	# augment with new data
1650	if (defined $m->[$i]->{$field}->{$field2}) {
1651	my $new_entries = $m->[$i]->{$field}->{$field2};
1652	foreach my $entry (@$new_entries) {
1653	if (($entry ne "") && (!defined $entries{$entry})) {
1654	$newprog->{$field}->{$field2}->[$num_added] = $entry;
1655	$entries{$entry} = 1;
1656	$num_added++;
1657
1658	&log($reclogic{debug_add_logic},
1659	(sprintf " - added field %s/%s from #%d (%s) value %s",
1660	$field,$field2,$m->[$i]->{grabber_num},$m->[$i]->{grabber},$entry));
1661	}
1662	}
1663	}
1664	}
1665	}
1666
1667	# (5) merge in attributes which are by name with no values, or values we don't care to interpret
1668	foreach my $field ('new', 'subtitles', 'previously-shown') {
1669	if ((!defined $newprog->{$field}) && (defined $m->[$i]->{$field})) {
1670	$newprog->{$field} = $m->[$i]->{$field};
1671
1672	&log($reclogic{debug_add_logic},
1673	(sprintf " - added field %s from #%d (%s)",
1674	$field,$m->[$i]->{grabber_num},$m->[$i]->{grabber}));
1675	}
1676	}
1677
1678	# (6) merge in attributes which are {hash}->{hash}=val
1679	foreach my $field ('video', 'audio') {
1680	my %entries;
1681
1682	# pick up existing entries we already have
1683	if (defined $newprog->{$field}) {
1684	my $existing_entries = $newprog->{$field};
1685	foreach my $entry (keys %{$existing_entries}) {
1686	$entries{$entry} = $newprog->{$field}->{$entry};
1687	}
1688	}
1689
1690	# augment with new data
1691	if (defined $m->[$i]->{$field}) {
1692	my $new_entries = $m->[$i]->{$field};
1693	foreach my $entry (keys %{$new_entries}) {
1694	if (($entry ne "") && (!defined $entries{$entry})) {
1695	$newprog->{$field}->{$entry} = $m->[$i]->{$field}->{$entry};
1696	$entries{$entry} = $m->[$i]->{$field}->{$entry};
1697
1698	&log($reclogic{debug_add_logic},
1699	(sprintf " - added field %s from #%d (%s) value %s",
1700	$field,$m->[$i]->{grabber_num},$m->[$i]->{grabber},$entries{$entry}));
1701	}
1702	}
1703	}
1704	}
1705
1706	# ignored attributes:
1707	# icon
1708	}
1709
1710
1711	# (7) XMLTV supports multiple 'categories' but alas mythfilldatabase doesn't
1712	# really support that properly. Ensure that categories called
1713	# 'movie', 'series', 'sports' and 'tvshow' are not listed first
1714	if (defined $newprog->{category}) {
1715	my $num_categories = scalar @{$newprog->{category}};
1716	my $first_category = $newprog->{category}->[0]->[0];
1717	if (($num_categories > 1) &&
1718	(($first_category eq "movie") \|\| ($first_category eq "series") \|\|
1719	($first_category eq "sports") \|\| ($first_category eq "tvshow"))) {
1720	# see if we can switch two around...
1721	for (my $i=1; $i < $num_categories; $i++) {
1722	my $this_cat = $newprog->{category}->[$i]->[0];
1723	if (($this_cat ne "movie") && ($this_cat ne "series") &&
1724	($this_cat ne "sports") && ($this_cat ne "tvshow")) {
1725	$newprog->{category}->[$i]->[0] = $first_category;
1726	$newprog->{category}->[0]->[0] = $this_cat;
1727	&log($reclogic{debug_add_logic},
1728	(sprintf " - set primary category from '%s' to '%s'",
1729	$first_category, $this_cat));
1730	$i = $num_categories;
1731	}
1732	}
1733	}
1734	}
1735
1736
1737	if (defined $out->{$chan}->{$starttime}) {
1738	&log(1,(sprintf "ERROR: already have a programme on channel \"%s\" scheduled for %s! bug!",
1739	$chan, (strftime "%a %e %b %H:%M",localtime($starttime))));
1740	} else {
1741	$out->{$chan}->{$starttime} = $newprog;
1742	$in->{total_progs_out}->{($newprog->{channel})}++;
1743	}
1744	}
1745
1746	######################################################################################################
1747	# remove all programming data for this channel where programming is between start/stop times
1748
1749	sub delete_overlapping_programmes
1750	{
1751	my($chan_id,$del_start,$del_stop) = @_;
1752
1753	&log($reclogic{debug_delete_logic},
1754	(sprintf "delete_overlapping_programmes: called to delete within %s-%s on chan %s",
1755	(strftime "%a%e%b%H:%M", localtime($del_start)), (strftime "%a%e%b%H:%M", localtime($del_stop)),
1756	$in->{channels}->{$chan_id}->{pref_desc}));
1757
1758	# remove programming between $del_start and $del_stop
1759	foreach my $prog_key ( keys %{($in->{tree}->{$chan_id})} ) {
1760	for my $i (0..($in->{tree}->{$chan_id}->{$prog_key}->{numprogs}-1)) {
1761	my $delete_this = 0;
1762	my $prog_start = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch};
1763	my $prog_stop = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch};
1764	my $prog_title = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{title}->[0]->[0];
1765	my $prog_grabber = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{grabber_num};
1766
1767	if (($prog_start >= $del_start) && ($prog_stop <= $del_stop)) {
1768	#
1769	# prog entirely within window - delete it
1770	#
1771
1772	$delete_this = 1;
1773	&log($reclogic{debug_delete_logic},
1774	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - within window",
1775	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1776	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber));
1777	} elsif (($prog_start < $del_start) && ($prog_stop > $del_stop)) {
1778	#
1779	# looks very bogus. starts before our delete window and ends after our delete window.
1780	# there is no "right" action here - try to apply some heuristics
1781	#
1782
1783	if ((($prog_start + $reclogic{delete_window_smaller_than_prog_window_threshold}) >= $del_start) &&
1784	(($prog_stop - $reclogic{delete_window_smaller_than_prog_window_threshold}) <= $del_stop)) {
1785	#
1786	# if programme is within -/+5 minutes (default) for both start/end of delete window
1787	# then delete it
1788	#
1789
1790	$delete_this = 1;
1791	&log($reclogic{debug_delete_logic},
1792	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - within window +/- delete_window_smaller_than_prog_window_threshold (%d)",
1793	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1794	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1795	$reclogic{delete_window_smaller_than_prog_window_threshold}));
1796	$stats{prog_del_overwindow_close_enough}++;
1797	} else {
1798	#
1799	# rather than deleting it, try to cut back either the stop or bring forward the start
1800	#
1801
1802	my $before_del_start = $del_start - $prog_start;
1803	my $after_del_stop = $prog_stop - $del_stop;
1804
1805	if (($before_del_start <= $reclogic{min_prog_length_for_delete_cutoff}) &&
1806	($after_del_stop <= $reclogic{min_prog_length_for_delete_cutoff})) {
1807	#
1808	# programme would be too short if we did that. delete it
1809	#
1810	$delete_this = 1;
1811	&log($reclogic{debug_delete_logic},
1812	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating start/stop would result in under min_prog_length_for_delete_cutoff (%d)",
1813	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1814	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1815	$reclogic{min_prog_length_for_delete_cutoff}));
1816	$stats{prog_del_overwindow_too_short}++;
1817	} else {
1818	if ($before_del_start > $after_del_stop) {
1819	#
1820	# cut off end
1821	#
1822	&log($reclogic{debug_delete_logic},
1823	(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",
1824	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1825	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1826	$before_del_start, $after_del_stop,
1827	(strftime "%a%e%b%H:%M", localtime($prog_start)),
1828	(strftime "%a%e%b%H:%M", localtime($del_start))));
1829	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch} = $del_start;
1830	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop} = strftime "%Y%m%d%H%M",localtime($del_start);
1831	$stats{prog_del_overwindow_cut_end}++;
1832	} else {
1833	#
1834	# cut off beginning
1835	#
1836	&log($reclogic{debug_delete_logic},
1837	(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",
1838	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1839	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1840	$before_del_start, $after_del_stop,
1841	(strftime "%a%e%b%H:%M", localtime($del_stop)),
1842	(strftime "%a%e%b%H:%M", localtime($prog_stop))));
1843	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch} = $del_stop;
1844	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start} = strftime "%Y%m%d%H%M",localtime($del_stop);
1845	$stats{prog_del_overwindow_culled_start}++;
1846	}
1847	}
1848	}
1849	} elsif (($prog_start < $del_stop) && ($prog_stop > $del_stop)) {
1850	#
1851	# programme starts within window but ends outside of it.
1852	#
1853	if (($del_stop - $prog_start) > $reclogic{max_prog_length_for_rejig}) {
1854	# would cut off too much programme - delete it
1855	$delete_this = 1;
1856	&log($reclogic{debug_delete_logic},
1857	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating start would lose more than max_prog_length_for_rejig (%d)",
1858	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1859	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1860	$reclogic{max_prog_length_for_rejig}));
1861	$stats{prog_del_too_much_culled_from_start}++;
1862	} else {
1863	&log($reclogic{debug_delete_logic},
1864	(sprintf " - updating \"%s\" (%s-%s, grabber %d) - pushed forward start time because under max_prog_length_for_rejig (%d). prog now %s-%s",
1865	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1866	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1867	$reclogic{max_prog_length_for_rejig},
1868	(strftime "%a%e%b%H:%M", localtime($del_stop)),
1869	(strftime "%a%e%b%H:%M", localtime($prog_stop))));
1870	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start_epoch} = $del_stop;
1871	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{start} = strftime "%Y%m%d%H%M",localtime($del_stop);
1872	$stats{prog_del_start_cull_ok}++;
1873	}
1874	} elsif (($prog_start < $del_start) && ($prog_stop > $del_start)) {
1875	#
1876	# programme starts outside window but ends within it.
1877	#
1878	if (($prog_stop - $del_start) > $reclogic{max_prog_length_for_rejig}) {
1879	# would cut off too much programme - delete it
1880	$delete_this = 1;
1881	&log($reclogic{debug_delete_logic},
1882	(sprintf " - deleting \"%s\" (%s-%s, grabber %d) - updating stop would lose more than max_prog_length_for_rejig (%d)",
1883	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1884	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1885	$reclogic{max_prog_length_for_rejig}));
1886	$stats{prog_del_too_much_cut_from_end}++;
1887	} else {
1888	&log($reclogic{debug_delete_logic},
1889	(sprintf " - updating \"%s\" (%s-%s, grabber %d) - pulled back stop time due to under max_prog_length_for_rejig (%d). prog now %s-%s",
1890	$prog_title, (strftime "%a%e%b%H:%M", localtime($prog_start)),
1891	(strftime "%a%e%b%H:%M", localtime($prog_stop)), $prog_grabber,
1892	$reclogic{max_prog_length_for_rejig},
1893	(strftime "%a%e%b%H:%M", localtime($prog_start)),
1894	(strftime "%a%e%b%H:%M", localtime($del_start))));
1895	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop_epoch} = $del_start;
1896	$in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i]->{stop} = strftime "%Y%m%d%H%M",localtime($del_start);
1897	$stats{prog_del_end_cut_ok}++;
1898	}
1899	}
1900
1901	if ($delete_this) {
1902	delete $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[$i];
1903	$in->{tree}->{$chan_id}->{$prog_key}->{numprogs}--;
1904	$in->{total_progs}->{$chan_id}--;
1905	$i--;
1906	}
1907	}
1908
1909	# if no progs left in group, delete entire group
1910	if ($in->{tree}->{$chan_id}->{$prog_key}->{numprogs} == 0) {
1911	# delete entire group
1912	delete $in->{tree}->{$chan_id}->{$prog_key};
1913	}
1914	}
1915	}
1916
1917	######################################################################################################
1918	# when given multiple programmes matching same timeslot, compare titles of them to see if
1919	# they are the same programme.
1920	# - if the same programme, insert them.
1921	# - if different programmes, select our preferred one to insert.
1922
1923	sub find_prog_to_add
1924	{
1925	my ($chan_id,$numprogs,$log_check_matching,$prog_list) = @_;
1926
1927	#
1928	# find out what titles match, store results
1929	#
1930
1931	&log($reclogic{debug_find_prog_to_add},
1932	(sprintf "find_prog_to_add: slot on channel %s has %d programmes to choose from.",
1933	$chan_id,$numprogs));
1934
1935	my @match_count;
1936	my $data_match;
1937	my $highest_num_matches_slot = 0;
1938
1939	for my $i (0..($numprogs-2)) {
1940	my $primary_title = $prog_list->[$i]{title}->[0]->[0];
1941	$match_count[$i] = 0;
1942
1943	for my $j ($i+1..($numprogs-1)) {
1944	# skip if we're comparing titles from the same grabber
1945	next if ($prog_list->[$i]->{grabber} eq $prog_list->[$j]->{grabber});
1946
1947	my $compare_title = $prog_list->[$j]->{title}->[0]->[0];
1948	if (canonicalizeTitles_match($primary_title, $compare_title)) {
1949	$data_match->[$i]->[$j] = 1;
1950	$data_match->[$j]->[$i] = 1;
1951	$match_count[$i]++;
1952	$match_count[$j]++;
1953	}
1954	}
1955
1956	$highest_num_matches_slot = $i if ($match_count[$i] > $match_count[$highest_num_matches_slot]);
1957	}
1958
1959	$match_count[0] = 0 if $numprogs < 2;
1960
1961	&log($reclogic{debug_find_prog_to_add},
1962	(sprintf "find_prog_to_add: grabber %d wins for this slot with %d matches.",
1963	$highest_num_matches_slot,$match_count[$highest_num_matches_slot]));
1964
1965	my $matching_progs, my $num_matching_progs = 1;
1966	if ($match_count[$highest_num_matches_slot] == 0) {
1967	my $prog = $prog_list->[0];
1968	if (($numprogs > 1) && ($log_check_matching)) {
1969	#
1970	# no data matched - log this for further inspection
1971	#
1972	my $alternate_titles = sprintf " channel %s %s - %s, (used grabber %d %s)\n",
1973	$in->{channels}->{$chan_id}->{pref_desc},
1974	(strftime "%a %e %b %H:%M",localtime(($prog->{start_epoch}))),
1975	(strftime "%a %e %b %H:%M",localtime(($prog->{stop_epoch}))),
1976	$prog->{grabber_num},$prog->{grabber};
1977
1978	for my $i (0..($numprogs-1)) {
1979	my $this_prog = $prog_list->[$i];
1980	$alternate_titles .= sprintf " #%d. \"%s\" {src %s}\n",
1981	$this_prog->{grabber_num}, $this_prog->{title}->[0]->[0], $this_prog->{grabber};
1982	}
1983
1984	&log($reclogic{debug_show_nonmatching_title_alternatives}, $alternate_titles);
1985
1986	$alternate_titles .= "\n";
1987	$in->{alt_title_mismatches} .= $alternate_titles;
1988	}
1989
1990	# add entry from our preferred grabber
1991	$matching_progs->[0] = $prog;
1992	} else {
1993	# add entry from our multiple grabbers
1994	$stats{rec_start_stop_title_match}++;
1995	$matching_progs->[0] = $prog_list->[$highest_num_matches_slot];
1996	my $primary_title = $matching_progs->[0]->{title}->[0]->[0];
1997	&log($reclogic{debug_find_prog_to_add},(sprintf "find_prog_to_add: \"%s\" selected data from grabber %d (%s)",
1998	$primary_title, $highest_num_matches_slot, $matching_progs->[0]->{grabber}));
1999	for my $i (0..($numprogs-1)) {
2000	if ($data_match->[$highest_num_matches_slot]->[$i]) {
2001	$matching_progs->[$num_matching_progs] = $prog_list->[$i];
2002	my $this_title = $matching_progs->[$num_matching_progs]->{title}->[0]->[0];
2003
2004	&log($reclogic{debug_find_prog_to_add},
2005	(sprintf "find_prog_to_add: - augmenting with data from \"%s\" grabber %d (%s)",
2006	$this_title, $i, $matching_progs->[$num_matching_progs]->{grabber}));
2007
2008	$num_matching_progs++;
2009	}
2010	}
2011	}
2012
2013	my ($title, $title_lang) = &choose_title($num_matching_progs,$matching_progs);
2014	&add_one_programme($chan_id,$title,$title_lang,$num_matching_progs,$matching_progs);
2015
2016	# remove all programming data for this channel which overlaps with this (inserted) programme
2017	&delete_overlapping_programmes($chan_id,$matching_progs->[0]->{start_epoch},$matching_progs->[0]->{stop_epoch});
2018	}
2019
2020	######################################################################################################
2021
2022	sub reconcile
2023	{
2024
2025	#
2026	# loop through channels
2027	# (chan_id)
2028	#
2029
2030	foreach my $chan_id (sort keys %{($in->{channels})}) {
2031	my $this_chan = $in->{channels}->{$chan_id};
2032
2033	#
2034	# (1) look for programmes within the same timeslot
2035	# if at least 2 grabbers say a programme starts/ends at the
2036	# same time & have a similar title, use that
2037	#
2038
2039	&log($reclogic{debug_reconcile},
2040	(sprintf "reconcile: channel '%s': pass 1: %d programmes remaining",
2041	$in->{channels}->{$chan_id}->{pref_desc}, $in->{total_progs}->{$chan_id}));
2042
2043	# 1a. gather up programming timeslots
2044	foreach my $prog_key (
2045	sort { $in->{tree}->{$chan_id}->{$a}->{numprogs} <=> $in->{tree}->{$chan_id}->{$b}->{numprogs} }
2046	keys %{($in->{tree}->{$chan_id})} ) {
2047	next if (!defined $in->{tree}->{$chan_id}->{$prog_key});
2048	my $num_progs_in_slot = $in->{tree}->{$chan_id}->{$prog_key}->{numprogs};
2049
2050	# 1b. at least 2 programs in the same timeslot - try to add it if titles match
2051	if ($num_progs_in_slot > 1) {
2052	my $this_prog_start = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{start_epoch};
2053	my $this_prog_stop = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{stop_epoch};
2054
2055	&log($reclogic{debug_reconcile_pass1},
2056	(sprintf "reconcile: %d programs between %s - %s",
2057	$num_progs_in_slot, (strftime "%a%e%b%H:%M",localtime($this_prog_start)),
2058	(strftime "%a%e%b%H:%M",localtime($this_prog_stop))));
2059
2060	$stats{rec_start_stop_match}++;
2061	&find_prog_to_add($chan_id,$num_progs_in_slot,1,$in->{tree}->{$chan_id}->{$prog_key}->{progs});
2062	}
2063	}
2064
2065	#
2066	# (2) look for programmes within similar (but not exact) timeslots
2067	# but with same name. use timeslot from the "higher preference"
2068	# grabber
2069	#
2070
2071	my $done = 0, my $preferred_grabber = 0;
2072	while (($in->{total_progs}->{$chan_id} > 0) && (!$done)) {
2073	&log($reclogic{debug_reconcile},
2074	(sprintf "reconcile: channel '%s': pass 2: %d programmes remaining, preferring grabber %d",
2075	$in->{channels}->{$chan_id}->{pref_desc}, $in->{total_progs}->{$chan_id}, $preferred_grabber));
2076
2077	# 2a. find first programme from preferred grabber
2078	my @prog_keys = sort { $in->{tree}->{$chan_id}->{$a} <=> $in->{tree}->{$chan_id}->{$b} } keys %{($in->{tree}->{$chan_id})};
2079	foreach my $prog_key (@prog_keys) {
2080	next if (!defined $in->{tree}->{$chan_id}->{$prog_key});
2081	next if ($in->{tree}->{$chan_id}->{$prog_key}->{numprogs} == 0);
2082	next if ($in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{grabber_num} != $preferred_grabber);
2083
2084	# got a programme from our preferred grabber
2085	my $found_prog = $in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0];
2086	my $start_window = $found_prog->{start_epoch} - $reclogic{fuzzy_match_title_time_window};
2087	my $stop_window = $found_prog->{start_epoch} + $reclogic{fuzzy_match_title_time_window};
2088
2089	my $matched_progs;
2090	$matched_progs->[0] = $found_prog;
2091	my $num_matched_progs = 1;
2092
2093	&log($reclogic{debug_reconcile_pass2},
2094	(sprintf "reconcile: (%d to go) chose programme for %s-%s: \"%s\", looking for alternatives between %s-%s",
2095	$in->{total_progs}->{$chan_id},
2096	(strftime "%a%e%b%H:%M",localtime($found_prog->{start_epoch})),
2097	(strftime "%a%e%b%H:%M",localtime($found_prog->{stop_epoch})), $found_prog->{title}->[0]->[0],
2098	(strftime "%a%e%b%H:%M",localtime($start_window)),
2099	(strftime "%a%e%b%H:%M",localtime($stop_window))));
2100
2101	foreach my $prog_key2 ( sort { $in->{tree}->{$chan_id}->{$a} <=> $in->{tree}->{$chan_id}->{$b} } keys %{($in->{tree}->{$chan_id})} ) {
2102	next if ($in->{tree}->{$chan_id}->{$prog_key}->{progs}->[0]->{grabber_num} != $preferred_grabber);
2103	next if ($prog_key2 eq $prog_key);
2104
2105	my $numprogs = $in->{tree}->{$chan_id}->{$prog_key2}->{numprogs};
2106	for my $i (0..($numprogs-1)) {
2107	my $check_prog = $in->{tree}->{$chan_id}->{$prog_key2}->{progs}->[$i];
2108
2109	# match programmes which _start_ within the timewindow (but not necessarily end!)
2110	if (($check_prog->{start_epoch} >= $start_window) && ($check_prog->{start_epoch} < $stop_window)) {
2111	$matched_progs->[$num_matched_progs] = $check_prog;
2112	$num_matched_progs++;
2113
2114	&log($reclogic{debug_reconcile_pass2},
2115	(sprintf "reconcile: found alternative prog: %s-%s, \"%s\"",
2116	(strftime "%a%e%b%H:%M",localtime($check_prog->{start_epoch})),
2117	(strftime "%a%e%b%H:%M",localtime($check_prog->{stop_epoch})),
2118	$check_prog->{title}->[0]->[0]));
2119	}
2120	}
2121	}
2122
2123	&find_prog_to_add($chan_id,$num_matched_progs,0,$matched_progs);
2124	}
2125
2126	&log($reclogic{debug_reconcile},
2127	(sprintf "reconcile: still have %d programmes left, switching preferred grabbers",
2128	$in->{total_progs}->{$chan_id}))
2129	if ($in->{total_progs}->{$chan_id} > 0);
2130
2131	$preferred_grabber++;
2132	$done = 1 if ($preferred_grabber == $in->{num_datafiles});
2133	}
2134
2135	&log(1,(sprintf "reconciled \"%s\" (%s) %d input -> %d output programmes",
2136	$in->{channels}->{$chan_id}->{pref_desc}, $chan_id, $in->{total_progs_in}->{$chan_id}, $in->{total_progs_out}->{$chan_id}));
2137	}
2138	}

Note: See TracBrowser for help on using the browser.

Context Navigation

root/trunk/reconcilers/reconciler_mk2 @ 1026

Download in other formats: