Context Navigation

sbsnews_website @ 719

Revision 719, 18.7 kB (checked in by paul, 6 years ago)
Fill another gap in sbsbews
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	# sbsnews_website au_tv guide grabber - runs from "Shepherd" master grabber
4	# * written by ltd
5	# * uses SBS website for SBSNEWS data
6	# (http://www.sbs.com.au/whatson/WNC-Schedule.html)
7	# * when used in conjunction with Shepherd, shepherd can collect other channels
8	# using other grabbers
9	# * this does NOT use any config file - all settings are passed in from shepherd
10
11	# changelog:
12	# 0.01 24oct06 initial release
13
14	use strict;
15
16	my $progname = "sbsnews_website";
17	my $version = "0.16";
18
19	use LWP::UserAgent;
20	use XMLTV;
21	use POSIX qw(strftime);
22	use Getopt::Long;
23	use Data::Dumper;
24	use HTML::TreeBuilder;
25
26	#
27	# some initial cruft
28	#
29
30	my $script_start_time = time;
31	my %stats;
32	my $channels, my $opt_channels, my $gaps;
33	my $tv_guide, my $tv_guide_by_wday;
34
35	my $ua;
36	$ua = LWP::UserAgent->new('timeout' => 30, 'keep_alive' => 30, 'agent' => "Shepherd / $progname $version");
37	$ua->env_proxy;
38	# $ua->cookie_jar({});
39	$\| = 1;
40
41	#
42	# parse command line
43	#
44
45	my $opt;
46	$opt->{days} = 7; # default
47	$opt->{offset} = 0; # default
48	$opt->{outputfile} = "output.xmltv"; # default
49	$opt->{channels_file} = ""; # mandatory for user to specify
50	$opt->{debug} = 0; # default
51	$opt->{lang} = "en"; # default
52
53	GetOptions(
54	'region=i' => \$opt->{region}, # ignored
55	'timezone=s' => \$opt->{timezone}, # ignored
56	'config-file=s' => \$opt->{configfile}, # ignored
57	'days=i' => \$opt->{days},
58	'offset=i' => \$opt->{offset},
59	'channels_file=s' => \$opt->{channels_file},
60	'gaps_file=s' => \$opt->{gaps_file},
61	'output=s' => \$opt->{outputfile},
62	'fast' => \$opt->{fast},
63	'debug+' => \$opt->{debug},
64	'lang=s' => \$opt->{lang},
65	'no-retry' => \$opt->{dont_retry},
66	'help' => \$opt->{help},
67	'verbose' => \$opt->{help},
68	'version' => \$opt->{version},
69	'ready' => \$opt->{version},
70	'v' => \$opt->{help});
71
72	&help if ($opt->{help});
73
74	if ($opt->{version}) {
75	printf "%s %s\n",$progname,$version;
76	printf "Collects news lineup for SBSNEWS from SBS Web site." if $opt->{desc};
77	exit(0);
78	}
79
80	die "no channel file specified, see --help for instructions\n", if ($opt->{channels_file} eq "");
81
82	#
83	# go go go!
84	#
85
86	&log(sprintf "going to %sfetch %d days%s of data into %s (%s)",
87	(defined $opt->{gaps_file} ? "micro-gap " : ""),
88	$opt->{days},
89	($opt->{offset} ? " (skipping first $opt->{offset} days)" : ""),
90	$opt->{outputfile},
91	($opt->{fast} ? "with haste" : "slowly"));
92
93	# read channels file
94	if (-r $opt->{channels_file}) {
95	local (@ARGV, $/) = ($opt->{channels_file});
96	no warnings 'all'; eval <>; die "$@" if $@;
97	} else {
98	die "WARNING: channels file $opt->{channels_file} could not be read: $!\n";
99	}
100
101	# unless we have SBSNEWS defined as a channel, nothing to do!
102
103	die "no SBSNEWS channel found in channel lineup from $opt->{channels_file}\n"
104	unless (defined $channels->{'SBS News'});
105
106	if (defined $opt->{gaps_file}) {
107	if (-r $opt->{gaps_file}) {
108	local (@ARGV, $/) = ($opt->{gaps_file});
109	no warnings 'all'; eval <>; die "$@" if $@;
110	} else {
111	die "WARNING: gaps file $opt->{gaps_file} could not be read: $!\n";
112	}
113
114	die "no SBSNEWS channel in gaps lineup, nothing to do!\n"
115	unless ((defined $gaps) && (defined $gaps->{'SBS News'}));
116	}
117
118	&get_sbsnews_data;
119	&adjust_stop_times;
120	&write_data;
121	&print_stats;
122	exit(0);
123
124	######################################################################################################
125	# help
126
127	sub help
128	{
129	print<<EOF
130	$progname $version
131
132	options are as follows:
133	--help show these help options
134	--days=N fetch 'n' days of data (default: $opt->{days})
135	--output=file send xml output to file (default: "$opt->{outputfile}")
136	--fast don't run slow - get data as quick as you can - not recommended
137	--debug increase debug level
138	--no-retry if webserver is rejecting our request, don't retry (default: do retry)
139	--lang=[s] set language of xmltv output data (default $opt->{lang})
140	--channels_file=file where to get channel data from
141	--gaps_file=file micro-fetch gaps only
142
143	EOF
144	;
145
146	exit(0);
147	}
148
149	######################################################################################################
150
151	sub get_sbsnews_data
152	{
153	# 7 days in one URL: http://www.sbs.com.au/whatson/WNC-Schedule.html
154	my $data = &get_url("http://www.sbs.com.au/whatson/WNC-Schedule.html","weekly summary data",5);
155	die "no data returned from web server! failed.\n" unless ($data);
156
157	my %day_range_names = (sunday=>0,monday=>1,tuesday=>2,wednesday=>3,thursday=>4,friday=>5,saturday=>6);
158
159	#
160	# parse html using the following state machine:
161	# 0 = looking for first time tag
162	# 1 = got first time tag
163	# 2 = reading programmes
164	# 3 = end of programmes
165	#
166	my $state_machine = 0;
167	my @time_column;
168	my $tree = HTML::TreeBuilder->new_from_content($data);
169	my $time_tag_count = 0;
170	my $tr_count = 0;
171
172	my @seen_day_tag, my @column_is_day, my @column_maps_to_time;
173	my @time_column_wrapped_over_midnight;
174	my @prev_row_prog_tag;
175
176	my $seen_time_tag_column = -1;
177	&log("state machine is 0, looking for start of table") if $opt->{debug};
178
179	foreach my $tr1 ($tree->look_down('_tag' => 'tr')) {
180	my $td_count = 0;
181	my @row;
182
183	foreach my $td1 ($tr1->look_down('_tag' => 'td')) {
184	if ($td1->as_text() =~ /^Time$/) {
185	if ($state_machine < 2) {
186	&log("found time tag $time_tag_count in column $td_count") if $opt->{debug};
187	$time_column[$time_tag_count] = $td_count;
188	$seen_time_tag_column = $time_tag_count;
189	if ($time_tag_count == 0) {
190	$state_machine = 1;
191	&log("advanced state machine to 1, looking for day names") if $opt->{debug};
192	}
193
194	# if this is a new time tag & we have existing unprocessed
195	# columns, fix em up now
196	for my $col (0..($#column_maps_to_time)) {
197	if ((defined $column_maps_to_time[$col]) &&
198	($column_maps_to_time[$col] == -1)) {
199	$column_maps_to_time[$col] = $td_count;
200	&log("fixed up column $col to map to time in column $td_count") if $opt->{debug};
201	}
202	}
203	$time_tag_count++;
204	} else {
205	$state_machine = 3;
206	}
207	} elsif ($td1->as_text() =~ /^\S$/) {
208	if ($state_machine == 1) {
209	$time_tag_count++;
210	&log("blank column in $td_count, incremented time_tag to $time_tag_count") if $opt->{debug};
211
212	# blank column clears out our time column
213	$seen_time_tag_column = -1;
214	}
215	} else {
216	next if ($state_machine == 0);
217
218	# parse day name
219	if (($state_machine == 1) && ($td1->as_text() =~ /day$/)) {
220	# got a day name..
221	my $dname = lc($td1->as_text());
222	if (defined $day_range_names{$dname}) {
223	my $dnum = $day_range_names{$dname};
224	die "saw day tag for $dname more than once. has the HTML format changed?"
225	if (defined $seen_day_tag[$dnum]);
226	$seen_day_tag[$dnum]++;
227	$column_is_day[$td_count] = $dnum;
228	$column_maps_to_time[$td_count] = $seen_time_tag_column;
229	&log("column $td_count is day $dnum ($dname) epoch time column $seen_time_tag_column")
230	if $opt->{debug};
231	} else {
232	die "expected day name, got '$dname'. has the HTML format changed?";
233	}
234	} elsif ($state_machine == 2) {
235	# soak up the data!
236	$row[$td_count] = $td1->as_text();
237	$row[$td_count] =~ s/(^\s+\|\s+$)//g;
238	&log((sprintf "stored row data %d: '%s'", $td_count, $td1->as_text())) if $opt->{debug};
239	} else {
240	&log((sprintf "got other text: state_machine=%d, td_count=%d, got: '%s'",
241	$state_machine,$td_count,$td1->as_text())) if $opt->{debug};
242	}
243	}
244	$td_count++;
245	}
246	if ($state_machine == 1) {
247	$state_machine = 2;
248	&log("advanced state machine to 2, now looking for programmes") if $opt->{debug};
249	next;
250	} elsif ($state_machine == 2) {
251	# process row
252	# 1. loop through $time_column ...
253	foreach my $tcount (0..($time_tag_count-1)) {
254	next if (!defined $time_column[$tcount]);
255	my $tcol = $time_column[$tcount];
256	next if (!defined $row[$tcol]);
257
258	# parse time from $row[$tcol] ... format is "13:30-13:50"
259	my $start_time = -1, my $stop_time = -1;
260	if ($row[$tcol] =~ /^(\d{1,2}):(\d{1,2})\s\-\s(\d{1,2}):(\d{1,2})$/) {
261	$start_time = ($16060)+($2*60);
262	$stop_time = ($36060)+($4*60);
263	} else {
264	&log("couldn't match start/stop time from '".$row[$tcol]."' in column $tcol") if $opt->{debug};
265	}
266
267	# sometimes-subtitle-line (but not always)
268	# if previous line had a programme in this slot and can't match a time,
269	# use this row data as a sub-title for the programme
270	if (($start_time == -1) \|\| ($stop_time == -1)) {
271	foreach my $col (0..$td_count) {
272	if ((defined $column_is_day[$col]) &&
273	(defined $column_maps_to_time[$col]) &&
274	($column_maps_to_time[$col] == $tcol) &&
275	(defined $prev_row_prog_tag[$col])) {
276	if ($row[$col] ne "") {
277	&log("added subtitle '".$row[$col]."' from col $col to previous-row prog '".
278	$tv_guide->{$prev_row_prog_tag[$col]}->{title}->[0]->[0]."'") if $opt->{debug};
279
280	$tv_guide->{$prev_row_prog_tag[$col]}->{'sub-title'} = [[ $row[$col], $opt->{lang} ]];
281	&cleanup($tv_guide->{$prev_row_prog_tag[$col]}->{'sub-title'});
282	}
283	$prev_row_prog_tag[$col] = undef;
284	}
285	}
286	next;
287	}
288
289	# wrapping over midnight for the first time
290	if ($stop_time < $start_time) {
291	$time_column_wrapped_over_midnight[$tcol] = 1;
292	$stop_time += (606024);
293	&log("detected wrap-around-midnight for time '$row[$tcol]' in column $tcol") if $opt->{debug};
294	}
295
296	# loop through all programmes which match this time column
297	foreach my $col (0..$td_count) {
298	if ((defined $column_is_day[$col]) &&
299	(defined $column_maps_to_time[$col]) &&
300	($column_maps_to_time[$col] == $tcol)) {
301	next if ($row[$col] eq "");
302
303	my $prog;
304	$prog->{channel} = $channels->{'SBS News'};
305	$prog->{title} = [[ $row[$col], $opt->{lang} ]];
306	&cleanup($prog->{title});
307	$prog->{start} = $start_time;
308	$prog->{stop} = $stop_time;
309
310	$prog->{category} = [[ 'News', undef ]] if ($progname =~ /News/i);
311	my $wday = $column_is_day[$col];
312	if (defined $time_column_wrapped_over_midnight[$tcol] and $stop_time < (246060)) {
313	$wday = ($wday + 1) % 7;
314	}
315	$prog->{wday} = $wday;
316
317	$prev_row_prog_tag[$col] = $wday(2460*60) + $start_time;
318	$tv_guide->{$prev_row_prog_tag[$col]} = $prog;
319	$tv_guide_by_wday->{$wday}->{$start_time} = $prog;
320
321	&log((sprintf "got prog col %d: start=%s, stop=%s, '%s', day=%d (%d)",
322	$col,&print_time($start_time),&print_time($stop_time),$row[$col],$column_is_day[$col],$wday))
323	if $opt->{debug};
324
325	$stats{seen_progs}++;
326	}
327	}
328	}
329	}
330	$tr_count++;
331	&log("advanced tr_count to $tr_count") if $opt->{debug};
332	}
333
334	$tree->delete;
335
336	die "didn't find 'time' tag in HTML table. has the HTML format changed?"
337	if ($state_machine == 0);
338
339	die "didn't find any programmes! has the HTML format changed?"
340	if ($stats{seen_progs} == 0);
341	}
342
343	######################################################################################################
344
345	# sbsnews data from http://www.sbs.com.au/whatson/WNC-Schedule.html has 5 or 10
346	# minute holes in it. this fills in those holes by extending programs over holes.
347	# it also adds in "Station Close" programs for long overnight gaps.
348
349	sub adjust_stop_times
350	{
351	&log("Extending stop times to fill in small guide data holes.");
352
353	my @day_names = ("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday");
354
355	# reverse-sort thru list to adjust prog stop times
356	my @list = sort {$b <=> $a} keys %$tv_guide;
357	my $prev_start = $tv_guide->{$list[$#list]}->{start} + (72460*60);
358	foreach my $key (@list) {
359	my $stop = $tv_guide->{$key}->{wday}(2460*60) + $tv_guide->{$key}->{stop};
360	if ($stop != $prev_start) {
361	my $diff = $prev_start - $stop;
362	$stop = $tv_guide->{$key}->{stop};
363	my $new_wday = $tv_guide->{$key}->{wday};
364	if ($stop >= (246060)) {
365	$stop -= (246060);
366	$new_wday = ($new_wday + 1) % 7;
367	}
368
369	# Gaps of at least 30 minutes before 7am are Station Closes
370	if ($diff / 60 >= 30 and (($prev_start % (246060)) <= (76060))) {
371	my $new_prog = { title => [[ 'Station Close', $opt->{lang} ]],
372	channel => $channels->{'SBS News'},
373	start => $stop,
374	stop => $prev_start % (246060) };
375	&log(sprintf "Inserting \"Station Close\" on %s between %s to %s",
376	$day_names[$new_wday],
377	&print_time($new_prog->{start}),
378	&print_time($new_prog->{stop}));
379	$tv_guide_by_wday->{$new_wday}->{$stop} = $new_prog;
380
381	# Gaps of 15 or more minutes in other times are genuine holes
382	# If the gap is a weekday, fill it with whatever was in
383	# that timeslot tommorow (we have Monday holes for some reason)
384	} elsif ($diff / 60 >= 15) {
385	if ($new_wday > 0 and $new_wday < 6) {
386	my $copy_wday = $new_wday + 1;
387	$copy_wday = 1 if $new_wday >= 6;
388
389	if ($tv_guide_by_wday->{$copy_wday}->{$stop}) {
390	my $new_prog = { %{$tv_guide_by_wday->{$copy_wday}->{$stop}}};
391	delete $new_prog->{wday} if $new_prog->{wday};
392	&log(sprintf "Filling weekday gap on %s at %s with next day's schedule \"%s\".",
393	$day_names[$new_wday], &print_time($stop), $new_prog->{title}[0][0]);
394	$tv_guide_by_wday->{$new_wday}->{$stop} = $new_prog;
395	} else {
396	&log(sprintf "Unable to find suitable program to copy to fill " .
397	"weekday gap on %s at %s.", $day_names[$new_wday], &print_time($stop));
398	}
399	} else {
400	&log(sprintf "Can't fill gap on %s at %s after \"%s\" for %d mins.",
401	$day_names[$new_wday],
402	&print_time($stop),
403	$tv_guide->{$key}->{title}[0][0],
404	$diff/60);
405	}
406
407	# Gaps of <15 minutes shall be filled in
408	} else {
409	&log(sprintf "Extending stop time of \"%s\" by %d mins, from %s to %s on %s.",
410	$tv_guide->{$key}->{title}[0][0],
411	$diff/60,
412	&print_time($tv_guide->{$key}->{stop}),
413	&print_time($tv_guide->{$key}->{stop} + $diff),
414	$day_names[$tv_guide->{$key}->{wday}]) if ($opt->{debug});
415	$tv_guide->{$key}->{stop} += $diff;
416	$stats{extended_stops}++
417	}
418	}
419	delete $tv_guide->{$key}->{wday};
420	$prev_start = $key;
421	}
422	}
423
424	######################################################################################################
425
426	# logic to fetch a page via http
427	# retries up to 3 times to get a page with 5 second pauses inbetween
428
429	sub get_url
430	{
431	my ($url,$status,$retrycount) = @_;
432	my $response;
433	my $attempts = 0;
434	my ($raw, $page, $base);
435
436	$retrycount = 8 if ($retrycount == 0);
437	my $request = HTTP::Request->new(GET => $url);
438	$request->header('Accept-Encoding' => 'gzip');
439
440	for (1..$retrycount) {
441	$attempts++;
442	&log("fetching $url, attempt $attempts");
443
444	$response = $ua->request($request);
445	last if ($response->is_success);
446
447	$stats{http_failed_requests}++;
448	$stats{slept_for} += 20;
449	sleep 20;
450	}
451	if (!($response->is_success)) {
452	&log("aborting after $attempts attempts to fetch url $url");
453	return undef;
454	}
455
456	$stats{bytes_fetched} += do {use bytes; length($response->content)};
457	$stats{http_successful_requests}++;
458
459	# if (!$opt->{fast}) {
460	# my $sleeptimer = int(rand(5)) + 1; # sleep anywhere from 1 to 5 seconds
461	# $stats{slept_for} += $sleeptimer;
462	# sleep $sleeptimer;
463	# }
464
465	if ($response->header('Content-Encoding') &&
466	$response->header('Content-Encoding') eq 'gzip') {
467	$stats{compressed_pages} += do {use bytes; length($response->content)};
468	$response->content(Compress::Zlib::memGunzip($response->content));
469	}
470	return $response->content;
471	}
472
473	######################################################################################################
474
475	sub log
476	{
477	my ($entry) = @_;
478	printf "%s\n",$entry;
479	}
480
481	######################################################################################################
482
483	sub print_time
484	{
485	my $t = shift;
486	return sprintf "%02d:%02d",$t/(60*60),$t/60%60;
487	}
488
489	######################################################################################################
490
491	sub nice_time
492	{
493	my $t = shift;
494	return POSIX::strftime("%Y%m%d%H%M",localtime($t));
495	}
496
497	######################################################################################################
498
499	sub print_stats
500	{
501	printf "STATS: %s v%s completed in %d seconds",$progname, $version, (time-$script_start_time);
502	foreach my $key (sort keys %stats) {
503	printf ", %d %s",$stats{$key},$key;
504	}
505	printf "\n";
506	}
507
508	######################################################################################################
509	# descend a structure and clean up various things, including stripping
510	# leading/trailing spaces in strings, translations of html stuff etc
511	# -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
512
513	my %amp;
514	BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
515
516	sub cleanup {
517	my $x = shift;
518	if (ref $x eq "REF") { cleanup($_) }
519	elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x }
520	elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
521	elsif (defined $$x) {
522	$$x =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
523	$$x =~ s/[^\x20-\x7f]//g;
524	$$x =~ s/(^\s+\|\s+$)//g;
525	}
526	}
527
528	######################################################################################################
529
530	sub write_data
531	{
532	my $writer;
533
534	my %writer_args = ( encoding => 'ISO-8859-1' );
535	my $fh = new IO::File(">$opt->{outputfile}") \|\| die "can't open $opt->{outputfile}: $!";
536	$writer_args{OUTPUT} = $fh;
537
538	$writer = new XMLTV::Writer(%writer_args);
539
540	$writer->start
541	( { 'source-info-name' => "$progname $version",
542	'generator-info-name' => "$progname $version"} );
543
544	$writer->write_channel( {
545	'display-name' => [[ 'SBS News', $opt->{lang} ]],
546	'id' => $channels->{'SBS News'} } );
547
548	my $currtime = time;
549	my @today = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
550	# set currtime back to match midnight.
551	$currtime -= (($today[0]) + ($today[1]60) + ($today[2]60*60));
552
553	foreach my $day ($opt->{offset} .. ($opt->{days}-1)) {
554	my $wday = ($today[6] + $day) % 7;
555
556	foreach my $key (sort {$a <=> $b} keys %{$tv_guide_by_wday->{$wday}}) {
557	my $start_time = $currtime + $day(2460*60) + $tv_guide_by_wday->{$wday}->{$key}->{start};
558	my $stop_time = $currtime + $day(2460*60) + $tv_guide_by_wday->{$wday}->{$key}->{stop};;
559
560	# if we are fetching microgaps, skip if this isn't
561	# in a micro-gap
562	if (defined $opt->{gaps_file}) {
563	my $found_gap_match = 0;
564	foreach my $g (@{($gaps->{'SBS News'})}) {
565	my ($s, $e) = split(/-/,$g);
566
567	$found_gap_match = 1 if
568	((($s >= $start_time) &&
569	($s <= $stop_time)) \|\|
570	(($e >= $start_time) &&
571	($e <= $stop_time)) \|\|
572	(($s <= $start_time) &&
573	($e >= $stop_time)));
574	}
575	if (!$found_gap_match) {
576	$stats{gaps_skipped}++;
577	next;
578	} else {
579	$stats{gaps_included}++;
580	}
581	}
582
583	my $prog = { %{$tv_guide_by_wday->{$wday}->{$key}}};
584	$prog->{start} = &nice_time($start_time);
585	$prog->{stop} = &nice_time($stop_time);
586
587	$writer->write_programme($prog);
588	$stats{progs}++;
589	}
590	}
591
592	$writer->end();
593	}
594
595	######################################################################################################

Note: See TracBrowser for help on using the browser.

Context Navigation

root/grabbers/sbsnews_website @ 719

Download in other formats: