Context Navigation

reconciler_mk2 @ 949

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

Note: See TracBrowser for help on using the browser.

Context Navigation

root/trunk/reconcilers/reconciler_mk2 @ 949

Download in other formats: