root/grabbers/ninemsn @ 258

Revision 258, 25.0 kB (checked in by lincoln, 7 years ago)

fix bug in ninemsn caching
  • 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
9use strict;
10
11my $progname = "ninemsn";
12my $version = "0.01";
13
14use LWP::UserAgent;
15use XMLTV;
16use POSIX qw(strftime mktime);
17use Getopt::Long;
18use HTML::TreeBuilder;
19use Data::Dumper;
20use Cwd;
21use JavaScript;
22
23#
24# global variables and settings
25#
26
27$| = 1;
28my $script_start_time = time;
29my %stats;
30my $channels, my $opt_channels;
31my $data_cache;
32my $writer;
33my $jsc;
34my $ua;
35my $prev_url;
36my $d;
37my $opt;
38
39#
40# parse command line
41#
42
43$opt->{days} =          7;                              # default
44$opt->{outputfile} =    cwd() . "/ninemsn.xmltv";       # default
45$opt->{cache_file} =    cwd() . "/ninemsn.cache";       # default
46$opt->{lang} =          "en";
47$opt->{region} =        94;
48
49GetOptions(
50        'log-http'      => \$opt->{log_http},
51        'region=i'      => \$opt->{region},
52        'days=i'        => \$opt->{days},
53        'offset=i'      => \$opt->{offset},
54        'timezone=s'    => \$opt->{timezone},
55        'channels_file=s' => \$opt->{channels_file},
56        'output=s'      => \$opt->{outputfile},
57        'cache-file=s'  => \$opt->{cache_file},
58        'fast'          => \$opt->{fast},
59        'no-cache'      => \$opt->{no_cache},
60        'no-details'    => \$opt->{no_details},
61        'debug+'        => \$opt->{debug},
62        'warper'        => \$opt->{warper},
63        'lang=s'        => \$opt->{lang},
64        'obfuscate'     => \$opt->{obfuscate},
65        'help'          => \$opt->{help},
66        'verbose'       => \$opt->{help},
67        'version'       => \$opt->{version},
68        'ready'         => \$opt->{version},
69        'v'             => \$opt->{help});
70
71&help if ($opt->{help});
72
73if ($opt->{version}) {
74        printf "%s %s\n",$progname,$version;
75        exit(0);
76}
77
78die "no channel file specified, see --help for instructions\n", if (!$opt->{channels_file});
79$opt->{days} = 7 if ($opt->{days} > 7); # limit to a max of 7 days
80
81&log("WARNING: JavaScript version ".$JavaScript::VERSION." is too old. Please use at least version 0.55.")
82  if $JavaScript::VERSION < 0.55;
83
84
85#
86# go go go!
87#
88
89&log(sprintf "going to grab %d days%s of data into %s (%s%s%s)",
90        $opt->{days},
91        (defined $opt->{offset} ? " (skipping first $opt->{offset} days)" : ""),
92        $opt->{outputfile},
93        (defined $opt->{fast} ? "with haste" : "slowly"),
94        (defined $opt->{warper} ? ", anonymously" : ""),
95        (defined $opt->{no_details} ? ", without details" : ", with details"),
96        (defined $opt->{no_cache} ? ", without caching" : ", with caching"));
97
98# read channels file
99if (-r $opt->{channels_file}) {
100        local (@ARGV, $/) = ($opt->{channels_file});
101        no warnings 'all'; eval <>; die "$@" if $@;
102} else {
103        die "WARNING: channels file $opt->{channels_file} could not be read\n";
104}
105
106&read_cache unless (defined $opt->{no_cache});
107
108&set_ua;
109&setup_javascript;
110
111&get_initial_page;
112
113&start_writing_xmltv;
114
115&get_daily_pages;
116&get_detailed_pages;
117
118&write_cache unless (defined $opt->{no_cache});
119$writer->end();
120
121&print_stats;
122exit(0);
123
124##############################################################################
125# help
126
127sub help
128{
129        print<<EOF
130$progname $version
131
132options 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        --no-cache              don't use a cache to optimize (reduce) number of web queries
137        --no-details            don't fetch detailed descriptions (default: do)
138        --cache-file=file       where to store cache (default "$opt->{cache_file}")
139        --fast                  don't run slow - get data as quick as you can - not recommended
140        --debug                 increase debug level
141        --warper                fetch data using WebWarper web anonymizer service
142        --obfuscate             pretend to be a proxy servicing multiple clients
143        --lang=[s]              set language of xmltv output data (default $opt->{lang})
144
145        --region=N              set region for where to collect data from (default: $opt->{region})
146        --channels_file=file    where to get channel data from
147EOF
148;
149
150        exit(0);
151}
152
153##############################################################################
154# populate cache
155
156sub read_cache
157{
158        if (-r $opt->{cache_file}) {
159                local (@ARGV, $/) = ($opt->{cache_file});
160                no warnings 'all'; eval <>; die "$@" if $@;
161
162                my $cache_items = 0;
163                foreach (keys %{$data_cache}) {
164                        $cache_items++;
165                }
166                &log("$cache_items programmes loaded from cache.");
167        } else {
168                printf "WARNING: no programme cache $opt->{cache_file} - have to fetch all details\n";
169
170                # try to write to it - if directory doesn't exist this will then cause an error
171                &write_cache;
172        }
173}
174
175##############################################################################
176# write out updated cache
177
178sub write_cache
179{
180        if (!(open(F,">$opt->{cache_file}"))) {
181                printf "ERROR: could not write cache file $opt->{cache_file}: $!\n";
182                printf "Please fix this in order to reduce the number of queries for data!\n";
183                exit 1;
184        } else {
185                # cleanup old entries from cache
186                for my $cache_key (keys %{$data_cache}) {
187                        my ($starttime, @rest) = split(/:/,$cache_key);
188                        if ($starttime < (time-86400)) {
189                                delete $data_cache->{$cache_key};
190                                $stats{expired_from_cache}++;
191                        }
192                }
193                print F Data::Dumper->Dump([$data_cache], ["data_cache"]);
194                close F;
195        }
196}
197
198##############################################################################
199# logic to fetch a page via http
200#  retries up to $retrycount times to get a page with 10 second pauses inbetween
201
202sub get_url
203{
204        my ($url,$retrycount,$referer,$reqtype,$postvars) = @_;
205        my $request;
206        my $response;
207        my $attempts = 0;
208        my ($raw, $page, $base);
209
210        $reqtype = "GET" if (!defined $reqtype);
211
212        $retrycount = 5 if ($retrycount == 0);
213        $url =~ s#^http://#http://webwarper.net/ww/# if (defined $opt->{warper});
214
215        if ($reqtype eq "GET") {
216                $request = HTTP::Request->new(GET => $url);
217        } elsif ($reqtype eq "POST") {
218                $request = HTTP::Request->new(POST => $url);
219                $request->add_content($postvars);
220        }
221
222        if (defined $referer) {
223                $request->header('Referer' => $referer);
224                printf "DEBUG: explicitly set Referer to '%s'\n", $referer if (defined $opt->{debug});
225        } else {
226                if (defined $prev_url) {
227                        $request->header('Referer' => $prev_url);
228                        printf "DEBUG: set Referer to '%s'\n", $prev_url if (defined $opt->{debug});
229                }
230        }
231        $prev_url = $url;
232
233        $request->header('Accept-Encoding' => 'gzip');
234
235        if ($opt->{obfuscate}) {
236                my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1);
237                $request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)');
238                $request->header('X-Forwarded-For' => $randomaddr);
239        }
240        for (1..$retrycount) {
241                $response = $ua->request($request);
242
243                if ((defined $opt->{log_http}) && (open(F,">>http_log.txt"))) {
244                        printf F "\n----------------------------------------------------\n";
245                        printf F "request: %s %s %s\n",$reqtype,$url,(defined $postvars ? $postvars : "");
246                        printf F "referer: %s\n",$request->header('Referer');
247                        printf F "response: %s\n",$response->status_line;
248                        print F $response->content;
249                        close F;
250                }
251
252                last if ($response->is_success);
253
254                $stats{http_failed_requests}++;
255                $attempts++;
256                &log("attempt $attempts to fetch $url failed: ".$response->status_line);
257
258                $stats{slept_for} += 20;
259                sleep 20;
260        }
261        if (!($response->is_success)) {
262                &log("aborting after $attempts attempts to fetch url $url");
263                return undef;
264        }
265
266        $prev_url = $response->base;
267        $prev_url =~ s#^http://webwarper.net/ww/#http://# if (defined $opt->{warper});
268        printf "DEBUG: set prev_url to '%s'\n", $prev_url if (defined $opt->{debug});
269
270        $stats{bytes_fetched} += do {use bytes; length($response->content)};
271        $stats{http_successful_requests}++;
272
273        if (!$opt->{fast}) {
274                my $sleeptimer = int(rand(5)) + 16;  # sleep anywhere from 16 to 20 seconds
275                $stats{slept_for} += $sleeptimer;
276                sleep $sleeptimer;
277        }
278
279        if ($response->header('Content-Encoding') &&
280            $response->header('Content-Encoding') eq 'gzip') {
281                $stats{compressed_pages} += do {use bytes; length($response->content)};
282                $response->content(Compress::Zlib::memGunzip($response->content));
283        }
284        return $response->content;
285}
286
287##############################################################################
288# turn a string into something that can be used on a URL line
289
290sub urlify
291{
292        my $str = shift;
293        $str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
294        return $str;
295}
296
297##############################################################################
298
299sub log
300{
301        my ($entry) = @_;
302        printf "%s [%d] %s\n",$progname,time,$entry;
303}
304
305##############################################################################
306
307sub print_stats
308{
309        printf "%s %s [%d] completed in %d seconds",$progname, $version, time, time-$script_start_time;
310        foreach my $key (sort keys %stats) {
311                printf ", %d %s",$stats{$key},$key;
312        }
313        printf "\n";
314}
315
316##############################################################################
317# descend a structure and clean up various things, including stripping
318# leading/trailing spaces in strings, translations of html stuff etc
319#   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
320
321my %amp;
322BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
323
324sub cleanup {
325        my $x = shift;
326        if    (ref $x eq "REF")   { cleanup($_) }
327        elsif (ref $x eq "HASH")  { cleanup(\$_) for values %$x }
328        elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
329        elsif (defined $$x) {
330                $$x =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg;
331                $$x =~ s/[^\x20-\x7f]/ /g;
332                $$x =~ s/(^\s+|\s+$)//g;
333        }
334}
335
336##############################################################################
337
338sub start_writing_xmltv
339{
340        my %writer_args = ( encoding => 'ISO-8859-1' );
341        if ($opt->{outputfile}) {
342                my $fh = new IO::File(">$opt->{outputfile}") || die "can't open $opt->{outputfile}: $!";
343                $writer_args{OUTPUT} = $fh;
344        }
345
346        $writer = new XMLTV::Writer(%writer_args);
347
348        $writer->start
349          ( { 'source-info-name'   => "$progname $version",
350              'generator-info-name' => "$progname $version"} );
351
352        for my $channel (sort keys %{$channels}) {
353                $writer->write_channel( {
354                        'display-name' => [[ $channel, $opt->{lang} ]],
355                        'id' => $channels->{$channel}
356                        } );
357        }
358}
359
360##############################################################################
361
362sub set_ua
363{
364        my @agent_list = (
365                'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)',
366                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
367                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; FunWebProducts)',
368                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322)',
369                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)',
370                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Q312466)',
371                'Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)',
372                'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85.8.5 (KHTML, like Gecko) Safari/85.8.1',
373                'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.4) Gecko/20060508 Firefox/1.5.0.4',
374                'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox',
375                'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.8) Gecko/20061025 Firefox/1.5.0.8',
376                'Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1) Gecko/20061010 Firefox/2.0',
377                'Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)',
378                'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412',
379                'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-us) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
380                'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; fr) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
381                'Opera/9.00 (Windows NT 5.1; U; en)');
382
383        $ua = undef;
384        $ua = LWP::UserAgent->new('timeout' => 30, 'agent' => $agent_list[(int(rand($#agent_list+1)))] );
385        $ua->env_proxy;
386        $ua->cookie_jar({});
387        $prev_url = undef; # reset referer
388}
389
390##############################################################################
391# 1.
392# browse to http://tvguide.ninemsn.com.au/ via
393# http://tvguide.ninemsn.com.au/setlocation.asp?region=<reg>&returnURL=http://tvguide.ninemsn.com.au/
394# and soak up the "day" URLs
395
396sub get_initial_page
397{
398        my $returl = "http://tvguide.ninemsn.com.au/";
399        my $url = "http://tvguide.ninemsn.com.au/setlocation.asp?region=".$opt->{region}."&returnURL=$returl";
400
401        &log("setting location via $url");
402        my $data = &get_url($url, 5, $returl);
403
404        if (!$data) {
405                &log("CRITIAL ERROR: ABORTING: could not read initial page '$url'");
406                exit(1);
407        }
408
409        # parse initial page
410        my $tree = HTML::TreeBuilder->new_from_content($data);
411        if (!$tree) {
412                &log("CRITICAL ERROR: ABORTING: could not build tree from data in '$url'");
413                exit(1);
414        }
415
416        # find <select name=day..> tag
417        my $select_day_tag = $tree->look_down('_tag' => 'select', 'name' => 'day');
418        if (!$select_day_tag) {
419                &log("CRITICAL ERROR: ABORTING: could not find a day tag in '$url'");
420                exit(1);
421        }
422
423        # take note of options
424        my $found_options = 0;
425
426        foreach my $opt_tag ($select_day_tag->look_down('_tag' => 'option')) {
427                push (@{($d->{day_values})},$opt_tag->attr('value'));
428                $found_options++;
429
430                printf "DEBUG: day %d tag is '%s'\n",$found_options,$opt_tag->attr('value')
431                  if (defined $opt->{debug});
432        }
433
434        if ($found_options == 0) {
435                &log("CRITICAL ERROR: ABORTING: could not find any day tag options in '$url'");
436                exit(1);
437        }
438}
439
440##############################################################################
441# get daily pages
442
443sub get_daily_pages
444{
445        my $starttime = time;
446        my $day_num = 0;
447        my $skip_days = 0;
448
449        $skip_days = $opt->{offset} if (defined $opt->{offset});
450
451        foreach my $day_opt (@{($d->{day_values})}) {
452                my $currtime = $starttime + (60*60*24 * $day_num);
453                $day_num++;
454
455                return if ($day_num > $opt->{days});
456
457                # skip if --offset applies against this day
458                if ($skip_days > 0) {
459                        $skip_days--;
460                        next;
461                }
462
463                my @timeattr = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
464                $timeattr[0] = 0; # zero sec
465                $timeattr[1] = 0; # zero min
466                $timeattr[2] = 0; # zero hour
467                my $day_start = mktime(@timeattr); # midnight on the day
468
469                &parse_daily_page($day_opt,$day_start,$day_num);
470        }
471}
472
473##############################################################################
474# parse a daily page
475
476sub parse_daily_page
477{
478        my ($day_opt,$day_start,$day_num) = @_;
479
480        my $url = "http://tvguide.ninemsn.com.au/todaytv/default.asp";
481        my $postvars = "channel=free&day=".urlify($day_opt)."&go=go";
482
483        my $progs_in_day = 0;
484
485        my $tries = 0;
486        my $tree;
487        while ((!$tree) && ($tries < 5)) {
488                $tries++;
489                &log("fetching day $day_num summary page (try $tries): POST $url $postvars");
490
491                # my $data = &get_url($url, 1, undef, "POST", $postvars);
492                my $data = &get_url($url."?".$postvars, 1, undef);
493                $tree = HTML::TreeBuilder->new_from_content($data) if ($data);
494        }
495
496        if (!$tree) {
497                &log("WARNING: skipping day $day_num: could not fetch '$url' afer 5 attempts: format/URL changed?");
498                return 0;
499        }
500
501        my $table_tag = $tree->look_down('_tag' => 'table', 'class' => 'tv');
502        if (!$table_tag) {
503                &log("WARNING: skipping day $day_num: could not find tv table in '$url': has the format changed?");
504                return 0;
505        }
506
507        my $row_num = 0;
508        my @row_span;   # used to track rowspan= counts
509        my @chan_col;
510        my $max_cols;
511
512        foreach my $tree_tr ($table_tag->look_down('_tag' => 'tr')) {
513                if ($row_num == 0) {
514                        #
515                        # parse channels
516                        #
517
518                        my $col_num = 0;
519                        foreach my $tree_td ($tree_tr->look_down('_tag' => 'td')) {
520                                my $ch = $tree_td->as_text();
521       
522                                #
523                                # map channel name to our xmltvids
524                                #
525       
526                                $chan_col[$col_num] = $channels->{'Nine'} if ($ch =~ /nine/i);
527                                $chan_col[$col_num] = $channels->{'Seven'} if ($ch =~ /seven/i);
528                                $chan_col[$col_num] = $channels->{'TEN'} if ($ch =~ /ten/i);
529                                $chan_col[$col_num] = $channels->{'SBS News'} if ($ch =~ /SBS NEWS/i);
530                                $chan_col[$col_num] = $channels->{'ABC2'} if ($ch =~ /abc2/i);
531       
532                                # we pick these up seperately so as to not confuse ABC/ABC2 / SBS/SBS News
533                                if (!defined $chan_col[$col_num]) {
534                                        $chan_col[$col_num] = $channels->{'ABC'} if ($ch =~ /abc/i);
535                                        $chan_col[$col_num] = $channels->{'SBS'} if ($ch =~ /sbs/i);
536                                }
537       
538                                printf "DEBUG: chan_map col %d '%s' -> %s\n", $col_num, $ch,
539                                  (defined $chan_col[$col_num] ? $chan_col[$col_num] : "(undef)")
540                                  if (defined $opt->{debug});
541
542                                if ((!defined $chan_col[$col_num]) && (!defined $d->{unknown_chan}->{$ch})) {   
543                                        &log("Ignoring programmes from unknown channel '$ch'");
544                                        $d->{unknown_chan}->{$ch} = 1; # so we report this only once
545                                }
546
547                                $row_span[$col_num] = 1; # set initial row_span to 1
548                                $col_num++;
549                        }
550                        $max_cols = $col_num;
551                        printf "DEBUG: set max_cols to $max_cols\n" if (defined $opt->{debug});
552                } else {
553                        #
554                        # parse programmes
555                        #
556
557                        my $col_num = -1;
558                        foreach my $tree_td ($tree_tr->look_down('_tag' => 'td', 'class' => 'tv')) {
559                                $col_num++; # increment at beginning - just easier
560
561                                my $prog;
562                                my $prog_name = $tree_td->as_text();
563
564                                # calculate programme starttime, either based on row number
565                                # (each row = 5 mins) or an explicit start time in the prog_name
566                                if ($prog_name =~ s/\s*\[\s* (\d+):(\d+) \s* (am|pm) \s*\]\s* //x) {
567                                        my ($hr, $min, $ampm) = ($1, $2, lc($3));
568                                        $hr = 0 if ($hr == 12);
569                                        $hr += 12 if ($ampm eq "pm");
570                                        $hr += 24 if (($ampm eq "am") && ($hr < 6));
571
572                                        $prog->{starttime} = $day_start + ((60*60)*$hr) + (60*$min);
573
574                                        printf "DEBUG: starttime of prog '%s' explicitly set to %s\n",
575                                          $prog_name, (strftime "%Y%m%d%H%M", localtime($prog->{starttime}))
576                                          if (defined $opt->{debug});
577                                } else {
578                                        $prog->{starttime} = $day_start + ((60*60)*6) + ((5*60)*($row_num-1));
579
580                                        printf "DEBUG: starttime of prog '%s' calculated to be %s based on row %d\n",
581                                          $prog_name, (strftime "%Y%m%d%H%M", localtime($prog->{starttime})),
582                                          $row_num, if (defined $opt->{debug});
583                                }
584
585                                # got a cell.  work out what column it applies to,
586                                # taking into account any rowspans that are going on
587                                while (($col_num < $max_cols) && ($row_span[$col_num] > 1)) {
588                                        printf "DEBUG: row %d column %d skipped due to rowspan (%d)\n",
589                                          $row_num, $col_num, $row_span[$col_num] if (defined $opt->{debug});
590
591                                        $row_span[$col_num]--; # decrease span
592                                        $col_num++; # jump to next column
593                                }
594
595                                if ($col_num == $max_cols) {
596                                        # no longer in a valid column!
597                                        &log("WARNING: Bad HTML (excess columns) in row $row_num of '$url': celltext: '$prog_name'. Format changed?");
598                                        next;
599                                }
600
601                                # set (future) rowspan
602                                if ($tree_td->attr('rowspan')) {
603                                        my $found_span = $tree_td->attr('rowspan');
604
605                                        if ($found_span =~ /^(\d+)$/) {
606                                                $row_span[$col_num] = $found_span;
607                                        } else {
608                                                # a BOGUS span - invalid HTML - who would have thought?!???
609                                                printf "DEBUG: ignored a non-numeric rowspan in row %d column %d: '%s': skipped\n",
610                                                  $row_num, $col_num, $found_span if (defined $opt->{debug});
611                                                next;
612                                        }
613                                }
614
615                                # programme length is based on number of rows spanned
616                                $prog->{stoptime} = $prog->{starttime} + ((5*60)*$row_span[$col_num]);
617
618                                my $prog_a = $tree_td->look_down('_tag' => 'a');
619                                $prog->{url} = $prog_a->attr('href') if ($prog_a);
620                                       
621                                if (!defined $prog->{url}) {
622                                        # no url - not a programme?
623                                        &log("WARNING: Bad HTML (no link) in row $row_num column $col_num of '$url': '$prog_name' has no URL. Format changed?");
624                                        next;
625                                }
626
627                                if (!defined $chan_col[$col_num]) {
628                                        # no channel for this programme!
629                                        printf "DEBUG: Programme in row $row_num column $col_num had no known channel! ($prog_name)\n"
630                                          if (defined $opt->{debug});
631                                        $stats{skipped_prog_no_channel}++;
632                                        next;
633                                }
634                                $prog->{channel} = $chan_col[$col_num];
635                                $prog->{title} = [[ $prog_name, $opt->{lang} ]];
636
637                                #
638                                # got programme, store it for grabbing detailed info in next step
639                                #
640
641                                $progs_in_day++;
642                                $stats{programmes}++;
643
644                                push(@{($d->{progs})},$prog);
645                        }
646
647                        # update any remaining rowspan counters
648                        $col_num++;
649                        while (($col_num < $max_cols) && ($row_span[$col_num] > 1)) {
650                                printf "DEBUG: blank row %d: decreasing column %d rowspan (%d)\n",
651                                  $row_num, $col_num, $row_span[$col_num] if (defined $opt->{debug});
652
653                                $row_span[$col_num]--; # decrease span
654                                $col_num++; # jump to next column
655                        }
656                }
657
658                $row_num++;
659        }
660
661        &log("WARNING: $progs_in_day programmes seen for day $day_num.  URL/formatting changed? (url $url)")
662          if ($progs_in_day < 50);
663}
664
665##############################################################################
666# loop through our progs, fetching details where we don't have a pre-cached
667# entry for them.
668# write out XMLTV
669
670sub get_detailed_pages
671{
672        my $prog_count = 0;
673        my $added_to_cache = 0;
674
675        foreach my $prog (@{($d->{progs})}) {
676                $prog_count++;
677                my $cache_key = sprintf "%d:%s:%s", $prog->{starttime}, $prog->{channel}, $prog->{title}->[0]->[0];
678
679                if ((!defined $data_cache->{$cache_key}) && (!defined $opt->{no_details}) &&
680                    ($prog->{title}->[0]->[0] ne "Station Close")) {
681                        printf "DEBUG: Fetching detail page: %s: %s\n",
682                          $prog->{channel}, $prog->{url} if (defined $opt->{debug});
683
684                        # not in cache, go fetch additional details if we can
685                        &fetch_one_prog($cache_key, $prog->{url}, $prog_count, $stats{programmes});
686                        $stats{added_to_cache}++;
687                        &write_cache if ((($stats{added_to_cache} % 5) == 0) && (!defined $opt->{no_cache}));
688                } else {
689                        $stats{used_existing_cache_entry}++;
690                }
691
692                # if we got additional details, add them now
693                if (defined $data_cache->{$cache_key}) {
694                        foreach my $key (keys %{($data_cache->{$cache_key})}) {
695                                $prog->{$key} = $data_cache->{$cache_key}->{$key};
696                        }
697                }
698
699                # if we now have a length field, use that as a more accurate
700                # stop time (we may have got a length field in the detailed data)
701                $prog->{stop} = $prog->{start} + (60*$prog->{length})
702                  if (defined $prog->{length});
703
704                # convert epoch starttime into XMLTV starttime
705                $prog->{start} = strftime "%Y%m%d%H%M", localtime($prog->{starttime});
706                delete $prog->{starttime};
707
708                # convert epoch stoptime into XMLTV stoptime
709                $prog->{stop} = strftime "%Y%m%d%H%M", localtime($prog->{stoptime});
710                delete $prog->{stoptime};
711
712                delete $prog->{url};
713                &cleanup($prog);
714
715                printf "DEBUG: programme xmltv: ".Dumper($prog) if (defined $opt->{debug});
716                $writer->write_programme($prog);
717        }
718}
719
720##############################################################################
721# fetch detailed info on one prog
722
723sub fetch_one_prog
724{
725        my ($cache_key,$url,$prog_count,$total_prog_count) = @_;
726
727        $url = "http://tvguide.ninemsn.com.au".$url if ($url !~ /^http/);
728        $url =~ s/\/closeup\//\/cu\//;
729
730        my $tries = 0;
731        my $data;
732        my $parsed_text = "";
733        while ((!$data) && ($tries < 12)) {
734                $tries++;
735                &log("fetching programme detail page ($prog_count of $total_prog_count) [try $tries]");
736                $data = &get_url($url, 1);
737
738                if ($data) {
739                        $data =~ s{<script language="?Javascript"?[^>]*>(.*?)</script>}{
740                                my $x = $1;
741                                $jsc->eval(qq{ doc = '' });
742                                $jsc->eval($x);
743                                $parsed_text .= $jsc->eval(qq{ doc }) || '';
744                                }isge;
745
746                        if ($data =~ /we are unable/i) {
747                                &log("sleeping for 600 seconds");
748                                sleep 600;
749                                $stats{slept_for} += 600;
750
751                                $data = undef;
752                        }
753                }
754        }
755
756        if (!$data) {
757                &log("WARNING: skipping programme, could not fetch '$url' afer 12 attempts: format/URL changed?");
758                return;
759        }
760
761        if ($parsed_text eq "") {
762                &log("WARNING: skipping programme, could not find javascript to execute in '$url': format changed?");
763                return;
764        }
765
766        # split HTML up into sections seperated by <BR><BR>
767        my @html_lines = split(/<BR><BR>/,$parsed_text);
768        &cleanup(@html_lines);
769
770        # line 1 contains progname, duration and genre
771        $html_lines[0] =~ s/<.*?>//g;   # note: can fail on complex tags
772        if ($html_lines[0] =~ /\((\d+) mins/) {
773                $data_cache->{$cache_key}->{length} = $1;
774                printf "DEBUG: set 'length' to '%d'\n",$1 if (defined $opt->{debug});
775        }
776        if ($html_lines[0] =~ /Rated: ([^\)]+)\)/) {
777                my @ratings;
778                push(@ratings, [$1, 'ABA', undef]);
779                $data_cache->{$cache_key}->{rating} = [ @ratings ];
780                printf "DEBUG: set 'rating' to '%s'\n",$1 if (defined $opt->{debug});
781        }
782        if ($html_lines[0] =~ /Genre: (.*)$/) {
783                my $cat = translate_category($1);
784                my @categories;
785                push(@categories,$cat,$opt->{lang});
786                $data_cache->{$cache_key}->{category} = [[ @categories ]];
787                printf "DEBUG: set 'category' to '%s'\n",$cat if (defined $opt->{debug});
788        }
789
790        # line 2 contains description
791        if ($html_lines[1] ne "") {
792                $data_cache->{$cache_key}->{desc} = [[ $html_lines[1], $opt->{lang} ]];
793                printf "DEBUG: set desc to '%s'\n",$html_lines[1] if (defined $opt->{debug});
794        }
795}
796
797##############################################################################
798
799sub setup_javascript
800{
801        $jsc = new JavaScript::Runtime->create_context();
802        $jsc->set_error_handler( sub { } );
803 
804        $jsc->eval(qq{
805                var doc = '';
806                function Location() { this.href  = 'http://ninemsn.com.au'; }
807                function Document() { this.write = function(x) { doc += x; } }
808                function Window()   { this.___ww = 0 }
809
810                location = new Location;
811                document = new Document;
812                window   = new Window;
813                });
814}
815
816##############################################################################
817
818sub translate_category
819{
820        my $genre = shift;
821        my %translation = (
822                'Sport' => 'sports',
823                'Soap Opera' => 'Soap',
824                'Science and Technology' => 'Science/Nature',
825                'Real Life' => 'Reality',
826                'Cartoon' => 'Animation',
827                'Family' => 'Children',
828                'Murder' => 'Crime' );
829
830        return $translation{$genre} if defined $translation{$genre};
831        return $genre;
832}
833
834
835##############################################################################
836##############################################################################
Note: See TracBrowser for help on using the browser.