Context Navigation

flag_aus_hdtv

Revision 1390, 26.6 kB (checked in by max, 8 months ago)
shepherd 1.6.0: Change shebang lines from '/usr/bin/perl' to '/usr/bin/env perl', which is more portable (i.e. works on OSX).
Property svn:executable set to ``*

Line
1	#!/usr/bin/env perl
2
3	# flag_aus_hdtv
4
5	# performs two functions:
6	# 1. takes existing programmes flagged as HDTV by grabbers,
7	# 2. checks the DTV Forum Australia (http://www.dtvforum.info/)
8	# .. and populates the '(chan)HD' channels (if they exist)
9	# with the HD versions of the programs.
10
11	# originally written by Richard Dale <richard@interlink.com.au>,
12	# September 2006
13	# Modified to use DTV Forums Australia instead of Digital Broadcasting Australia
14	# http://www.dtvforum.info/index.php?showtopic=28574
15	# Chris Williams <shepherd@psychogeeks.com>
16	# May 2008
17
18	my $progname = "flag_aus_hdtv";
19	my $version = "0.51";
20
21	$\| = 1;
22	print "$progname v$version\n";
23
24	use strict;
25	use Getopt::Long;
26	use Shepherd::Common;
27	use HTML::TreeBuilder;
28	use IO::File;
29	use XMLTV;
30	use Data::Dumper;
31
32	#
33	# customizations
34	#
35
36	# Add overrides for HD - sometimes DBA doesn't always have the latest HD information about TV shows so set them here in the override
37	my $hdoverride;
38	# $hdoverride->{TEN} = [
39	# "The Handler",
40	# "N.Y.P.D. Blue",
41	# "The Office",
42	# "Battlestar Galactica"
43	# ];
44	$hdoverride->{Nine} = [
45	"CSI: Crime Scene Investigation",
46	"Without a Trace"
47	];
48
49	# Add translations for show names that differ between DBA and our normal tv_grab_au names
50	my $translation;
51	$translation->{'ACA'} = 'A Current Affair';
52	$translation->{'CSI'} = 'CSI: Crime Scene Investigation';
53	$translation->{'CSI-Miami'} = 'CSI: Miami';
54
55	# translations between website and what we know channels as
56	my $chan_name_translations;
57	$chan_name_translations->{"ABC"} = "ABC HD";
58	$chan_name_translations->{"Seven"} = "7HD";
59	$chan_name_translations->{"Prime"} = "Prime HD";
60	$chan_name_translations->{"Nine"} = "Nine HD";
61	$chan_name_translations->{"One Digital"} = "One HD";
62	$chan_name_translations->{"SBS"} = "SBS HD";
63
64	my $hd_to_sds;
65	@{$hd_to_sds->{"ABC HD"}} = ("ABC1");
66	@{$hd_to_sds->{"7HD"}} = ("Seven","Southern Cross","SCTV Central","Central GTS/BKN","Golden West");
67	@{$hd_to_sds->{"Prime HD"}} = ("Prime");
68	@{$hd_to_sds->{"Nine HD"}} = ("Nine","WIN","NBN","Imparja");
69	@{$hd_to_sds->{"One HD"}} = ("One Digital");
70	@{$hd_to_sds->{"SBS HD"}} = ("SBS ONE");
71
72
73	my $sd_to_hd;
74	foreach my $hdchannel (keys %$hd_to_sds) {
75	foreach my $channel (@{$hd_to_sds->{$hdchannel}}) {
76	$sd_to_hd->{$channel} = $hdchannel;
77	}
78	}
79
80	#
81	# options
82	#
83
84	my $script_start_time = time;
85	my %stats;
86	my $channels, my $reverse_channels, my $detailed_reverse_channels, my $opt_channels, my %channel_xmlid_to_opt_channel_xmlid, my $hdwithsd;
87	my $d, my $ar, my $sd, my $hd;
88	my $gapchannel, my $gaplaststop;
89	my $override_settings = { };
90	my %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } );
91
92	my $opt;
93	$opt->{url} = "http://www.dtvforum.info/index.php?showtopic=28574";
94	$opt->{newurl} = "http://www.dtvforum.info/index.php?showtopic=68946";
95
96	$opt->{output_file} = "output.xmltv";
97	$opt->{region} = 94;
98	$opt->{debug} = 0;
99	$opt->{action} = "copysd";
100
101	&parse_command_line;
102
103	# set defaults
104	Shepherd::Common::set_default("debug", (($opt->{debug} > 0) ? 2 : 0));
105	Shepherd::Common::set_default("stats" => \%stats);
106	Shepherd::Common::set_default("retry_delay" => "15-45");
107
108	# check XMLTV version for HDTV compatability
109	my @xmltv_version = split(/\./,$XMLTV::VERSION);
110	if (($xmltv_version[0] <= 0) && ($xmltv_version[1] <= "5") && ($xmltv_version[2] <= "43")) {
111	print " - XMLTV version ".$XMLTV::VERSION." too old to support HDTV flags. Disabling HDTV flags.\n";
112	$opt->{notag} = 1;
113	$stats{disabled_hdtv_flag}++;
114	}
115
116	&read_config_file($progname.".config",0);
117	&apply_setting_overrides;
118
119	&read_config_file($opt->{channels_file},1);
120
121	&setup_channels;
122
123	&lookup_website($opt->{url}, 0) if (!defined $opt->{nodbalookup});
124	&lookup_website($opt->{newurl}, 1) if (!defined $opt->{nodbalookup});
125
126	#
127	# now eat up the XMLTV inputs we were given!
128	#
129
130	my %writer_args = ( encoding => 'ISO-8859-1' );
131	my $fh = new IO::File(">".$opt->{output_file}) \|\| die "can't open $opt->{output_file} for writing: $!";
132	$writer_args{OUTPUT} = $fh;
133
134	my $writer = new XMLTV::Writer(%writer_args);
135	$writer->start( {
136	'source-info-name' => "$progname $version",
137	'generator-info-name' => "$progname $version"} );
138
139	foreach my $file (@ARGV) {
140	printf "Parsing: %s\n",($file eq "-" ? "(from-stdin, hit control-D to finish)" : $file);
141	XMLTV::parsefiles_callback(undef, undef, \&channel_cb,\&programme_cb, $file);
142	}
143
144	&write_hd();
145
146	$writer->end();
147	printf "Finished parsing, output in $opt->{output_file}\n";
148
149	Shepherd::Common::print_stats($progname, $version, $script_start_time, %stats);
150	exit(0);
151
152	######################################################################################################
153	# read settings
154
155	sub read_config_file
156	{
157	my($file,$die_on_failure) = @_;
158	if (!(-r $file)) {
159	die "file $file could not be read. aborting.\n" if $die_on_failure;
160	return;
161	}
162	local (@ARGV, $/) = ($file);
163	no warnings 'all'; eval <>; die "$@" if $@;
164	}
165
166	######################################################################################################
167
168	sub parse_command_line
169	{
170	GetOptions(
171	'channels_file=s' => \$opt->{channels_file},
172	'config=s' => \$opt->{config_file},
173	'action=s' => \$opt->{action},
174	'region=i' => \$opt->{region},
175	'nodbalookup' => \$opt->{nodbalookup},
176	'url=s' => \$opt->{url},
177	'notag' => \$opt->{notag},
178	'days=i' => \$opt->{days}, # ignored
179	'offset=i' => \$opt->{offset}, # ignored
180	'output=s' => \$opt->{output_file},
181	'debug+' => \$opt->{debug},
182	'set=s' => \$opt->{set},
183	'help' => \$opt->{help},
184	'h' => \$opt->{help},
185	'v' => \$opt->{version},
186	'version' => \$opt->{version});
187
188	if ($opt->{help}) {
189	print<<EOF
190
191	options:
192	--channels_file=(f) shepherd channels file (mandatory)
193
194	--nodbalookup don't look up programmes on DBA website (default: do)
195	--url=(url) URL that lists HDTV programming (default: $opt->{url})
196
197	--action=(policy) policy can be one of:
198	move - move HD progs to HD channel (remove it from SD channel)
199	copy - copy HD progs to HD channel (keep it in SD channel also)
200	copysd - copy all progs to HD channel, flagging HD ones (default)
201	--notag don't tag with HD flags (default: do)
202
203	--output=(f) output XMLTV filename (default: $opt->{output})
204	--debug increase debug level
205
206	--set=(setting):(value) save setting override: (value)
207	nodbalookup:1/0 (disable / enable) DBA website lookup
208	notag:1/0 (don't / do) tag with HD flags
209	action:move/copy/copysd set policy (as per above)
210
211	EOF
212	;
213	}
214
215	exit 0 if (($opt->{version}) \|\| ($opt->{help}));
216
217	if (defined $opt->{set}) {
218	&set_overrides;
219	}
220
221	die "'--channels_file {file}' must be specified. see --help for details.\n" if (!$opt->{channels_file});
222	if (($opt->{action} ne "move") && ($opt->{action} ne "copy") && ($opt->{action} ne "copysd")) {
223	print "unknown --action policy '$opt->{action}' using default 'copysd', see --help for details.\n\n";
224	$opt->{action} = "copysd";
225	}
226	}
227
228	######################################################################################################
229
230	sub set_overrides
231	{
232	&read_config_file($progname.".config",0);
233	my ($setting, $val) = split(/:/,$opt->{set});
234
235	die "--set format is (setting):(value)\n" if (!defined $val);
236
237	if (($setting eq "nodbalookup") \|\| ($setting eq "notag")) {
238	die "--set value must be 1/0 for setting '$setting'.\n" if (($val ne "1") && ($val ne "0"));
239	$override_settings->{$setting} = $val;
240	printf "%s: override parameter %s: %s\n", $progname, $setting, ($val eq "0" ? "disabled" : "enabled");
241	} elsif ($setting eq "action") {
242	die "--set value must be copy/move for setting '$setting'.\n"
243	if (($val ne "move") && ($val ne "copy") && ($val ne "copysd"));
244	$override_settings->{$setting} = $val;
245	printf "%s: override parameter %s: %s\n", $progname, $setting, $val;
246	} else {
247	die "unknown '--set' parameter '$setting', see --help for details.\n";
248	}
249
250	&write_config;
251	exit(0);
252	}
253
254	######################################################################################################
255
256	sub write_config
257	{
258	open(F,">".$progname.".config") \|\| die "can't write to config file $progname.config: $!\n";
259	print F Data::Dumper->Dump([$override_settings],["override_settings"]);
260	close F;
261	}
262
263	######################################################################################################
264
265	sub apply_setting_overrides
266	{
267	foreach my $setting (keys %$override_settings) {
268	if ($override_settings->{$setting} ne "0") {
269	printf "overriding setting %s: %s\n", $setting, $override_settings->{$setting};
270	$opt->{$setting} = $override_settings->{$setting};
271	}
272	}
273	}
274
275	######################################################################################################
276
277	sub setup_channels
278	{
279	while (my ($name, $chanid) = each %$channels) {
280	$detailed_reverse_channels->{$chanid} = $name;
281	}
282
283	# find the sd channel for each hd channel
284	foreach my $hdchannel (keys %$hd_to_sds) {
285	if (defined $channels->{$hdchannel}) {
286	foreach my $sdchannel (@{$hd_to_sds->{$hdchannel}}) {
287	if (defined $channels->{$sdchannel}) {
288	# there can be only one SD channel for the 7HD channel
289	$channel_xmlid_to_opt_channel_xmlid{$channels->{$sdchannel}} =
290	$channels->{$hdchannel};
291	$hd->{$channels->{$sdchannel}} = undef;
292	$hdwithsd->{$channels->{$hdchannel}} = 1;
293	print " '$hdchannel' with xmlid '$channels->{$hdchannel}'" .
294	" populated with programs provided by " .
295	"'$sdchannel' with xmlid '$channels->{$sdchannel}'\n";
296	last;
297	}
298	}
299	}
300	}
301
302	# convert all channel names to network names
303	my $shortchannels;
304	while (my ($name, $chanid) = each %$channels)
305	{
306	my $oldname = $name;
307
308	$name = @{$hd_to_sds->{$sd_to_hd->{$name}}}[0]
309	if (defined($sd_to_hd->{$name}));
310
311	push @{$shortchannels->{$name}}, $chanid;
312	print " '$oldname' treated as '$name' with xmlid '$chanid'\n" if ($name ne $oldname);
313
314	if (defined $opt_channels->{$oldname."HD"}) {
315	if (defined $channel_xmlid_to_opt_channel_xmlid{$chanid}) {
316	print " - Skipping '${oldname}HD' treated as '${name}HD' with xmlid '" .
317	$opt_channels->{$oldname."HD"} . "' " .
318	"because channel already populated to channel '" .
319	$detailed_reverse_channels->{$channel_xmlid_to_opt_channel_xmlid{$chanid}} .
320	"' with xmlid '" .
321	$channel_xmlid_to_opt_channel_xmlid{$chanid} .
322	"', see previous messages. Please reconfigure.\n";
323	} else {
324	$channel_xmlid_to_opt_channel_xmlid{$chanid} = $opt_channels->{$oldname."HD"};
325	print " '${oldname}HD' treated as '${name}HD' with xmlid '" . $opt_channels->{$oldname."HD"} . "'\n"
326	if ($name ne $oldname);
327	}
328	}
329	}
330	$channels = $shortchannels;
331
332	foreach my $channel (keys %$channels) {
333	foreach my $chanid (@{$channels->{$channel}}) {
334	$reverse_channels->{$chanid} = $channel;
335	}
336	}
337	}
338
339	######################################################################################################
340
341	sub lookup_website
342	{
343	my $url = shift;
344	my $new = shift;
345
346	unlink "dba.html"; # old cache file before 2008-05-08
347
348	my $mirror_to = "dtvinfo.html";
349	$mirror_to = "dtvforum.html" if $new;
350	my $data = &Shepherd::Common::get_url(url => $url, mirror => $mirror_to);
351	# the website doesn't support 'If-Modified-Since' headers but we can live in hope
352	$data = &Shepherd::Common::get_mirror_file($mirror_to, 14) if (!$data);
353	return if (!$data);
354
355	my $prime_present = $data =~ /Prime\s+HD/; # hack Seven also to Prime if no Prime data
356
357	# Parse the HTML of the page
358	#
359	my $tree = HTML::TreeBuilder->new_from_content($data);
360	if (!$tree) {
361	print "Can't build tree from url.\n";
362	return;
363	}
364
365	# Find the first post in the thread
366	#
367	my $postNode = $tree->look_down('_tag'=>'div', 'class'=>'postcolor', 'id'=>qr{post-.*});
368	if ($postNode) {
369	# Found the post, let's iterate through the children extracting text.
370	#
371	# We're interested in the data that follows the second horizontal line of
372	# underscores and precedes the third line. The earlier data is a
373	# comment, highlights list, and the later data is a disclaimer.
374	#
375	# The data is several chunks like this on the web page:
376	#
377	# Thursday 1st May 2008
378	# Nine HD
379	# 5:30am - Today
380	# 9:00am - Mornings With Kerri-Anne
381	# 11:30am - Fresh Cooking With The Australian Women's Weekly
382	# 7:00pm - Two And A Half Men (Did You Check with the Captain of the Flying Monkeys?)
383	# HD Only 11:00am - The Mountain [DD5.1]
384	#
385	# but they may appear in this loop split onto several lines at <B>, <U> or
386	# other boundaries in the source markup. For example, the last line becomes:
387	#
388	# HD Only
389	# 11:00am - The Mountain
390	# [DD5.1]
391	#
392	# because the "HD Only" is in a <SPAN> with colour red. This splitting will
393	# not have a negative impact on the actual programme, channel, or date info,
394	# as long as the triggering markup does not occur mid-field. It currently
395	# doesn't.
396	#
397	my $datePattern = qr{(?:(\d?\d)(?:st\|nd\|rd\|th)\s+([[:alpha:]]+)\s+(\d\d\d\d)$)\|(?:[[:alpha:]]+\s+(\d?\d)/(\d?\d)/(\d\d)$)}io;
398	my $chanPattern = qr{^(ABC\|Seven\|Prime\|Nine\|Ten\|SBS)\s+HD}io;
399	my $progPattern = qr{(\d?\d:\d\d\s(?:am\|pm))\s+(?:-\s+)?(.)$}io;
400	my $currDate = undef;
401	my $currChan = undef;
402
403	my $betweenLines = 0; # Toggle as we parse each horiz. line
404	foreach my $node ($postNode->content_list()) {
405	my $text = (ref($node) eq 'HTML::Element') ?
406	$node->as_text() :
407	$node;
408	$text =~ s/^\s+\|\s+$//g; # strip leading/trailing spaces
409	next if $text eq ''; # skip empty strings
410	if ($text =~ m/^_+$/) { # horiz line
411	$betweenLines++;
412	next;
413	}
414	next unless $betweenLines == 2 \|\| $new;
415
416	if ($text =~ $datePattern) {
417	# Date is not currently used except for debugging
418	$currDate = "$1 $2 $3" if $1; # e.g. 3 May 2008
419	$currDate = "$4/$5/$6" if $4;
420	}
421	elsif ($text =~ $chanPattern) {
422	my $channame = $1;
423	if (defined $chan_name_translations->{$channame}) {
424	$currChan = $chan_name_translations->{$channame};
425	} else {
426	# printf "** Found unknown channel '%s'! Ignored.\n", $channame;
427	$stats{unknown_channels}++;
428	$currChan = undef;
429	}
430	}
431	elsif ($text =~ $progPattern) {
432	# Time is not currently used except for debugging
433	my $progtime = $1;
434	my $progname = $2;
435	if (defined $currChan) {
436	# Clean up some cruft
437	$progname =~ s/\*$//;
438	$progname =~ s/^MOVIE:\s*//;
439	$progname =~ s/^HD Documentary:\s*/HD Docos: /;
440	$progname =~ s/\s*$[^(]+$$//; # (episode title)
441
442	# printf "Channel: '%s', Date: '%s', Time: '%s', Prog: '%s'\n",
443	# $currChan, $currDate, $progtime, $progname;
444
445	# Apply manual translation if needed
446	if (defined($translation->{$progname})) {
447	$progname = $translation->{$progname};
448	$stats{manual_translations}++;
449	}
450
451	# Store the result and update stats
452	push(@{$d->{prog}->{$currChan}}, $progname);
453	push(@{$d->{prog}->{'Prime HD'}}, $progname)
454	if ((!$prime_present) && ($currChan eq '7HD'));
455
456	$stats{parsed_hd_progs}++;
457	}
458	else {
459	# printf "** Ignoring matched prog '%s' at '%s'\n",
460	# $progname, $progtime;
461	}
462	}
463	else {
464	# printf "** Ignoring text '%s'\n", $text;
465	}
466	}
467	}
468
469	# Clean up
470	#
471	$tree->delete();
472	}
473
474
475	######################################################################################################
476
477	sub channel_cb( $ )
478	{
479	my $c = shift;
480	# printf "got channel ".Dumper($c);
481	$writer->write_channel($c);
482	}
483
484	######################################################################################################
485
486	sub programme_cb( $ )
487	{
488	my $prog=shift;
489	my $this_chan = $prog->{channel};
490	return if (!defined $this_chan);
491
492	# keep a copy of standard definition related to argumenting high definition channel programmes for program removal later
493	if (defined $channel_xmlid_to_opt_channel_xmlid{$this_chan} &&
494	defined $detailed_reverse_channels->{$channel_xmlid_to_opt_channel_xmlid{$this_chan}}) {
495	$sd->{$detailed_reverse_channels->{$channel_xmlid_to_opt_channel_xmlid{$this_chan}}}->
496	{Shepherd::Common::parse_xmltv_date($prog->{start})} = $prog;
497	}
498
499	my $this_title;
500	$this_title = $prog->{title}->[0]->[0]
501	if (($prog->{title}) && ($prog->{title}->[0]) && ($prog->{title}->[0]->[0]));
502	# print "got programme ".Dumper($prog);
503	goto NOMATCH if (!defined $this_title);
504
505	# if programme is already marked as HDTV, just skip all of this
506	if ((defined $prog->{video}) && (defined $prog->{video}->{quality}) &&
507	($prog->{video}->{quality} =~ /hdtv/i)) {
508	printf " matched '$this_title' (pre-marked)\n" if (!defined $d->{seenprog}->{$this_title});
509	$stats{prog_already_marked}++;
510	goto MATCH;
511	}
512
513	# see if title matches a known hd program for this channel
514	my $channel = $reverse_channels->{$this_chan};
515	$channel = $sd_to_hd->{$channel} if defined $sd_to_hd->{$channel}; # if sd name, use hd name
516	foreach my $t (@{$d->{prog}->{$channel}}) {
517	if (canonicalizeTitles_match($t,$this_title)) {
518	# match!
519	printf " matched '$t' to '$this_title' (canonical match)\n" if (!defined $d->{seenprog}->{$this_title});
520	$stats{matched_prog}++;
521	goto MATCH;
522	}
523	}
524
525	# see if title matches something in our override table
526	foreach my $ch (keys %{($hdoverride)}) {
527	next if $ch ne $reverse_channels->{$this_chan};
528	foreach my $t (@{($hdoverride->{$ch})}) {
529	if (canonicalizeTitles_match($t,$this_title)) {
530	# match!
531	printf " matched '$t' to '$this_title' (hd override)\n" if (!defined $d->{seenprog}->{$this_title});
532	$stats{override_matched_prog}++;
533	goto MATCH;
534	}
535	}
536	}
537
538	NOMATCH:
539	# process later argumenting high definition channel programmes
540	if (defined $reverse_channels->{$this_chan} &&
541	defined $hd_to_sds->{$reverse_channels->{$this_chan}} &&
542	defined $hdwithsd->{$this_chan}) {
543	return if defined $this_title && $this_title eq "See main channel's listings for programming details";
544	# just because its on 7HD doesn't make it high definition
545	$ar->{$reverse_channels->{$this_chan}}->{Shepherd::Common::parse_xmltv_date($prog->{start})} = $prog;
546	return;
547	}
548
549	$writer->write_programme($prog);
550
551	# copy to high definition channel
552	if ($opt->{action} eq "copysd" && defined $channel_xmlid_to_opt_channel_xmlid{$this_chan}) {
553	$prog->{channel} = $channel_xmlid_to_opt_channel_xmlid{$this_chan};
554	# but don't write HD channel until all programs read
555	$hd->{$this_chan}->{Shepherd::Common::parse_xmltv_date($prog->{start})} = $prog;
556	}
557
558	return;
559
560	MATCH:
561	$d->{seenprog}->{$this_title}++;
562	$prog->{video}->{aspect} = "16:9"; # widescreen
563
564	# process later argumenting high definition channel programmes
565	if (defined $reverse_channels->{$this_chan} &&
566	defined $hd_to_sds->{$reverse_channels->{$this_chan}} &&
567	defined $hdwithsd->{$this_chan}) {
568	return if defined $this_title && $this_title eq "See main channel's listings for programming details";
569	$prog->{video}->{quality} = "HDTV" unless (defined $opt->{notag});
570	$ar->{$reverse_channels->{$this_chan}}->{Shepherd::Common::parse_xmltv_date($prog->{start})} = $prog;
571	return;
572	}
573
574	if (!defined $channel_xmlid_to_opt_channel_xmlid{$this_chan}) {
575	# no HD variant
576	$prog->{video}->{quality} = "HDTV" unless (defined $opt->{notag});
577	$writer->write_programme($prog);
578	$stats{rewrote_prog_as_hdtv_inplace}++;
579	} else {
580	if ($opt->{action} eq "copy" \|\| $opt->{action} eq "copysd") {
581	# SD channel
582	delete $prog->{video}->{quality};
583	$writer->write_programme($prog);
584	$stats{rewrote_prog_as_sdtv_inplace}++;
585	}
586
587	# populate this programme in HD channel
588	$prog->{video}->{quality} = "HDTV" unless (defined $opt->{notag});
589	$prog->{channel} = $channel_xmlid_to_opt_channel_xmlid{$this_chan};
590	# but don't write HD channel until all programs read
591	$hd->{$this_chan}->{Shepherd::Common::parse_xmltv_date($prog->{start})} = $prog;
592	}
593	return;
594	}
595
596	# $hd keys are orignal xmlids, with {channel} set to HD xmlids from $channel_xmlid_to_opt_channel_xmlid
597	# details from SD channels
598	# that can be found in $channel_xmlid_to_opt_channel_xmlid
599	# and are detected as HD or "copysd" is set
600	# $sd keys are 7HD, Prime HD, Nine HD, TEN HD plus other $opt_channel *HD variants
601	# details from untouched SD channels
602	# that can be found in $channel_xmlid_to_opt_channel_xmlid
603	# $ar keys are 7HD, Prime HD, Nine HD, TEN HD
604	# details from HD channels only: 7HD, Prime HD, Nine HD, TEN HD
605	sub write_hd
606	{
607	# remove from argument channel identical (time, title, sub-title) programs found on sd channel
608	foreach my $channel (keys %$ar) {
609	next if !defined $sd->{$channel};
610	foreach my $start (keys %{$ar->{$channel}}) {
611	if (defined $sd->{$channel}->{$start}) {
612	my $aprog = $ar->{$channel}->{$start};
613	my $prog = $sd->{$channel}->{$start};
614
615	if (Shepherd::Common::parse_xmltv_date($aprog->{stop}) ==
616	Shepherd::Common::parse_xmltv_date($prog->{stop}) &&
617	(!defined $aprog->{title} \|\| !defined $prog->{title} \|\|
618	lc($aprog->{title}->[0]->[0]) eq lc($prog->{title}->[0]->[0])) &&
619	(!defined $aprog->{'sub-title'} \|\| !defined $prog->{'sub-title'} \|\|
620	lc($aprog->{'sub-title'}->[0]->[0]) eq
621	lc($prog->{'sub-title'}->[0]->[0]))){
622	delete $ar->{$channel}->{$start};
623	}
624	}
625	}
626	}
627
628	# write high definition channel programs argumenting as needed
629	foreach my $xmlid (keys %$hd) {
630	my ($argument, @aprogs, $aprog);
631
632	# if an argument channel exists, sort the programs ready for inserting
633	if (defined $detailed_reverse_channels->{$xmlid} &&
634	defined $sd_to_hd->{$detailed_reverse_channels->{$xmlid}}) {
635	$argument = $sd_to_hd->{$detailed_reverse_channels->{$xmlid}};
636
637	print " channel '";
638	if (defined $detailed_reverse_channels->{$channel_xmlid_to_opt_channel_xmlid{$xmlid}}) {
639	print $detailed_reverse_channels->{$channel_xmlid_to_opt_channel_xmlid{$xmlid}};
640	} else {
641	print $detailed_reverse_channels->{$xmlid} . "HD";
642	}
643	print "' with xmlid '$channel_xmlid_to_opt_channel_xmlid{$xmlid}'" .
644	" augmented with programs from channel '$argument'\n";
645
646	if (defined $ar->{$argument}) {
647	@aprogs = sort {$a <=> $b} keys %{$ar->{$argument}};
648	$aprog = $ar->{$argument}->{shift @aprogs};
649	}
650	}
651
652	# loop over this channels programs, inserting argument programs as needed
653	my @progs = sort {$a <=> $b} keys %{$hd->{$xmlid}};
654	my $prog = $hd->{$xmlid}->{shift @progs};
655	while (defined $prog) {
656
657	# insert argument programs if they start before other programs stop
658	while (defined $aprog && defined $prog &&
659	Shepherd::Common::parse_xmltv_date($aprog->{start}) <
660	Shepherd::Common::parse_xmltv_date($prog->{stop})) {
661	$aprog->{channel} = $channel_xmlid_to_opt_channel_xmlid{$xmlid};
662	&gapfill($aprog->{channel}, $aprog->{start}, $aprog->{stop});
663	$writer->write_programme($aprog);
664	$stats{wrote_prog_into_hdtv_channel}++;
665
666	# drop programs that conflict with argument program
667	while (defined $prog && Shepherd::Common::parse_xmltv_date($prog->{start}) <
668	Shepherd::Common::parse_xmltv_date($aprog->{stop})) {
669	$prog = $hd->{$xmlid}->{shift @progs};
670	}
671
672	$aprog = $ar->{$argument}->{shift @aprogs};
673	}
674	last if !defined $prog;
675
676	&gapfill($prog->{channel}, $prog->{start}, $prog->{stop});
677	$writer->write_programme($prog);
678	$stats{wrote_prog_into_hdtv_channel}++;
679
680	$prog = $hd->{$xmlid}->{shift @progs};
681	}
682
683	# write any left over argument programs
684	while (defined $aprog) {
685	$aprog->{channel} = $channel_xmlid_to_opt_channel_xmlid{$xmlid};
686	&gapfill($aprog->{channel}, $aprog->{start}, $aprog->{stop});
687	$writer->write_programme($aprog);
688	$stats{wrote_prog_into_hdtv_channel}++;
689
690	$aprog = $ar->{$argument}->{shift @aprogs};
691	}
692	}
693	}
694
695	sub gapfill
696	{
697	my $prog;
698	$prog->{channel} = shift;
699	$prog->{start} = $gaplaststop;
700	$prog->{stop} = shift;
701	$gaplaststop = shift;
702
703	if (defined $prog->{start} && defined $gapchannel && $gapchannel eq $prog->{channel}) {
704	if (Shepherd::Common::parse_xmltv_date($prog->{start}) !=
705	Shepherd::Common::parse_xmltv_date($prog->{stop})) {
706	if ($opt->{action} eq "copysd") {
707	$prog->{title}->[0]->[0] = "Gap";
708	} else {
709	$prog->{title}->[0]->[0] = "Upscaled SD or Loop";
710	$prog->{desc}->[0]->[0] =
711	"This can be populated with programs by changing your Shepherd settings.";
712	}
713	$writer->write_programme($prog);
714	$stats{wrote_gapfill_into_hdtv_channel}++;
715	}
716	} else {
717	$gapchannel = $prog->{channel};
718	}
719	}
720
721	######################################################################################################
722
723	sub canonicalizeTitle
724	{
725	my $title=shift;
726	$title =~ s/^\s+//;
727	$title =~ s/\s+$//;
728	$title =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
729	$title =~ s/ \& / and /g;
730	$title =~ s/[^ a-zA-Z0-9]//g;
731	$title =~ s/\s+/ /;
732	return(lc($title));
733	}
734
735	my %alternatives = ( one => "1",
736	two => "2",
737	to => "2",
738	too => "2",
739	three => "3",
740	four => "4",
741	for => "4",
742	five => "5",
743	six => "6",
744	seven => "7",
745	eight => "8",
746	nine => "9"
747	);
748
749	sub forgivingMatch
750	{
751	my $word1 = shift;
752	my $word2 = shift;
753
754	# exact match
755	return 1 if $word1 eq $word2;
756	# they match according to our alternatives lookup table
757	return 1 if $alternatives{$word1} && $alternatives{$word1} eq $word2 \|\|
758	$alternatives{$word2} && $alternatives{$word2} eq $word1;
759	# irreconcilable differences
760	return 0 if abs(length($word1) - length($word2)) > 1 \|\|
761	length($word1) < 3;
762
763	my @list1 = split(//,$word1);
764	my @list2 = split(//,$word2);
765	my $i = 0;
766	my $j = 0;
767
768	# find first difference
769	while ($i < @list1 && $j < @list2 && $list1[$i] eq $list2[$j]) {
770	++$i; ++$j;
771	}
772	if ($i+1 < @list1 && $j+1 < @list2) {
773	# at least 2 chars to go in both words
774	if ($list1[$i+1] eq $list2[$j] && $list1[$i] eq $list2[$j+1]) {
775	# characters transposed
776	$i += 2;
777	$j += 2;
778	} elsif ($list1[$i+1] eq $list2[$j]) {
779	# extra character inserted into @list1
780	$i += 2;
781	++$j;
782	} elsif ($list1[$i] eq $list2[$j+1]) {
783	# extra character inserted into @list2
784	++$i;
785	$j += 2;
786	} else {
787	# single character difference
788	++$i;
789	++$j;
790	}
791	# we forgave one difference; now do rest of strings match exactly?
792	while ($i < @list1 && $j < @list2 && $list1[$i] eq $list2[$j]) {
793	++$i; ++$j;
794	}
795	return($i == @list1 && $j == @list2);
796	} elsif ($i == @list1 \|\| $j == @list2) {
797	# only difference is one word has one extra letter, or last char
798	# of each word differ. That's still only one one-char difference
799	return(1);
800	}
801	}
802
803	sub canonicalizeTitles_match
804	{
805	my $word1=canonicalizeTitle(shift);
806	my $word2 =canonicalizeTitle(shift);
807	my @longer;
808	my @shorter;
809
810	if (length($word1) > length($word2)) {
811	@longer = split(/\s+/, $word1);
812	@shorter = split(/\s+/, $word2);
813	} else {
814	@shorter = split(/\s+/, $word1);
815	@longer = split(/\s+/, $word2);
816	}
817
818	WORD: for my $word (@shorter) {
819	for(my $i=0; $i < @longer; ++$i) {
820	if (forgivingMatch($longer[$i], $word)) {
821	splice(@longer,$i,1);
822	next WORD;
823	} elsif ($i+1 < @longer &&
824	$word eq "$longer[$i]$longer[$i+1]") {
825	splice(@longer,$i,2);
826	next WORD;
827	}
828	}
829	return(0);
830	}
831	return(1);
832	}
833
834	##############################################################################

Note: See TracBrowser for help on using the browser.

Context Navigation

root/trunk/postprocessors/flag_aus_hdtv

Download in other formats: