Context Navigation

ninemsn @ 467

Revision 467, 36.6 kB (checked in by lincoln, 6 years ago)
update ninemsn to newer channel names
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	# ninemsn au_tv guide grabber - runs from "Shepherd" master grabber
4	# * grabs data from NineMSN (http://tvguide.ninemsn.com.au/)
5	# * this does NOT use any config file - all settings are passed in from shepherd
6	# * roughly based on Michael 'Immar' Smith's excellent original
7	# ninemsn tv_grab_au script but essentially rewritten
8
9	use strict;
10
11	my $progname = "ninemsn";
12	my $version = "0.08";
13
14	use LWP::UserAgent;
15	use XMLTV;
16	use POSIX qw(strftime mktime);
17	use Getopt::Long;
18	use HTML::TreeBuilder;
19	use Data::Dumper;
20	use JavaScript;
21	use Compress::Zlib;
22	use Storable;
23
24	#
25	# global variables and settings
26	#
27
28	$\| = 1;
29	my $script_start_time = time;
30	my %stats;
31	my $channels, my $opt_channels;
32	my $data_cache;
33	my $writer;
34	my $jsc;
35	my $ua;
36	my $prev_url;
37	my $d;
38	my $opt;
39
40	#
41	# parse command line
42	#
43
44	$opt->{days} = 7; # default
45	$opt->{outputfile} = "output.xmltv"; # default
46	$opt->{cache_file} = $progname.".storable.cache"; # default
47	$opt->{lang} = "en";
48	$opt->{region} = 94;
49
50	GetOptions(
51	'log-http' => \$opt->{log_http},
52	'region=i' => \$opt->{region},
53	'days=i' => \$opt->{days},
54	'offset=i' => \$opt->{offset},
55	'timezone=s' => \$opt->{timezone},
56	'channels_file=s' => \$opt->{channels_file},
57	'output=s' => \$opt->{outputfile},
58	'cache-file=s' => \$opt->{cache_file},
59	'fast' => \$opt->{fast},
60	'no-cache' => \$opt->{no_cache},
61	'no-details' => \$opt->{no_details},
62	'debug+' => \$opt->{debug},
63	'warper' => \$opt->{warper},
64	'lang=s' => \$opt->{lang},
65	'obfuscate' => \$opt->{obfuscate},
66	'anonsocks=s' => \$opt->{anon_socks},
67	'scan-chan' => \$opt->{scan_chan},
68	'help' => \$opt->{help},
69	'verbose' => \$opt->{help},
70	'version' => \$opt->{version},
71	'ready' => \$opt->{version},
72	'v' => \$opt->{help});
73
74	&help if ($opt->{help});
75
76	&scan_channels if (defined $opt->{scan_chan});
77
78	if ($opt->{version}) {
79	printf "%s %s\n",$progname,$version;
80	exit(0);
81	}
82
83	die "no channel file specified, see --help for instructions\n", if (!$opt->{channels_file});
84	$opt->{days} = 7 if ($opt->{days} > 7); # limit to a max of 7 days
85
86	&log("WARNING: JavaScript version ".$JavaScript::VERSION." is too old. Please use at least version 0.55.")
87	if $JavaScript::VERSION < 0.55;
88
89
90	#
91	# go go go!
92	#
93
94	&log(sprintf "going to grab %d days%s of data into %s (%s%s%s%s%s)",
95	$opt->{days},
96	(defined $opt->{offset} ? " (skipping first $opt->{offset} days)" : ""),
97	$opt->{outputfile},
98	(defined $opt->{fast} ? "with haste" : "slowly"),
99	(defined $opt->{anon_socks} ? ", via multiple endpoints" : ""),
100	(defined $opt->{warper} ? ", anonymously" : ""),
101	(defined $opt->{no_details} ? ", without details" : ", with details"),
102	(defined $opt->{no_cache} ? ", without caching" : ", with caching"));
103
104	# read channels file
105	if (-r $opt->{channels_file}) {
106	local (@ARGV, $/) = ($opt->{channels_file});
107	no warnings 'all'; eval <>; die "$@" if $@;
108	} else {
109	die "WARNING: channels file $opt->{channels_file} could not be read\n";
110	}
111
112	&read_cache unless (defined $opt->{no_cache});
113
114	&set_ua(1);
115	&setup_socks if (defined $opt->{anon_socks});
116
117	&setup_javascript;
118
119	&get_initial_page;
120
121	&start_writing_xmltv;
122
123	&get_daily_pages;
124	&get_detailed_pages;
125
126	&write_cache unless (defined $opt->{no_cache});
127	$writer->end();
128
129	&print_stats;
130	exit(0);
131
132	##############################################################################
133	# help
134
135	sub help
136	{
137	print<<EOF
138	$progname $version
139
140	options are as follows:
141	--help show these help options
142	--days=N fetch 'n' days of data (default: $opt->{days})
143	--output=file send xml output to file (default: "$opt->{outputfile}")
144	--no-cache don't use a cache to optimize (reduce) number of web queries
145	--no-details don't fetch detailed descriptions (default: do)
146	--cache-file=file where to store cache (default "$opt->{cache_file}")
147	--fast don't run slow - get data as quick as you can - not recommended
148	--debug increase debug level
149	--warper fetch data using WebWarper web anonymizer service
150	--obfuscate pretend to be a proxy servicing multiple clients
151	--anonsocks=(ip:port) use SOCKS4A server at (ip):(port) (for Tor: recommended)
152	--lang=[s] set language of xmltv output data (default $opt->{lang})
153
154	--region=N set region for where to collect data from (default: $opt->{region})
155	--channels_file=file where to get channel data from
156	EOF
157	;
158
159	exit(0);
160	}
161
162	##############################################################################
163	# populate cache
164
165	sub read_cache
166	{
167	# convert old-style Data::Dumper cache to new format
168	if (-r "ninemsn.cache") {
169	local (@ARGV, $/) = ("ninemsn.cache");
170	no warnings 'all'; eval <>; die "$@" if $@;
171
172	&write_cache;
173	unlink "ninemsn.cache";
174	}
175
176	if (-r $opt->{cache_file}) {
177	my $store = Storable::retrieve($opt->{cache_file});
178	$data_cache = $store->{data_cache};
179	} else {
180	printf "WARNING: no programme cache $opt->{cache_file} - have to fetch all details\n";
181
182	# try to write to it - if directory doesn't exist this will then cause an error
183	&write_cache;
184	}
185	}
186
187	##############################################################################
188	# write out updated cache
189
190	sub write_cache
191	{
192	# cleanup old entries from cache
193	for my $cache_key (keys %{$data_cache}) {
194	my ($starttime, @rest) = split(/:/,$cache_key);
195	if ($starttime < (time-86400)) {
196	delete $data_cache->{$cache_key};
197	$stats{expired_from_cache}++;
198	}
199	}
200
201	my $store;
202	$store->{data_cache} = $data_cache;
203
204	Storable::store($store, $opt->{cache_file});
205	}
206
207	##############################################################################
208	# logic to fetch a page via http
209	# retries up to $retrycount times to get a page with 10 second pauses inbetween
210
211	sub get_url
212	{
213	my ($url,$retrycount,$referer,$reqtype,$postvars) = @_;
214	my $request;
215	my $response;
216	my $attempts = 0;
217	my ($raw, $page, $base);
218
219	$reqtype = "GET" if (!defined $reqtype);
220
221	$retrycount = 5 if ($retrycount == 0);
222	$url =~ s#^http://#http://webwarper.net/ww/# if (defined $opt->{warper});
223
224	if ($reqtype eq "GET") {
225	$request = HTTP::Request->new(GET => $url);
226	} elsif ($reqtype eq "POST") {
227	$request = HTTP::Request->new(POST => $url);
228	$request->add_content($postvars);
229	}
230
231	if (defined $referer) {
232	$request->header('Referer' => $referer);
233	printf "DEBUG: explicitly set Referer to '%s'\n", $referer if (defined $opt->{debug});
234	} else {
235	if (defined $prev_url) {
236	$request->header('Referer' => $prev_url);
237	printf "DEBUG: set Referer to '%s'\n", $prev_url if (defined $opt->{debug});
238	}
239	}
240	$prev_url = $url;
241
242	$request->header('Accept-Encoding' => 'gzip');
243
244	if ($opt->{obfuscate}) {
245	my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1);
246	$request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)');
247	$request->header('X-Forwarded-For' => $randomaddr);
248	}
249	for (1..$retrycount) {
250	$response = $ua->request($request);
251
252	if ((defined $opt->{log_http}) && (open(F,">>http_log.txt"))) {
253	printf F "\n----------------------------------------------------\n";
254	printf F "request: %s %s %s\n",$reqtype,$url,(defined $postvars ? $postvars : "");
255	printf F "referer: %s\n",$request->header('Referer');
256	printf F "response: %s\n",$response->status_line;
257	print F $response->content;
258	close F;
259	}
260
261	last if ($response->is_success);
262
263	$stats{http_failed_requests}++;
264	$attempts++;
265
266	my $sleep_for = 600;
267	$sleep_for = 10 if (defined $opt->{anon_socks});
268	&log("attempt $attempts to fetch $url failed, sleeping for $sleep_for seconds: ".$response->status_line);
269
270	$stats{slept_for} += $sleep_for;
271	sleep $sleep_for;
272	}
273	if (!($response->is_success)) {
274	&log("aborting after $attempts attempts to fetch url $url");
275	return undef;
276	}
277
278	$prev_url = $response->base;
279	$prev_url =~ s#^http://webwarper.net/ww/#http://# if (defined $opt->{warper});
280	printf "DEBUG: set prev_url to '%s'\n", $prev_url if (defined $opt->{debug});
281
282	$stats{bytes_fetched} += do {use bytes; length($response->content)};
283	$stats{http_successful_requests}++;
284
285	if ((!$opt->{fast}) && (!defined $opt->{anon_socks})) {
286	my $sleeptimer = int(rand(5)) + 16; # sleep anywhere from 16 to 20 seconds
287	$stats{slept_for} += $sleeptimer;
288	sleep $sleeptimer;
289	}
290
291	if ($response->header('Content-Encoding') &&
292	$response->header('Content-Encoding') eq 'gzip') {
293	$stats{compressed_pages} += do {use bytes; length($response->content)};
294	$response->content(Compress::Zlib::memGunzip($response->content));
295	}
296	return $response->content;
297	}
298
299	##############################################################################
300	# turn a string into something that can be used on a URL line
301
302	sub urlify
303	{
304	my $str = shift;
305	$str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
306	return $str;
307	}
308
309	##############################################################################
310
311	sub log
312	{
313	my ($entry) = @_;
314	printf "%s [%d] %s\n",$progname,time,$entry;
315	}
316
317	##############################################################################
318
319	sub print_stats
320	{
321	printf "STATS: %s v%s completed in %d seconds",$progname, $version, time-$script_start_time;
322	foreach my $key (sort keys %stats) {
323	printf ", %d %s",$stats{$key},$key;
324	}
325	printf "\n";
326	}
327
328	##############################################################################
329	# descend a structure and clean up various things, including stripping
330	# leading/trailing spaces in strings, translations of html stuff etc
331	# -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
332
333	my %amp;
334	BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
335
336	sub cleanup {
337	my $x = shift;
338	if (ref $x eq "REF") { cleanup($_) }
339	elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x }
340	elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
341	elsif (defined $$x) {
342	$$x =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
343	$$x =~ s/[^\x20-\x7f]/ /g;
344	$$x =~ s/(^\s+\|\s+$)//g;
345	}
346	}
347
348	##############################################################################
349
350	sub start_writing_xmltv
351	{
352	my %writer_args = ( encoding => 'ISO-8859-1' );
353	if ($opt->{outputfile}) {
354	my $fh = new IO::File(">$opt->{outputfile}") \|\| die "can't open $opt->{outputfile}: $!";
355	$writer_args{OUTPUT} = $fh;
356	}
357
358	$writer = new XMLTV::Writer(%writer_args);
359
360	$writer->start
361	( { 'source-info-name' => "$progname $version",
362	'generator-info-name' => "$progname $version"} );
363
364	for my $channel (sort keys %{$channels}) {
365	$writer->write_channel( {
366	'display-name' => [[ $channel, $opt->{lang} ]],
367	'id' => $channels->{$channel}
368	} );
369	}
370	}
371
372	##############################################################################
373
374	sub set_ua
375	{
376	my $enable_cookies = shift;
377
378	my @agent_list = (
379	'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)',
380	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
381	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; FunWebProducts)',
382	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322)',
383	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)',
384	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Q312466)',
385	'Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)',
386	'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85.8.5 (KHTML, like Gecko) Safari/85.8.1',
387	'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.4) Gecko/20060508 Firefox/1.5.0.4',
388	'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox',
389	'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.8) Gecko/20061025 Firefox/1.5.0.8',
390	'Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1) Gecko/20061010 Firefox/2.0',
391	'Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)',
392	'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412',
393	'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-us) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
394	'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; fr) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
395	'Opera/9.00 (Windows NT 5.1; U; en)');
396
397	$ua = undef;
398	$ua = LWP::UserAgent->new('timeout' => 30, 'agent' => $agent_list[(int(rand($#agent_list+1)))] );
399	$ua->env_proxy;
400	$ua->cookie_jar({}) if (defined $enable_cookies);
401	$prev_url = undef; # reset referer
402	}
403
404	##############################################################################
405	# 1.
406	# browse to http://tvguide.ninemsn.com.au/ via
407	# http://tvguide.ninemsn.com.au/setlocation.asp?region=<reg>&returnURL=http://tvguide.ninemsn.com.au/
408	# and soak up the "day" URLs
409
410	sub get_initial_page
411	{
412	my $returl = "http://tvguide.ninemsn.com.au/";
413	my $url = "http://tvguide.ninemsn.com.au/setlocation.asp?region=".$opt->{region}."&returnURL=$returl";
414
415	&log("setting location via $url");
416	my $data = &get_url($url, 5, $returl);
417
418	if (!$data) {
419	&log("CRITIAL ERROR: ABORTING: could not read initial page '$url'");
420	exit(1);
421	}
422
423	# parse initial page
424	my $tree = HTML::TreeBuilder->new_from_content($data);
425	if (!$tree) {
426	&log("CRITICAL ERROR: ABORTING: could not build tree from data in '$url'");
427	exit(1);
428	}
429
430	# find <select name=day..> tag
431	my $select_day_tag = $tree->look_down('_tag' => 'select', 'name' => 'day');
432	if (!$select_day_tag) {
433	&log("CRITICAL ERROR: ABORTING: could not find a day tag in '$url'");
434	exit(1);
435	}
436
437	# take note of options
438	my $found_options = 0;
439
440	foreach my $opt_tag ($select_day_tag->look_down('_tag' => 'option')) {
441	push (@{($d->{day_values})},$opt_tag->attr('value'));
442	$found_options++;
443
444	printf "DEBUG: day %d tag is '%s'\n",$found_options,$opt_tag->attr('value')
445	if (defined $opt->{debug});
446	}
447
448	if ($found_options == 0) {
449	&log("CRITICAL ERROR: ABORTING: could not find any day tag options in '$url'");
450	exit(1);
451	}
452	}
453
454	##############################################################################
455	# get daily pages
456
457	sub get_daily_pages
458	{
459	my $starttime = time;
460	my $day_num = 0;
461	my $skip_days = 0;
462
463	$skip_days = $opt->{offset} if (defined $opt->{offset});
464
465	foreach my $day_opt (@{($d->{day_values})}) {
466	my $currtime = $starttime + (606024 * $day_num);
467	$day_num++;
468
469	return if ($day_num > $opt->{days});
470
471	# skip if --offset applies against this day
472	if ($skip_days > 0) {
473	$skip_days--;
474	next;
475	}
476
477	my @timeattr = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
478	$timeattr[0] = 0; # zero sec
479	$timeattr[1] = 0; # zero min
480	$timeattr[2] = 0; # zero hour
481	my $day_start = mktime(@timeattr); # midnight on the day
482
483	&parse_daily_page($day_opt,$day_start,$day_num);
484	}
485	}
486
487	##############################################################################
488	# parse a daily page
489
490	sub parse_daily_page
491	{
492	my ($day_opt,$day_start,$day_num) = @_;
493
494	my $url = "http://tvguide.ninemsn.com.au/todaytv/default.asp";
495	my $postvars = "channel=free&day=".urlify($day_opt)."&go=go";
496
497	my $progs_in_day = 0;
498
499	my $tries = 0;
500	my $tree;
501	while ((!$tree) && ($tries < 10)) {
502	$tries++;
503	&log("fetching day $day_num summary page (try $tries): POST $url $postvars");
504
505	# my $data = &get_url($url, 1, undef, "POST", $postvars);
506	my $data = &get_url($url."?".$postvars, 1, undef);
507	$tree = HTML::TreeBuilder->new_from_content($data) if ($data);
508	}
509
510	if (!$tree) {
511	&log("WARNING: skipping day $day_num: could not fetch '$url' afer 5 attempts: format/URL changed?");
512	return 0;
513	}
514
515	my $table_tag = $tree->look_down('_tag' => 'table', 'class' => 'tv');
516	if (!$table_tag) {
517	&log("WARNING: skipping day $day_num: could not find tv table in '$url': has the format changed?");
518	return 0;
519	}
520
521	my $row_num = 0;
522	my @row_span; # used to track rowspan= counts
523	my @chan_col;
524	my $max_cols;
525
526	foreach my $tree_tr ($table_tag->look_down('_tag' => 'tr')) {
527	if ($row_num == 0) {
528	#
529	# parse channels
530	#
531
532	my $col_num = 0;
533	foreach my $tree_td ($tree_tr->look_down('_tag' => 'td')) {
534	my $ch = translate_channel_name($tree_td->as_text());
535
536	if (defined $channels->{$ch}) {
537	$chan_col[$col_num] = $channels->{$ch};
538
539	printf "DEBUG: chan_map col %d '%s' -> %s\n", $col_num, $ch,
540	(defined $chan_col[$col_num] ? $chan_col[$col_num] : "(undef)")
541	if (defined $opt->{debug});
542	} else {
543	if (!defined $d->{unknown_chan}->{$ch}) {
544	&log("Ignoring programmes from unknown channel '$ch'");
545	$d->{unknown_chan}->{$ch} = 1; # so we report this only once
546	}
547	}
548
549	$row_span[$col_num] = 1; # set initial row_span to 1
550	$col_num++;
551	}
552	$max_cols = $col_num;
553	printf "DEBUG: set max_cols to $max_cols\n" if (defined $opt->{debug});
554	} else {
555	#
556	# parse programmes
557	#
558
559	my $col_num = -1;
560	foreach my $tree_td ($tree_tr->look_down('_tag' => 'td', 'class' => 'tv')) {
561	$col_num++; # increment at beginning - just easier
562
563	my $prog;
564	my $prog_name = $tree_td->as_text();
565
566	# calculate programme starttime, either based on row number
567	# (each row = 5 mins) or an explicit start time in the prog_name
568	if ($prog_name =~ s/\s\[\s (\d+):(\d+) \s* (am\|pm) \s\]\s //x) {
569	my ($hr, $min, $ampm) = ($1, $2, lc($3));
570	$hr = 0 if ($hr == 12);
571	$hr += 12 if ($ampm eq "pm");
572	$hr += 24 if (($ampm eq "am") && ($hr < 6));
573
574	$prog->{starttime} = $day_start + ((6060)$hr) + (60*$min);
575
576	printf "DEBUG: starttime of prog '%s' explicitly set to %s\n",
577	$prog_name, (strftime "%Y%m%d%H%M", localtime($prog->{starttime}))
578	if (defined $opt->{debug});
579	} else {
580	$prog->{starttime} = $day_start + ((6060)6) + ((560)($row_num-1));
581
582	printf "DEBUG: starttime of prog '%s' calculated to be %s based on row %d\n",
583	$prog_name, (strftime "%Y%m%d%H%M", localtime($prog->{starttime})),
584	$row_num, if (defined $opt->{debug});
585	}
586
587	# got a cell. work out what column it applies to,
588	# taking into account any rowspans that are going on
589	while (($col_num < $max_cols) && ($row_span[$col_num] > 1)) {
590	printf "DEBUG: row %d column %d skipped due to rowspan (%d)\n",
591	$row_num, $col_num, $row_span[$col_num] if (defined $opt->{debug});
592
593	$row_span[$col_num]--; # decrease span
594	$col_num++; # jump to next column
595	}
596
597	if ($col_num == $max_cols) {
598	# no longer in a valid column!
599	&log("WARNING: Bad HTML (excess columns) in row $row_num of '$url': celltext: '$prog_name'. Format changed?");
600	next;
601	}
602
603	# set (future) rowspan
604	if ($tree_td->attr('rowspan')) {
605	my $found_span = $tree_td->attr('rowspan');
606
607	if ($found_span =~ /^(\d+)$/) {
608	$row_span[$col_num] = $found_span;
609	} else {
610	# a BOGUS span - invalid HTML - who would have thought?!???
611	printf "DEBUG: ignored a non-numeric rowspan in row %d column %d: '%s': skipped\n",
612	$row_num, $col_num, $found_span if (defined $opt->{debug});
613	next;
614	}
615	}
616
617	# programme length is based on number of rows spanned
618	$prog->{stoptime} = $prog->{starttime} + ((560)$row_span[$col_num]);
619
620	my $prog_a = $tree_td->look_down('_tag' => 'a');
621	$prog->{url} = $prog_a->attr('href') if ($prog_a);
622
623	if (!defined $prog->{url}) {
624	# no url - not a programme?
625	&log("WARNING: Bad HTML (no link) in row $row_num column $col_num of '$url': '$prog_name' has no URL. Format changed?");
626	next;
627	}
628
629	if (!defined $chan_col[$col_num]) {
630	# no channel for this programme!
631	printf "DEBUG: Programme in row $row_num column $col_num had no known channel! ($prog_name)\n"
632	if (defined $opt->{debug});
633	$stats{skipped_prog_no_channel}++;
634	next;
635	}
636	$prog->{channel} = $chan_col[$col_num];
637	$prog->{title} = [[ $prog_name, $opt->{lang} ]];
638
639	#
640	# got programme, store it for grabbing detailed info in next step
641	#
642
643	$progs_in_day++;
644	$stats{programmes}++;
645
646	push(@{($d->{progs})},$prog);
647	}
648
649	# update any remaining rowspan counters
650	$col_num++;
651	while (($col_num < $max_cols) && ($row_span[$col_num] > 1)) {
652	printf "DEBUG: blank row %d: decreasing column %d rowspan (%d)\n",
653	$row_num, $col_num, $row_span[$col_num] if (defined $opt->{debug});
654
655	$row_span[$col_num]--; # decrease span
656	$col_num++; # jump to next column
657	}
658	}
659
660	$row_num++;
661	}
662
663	&log("WARNING: $progs_in_day programmes seen for day $day_num. URL/formatting changed? (url $url)")
664	if ($progs_in_day < 50);
665	}
666
667	##############################################################################
668	# loop through our progs, fetching details where we don't have a pre-cached
669	# entry for them.
670	# write out XMLTV
671
672	sub get_detailed_pages
673	{
674	my $prog_count = 0;
675	my $added_to_cache = 0;
676
677	&set_ua;
678
679	foreach my $prog (@{($d->{progs})}) {
680	$prog_count++;
681	my $cache_key = sprintf "%d:%s:%s", $prog->{starttime}, $prog->{channel}, $prog->{title}->[0]->[0];
682
683	if ((!defined $data_cache->{$cache_key}) && (!defined $opt->{no_details}) &&
684	($prog->{title}->[0]->[0] ne "Station Close")) {
685	printf "DEBUG: Fetching detail page: %s: %s\n",
686	$prog->{channel}, $prog->{url} if (defined $opt->{debug});
687
688	# not in cache, go fetch additional details if we can
689	&fetch_one_prog($cache_key, $prog->{url}, $prog_count, $stats{programmes});
690	$stats{added_to_cache}++;
691	&write_cache if ((($stats{added_to_cache} % 5) == 0) && (!defined $opt->{no_cache}));
692	} elsif (!defined $opt->{no_details}) {
693	$stats{used_existing_cache_entry}++;
694	}
695
696	# if we got additional details, add them now
697	if (defined $data_cache->{$cache_key}) {
698	foreach my $key (keys %{($data_cache->{$cache_key})}) {
699	$prog->{$key} = $data_cache->{$cache_key}->{$key};
700	}
701	}
702
703	# if we now have a length field, use that as a more accurate
704	# stop time (we may have got a length field in the detailed data)
705	$prog->{stop} = $prog->{start} + (60*$prog->{length})
706	if (defined $prog->{length});
707
708	# convert epoch starttime into XMLTV starttime
709	$prog->{start} = strftime "%Y%m%d%H%M", localtime($prog->{starttime});
710	delete $prog->{starttime};
711
712	# convert epoch stoptime into XMLTV stoptime
713	$prog->{stop} = strftime "%Y%m%d%H%M", localtime($prog->{stoptime});
714	delete $prog->{stoptime};
715
716	delete $prog->{url};
717	&cleanup($prog);
718
719	printf "DEBUG: programme xmltv: ".Dumper($prog) if (defined $opt->{debug});
720	$writer->write_programme($prog);
721	}
722	}
723
724	##############################################################################
725	# fetch detailed info on one prog
726
727	sub fetch_one_prog
728	{
729	my ($cache_key,$url,$prog_count,$total_prog_count) = @_;
730
731	$url = "http://tvguide.ninemsn.com.au".$url if ($url !~ /^http/);
732	$url =~ s/\/closeup\//\/cu\//;
733
734	my $sleep_for = 600;
735	$sleep_for = 10 if (defined $opt->{anon_socks});
736
737	my $tries = 0;
738	my $data;
739	my $parsed_text = "";
740	while ((!$data) && ($tries < 12)) {
741	$tries++;
742	&log("fetching programme detail page ($prog_count of $total_prog_count) [try $tries]");
743	$data = &get_url($url, 1);
744
745	if ($data) {
746	$data =~ s{<script language="?Javascript"?[^>]>(.?)</script>}{
747	my $x = $1;
748	$jsc->eval(qq{ doc = '' });
749	$jsc->eval($x);
750	$parsed_text .= $jsc->eval(qq{ doc }) \|\| '';
751	}isge;
752
753	if ($data =~ /we are unable/i) {
754	&log("got unable page, sleeping for $sleep_for seconds");
755	sleep $sleep_for;
756	$stats{slept_for} += $sleep_for;
757	&set_ua;
758	$data = undef;
759	}
760	} else {
761	&log("failed, sleeping for $sleep_for seconds");
762	sleep $sleep_for;
763	$stats{slept_for} += $sleep_for;
764	&set_ua;
765	# &get_initial_page;
766	}
767	}
768
769	if (!$data) {
770	&log("WARNING: skipping programme, could not fetch '$url' afer 12 attempts: format/URL changed?");
771	return;
772	}
773
774	if ($parsed_text eq "") {
775	&log("WARNING: skipping programme, could not find javascript to execute in '$url': format changed?");
776	return;
777	}
778
779	# split HTML up into sections seperated by <BR><BR>
780	my @html_lines = split(/<BR><BR>/,$parsed_text);
781	&cleanup(@html_lines);
782
783	# line 1 contains progname, duration and genre
784	$html_lines[0] =~ s/<.*?>//g; # note: can fail on complex tags
785	if ($html_lines[0] =~ /\((\d+) mins/) {
786	$data_cache->{$cache_key}->{length} = $1;
787	printf "DEBUG: set 'length' to '%d'\n",$1 if (defined $opt->{debug});
788	}
789	if ($html_lines[0] =~ /Rated: ([^\)]+)\)/) {
790	my @ratings;
791	push(@ratings, [$1, 'ABA', undef]);
792	$data_cache->{$cache_key}->{rating} = [ @ratings ];
793	printf "DEBUG: set 'rating' to '%s'\n",$1 if (defined $opt->{debug});
794	}
795	if ($html_lines[0] =~ /Genre: (.*)$/) {
796	my $cat = translate_category($1);
797	my @categories;
798	push(@categories,$cat,$opt->{lang});
799	$data_cache->{$cache_key}->{category} = [[ @categories ]];
800	printf "DEBUG: set 'category' to '%s'\n",$cat if (defined $opt->{debug});
801	}
802
803	# line 2 contains description
804	if ($html_lines[1] ne "") {
805	$data_cache->{$cache_key}->{desc} = [[ $html_lines[1], $opt->{lang} ]];
806	printf "DEBUG: set desc to '%s'\n",$html_lines[1] if (defined $opt->{debug});
807	}
808	}
809
810	##############################################################################
811
812	sub setup_javascript
813	{
814	$jsc = new JavaScript::Runtime->create_context();
815	$jsc->set_error_handler( sub { } );
816
817	$jsc->eval(qq{
818	var doc = '';
819	function Location() { this.href = 'http://ninemsn.com.au'; }
820	function Document() { this.write = function(x) { doc += x; } }
821	function Window() { this.___ww = 0 }
822
823	location = new Location;
824	document = new Document;
825	window = new Window;
826	});
827	}
828
829	##############################################################################
830
831	sub translate_category
832	{
833	my $genre = shift;
834	my %translation = (
835	'Sport' => 'sports',
836	'Soap Opera' => 'Soap',
837	'Science and Technology' => 'Science/Nature',
838	'Real Life' => 'Reality',
839	'Cartoon' => 'Animation',
840	'Family' => 'Children',
841	'Murder' => 'Crime' );
842
843	return $translation{$genre} if defined $translation{$genre};
844	return $genre;
845	}
846
847
848	##############################################################################
849
850	sub setup_socks
851	{
852	use LWP::Protocol::http;
853	my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
854
855	# override LWP::Protocol::http's _new_socket method with our own
856	local($^W) = 0;
857	*LWP::Protocol::http::_new_socket = \&socks_new_socket;
858
859	# test that it works
860	&log("configured to use Tor, testing that it works by connecting to www.google.com ...");
861	my $data = &get_url("http://www.google.com/",10);
862	if (($data) && ($data =~ /Google/i)) {
863	&log("success. Tor appears to be working!");
864	return;
865	}
866
867	&log("ERROR: Could not connect to www.google.com via Tor, disabling Tor.");
868	&log(" DATA FETCHING WILL BE VERY SLOW.");
869	&log(" DISABLING DETAILS-FETCHING BECAUSE OF THIS - SIGNIFICANTLY LOWER DATA QUALITY!!");
870
871	$opt->{no_details} = 1;
872	delete $opt->{anon_socks};
873	$stats{fallback_to_non_tor}++;
874
875	*LWP::Protocol::http::_new_socket = $orig_new_socket;
876	}
877
878	##############################################################################
879	# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
880
881	sub socks_new_socket
882	{
883	my($self, $host, $port, $timeout) = @_;
884
885	my ($socks_ip,$socks_port) = split(/:/,$opt->{anon_socks});
886	$socks_ip = "127.0.0.1" if (!defined $socks_ip);
887	$socks_port = "9050" if (!defined $socks_port);
888
889	local($^W) = 0; # IO::Socket::INET can be noisy
890	my $sock = $self->socket_class->new(
891	PeerAddr => $socks_ip,
892	PeerPort => $socks_port,
893	Proto => 'tcp');
894
895	unless ($sock) {
896	# IO::Socket::INET leaves additional error messages in $@
897	$@ =~ s/^.*?: //;
898	&log("Can't connect to $host:$port ($@)");
899	return undef;
900	}
901
902	# perl 5.005's IO::Socket does not have the blocking method.
903	eval { $sock->blocking(0); };
904
905	# establish connectivity with socks server - SOCKS4A protocol
906	print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
907	(pack 'x') .
908	$host . (pack 'x');
909
910	my $received = "";
911	my $timeout_time = time + $timeout;
912	while ($sock->sysread($received, 8) && (length($received) < 8) ) {
913	select(undef, undef, undef, 0.25);
914	last if ($timeout_time < time);
915	}
916
917	if ($timeout_time < time) {
918	&log("Timeout ($timeout) while connecting via SOCKS server");
919	return $sock;
920	}
921
922	my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
923	&log("Connection via SOCKS4A server rejected or failed") if ($req_status == 0x5b);
924	&log("Connection via SOCKS4A server because client is not running identd") if ($req_status == 0x5c);
925	&log("Connection via SOCKS4A server because client's identd could not confirm the user") if ($req_status == 0x5d);
926
927	$sock;
928	}
929
930	##############################################################################
931
932	sub scan_channels
933	{
934	my %REGIONS = (
935	126 => "ACT", 73 => "NSW: Sydney", 184 => "NSW: Newcastle",
936	66 => "NSW: Central Coast", 67 => "NSW: Griffith", 63 => "NSW: Broken Hill",
937	69 => "NSW: Northern NSW", 71 => "NSW: Southern NSW", 106 => "NSW: Remote and Central",
938	74 => "NT: Darwin", 108 => "NT: Remote & Central", 75 => "QLD: Brisbane",
939	78 => "QLD: Gold Coast", 79 => "QLD: Regional", 114 => "QLD: Remote & Central",
940	81 => "SA: Adelaide", 82 => "SA: Renmark", 83 => "SA: Riverland",
941	85 => "SA: South East SA", 86 => "SA: Spencer Gulf", 107 => "SA: Remote & Central",
942	88 => "Tasmania", 94 => "VIC: Melbourne", 93 => "VIC: Geelong",
943	90 => "VIC: Eastern Victoria", 95 => "VIC: Mildura/Sunraysia", 98 => "VIC: Western Victoria",
944	101 => "WA: Perth", 102 => "WA: Regional");
945
946	&set_ua(1);
947	&setup_socks if (defined $opt->{anon_socks});
948	&setup_javascript;
949
950	my $now = time;
951
952	printf "\nScanning channels:\n\n";
953
954	foreach my $r (sort { $a <=> $b } keys %REGIONS) {
955	printf "Looking up region %d (%s) ..\n",$r, $REGIONS{$r};
956
957	#
958	# 1. get shepherd channels
959	#
960	my $ua2 = LWP::UserAgent->new();
961	$ua2->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322');
962	$ua2->cookie_jar({});
963	$ua2->get('http://www.yourtv.com.au');
964	my $response = $ua2->get('http://www.yourtv.com.au/profile/ajax.cfm?action=channels&region_id='.$r);
965	my $page = $response->content;
966	if ($response->is_error()) {
967	printf "Unable to download channel list for region $r from YourTV\n";
968	next;
969	}
970
971	# shepherd rules for station names
972	my (%shepherd_channels, $clist, $cn, $rq);
973	while ($page =~ /<label for="venue_id.?>(.?)<\/label>/sg) {
974	my $channel = $1;
975	$channel =~ s/\s{2,}//g;
976	if ($channel =~ /(.) ($.$)/) {
977	($cn, $rq) = ($1, $2);
978	} else {
979	($cn, $rq) = ($channel, "");
980	}
981
982	if ($clist->{$cn}) { # Is there already a channel with this name?
983	$clist->{$cn} = [ "(".$REGIONS{$r}.")" ] if (@{$clist->{$cn}} == 1 and $clist->{$cn}[0] eq '');
984	$rq = $REGIONS{$r} if ($rq eq '');
985	die "Bad channel list in region $r!" if (grep($rq eq $_, @{$clist->{$cn}}));
986	push @{$clist->{$cn}}, $rq;
987	} else {
988	$clist->{$cn} = [ $rq ];
989	}
990	}
991
992	foreach $cn (keys %$clist) {
993	if (@{$clist->{$cn}} == 1) {
994	$shepherd_channels{$cn} = 1;
995	} else {
996	foreach $rq (@{$clist->{$cn}}) {
997	$shepherd_channels{"$cn $rq"} = 1;
998	}
999	}
1000	}
1001
1002
1003	#
1004	# 2. get ninemsn channels
1005	#
1006	$opt->{region} = $r;
1007	delete $d->{day_values};
1008
1009	&set_ua(1);
1010	&get_initial_page;
1011
1012	my $url = "http://tvguide.ninemsn.com.au/todaytv/default.asp";
1013	my $postvars = "channel=free&day=".urlify(splice(@{($d->{day_values})},0,1))."&go=go";
1014
1015	my $tries = 0;
1016	my $tree;
1017	while ((!$tree) && ($tries < 10)) {
1018	$tries++;
1019	my $data = &get_url($url."?".$postvars, 1, undef);
1020	$tree = HTML::TreeBuilder->new_from_content($data) if ($data);
1021	}
1022	if (!$tree) {
1023	printf "WARNING: skipping region $r, couldn't fetch '$url' afer 10 attempts";
1024	next;
1025	}
1026
1027	my $table_tag = $tree->look_down('_tag' => 'table', 'class' => 'tv');
1028	if (!$table_tag) {
1029	printf "WARNING: skipping region $r, couldn't find tv table in '$url': has the format changed?";
1030	next;
1031	}
1032
1033	my %seen_ch;
1034	my $tree_tr = $table_tag->look_down('_tag' => 'tr');
1035	foreach my $tree_td ($tree_tr->look_down('_tag' => 'td')) {
1036	my $channel = translate_channel_name($tree_td->as_text());
1037
1038	if (!defined $shepherd_channels{$channel}) {
1039	$shepherd_channels{$channel} = 0; # shepherd doesn't know about this channel, ninemsn does
1040	} elsif ($shepherd_channels{$channel} == 1) {
1041	$shepherd_channels{$channel} = 2; # both shepherd & ninemsn know about channel
1042	} elsif ($shepherd_channels{$channel} == 2) {
1043	$shepherd_channels{$channel} = 3; # shepherd/ninemsn knew about channel but was duplicated!
1044	} elsif ($shepherd_channels{$channel} == 0) {
1045	; # aiee. a duplicate of a channel that shepherd doesn't know about!
1046	} else {
1047	die "unhandled shepherd_channels case for '$channel' value ".$shepherd_channels{$channel};
1048	}
1049
1050	printf " %35s %s%s%s\n",
1051	$channel,
1052	(defined $seen_ch{$channel} ? "\t[Duplicate in ninemsn]" : ""),
1053	($shepherd_channels{$channel} == 0 ? "\t[Only known to ninemsn]" : ""),
1054	($shepherd_channels{$channel} == 2 ? "\t[Known to both ninemsn/Shepherd (good!)]" : ""),
1055	($shepherd_channels{$channel} == 3 ? "\t[Known to both ninemsn/Shepherd but duplicate in ninemsn]" : "");
1056
1057	$seen_ch{$channel}++;
1058	}
1059
1060	# any channels in Shepherd that ninemsn didn't return?
1061	foreach my $ch (keys %shepherd_channels) {
1062	printf " %35s\t[Only known to Shepherd]\n",$ch if ($shepherd_channels{$ch} == 1);
1063	}
1064
1065	printf "\n";
1066	}
1067
1068	exit(0);
1069	}
1070
1071	##############################################################################
1072
1073	sub translate_channel_name
1074	{
1075	my $ch = shift;
1076	return $ch if (defined $channels->{$ch});
1077
1078	# generic remapping
1079	if ($ch =~ /^ABC\s/) {
1080	$ch = "ABC";
1081	} elsif (($ch =~ /^SBS/) && ($ch !~ /news/i)) {
1082	$ch = "SBS";
1083	} elsif ($ch =~ /^SBS News/i) {
1084	$ch = "SBS News";
1085	} elsif ($ch =~ /^CENTRAL\s(.*)$/) {
1086	$ch = "Central $1";
1087	} elsif ($ch =~ /^SOUTHERN CROSS\s(.*)$/) {
1088	$ch = "Sthn Cross $1";
1089	}
1090	return $ch if (defined $channels->{$ch});
1091
1092	# more specific remapping
1093	if ($ch =~ /^CHANNEL NINE [A-Z]+$/) {
1094	$ch = "Nine";
1095	} elsif ($ch =~ /^CHANNEL SEVEN [A-Z]+$/) {
1096	$ch = "Seven";
1097	} elsif ($ch =~ /^NETWORK TEN [A-Z]+$/) {
1098	$ch = "TEN";
1099	} elsif ($ch =~ /^PRIME [A-Z]+$/) {
1100	$ch = "Prime";
1101	} elsif ($ch =~ /^Sthn Cross [A-Z]+$/) {
1102	$ch = "Southern Cross";
1103	} elsif ($ch =~ /^WIN TELEVISION [A-Z]+$/) {
1104	$ch = "WIN";
1105	} elsif ($ch =~ /^IMPARJA TELEVISION/) {
1106	$ch = "Imparja";
1107	}
1108	return $ch if (defined $channels->{$ch});
1109
1110	# very specific channel mapping when the above generic ones don't match
1111	if ($opt->{region} == 63) {
1112	return "Sthn Cross TEN" if ($ch eq "Southern Cross");
1113	} elsif ($opt->{region} == 66) {
1114	return "Prime" if ($ch eq "PRIME NORTHERN, NEWCASTLE");
1115	return "Sthn Cross TEN" if ($ch eq "Sthn Cross TEN NORTHERN NSW, NON GOLD COAST");
1116	} elsif ($opt->{region} == 67) {
1117	return "TEN" if ($ch eq "Sthn Cross TEN CAPITAL, WAGGA");
1118	} elsif ($opt->{region} == 69) {
1119	return "Prime" if ($ch eq "PRIME NORTHERN, TAMWORTH/TAREE/LISMORE/COFFS HARBOUR");
1120	return "Sthn Cross TEN" if ($ch eq "Sthn Cross TEN NORTHERN NSW, NON GOLD COAST");
1121	} elsif ($opt->{region} == 71) {
1122	return "TEN (Mildura Digital)" if ($ch eq "NETWORK TEN DIGITAL, MILDURA");
1123	return "Prime (Canberra/Wollongong/South Coast)" if ($ch eq "PRIME SOUTHERN, CANBERRA/WOLLONGONG/STH COAST");
1124	return "Prime (Wagga Wagga/Orange)" if ($ch eq "PRIME SOUTHERN, WAGGA WAGGA/ORANGE");
1125	return "TEN (NSW: Southern NSW)" if ($ch eq "Sthn Cross TEN CAPITAL, WAGGA");
1126	} elsif ($opt->{region} == 75) {
1127	return "Nine" if ($ch eq "CHANNEL NINE BRISBANE METRO");
1128	} elsif ($opt->{region} == 78) {
1129	return "Nine" if ($ch eq "CHANNEL NINE GOLD COAST");
1130	return "NBN" if ($ch eq "NBN GOLD COAST");
1131	return "Prime" if ($ch eq "PRIME GOLD COAST");
1132	return "Sthn Cross TEN" if ($ch eq "Sthn Cross TEN NORTHERN NSW, GOLD COAST");
1133	} elsif ($opt->{region} == 79) {
1134	return "Seven (Cairns/Townsville/Mackay/Wide Bay/Sunshine Coast)" if ($ch eq "CHANNEL SEVEN QUEENSLAND, CAIRNS/TOWNSVILLE/MACKAY");
1135	return "Seven (Rockhampton/Toowoomba)" if ($ch eq "CHANNEL SEVEN QUEENSLAND, ROCKHAMPTON/TOOWOOMBA");
1136	return "TEN" if ($ch eq "Sthn Cross TEN QUEENSLAND");
1137	return "WIN (Mackay/Wide Bay)" if ($ch eq "WIN TELEVISION QLD, MACKAY/WIDE BAY");
1138	return "WIN (QLD: Regional)" if ($ch eq "WIN TELEVISION QLD, REGIONAL QLD");
1139	} elsif ($opt->{region} == 85) {
1140	return "WIN" if ($ch eq "WIN TELEVISION SOUTH EAST SA");
1141	} elsif ($opt->{region} == 86) {
1142	return "Sthn Cross TEN" if ($ch eq "Southern Cross");
1143	} elsif ($opt->{region} == 88) {
1144	return "TDT" if ($ch eq "TASMANIAN DIGITAL TELEVISION");
1145	} elsif ($opt->{region} == 90) {
1146	return "Prime (Albury)" if ($ch eq "PRIME TELEVISION, ALBURY");
1147	return "Prime (Regional)" if ($ch eq "PRIME TELEVISION, REGIONAL VICTORIA");
1148	return "TEN" if ($ch eq "Sthn Cross TEN VICTORIA");
1149	} elsif ($opt->{region} == 95) {
1150	return "Prime" if ($ch eq "PRIME TELEVISION, REGIONAL VICTORIA");
1151	} elsif ($opt->{region} == 98) {
1152	return "Prime" if ($ch eq "PRIME TELEVISION, REGIONAL VICTORIA");
1153	return "TEN" if ($ch eq "Sthn Cross TEN VICTORIA");
1154	} elsif ($opt->{region} == 101) {
1155	return "Access 31" if ($ch eq "ACCESS 31");
1156	} elsif ($opt->{region} == 102) {
1157	return "Golden West" if ($ch eq "GOLDEN WEST NETWORK");
1158	} elsif ($opt->{region} == 106) {
1159	return "Prime" if ($ch eq "PRIME SOUTHERN, WAGGA WAGGA/ORANGE");
1160	} elsif ($opt->{region} == 126) {
1161	return "Prime" if ($ch eq "PRIME SOUTHERN, CANBERRA/WOLLONGONG/STH COAST");
1162	return "TEN" if ($ch eq "Sthn Cross TEN CAPITAL, CANBERRA");
1163	} elsif ($opt->{region} == 184) {
1164	return "Prime" if ($ch eq "PRIME NORTHERN, NEWCASTLE");
1165	return "Sthn Cross TEN" if ($ch eq "Sthn Cross TEN NORTHERN NSW, NON GOLD COAST");
1166	}
1167
1168	return $ch; # no match
1169	}

Note: See TracBrowser for help on using the browser.

Context Navigation

root/grabbers/ninemsn @ 467

Download in other formats: