root/grabbers/yahoo7web @ 450

Revision 450, 26.0 kB (checked in by lincoln, 6 years ago)

yahoo7web supports regional areas again
  • Property svn:executable set to *
Line 
1#!/usr/bin/perl -w
2
3# yahoo7portal au_tv guide grabber - runs from "Shepherd" master grabber
4#  * grabs data from the yahoo7portal (http://au.tv.yahoo.com/)
5#  * this does NOT use any config file - all settings are passed in from shepherd
6
7use strict;
8
9my $progname = "yahoo7web";
10my $version = "0.07";
11
12use LWP::UserAgent;
13use XMLTV;
14use POSIX qw(strftime mktime);
15use Getopt::Long;
16use HTML::TreeBuilder;
17use Data::Dumper;
18use Compress::Zlib;
19use Storable;
20
21#
22# global variables and settings
23#
24
25$| = 1;
26my $script_start_time = time;
27my %stats;
28my $channels, my $opt_channels;
29my $data_cache;
30my $writer;
31my $ua;
32my $prev_url;
33my $d;
34my $opt;
35
36#
37# parse command line
38#
39
40$opt->{days} =          7;                      # default
41$opt->{outputfile} =    "output.xmltv";         # default
42$opt->{cache_file} =    $progname.".storable.cache";    # default
43$opt->{lang} =          "en";
44$opt->{region} =        94;
45
46GetOptions(
47        'log-http'      => \$opt->{log_http},
48        'region=i'      => \$opt->{region},
49        'days=i'        => \$opt->{days},
50        'offset=i'      => \$opt->{offset},
51        'timezone=s'    => \$opt->{timezone},
52        'channels_file=s' => \$opt->{channels_file},
53        'output=s'      => \$opt->{outputfile},
54        'cache-file=s'  => \$opt->{cache_file},
55        'fast'          => \$opt->{fast},
56        'no-cache'      => \$opt->{no_cache},
57        'no-details'    => \$opt->{no_details},
58        'debug+'        => \$opt->{debug},
59        'warper'        => \$opt->{warper},
60        'lang=s'        => \$opt->{lang},
61        'obfuscate'     => \$opt->{obfuscate},
62        'anonsocks=s'   => \$opt->{anon_socks},
63        'help'          => \$opt->{help},
64        'verbose'       => \$opt->{help},
65        'version'       => \$opt->{version},
66        'ready'         => \$opt->{version},
67        'v'             => \$opt->{help});
68
69&help if ($opt->{help});
70
71if ($opt->{version}) {
72        printf "%s %s\n",$progname,$version;
73        exit(0);
74}
75
76die "no channel file specified, see --help for instructions\n", if (!$opt->{channels_file});
77$opt->{days} = 7 if ($opt->{days} > 7); # limit to a max of 7 days
78
79#
80# go go go!
81#
82
83&log(sprintf "going to grab %d days%s of data into %s (%s%s%s%s%s)",
84        $opt->{days},
85        (defined $opt->{offset} ? " (skipping first $opt->{offset} days)" : ""),
86        $opt->{outputfile},
87        (defined $opt->{fast} ? "with haste" : "slowly"),
88        (defined $opt->{anon_socks} ? ", via multiple endpoints" : ""),
89        (defined $opt->{warper} ? ", anonymously" : ""),
90        (defined $opt->{no_details} ? ", without details" : ", with details"),
91        (defined $opt->{no_cache} ? ", without caching" : ", with caching"));
92
93# read channels file
94if (-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&read_cache unless (defined $opt->{no_cache});
102
103&set_ua;
104&setup_socks if (defined $opt->{anon_socks});
105
106&build_venue_map;
107&start_writing_xmltv;
108
109&get_summary_pages;
110&get_detailed_pages;
111
112&write_cache unless (defined $opt->{no_cache});
113$writer->end();
114
115&print_stats;
116exit(0);
117
118##############################################################################
119# help
120
121sub help
122{
123        print<<EOF
124$progname $version
125
126options are as follows:
127        --help                  show these help options
128        --days=N                fetch 'n' days of data (default: $opt->{days})
129        --output=file           send xml output to file (default: "$opt->{outputfile}")
130        --no-cache              don't use a cache to optimize (reduce) number of web queries
131        --no-details            don't fetch detailed descriptions (default: do)
132        --cache-file=file       where to store cache (default "$opt->{cache_file}")
133        --fast                  don't run slow - get data as quick as you can - not recommended
134        --anonsocks=(ip:port)   use SOCKS4A server at (ip):(port) (for Tor: recommended)
135
136        --debug                 increase debug level
137        --warper                fetch data using WebWarper web anonymizer service
138        --obfuscate             pretend to be a proxy servicing multiple clients
139        --lang=[s]              set language of xmltv output data (default $opt->{lang})
140
141        --region=N              set region for where to collect data from (default: $opt->{region})
142        --channels_file=file    where to get channel data from
143EOF
144;
145
146        exit(0);
147}
148
149##############################################################################
150# populate cache
151
152sub read_cache
153{
154        # convert old-style Data::Dumper cache to new format
155        if (-r "yahoo7web.cache") {
156                local (@ARGV, $/) = ("yahoo7web.cache");
157                no warnings 'all'; eval <>; die "$@" if $@;
158
159                &write_cache;
160                unlink "yahoo7web.cache";
161        }
162
163        if (-r $opt->{cache_file}) {
164                my $store = Storable::retrieve($opt->{cache_file});
165                $data_cache = $store->{data_cache};
166        } else {
167                printf "WARNING: no programme cache $opt->{cache_file} - have to fetch all details\n";
168
169                # try to write to it - if directory doesn't exist this will then cause an error
170                &write_cache;
171        }
172}
173
174##############################################################################
175# write out updated cache
176
177sub write_cache
178{
179        # cleanup old entries from cache
180        for my $cache_key (keys %{$data_cache}) {
181                my ($starttime, @rest) = split(/:/,$cache_key);
182                if ($starttime < (time-86400)) {
183                        delete $data_cache->{$cache_key};
184                        $stats{expired_from_cache}++;
185                }
186        }
187
188        my $store;
189        $store->{data_cache} = $data_cache;
190
191        Storable::store($store, $opt->{cache_file});
192}
193
194##############################################################################
195# logic to fetch a page via http
196#  retries up to $retrycount times to get a page with 10 second pauses inbetween
197
198sub get_url
199{
200        my ($url,$retrycount,$referer,$reqtype,$postvars) = @_;
201        my $request;
202        my $response;
203        my $attempts = 0;
204        my ($raw, $page, $base);
205
206        $reqtype = "GET" if (!defined $reqtype);
207
208        $retrycount = 5 if ($retrycount == 0);
209        $url =~ s#^http://#http://webwarper.net/ww/# if (defined $opt->{warper});
210
211        if ($reqtype eq "GET") {
212                $request = HTTP::Request->new(GET => $url);
213        } elsif ($reqtype eq "POST") {
214                $request = HTTP::Request->new(POST => $url);
215                $request->add_content($postvars);
216        }
217
218        if (defined $referer) {
219                $request->header('Referer' => $referer);
220                printf "DEBUG: explicitly set Referer to '%s'\n", $referer if (defined $opt->{debug});
221        } else {
222                if (defined $prev_url) {
223                        $request->header('Referer' => $prev_url);
224                        printf "DEBUG: set Referer to '%s'\n", $prev_url if (defined $opt->{debug});
225                }
226        }
227        $prev_url = $url;
228
229        $request->header('Accept-Encoding' => 'gzip');
230
231        if ($opt->{obfuscate}) {
232                my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1);
233                $request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)');
234                $request->header('X-Forwarded-For' => $randomaddr);
235        }
236
237        my $status;
238        for (1..$retrycount) {
239                $response = $ua->request($request);
240
241                if ((defined $opt->{log_http}) && (open(F,">>http_log.txt"))) {
242                        printf F "\n----------------------------------------------------\n";
243                        printf F "request: %s %s %s\n",$reqtype,$url,(defined $postvars ? $postvars : "");
244                        printf F "referer: %s\n",$request->header('Referer');
245                        printf F "response: %s\n",$response->status_line;
246                        print F $response->content;
247                        close F;
248                }
249
250                if ($response->is_success) {
251                        if ($response->content =~ /we are unable to process your request/) {
252                                $status = "fail: 999: Service unavailable"; # CPAN's LWP lied to us
253                        } else {
254                                $status = "good";
255                                last;
256                        }
257                } else {
258                        $status = "fail: ".$response->status_line;
259                }
260
261                $stats{http_failed_requests}++;
262                $attempts++;
263
264                my $sleep_for = 600;
265                $sleep_for = 10 if (defined $opt->{anon_socks});
266
267                &log("attempt $attempts of $retrycount failed to fetch $url, sleeping for $sleep_for secs: $status");
268
269                $stats{slept_for} += $sleep_for;
270                sleep $sleep_for;
271        }
272        if ($status !~ /^good/) {
273                &log("aborting after $attempts attempts to fetch url $url");
274                return undef;
275        }
276
277        $prev_url = $response->base;
278        $prev_url =~ s#^http://webwarper.net/ww/#http://# if (defined $opt->{warper});
279
280        $stats{bytes_fetched} += do {use bytes; length($response->content)};
281        $stats{http_successful_requests}++;
282
283        if ((!$opt->{fast}) || (!defined $opt->{anon_socks})) {
284                my $sleeptimer = int(rand(6)) + 17;  # sleep anywhere from 17 to 23 seconds
285                $stats{slept_for} += $sleeptimer;
286                sleep $sleeptimer;
287        }
288
289        if ($response->header('Content-Encoding') &&
290            $response->header('Content-Encoding') eq 'gzip') {
291                $stats{compressed_pages} += do {use bytes; length($response->content)};
292                $response->content(Compress::Zlib::memGunzip($response->content));
293        }
294        return $response->content;
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 "STATS: %s v%s completed in %d seconds",$progname, $version, 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
392sub translate_category
393{
394        my $genre = shift;
395        my %translation = (
396                'Sport' => 'sports',
397                'Soap Opera' => 'Soap',
398                'Science and Technology' => 'Science/Nature',
399                'Real Life' => 'Reality',
400                'Cartoon' => 'Animation',
401                'Family' => 'Children',
402                'Murder' => 'Crime' );
403
404        return $translation{$genre} if defined $translation{$genre};
405        return $genre;
406}
407
408##############################################################################
409
410sub build_venue_map
411{
412        &log("fetching initial channel-to-venue map");
413
414        # set up channel name exceptions list
415        my %chan_map;
416        if ($opt->{region} == 71) {
417                # NSW: Southern NSW
418                push (@{($chan_map{"Prime"})},
419                        "Prime (Canberra/Wollongong/South Coast)",
420                        "Prime (Wagga Wagga/Orange)");
421                push (@{($chan_map{"TEN"})},
422                        "TEN (NSW: Southern NSW)",
423                        "TEN (Mildura Digital)");
424        } elsif ($opt->{region} == 79) {
425                # QLD: Regional
426                push (@{($chan_map{"Seven"})},
427                        "Seven (Cairns/Townsville/Mackay/Wide Bay/Sunshine Coast)",
428                        "Seven (Rockhampton/Toowoomba)");
429                push (@{($chan_map{"WIN"})},
430                        "WIN (QLD: Regional)",
431                        "WIN (Mackay/Wide Bay)");
432        } elsif ($opt->{region} == 90) {
433                # VIC: Eastern Victoria
434                push (@{($chan_map{"Prime"})},
435                        "Prime (Regional)",
436                        "Prime (Albury)");
437        }
438
439
440        my $url = sprintf "http://au.tv.yahoo.com/results.html?vn=&rg=%d&dt=%s&ts=12&x=19&y=14",
441          $opt->{region}, (strftime "%Y-%m-%d",localtime(time));
442
443        my $data = &get_url($url,5);
444        if (!$data) {
445                &log("CRITICAL ERROR: Could not build venue map because of error fetching '$url'");
446                exit(1);
447        }
448
449        my $tree = HTML::TreeBuilder->new_from_content($data);
450        if (!$tree) {
451                &log("CRITICAL ERROR: url '$url' doesn't seem to contain any valid HTML: has the format changed?");
452                exit(1);
453        }
454
455        foreach my $venuelink ($tree->look_down('_tag' => 'a')) {
456                my $venueurl = $venuelink->attr('href');
457                if (($venueurl) && ($venueurl =~ /^venueresults.html.*vn=(\d+)$/)) {
458                        my $venue_id = $1;
459                        my $channame = $venuelink->as_text();
460
461                        if (($channame) && ($channame ne "")) {
462                                # see if we have an alternate name for this channel
463                                if (defined $chan_map{$channame}) {
464                                        my $new_channame = splice(@{($chan_map{$channame})},0,1);
465                                        printf "DEBUG: mapped channel '%s' to new channel name '%s'\n",
466                                          $channame, $new_channame if (defined $opt->{debug});
467                                        $channame = $new_channame;
468                                }
469
470                                if (defined $channels->{$channame}) {
471                                        $d->{venuemap}->{$channame} = $venue_id;
472
473                                        printf "DEBUG: mapped channel '%s' to venue '%s'\n",
474                                          $channame, $venue_id if (defined $opt->{debug});
475                                } else {
476                                        printf "DEBUG: ignored unknown channel '%s'\n", $channame if (defined $opt->{debug});
477                                }
478                        }
479                }
480        }
481}
482
483##############################################################################
484
485sub get_summary_pages
486{
487        my $starttime = time;
488        my $day_num = 0;
489        my $skip_days = 0;
490
491        $skip_days = $opt->{offset} if (defined $opt->{offset});
492        while ($day_num < $opt->{days}) {
493                my $currtime = $starttime + (60*60*24 * $day_num);
494                $day_num++;
495
496                # skip if --offset applies against this day
497                if ($skip_days > 0) {
498                        $skip_days--;
499                        next;
500                }
501
502                my @timeattr = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
503                $timeattr[0] = 0; # zero sec
504                $timeattr[1] = 0; # zero min
505                $timeattr[2] = 0; # zero hour
506                my $day_start = mktime(@timeattr); # midnight on the day
507
508                foreach my $ch (keys %$channels) {
509                        if ((!defined $d->{venuemap}->{$ch}) && (!defined $d->{skipmap}->{$ch})) {
510                                &log("channel '$ch' skipped due to no channel-to-vanue mapping data");
511                                $d->{skipmap}->{$ch} = 1;       # report this only once
512                                next;
513                        }
514
515                        &log("fetching day $day_num summary page for '$ch'");
516                        &parse_summary_page($day_start, $d->{venuemap}->{$ch}, $channels->{$ch}, $day_num);
517                }
518        }
519}
520
521##############################################################################
522
523sub parse_summary_page
524{
525        my ($day_start, $venueid, $xmlid, $day_num) = @_;
526
527        my $url = sprintf "http://au.tv.yahoo.com/venueresults.html?dt=%s&vn=%d",
528                (strftime "%Y-%m-%d",localtime($day_start)), $venueid;
529        my $data = &get_url($url,5);
530        return if (!$data);
531
532        my $tree = HTML::TreeBuilder->new_from_content($data);
533        if (!$tree) {
534                &log("url '$url' doesn't seem to contain any valid HTML: has the format changed?");
535                return;
536        }
537
538        my $tree_table = $tree->look_down('_tag' => 'table', 'width' => '100%', 'border' => '1', 'bordercolor' => '#efefef');
539        if (!$tree_table) {
540                &log("url '$url' doesn't seem to contain a TV table.  Has the format changed?");
541                return;
542        }
543
544        $stats{programmes} = 0 if (!defined $stats{programmes});
545        my $progs_in_day = 0;
546        my $rownum = 0;
547        my $seen_am = 0;
548        my $seen_pm = 0;
549
550        for my $tree_tr ($tree_table->look_down('_tag' => 'tr')) {
551                $rownum++;
552                next if ($rownum == 1); # skip header
553
554                my @tree_col = $tree_tr->look_down('_tag' => 'td');
555
556                if ($#tree_col != 1) {
557                        &log("WARNING: unexpected number of columns in table from '$url' in table row $rownum; ignoring: URL format changed?");
558                        next;
559                }
560
561                my $prog;
562                $prog->{channel} = $xmlid;
563
564                # first column contains time
565                if ($tree_col[0]->as_text() =~ /^(\d+):(\d+)(.)M$/) {
566                        my $hr = $1;
567                        my $min = $2;
568                        my $ampm = lc($3);
569
570                        $hr = 0 if ($hr == 12);         # convert to 24hr format
571                        $hr += 12 if ($ampm eq "p");
572
573                        $hr -= 24 if (($seen_am == 0) && ($ampm eq "p")); # yesterday
574                        $hr += 24 if (($seen_pm == 1) && ($ampm eq "a")); # tomorrow
575
576                        $prog->{starttime} = $day_start + ((60*60)*$hr) + (60*$min);
577                        printf "DEBUG: Parsed time '%s' on day %d to be %s\n",
578                          $tree_col[0]->as_text(), $day_num, (strftime "%Y%m%d%H%M",
579                          localtime($prog->{starttime})) if (defined $opt->{debug});
580
581                        $seen_am = 1 if ($ampm eq "a");
582                        $seen_pm = 1 if (($ampm eq "p") && ($seen_am));
583                } else {
584                        &log((sprintf "Couldn't parse malformed time '%s' in row $rownum of '%s': ignored.",
585                          $tree_col[0]->as_text(), $url));
586                        $stats{malformed_time}++;
587                        next;
588                }
589
590                # second column contains programme title + rating
591                if (my $detail_link = $tree_col[1]->look_down('_tag' => 'a')) {
592                        $prog->{title} = [[ $detail_link->as_text(), $opt->{lang} ]];
593
594                        my $progurl = $detail_link->attr('href');
595                        $progurl =~ s#^javascript:popup\(\"(.*)\"\)#http://au.tv.yahoo.com/$1#g;
596
597                        if (defined $d->{already_seen_details}->{$progurl}) {
598                                printf "DEBUG: skipping prog '%s' as we have seen its URL before '%s'\n",
599                                  $prog->{title}->[0]->[0], $progurl if (defined $opt->{debug});
600                                $stats{duplicate_programme}++;
601                                next;
602                        }
603
604                        $d->{already_seen_details}->{$progurl} = 1;
605                        $prog->{url} = $progurl;
606                } else {
607                        &log((sprintf "couldn't find a programme name/url for programme at %s in row %d of '%s': ignored.",
608                          (strftime "%Y%m%d%H%M",localtime($prog->{starttime})), $rownum, $url));
609                        $stats{prog_with_no_name}++;
610                        next;
611                }
612
613                # see if we can derive an ABA rating
614                if ($tree_col[1]->as_text() =~ / - ([A-Z]+)$/) {
615                        my @ratings;
616                        push(@ratings, [$1, 'ABA', undef]);
617                        $prog->{rating} = [ @ratings ];
618
619                        printf "DEBUG: prog '%s' has a rating of '%s'\n",
620                          $prog->{title}->[0]->[0], $1 if (defined $opt->{debug});
621                }
622
623                push(@{($d->{progs})},$prog);
624
625                printf "DEBUG: added prog %d from row %d: %s '%s' on channel '%s'\n", $stats{programmes},
626                  $rownum, (strftime "%Y%m%d%H%M",localtime($prog->{starttime})), $prog->{title}->[0]->[0], 
627                  $prog->{channel} if (defined $opt->{debug});
628
629                # if we can fill in a stoptime for previous program on this channel on this day, do so!
630                if ($progs_in_day > 0) {
631                        $d->{progs}->[($stats{programmes})]->{stoptime} = $prog->{starttime};
632
633                        printf "DEBUG: added stoptime of '%s' to previous programme %d\n",
634                          (strftime "%Y%m%d%H%M",localtime($prog->{starttime})), ($stats{programmes}-1)
635                          if (defined $opt->{debug});
636                }
637
638                $stats{programmes}++;
639                $progs_in_day++;
640        }
641
642        &log("WARNING: $progs_in_day programmes seen on day $day_num for channel '$xmlid' in '$url'. ".
643          "Data may be bad.") if ($progs_in_day < 10);
644}
645
646##############################################################################
647# loop through our progs, fetching details where we don't have a pre-cached
648# entry for them.
649# write out XMLTV
650
651sub get_detailed_pages
652{
653        my $prog_count = 0;
654        my $added_to_cache = 0;
655
656        foreach my $prog (@{($d->{progs})}) {
657                $prog_count++;
658                my $cache_key = sprintf "%d:%s:%s", $prog->{starttime}, $prog->{channel}, $prog->{title}->[0]->[0];
659
660                if ((!defined $data_cache->{$cache_key}) && (!defined $opt->{no_details}) &&
661                    ($prog->{title}->[0]->[0] ne "Station Close")) {
662                        printf "DEBUG: Fetching detail page: %s: %s\n",
663                          $prog->{channel}, $prog->{url} if (defined $opt->{debug});
664
665                        # not in cache, go fetch additional details if we can
666                        &log("fetching programme detail page ($prog_count of $stats{programmes})");
667                        &fetch_one_prog($cache_key, $prog->{url});
668
669                        $stats{added_to_cache}++;
670                        &write_cache if ((($stats{added_to_cache} % 5) == 0) && (!defined $opt->{no_cache}));
671                } elsif (!defined $opt->{no_details}) {
672                        $stats{used_existing_cache_entry}++;
673                }
674
675                # if we got additional details from the cache, add them now
676                if (defined $data_cache->{$cache_key}) {
677                        foreach my $key (keys %{($data_cache->{$cache_key})}) {
678                                $prog->{$key} = $data_cache->{$cache_key}->{$key};
679                        }
680                }
681
682                # if we now have a length field, use that as a more accurate
683                # stop time (we may have got a length field in the detailed data)
684                $prog->{stoptime} = $prog->{starttime} + (60*$prog->{length})
685                  if (defined $prog->{length});
686
687                # if we don't have a stoptime, skip prog
688                if (!defined $prog->{stoptime}) {
689                        $stats{skipped_no_stoptime}++;
690                        next;
691                }
692
693                # convert epoch starttime into XMLTV starttime
694                $prog->{start} = strftime "%Y%m%d%H%M", localtime($prog->{starttime});
695                delete $prog->{starttime};
696
697                # convert epoch stoptime into XMLTV stoptime
698                $prog->{stop} = strftime "%Y%m%d%H%M", localtime($prog->{stoptime});
699                delete $prog->{stoptime};
700
701                delete $prog->{url};
702                &cleanup($prog);
703
704                printf "DEBUG: programme xmltv: ".Dumper($prog) if (defined $opt->{debug});
705                $writer->write_programme($prog);
706        }
707}
708
709##############################################################################
710
711sub fetch_one_prog
712{
713        my ($cache_key, $url) = @_;
714
715        my $data = &get_url($url,5);
716        return if (!$data);
717
718        my $tree = HTML::TreeBuilder->new_from_content($data);
719        return if (!$tree);
720
721        my @categories;
722        my $desc = "";
723
724        if (my $inner_tree = $tree->look_down('_tag' => 'div', 'class' => 'inner')) {
725                if ($_ = $inner_tree->look_down('_tag' => 'h1')) {
726                        $data_cache->{$cache_key}->{title} = [[ $_->as_text(), $opt->{lang} ]] if ($_->as_text() ne "");
727                }
728
729                if ($_ = $inner_tree->look_down('_tag' => 'h2')) {
730                        $data_cache->{$cache_key}->{'sub-title'} = [[ $_->as_text(), $opt->{lang} ]] if ($_->as_text() ne "");
731                }
732
733                foreach my $para ($inner_tree->look_down('_tag' => 'p')) {
734                        if ($para->as_HTML() =~ /<p>Genre:&nbsp; (.*)$/) {
735                                push(@categories,translate_category($1), $opt->{lang});
736                        } elsif ($para->as_HTML() =~ /(\d+)&nbsp;mins/) {
737                                $data_cache->{$cache_key}->{'length'} = ($1*60);
738
739                                # any other tags in here?
740                                if ($para->as_HTML() =~ /Premiere/) {
741                                        $data_cache->{$cache_key}->{premiere} = [ 'premiere', $opt->{lang} ];
742                                        push(@categories,"premiere",$opt->{lang});
743                                }
744
745                                if ($para->as_HTML() =~ /Final/) {
746                                        $data_cache->{$cache_key}->{'last-chance'} = [ 'final', $opt->{lang} ];
747                                        push(@categories,"final",$opt->{lang});
748                                }
749
750                                push(@categories,"highlight",$opt->{lang})
751                                  if ($para->as_HTML() =~ /highlight/);
752
753                                push(@categories,"live",$opt->{lang})
754                                  if ($para->as_HTML() =~ /Live/);
755
756                                $data_cache->{$cache_key}->{'previously-shown'} = { }
757                                  if ($para->as_HTML() =~ /Repeat/);
758
759                                $data_cache->{$cache_key}->{'subtitles'} = [ { 'type' => 'teletext' } ]
760                                  if ($para->as_HTML() =~ /Closed Captions/);
761                        } else {
762                                $desc .= $para->as_text();
763                        }
764                }
765
766                $data_cache->{$cache_key}->{desc} = [[ $desc, $opt->{lang} ]] if ($desc ne "");
767                $data_cache->{$cache_key}->{category} = [[ @categories ]] if @categories;
768
769                &cleanup($data_cache->{$cache_key});
770
771                printf "DEBUG: cached entries for '$cache_key': ".Dumper($data_cache->{$cache_key})
772                  if (defined $opt->{debug});
773        }
774}
775
776##############################################################################
777
778sub setup_socks
779{
780        use LWP::Protocol::http;
781        my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
782
783        # override LWP::Protocol::http's _new_socket method with our own
784        local($^W) = 0;
785        *LWP::Protocol::http::_new_socket = \&socks_new_socket;
786
787        # test that it works
788        &log("configured to use Tor, testing that it works by connecting to www.google.com ...");
789        my $data = &get_url("http://www.google.com/",10);
790        if (($data) && ($data =~ /Google/i)) {
791                &log("success.  Tor appears to be working!");
792                return;
793        }
794
795        &log("ERROR: Could not connect to www.google.com via Tor, disabling Tor.");
796        &log("       DATA FETCHING WILL BE VERY SLOW.");
797        &log("       DISABLING DETAILS-FETCHING BECAUSE OF THIS - SIGNIFICANTLY LOWER DATA QUALITY!!");
798
799        $opt->{no_details} = 1;
800        delete $opt->{anon_socks};
801        $stats{fallback_to_non_tor}++;
802
803        *LWP::Protocol::http::_new_socket = $orig_new_socket;
804}
805
806##############################################################################
807# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
808
809sub socks_new_socket
810{
811        my($self, $host, $port, $timeout) = @_;
812
813        my ($socks_ip,$socks_port) = split(/:/,$opt->{anon_socks});
814        $socks_ip = "127.0.0.1" if (!defined $socks_ip);
815        $socks_port = "9050" if (!defined $socks_port);
816
817        local($^W) = 0;  # IO::Socket::INET can be noisy
818        my $sock = $self->socket_class->new(
819                PeerAddr => $socks_ip,
820                PeerPort => $socks_port,
821                Proto    => 'tcp');
822
823        unless ($sock) {
824                # IO::Socket::INET leaves additional error messages in $@
825                $@ =~ s/^.*?: //;
826                &log("Can't connect to $host:$port ($@)");
827                return undef;
828        }
829
830        # perl 5.005's IO::Socket does not have the blocking method.
831        eval { $sock->blocking(0); };
832
833        # establish connectivity with socks server - SOCKS4A protocol
834        print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
835                (pack 'x') .
836                $host . (pack 'x');
837
838        my $received = "";
839        my $timeout_time = time + $timeout;
840        while ($sock->sysread($received, 8) && (length($received) < 8) ) {
841                select(undef, undef, undef, 0.25);
842                last if ($timeout_time < time);
843        }
844
845        if ($timeout_time < time) {
846                &log("Timeout ($timeout) while connecting via SOCKS server");
847                return $sock;
848        }
849
850        my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
851        &log("Connection via SOCKS4A server rejected or failed") if ($req_status == 0x5b);
852        &log("Connection via SOCKS4A server because client is not running identd") if ($req_status == 0x5c);
853        &log("Connection via SOCKS4A server because client's identd could not confirm the user") if ($req_status == 0x5d);
854
855        $sock;
856}
857
858##############################################################################
Note: See TracBrowser for help on using the browser.