Context Navigation

sbsnews_website @ 715

Revision 715, 18.4 kB (checked in by max, 6 years ago)
Better memory management: use $tree->delete
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.15";
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	# reverse-sort thru list to adjust prog stop times
354	my @list = sort {$b <=> $a} keys %$tv_guide;
355	my $prev_start = $tv_guide->{$list[$#list]}->{start} + (72460*60);
356	foreach my $key (@list) {
357	my $stop = $tv_guide->{$key}->{wday}(2460*60) + $tv_guide->{$key}->{stop};
358	if ($stop != $prev_start) {
359	my $diff = $prev_start - $stop;
360	$stop = $tv_guide->{$key}->{stop};
361	my $new_wday = $tv_guide->{$key}->{wday};
362	if ($stop >= (246060)) {
363	$stop -= (246060);
364	$new_wday = ($new_wday + 1) % 7;
365	}
366
367	# Gaps of 50+ minutes before 7am are Station Closes
368	if ($diff / 60 > 50 and (($prev_start % (246060)) < (76060))) {
369	my $new_prog = { title => [[ 'Station Close', $opt->{lang} ]],
370	channel => $channels->{'SBS News'},
371	start => $stop,
372	stop => $prev_start % (246060) };
373	&log(sprintf "Inserting Station Close: %s to %s.",
374	&print_time($new_prog->{start}),
375	&print_time($new_prog->{stop}));
376	$tv_guide_by_wday->{$new_wday}->{$stop} = $new_prog;
377
378	# Gaps of 15+ minutes in other times are genuine holes
379	# If the gap is a weekday, fill it with whatever was in
380	# that timeslot tommorow (we have Monday holes for some reason)
381	} elsif ($diff / 60 >= 15) {
382	if ($new_wday > 0 and $new_wday < 6) {
383	my $copy_wday = $new_wday + 1;
384	$copy_wday = 1 if $new_wday >= 6;
385
386	if ($tv_guide_by_wday->{$copy_wday}->{$stop}) {
387	my $new_prog = { %{$tv_guide_by_wday->{$copy_wday}->{$stop}}};
388	delete $new_prog->{wday} if $new_prog->{wday};
389	&log(sprintf "Filling weekday gap (%s) with next day's schedule (\"%s\").",
390	&print_time($stop), $new_prog->{title}[0][0]);
391	$tv_guide_by_wday->{$new_wday}->{$stop} = $new_prog;
392	} else {
393	&log(sprintf "Unable to find suitable program to copy to fill " .
394	"weekday gap (%s).", &print_time($stop));
395	}
396	} else {
397	&log(sprintf "Can't fill gap after \"%s\": gap too large (%d mins) (ends at %s)",
398	$tv_guide->{$key}->{title}[0][0],
399	$diff/60,
400	&print_time($tv_guide->{$key}->{stop}));
401	}
402
403	# Gaps of <15 minutes shall be filled in
404	} else {
405	&log(sprintf "Extending stop time of \"%s\" by %d mins (from %s to %s).",
406	$tv_guide->{$key}->{title}[0][0],
407	$diff/60,
408	&print_time($tv_guide->{$key}->{stop}),
409	&print_time($prev_start % (246060))) if ($opt->{debug});
410	$tv_guide->{$key}->{stop} += $diff;
411	}
412	}
413	delete $tv_guide->{$key}->{wday};
414	$prev_start = $key;
415	}
416	}
417
418	######################################################################################################
419
420	# logic to fetch a page via http
421	# retries up to 3 times to get a page with 5 second pauses inbetween
422
423	sub get_url
424	{
425	my ($url,$status,$retrycount) = @_;
426	my $response;
427	my $attempts = 0;
428	my ($raw, $page, $base);
429
430	$retrycount = 8 if ($retrycount == 0);
431	my $request = HTTP::Request->new(GET => $url);
432	$request->header('Accept-Encoding' => 'gzip');
433
434	for (1..$retrycount) {
435	$attempts++;
436	&log("fetching $url, attempt $attempts");
437
438	$response = $ua->request($request);
439	last if ($response->is_success);
440
441	$stats{http_failed_requests}++;
442	$stats{slept_for} += 20;
443	sleep 20;
444	}
445	if (!($response->is_success)) {
446	&log("aborting after $attempts attempts to fetch url $url");
447	return undef;
448	}
449
450	$stats{bytes_fetched} += do {use bytes; length($response->content)};
451	$stats{http_successful_requests}++;
452
453	# if (!$opt->{fast}) {
454	# my $sleeptimer = int(rand(5)) + 1; # sleep anywhere from 1 to 5 seconds
455	# $stats{slept_for} += $sleeptimer;
456	# sleep $sleeptimer;
457	# }
458
459	if ($response->header('Content-Encoding') &&
460	$response->header('Content-Encoding') eq 'gzip') {
461	$stats{compressed_pages} += do {use bytes; length($response->content)};
462	$response->content(Compress::Zlib::memGunzip($response->content));
463	}
464	return $response->content;
465	}
466
467	######################################################################################################
468
469	sub log
470	{
471	my ($entry) = @_;
472	printf "%s\n",$entry;
473	}
474
475	######################################################################################################
476
477	sub print_time
478	{
479	my $t = shift;
480	return sprintf "%02d:%02d",$t/(60*60),$t/60%60;
481	}
482
483	######################################################################################################
484
485	sub nice_time
486	{
487	my $t = shift;
488	return POSIX::strftime("%Y%m%d%H%M",localtime($t));
489	}
490
491	######################################################################################################
492
493	sub print_stats
494	{
495	printf "STATS: %s v%s completed in %d seconds",$progname, $version, (time-$script_start_time);
496	foreach my $key (sort keys %stats) {
497	printf ", %d %s",$stats{$key},$key;
498	}
499	printf "\n";
500	}
501
502	######################################################################################################
503	# descend a structure and clean up various things, including stripping
504	# leading/trailing spaces in strings, translations of html stuff etc
505	# -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
506
507	my %amp;
508	BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
509
510	sub cleanup {
511	my $x = shift;
512	if (ref $x eq "REF") { cleanup($_) }
513	elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x }
514	elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
515	elsif (defined $$x) {
516	$$x =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
517	$$x =~ s/[^\x20-\x7f]//g;
518	$$x =~ s/(^\s+\|\s+$)//g;
519	}
520	}
521
522	######################################################################################################
523
524	sub write_data
525	{
526	my $writer;
527
528	my %writer_args = ( encoding => 'ISO-8859-1' );
529	my $fh = new IO::File(">$opt->{outputfile}") \|\| die "can't open $opt->{outputfile}: $!";
530	$writer_args{OUTPUT} = $fh;
531
532	$writer = new XMLTV::Writer(%writer_args);
533
534	$writer->start
535	( { 'source-info-name' => "$progname $version",
536	'generator-info-name' => "$progname $version"} );
537
538	$writer->write_channel( {
539	'display-name' => [[ 'SBS News', $opt->{lang} ]],
540	'id' => $channels->{'SBS News'} } );
541
542	my $currtime = time;
543	my @today = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
544	# set currtime back to match midnight.
545	$currtime -= (($today[0]) + ($today[1]60) + ($today[2]60*60));
546
547	foreach my $day ($opt->{offset} .. ($opt->{days}-1)) {
548	my $wday = ($today[6] + $day) % 7;
549
550	foreach my $key (sort {$a <=> $b} keys %{$tv_guide_by_wday->{$wday}}) {
551	my $start_time = $currtime + $day(2460*60) + $tv_guide_by_wday->{$wday}->{$key}->{start};
552	my $stop_time = $currtime + $day(2460*60) + $tv_guide_by_wday->{$wday}->{$key}->{stop};;
553
554	# if we are fetching microgaps, skip if this isn't
555	# in a micro-gap
556	if (defined $opt->{gaps_file}) {
557	my $found_gap_match = 0;
558	foreach my $g (@{($gaps->{'SBS News'})}) {
559	my ($s, $e) = split(/-/,$g);
560
561	$found_gap_match = 1 if
562	((($s >= $start_time) &&
563	($s <= $stop_time)) \|\|
564	(($e >= $start_time) &&
565	($e <= $stop_time)) \|\|
566	(($s <= $start_time) &&
567	($e >= $stop_time)));
568	}
569	if (!$found_gap_match) {
570	$stats{gaps_skipped}++;
571	next;
572	} else {
573	$stats{gaps_included}++;
574	}
575	}
576
577	my $prog = { %{$tv_guide_by_wday->{$wday}->{$key}}};
578	$prog->{start} = &nice_time($start_time);
579	$prog->{stop} = &nice_time($stop_time);
580
581	$writer->write_programme($prog);
582	$stats{progs}++;
583	}
584	}
585
586	$writer->end();
587	}
588
589	######################################################################################################

Note: See TracBrowser for help on using the browser.

Context Navigation

root/grabbers/sbsnews_website @ 715

Download in other formats: