root/grabbers/yahoo7web @ 517

Revision 517, 25.7 kB (checked in by lincoln, 6 years ago)

yahoo kindly AJAXified their website, making grabbing with yahoo7web far easier than it used to be. they also removed their previous speed-limiters, meaning yahoo7web is now quite fast. added micrograbbing into yahoo7web in the process
  • 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.08";
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 %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } );
28my %stats;
29my $channels, my $opt_channels, my $gaps;
30my $data_cache;
31my $writer;
32my $ua;
33my $prev_url;
34my $d;
35my $opt;
36
37#
38# parse command line
39#
40
41$opt->{days} =          7;                      # default
42$opt->{outputfile} =    "output.xmltv";         # default
43$opt->{cache_file} =    $progname.".storable.cache";    # default
44$opt->{lang} =          "en";
45$opt->{region} =        94;
46
47GetOptions(
48        'log-http'      => \$opt->{log_http},
49        'region=i'      => \$opt->{region},
50        'days=i'        => \$opt->{days},
51        'offset=i'      => \$opt->{offset},
52        'timezone=s'    => \$opt->{timezone},
53        'channels_file=s' => \$opt->{channels_file},
54        'gaps_file=s'   => \$opt->{gaps_file},
55        'output=s'      => \$opt->{outputfile},
56        'cache-file=s'  => \$opt->{cache_file},
57        'fast'          => \$opt->{fast},
58        'no-cache'      => \$opt->{no_cache},
59        'no-details'    => \$opt->{no_details},
60        'debug+'        => \$opt->{debug},
61        'warper'        => \$opt->{warper},
62        'lang=s'        => \$opt->{lang},
63        'obfuscate'     => \$opt->{obfuscate},
64        'anonsocks=s'   => \$opt->{anon_socks},
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#
82# go go go!
83#
84
85&log(sprintf "going to %sgrab %d days%s of data into %s (%s%s%s%s%s)",
86        (defined $opt->{gaps_file} ? "micro-gap " : ""),
87        $opt->{days},
88        (defined $opt->{offset} ? " (skipping first $opt->{offset} days)" : ""),
89        $opt->{outputfile},
90        (defined $opt->{fast} ? "with haste" : "slowly"),
91        (defined $opt->{anon_socks} ? ", via multiple endpoints" : ""),
92        (defined $opt->{warper} ? ", anonymously" : ""),
93        (defined $opt->{no_details} ? ", without details" : ", with details"),
94        (defined $opt->{no_cache} ? ", without caching" : ", with caching"));
95
96# read channels file
97if (-r $opt->{channels_file}) {
98        local (@ARGV, $/) = ($opt->{channels_file});
99        no warnings 'all'; eval <>; die "$@" if $@;
100} else {
101        die "WARNING: channels file $opt->{channels_file} could not be read\n";
102}
103
104# if just filling in microgaps, parse gaps
105if (defined $opt->{gaps_file}) {
106        if (-r $opt->{gaps_file}) {
107                local (@ARGV, $/) = ($opt->{gaps_file});
108                no warnings 'all'; eval <>; die "$@" if $@;
109        } else {
110                die "WARNING: gaps_file $opt->{gaps_file} could not be read: $!\n";
111        }
112}
113
114&read_cache unless (defined $opt->{no_cache});
115
116&set_ua;
117&setup_socks if (defined $opt->{anon_socks});
118
119&start_writing_xmltv;
120
121&get_summary_pages;
122&get_detailed_pages;
123
124&write_cache unless (defined $opt->{no_cache});
125$writer->end();
126
127&print_stats;
128exit(0);
129
130##############################################################################
131# help
132
133sub help
134{
135        print<<EOF
136$progname $version
137
138options are as follows:
139        --help                  show these help options
140        --days=N                fetch 'n' days of data (default: $opt->{days})
141        --output=file           send xml output to file (default: "$opt->{outputfile}")
142        --no-cache              don't use a cache to optimize (reduce) number of web queries
143        --no-details            don't fetch detailed descriptions (default: do)
144        --cache-file=file       where to store cache (default "$opt->{cache_file}")
145        --fast                  don't run slow - get data as quick as you can - not recommended
146        --anonsocks=(ip:port)   use SOCKS4A server at (ip):(port) (for Tor: recommended)
147
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        --lang=[s]              set language of xmltv output data (default $opt->{lang})
152
153        --region=N              set region for where to collect data from (default: $opt->{region})
154        --channels_file=file    where to get channel data from
155        --gaps_file=file        micro-fetch gaps only
156
157EOF
158;
159
160        exit(0);
161}
162
163##############################################################################
164# populate cache
165
166sub read_cache
167{
168        # convert old-style Data::Dumper cache to new format
169        if (-r "yahoo7web.cache") {
170                local (@ARGV, $/) = ("yahoo7web.cache");
171                no warnings 'all'; eval <>; die "$@" if $@;
172
173                &write_cache;
174                unlink "yahoo7web.cache";
175        }
176
177        if (-r $opt->{cache_file}) {
178                my $store = Storable::retrieve($opt->{cache_file});
179                $data_cache = $store->{data_cache};
180        } else {
181                printf "WARNING: no programme cache $opt->{cache_file} - have to fetch all details\n";
182
183                # try to write to it - if directory doesn't exist this will then cause an error
184                &write_cache;
185        }
186}
187
188##############################################################################
189# write out updated cache
190
191sub write_cache
192{
193        # cleanup old entries from cache
194        for my $cache_key (keys %{$data_cache}) {
195                my ($starttime, @rest) = split(/:/,$cache_key);
196                if ($starttime < (time-86400)) {
197                        delete $data_cache->{$cache_key};
198                        $stats{expired_from_cache}++;
199                }
200        }
201
202        my $store;
203        $store->{data_cache} = $data_cache;
204
205        Storable::store($store, $opt->{cache_file});
206}
207
208##############################################################################
209# logic to fetch a page via http
210#  retries up to $retrycount times to get a page with 10 second pauses inbetween
211
212sub get_url
213{
214        my ($url,$retrycount,$referer,$reqtype,$postvars) = @_;
215        my $request;
216        my $response;
217        my $attempts = 0;
218        my ($raw, $page, $base);
219
220        $reqtype = "GET" if (!defined $reqtype);
221
222        $retrycount = 5 if ($retrycount == 0);
223        $url =~ s#^http://#http://webwarper.net/ww/# if (defined $opt->{warper});
224
225        if ($reqtype eq "GET") {
226                $request = HTTP::Request->new(GET => $url);
227        } elsif ($reqtype eq "POST") {
228                $request = HTTP::Request->new(POST => $url);
229                $request->add_content($postvars);
230        }
231
232        if (defined $referer) {
233                $request->header('Referer' => $referer);
234                printf "DEBUG: explicitly set Referer to '%s'\n", $referer if (defined $opt->{debug});
235        } else {
236                if (defined $prev_url) {
237                        $request->header('Referer' => $prev_url);
238                        printf "DEBUG: set Referer to '%s'\n", $prev_url if (defined $opt->{debug});
239                }
240        }
241        $prev_url = $url;
242
243        $request->header('Accept-Encoding' => 'gzip');
244
245        if ($opt->{obfuscate}) {
246                my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1);
247                $request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)');
248                $request->header('X-Forwarded-For' => $randomaddr);
249        }
250
251        my $status;
252        for (1..$retrycount) {
253                $response = $ua->request($request);
254
255                if ((defined $opt->{log_http}) && (open(F,">>http_log.txt"))) {
256                        printf F "\n----------------------------------------------------\n";
257                        printf F "request: %s %s %s\n",$reqtype,$url,(defined $postvars ? $postvars : "");
258                        printf F "referer: %s\n",$request->header('Referer');
259                        printf F "response: %s\n",$response->status_line;
260                        print F $response->content;
261                        close F;
262                }
263
264                if ($response->is_success) {
265                        if ($response->content =~ /we are unable to process your request/) {
266                                $status = "fail: 999: Service unavailable"; # CPAN's LWP lied to us
267                        } else {
268                                $status = "good";
269                                last;
270                        }
271                } else {
272                        $status = "fail: ".$response->status_line;
273                }
274
275                $stats{http_failed_requests}++;
276                $attempts++;
277
278                my $sleep_for = 30;
279                $sleep_for = 10 if (defined $opt->{anon_socks});
280
281                &log("attempt $attempts of $retrycount failed to fetch $url, sleeping for $sleep_for secs: $status");
282
283                $stats{slept_for} += $sleep_for;
284                sleep $sleep_for;
285        }
286        if ($status !~ /^good/) {
287                &log("aborting after $attempts attempts to fetch url $url");
288                return undef;
289        }
290
291        $prev_url = $response->base;
292        $prev_url =~ s#^http://webwarper.net/ww/#http://# if (defined $opt->{warper});
293
294        $stats{bytes_fetched} += do {use bytes; length($response->content)};
295        $stats{http_successful_requests}++;
296
297#       if ((!$opt->{fast}) || (!defined $opt->{anon_socks})) {
298#               my $sleeptimer = int(rand(6));
299#               $stats{slept_for} += $sleeptimer;
300#               sleep $sleeptimer;
301#       }
302
303        if ($response->header('Content-Encoding') &&
304            $response->header('Content-Encoding') eq 'gzip') {
305                $stats{compressed_pages} += do {use bytes; length($response->content)};
306                $response->content(Compress::Zlib::memGunzip($response->content));
307        }
308        return $response->content;
309}
310
311##############################################################################
312
313sub log
314{
315        my ($entry) = @_;
316        printf "%s\n",$entry;
317}
318
319##############################################################################
320
321sub print_stats
322{
323        printf "STATS: %s v%s completed in %d seconds",$progname, $version, time-$script_start_time;
324        foreach my $key (sort keys %stats) {
325                printf ", %d %s",$stats{$key},$key;
326        }
327        printf "\n";
328}
329
330##############################################################################
331# descend a structure and clean up various things, including stripping
332# leading/trailing spaces in strings, translations of html stuff etc
333#   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
334
335sub cleanup {
336        my $x = shift;
337        if    (ref $x eq "REF")   { cleanup($_) }
338        elsif (ref $x eq "HASH")  { cleanup(\$_) for values %$x }
339        elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
340        elsif (defined $$x) {
341                $$x =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg;
342                $$x =~ s/[^\x20-\x7f]/ /g;
343                $$x =~ s/(^\s+|\s+$)//g;
344        }
345}
346
347##############################################################################
348
349sub start_writing_xmltv
350{
351        my %writer_args = ( encoding => 'ISO-8859-1' );
352        if ($opt->{outputfile}) {
353                my $fh = new IO::File(">$opt->{outputfile}") || die "can't open $opt->{outputfile}: $!";
354                $writer_args{OUTPUT} = $fh;
355        }
356
357        $writer = new XMLTV::Writer(%writer_args);
358
359        $writer->start
360          ( { 'source-info-name'   => "$progname $version",
361              'generator-info-name' => "$progname $version"} );
362
363        for my $channel (sort keys %{$channels}) {
364                $writer->write_channel( {
365                        'display-name' => [[ $channel, $opt->{lang} ]],
366                        'id' => $channels->{$channel}
367                        } );
368        }
369}
370
371##############################################################################
372
373sub set_ua
374{
375        my @agent_list = (
376                'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)',
377                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
378                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; FunWebProducts)',
379                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322)',
380                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)',
381                'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Q312466)',
382                'Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)',
383                'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85.8.5 (KHTML, like Gecko) Safari/85.8.1',
384                'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.4) Gecko/20060508 Firefox/1.5.0.4',
385                'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox',
386                'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.8) Gecko/20061025 Firefox/1.5.0.8',
387                'Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1) Gecko/20061010 Firefox/2.0',
388                'Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)',
389                'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412',
390                'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-us) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
391                'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; fr) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
392                'Opera/9.00 (Windows NT 5.1; U; en)');
393
394        $ua = undef;
395        $ua = LWP::UserAgent->new('timeout' => 30, 'agent' => $agent_list[(int(rand($#agent_list+1)))] );
396        $ua->env_proxy;
397        $ua->cookie_jar({});
398        $prev_url = undef; # reset referer
399}
400
401##############################################################################
402
403sub translate_category
404{
405        my $genre = shift;
406        my %translation = (
407                'Sport' => 'sports',
408                'Soap Opera' => 'Soap',
409                'Science and Technology' => 'Science/Nature',
410                'Real Life' => 'Reality',
411                'Cartoon' => 'Animation',
412                'Family' => 'Children',
413                'Murder' => 'Crime' );
414
415        return $translation{$genre} if defined $translation{$genre};
416        return $genre;
417}
418
419##############################################################################
420
421sub build_channel_quirks_map
422{
423        # set up channel name exceptions list
424        my %chan_map;
425        if ($opt->{region} == 71) {
426                # NSW: Southern NSW
427                push (@{($chan_map{"Prime"})},
428                        "Prime (Canberra/Wollongong/South Coast)",
429                        "Prime (Wagga Wagga/Orange)");
430                push (@{($chan_map{"TEN"})},
431                        "TEN (NSW: Southern NSW)",
432                        "TEN (Mildura Digital)");
433        } elsif ($opt->{region} == 79) {
434                # QLD: Regional
435                push (@{($chan_map{"Seven"})},
436                        "Seven (Cairns/Townsville/Mackay/Wide Bay/Sunshine Coast)",
437                        "Seven (Rockhampton/Toowoomba)");
438                push (@{($chan_map{"WIN"})},
439                        "WIN (QLD: Regional)",
440                        "WIN (Mackay/Wide Bay)");
441        } elsif ($opt->{region} == 90) {
442                # VIC: Eastern Victoria
443                push (@{($chan_map{"Prime"})},
444                        "Prime (Regional)",
445                        "Prime (Albury)");
446        }
447
448        return %chan_map;
449}
450
451##############################################################################
452
453sub get_summary_pages
454{
455        my $starttime = time;
456        my $day_num = 0;
457        my $skip_days = 0;
458        $stats{programmes} = 0;
459
460        my @timeattr = localtime($starttime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
461        $timeattr[0] = 0;       # zero sec
462        $timeattr[1] = 0;       # zero min
463        $timeattr[2] = 0;       # zero hour (midnight)
464        my $starttime_midnight = mktime(@timeattr);
465
466        $skip_days = $opt->{offset} if (defined $opt->{offset});
467        while ($day_num < $opt->{days}) {
468                my $day_start = $starttime_midnight + (60*60*24 * $day_num);
469                $day_num++;
470
471                # skip if --offset applies against this day
472                if ($skip_days > 0) {
473                        $skip_days--;
474                        next;
475                }
476               
477                # within each day, fetch in groups of 3 hours
478                for (my $hr = 0; $hr < 23; $hr += 3) {
479                        my $currtime = $day_start + ($hr * 60 * 60);
480                        next if (($currtime + (3 * 60 * 60)) < $starttime); # no point fetching the past
481
482                        my $url = sprintf "http://au.tv.yahoo.com/tv-guide/?hour=%s&min=%s&date=%s&mon=%s&year=%s&tvrg=%s&next=%s",
483                                POSIX::strftime("%H",localtime($starttime)),
484                                POSIX::strftime("%M",localtime($starttime)),
485                                POSIX::strftime("%d",localtime($starttime)),
486                                POSIX::strftime("%m",localtime($starttime)),
487                                POSIX::strftime("%Y",localtime($starttime)),
488                                $opt->{region}, $currtime;
489
490                        &log("fetching day $day_num summary page hour $hr ($url)");
491                        &parse_summary_page($url, $day_num, $day_start);
492
493                        my $wait_for = 2;
494                        $stats{slept_for} += $wait_for;
495                        sleep($wait_for);
496                }
497
498                my $wait_for = 5 + int(rand(5));
499                $stats{slept_for} += $wait_for;
500                sleep($wait_for);
501        }
502}
503
504##############################################################################
505
506sub parse_summary_page
507{
508        my ($url, $day_num, $day_start) = @_;
509        my %chan_map = &build_channel_quirks_map;
510
511        my $data = &get_url($url,5);
512        return if (!$data);
513
514        my $tree = HTML::TreeBuilder->new_from_content($data);
515        if (!$tree) {
516                &log("url '$url' doesn't seem to contain any valid HTML: has the format changed?");
517                return;
518        }
519
520        my $tree_table = $tree->look_down('_tag' => 'table', 'id' => 'listing-table');
521        if (!$tree_table) {
522                &log("url '$url' doesn't seem to contain a TV table.  Has the format changed?");
523                return;
524        }
525
526        my $progs_in_table = 0;
527
528        for my $tree_tr ($tree_table->look_down('_tag' => 'tr', 'class' => 'lt-listing-row')) {
529                # get channel
530                my $this_chan = "";
531                if (my $channel_td = $tree_tr->look_down('_tag' => 'td', 'class' => 'lt-channel')) {
532                        $this_chan = $channel_td->as_text();
533                }
534
535                if ($this_chan eq "") {
536                        &log("ignoring blank channel in $url") if (defined $opt->{debug});
537                        $stats{blank_channels_ignored}++;
538                        next;
539                }
540
541                if (defined $chan_map{$this_chan}) {
542                        my $new_channame = splice(@{($chan_map{$this_chan})},0,1);
543                        &log("substituted channel name '$new_channame' for '$this_chan'") if (defined $opt->{debug});
544                        $stats{substituted_channels}++;
545                        $this_chan = $new_channame;
546                }
547
548                if (!defined $channels->{$this_chan}) {
549                        &log("skipping unlisted channel '$this_chan'") if (!defined $d->{skipped_channels}->{$this_chan});
550                        $d->{skipped_channels}->{$this_chan} = 1 if (!defined $opt->{debug});
551                        $stats{skipped_channels}++;
552                        next;
553                }
554
555                for my $tree_td ($tree_tr->look_down('_tag' => 'td', 'class' => 'lt-listing')) {
556                        if (my $listing_div = $tree_td->look_down('_tag' => 'div')) {
557                                next if ($listing_div->attr('class') !~ /^lt-listing-wrapper/i);
558
559                                my @listing_links = $listing_div->look_down('_tag' => 'a', 'class' => 'listing-link');
560                                my @listing_data = $listing_div->look_down('_tag' => 'strong');
561
562                                for (my $i=0; $i <= $#listing_links; $i++) {
563                                        my $prog;
564                                        $prog->{channel} = $channels->{$this_chan};
565
566                                        if ($listing_links[$i]->attr('rel') =~ /^(\d+)-(\d+)-(\d+)$/) {
567                                                $prog->{event_id} = $3;
568                                        }
569                                        $prog->{title} = [[ $listing_links[$i]->as_text(), $opt->{lang} ]];
570
571                                        my $listing_text = $listing_data[$i]->as_text();
572                                        if ($listing_text =~ /^(.*)\((\d+)\)(\d+):(\d+)(.)m - (\d+):(\d+)(.)m$/i) {
573                                                my ($rating_text, $prog_length, $start_sec, $stop_sec) = ($1, $2, parse_time($3, $4, $5), parse_time($6, $7, $8));
574
575                                                $prog->{rating} = [[ $rating_text, 'ABA', undef ]] if ((defined $rating_text) && ($rating_text ne ""));
576                                                $prog->{length} = ($prog_length * 60) if ((defined $prog_length) && ($prog_length > 0));
577                                                $prog->{starttime} = $day_start + $start_sec;
578                                                $prog->{stoptime} = $day_start + $stop_sec;
579                                        } else {
580                                                &log("malformed listing_text '$listing_text' for prog '".$listing_links[$i]->as_text()."'; ignored.");
581                                                $stats{malformed_listing}++;
582                                                next;
583                                        }
584
585                                        $progs_in_table++;
586
587                                        # if we are fetching microgaps, skip if this isn't
588                                        # in a micro-gap.
589                                        if (defined $opt->{gaps_file}) {
590                                                my $found_gap_match = 0;
591                                                if (defined $gaps->{$prog->{channel}}) {
592                                                        foreach my $g (@{($gaps->{$prog->{channel}})}) {
593                                                                my ($s, $e) = split(/-/,$g);
594                                                                $found_gap_match = 1 if
595                                                                  ((($s >= $prog->{starttime}) && ($s <= $prog->{stoptime})) ||
596                                                                   (($e >= $prog->{starttime}) && ($e <= $prog->{stoptime})) ||
597                                                                   (($s <= $prog->{starttime}) && ($e >= $prog->{stoptime})));
598                                                        }
599                                                }
600                                                if (!$found_gap_match) {
601                                                        $stats{gaps_skipped}++;
602                                                        next;
603                                                } else {
604                                                        $stats{gaps_included}++;
605                                                }
606                                        }
607
608                                        # include programme
609                                        &log("found prog: '".$prog->{title}->[0]->[0]."', channel ".$prog->{channel}.
610                                          " start ".$prog->{starttime}." stop ".$prog->{stoptime}) if (defined $opt->{debug});
611
612                                        my $cache_key = sprintf "%d:%s:%s", $prog->{starttime}, $prog->{channel}, $prog->{title}->[0]->[0];
613                                        if (!defined $d->{progs}->{$cache_key}) {
614                                                $d->{progs}->{$cache_key} = $prog;
615                                                $stats{programmes}++;
616                                        }
617                                }
618                        }
619                }
620        }
621
622        &log("WARNING: Data may be bad. Only $progs_in_table programmes seen in $url") if ($progs_in_table < 5);
623}
624
625##############################################################################
626# loop through our progs, fetching details where we don't have a pre-cached
627# entry for them.
628# write out XMLTV
629
630sub get_detailed_pages
631{
632        &log("fetching details for up to ".$stats{programmes}." programmes ...") if (!defined $opt->{no_details});
633
634        my $prog_count = 0;
635        my $added_to_cache = 0;
636        $stats{used_existing_cache_entry} = 0;
637        $stats{added_to_cache} = 0;
638
639        foreach my $cache_key (sort keys %{($d->{progs})}) {
640                my $prog = $d->{progs}->{$cache_key};
641                $prog_count++;
642
643                if ((!defined $data_cache->{$cache_key}) &&
644                    (!defined $opt->{no_details}) &&
645                    (defined $prog->{event_id}) &&
646                    ($prog->{title}->[0]->[0] ne "Station Close")) {
647                        &fetch_one_prog($cache_key, $prog->{event_id});
648                        &write_cache if ((($stats{added_to_cache} % 15) == 0) && (!defined $opt->{no_cache}));
649                } elsif (!defined $opt->{no_details}) {
650                        $stats{used_existing_cache_entry}++;
651                }
652
653                if ((($prog_count % 25) == 0) && (!defined $opt->{no_details})) {
654                        &log(" ... at ".$prog_count." of ".$stats{programmes}." programmes (used ".$stats{used_existing_cache_entry}." from cache)");
655                }
656
657                # if we got additional details from the cache, add them now
658                if (defined $data_cache->{$cache_key}) {
659                        foreach my $key (keys %{($data_cache->{$cache_key})}) {
660                                $prog->{$key} = $data_cache->{$cache_key}->{$key};
661                        }
662                }
663
664                # convert epoch starttime into XMLTV starttime
665                $prog->{start} = POSIX::strftime("%Y%m%d%H%M", localtime($prog->{starttime}));
666                delete $prog->{starttime};
667
668                # convert epoch stoptime into XMLTV stoptime
669                $prog->{stop} = POSIX::strftime("%Y%m%d%H%M", localtime($prog->{stoptime}));
670                delete $prog->{stoptime};
671
672                delete $prog->{event_id};
673                &cleanup($prog);
674
675                printf "DEBUG: programme xmltv: ".Dumper($prog) if ((defined $opt->{debug}) && ($opt->{debug} > 1));
676                $writer->write_programme($prog);
677        }
678}
679
680##############################################################################
681
682sub fetch_one_prog
683{
684        my ($cache_key, $event_id) = @_;
685        &log("fetching detail page for $cache_key with event_id $event_id") if (defined $opt->{debug});
686
687        my $url = "http://au.tv.yahoo.com/tv-guide/broker.html?event_id=".$event_id;
688        my $data = &get_url($url,5);
689
690        if ((!$data) || ($data !~ /^\{.*\}$/)) {
691                $stats{bad_details_page}++;
692                return;
693        }
694
695        $stats{added_to_cache}++;
696
697        if (($stats{added_to_cache} % 35) == 0) {
698                my $wait_for = 12 + int(rand(5));
699                $stats{slept_for} += $wait_for;
700                sleep $wait_for;
701        }
702
703        my @genre;
704
705        $data =~ s/(^\{|\}$)//g; # strip leading/trailing { and }
706        foreach my $field_item (split(/,"/,$data)) {
707                if ($field_item =~ /^([A-Za-z0-9\_\"]+):(.*)/) {
708                        my ($f, $v) = ($1, $2);
709                        $f =~ s/(^\"|\"$)//g;   # strip leading/trailing quotes from field if present
710                        $v =~ s/(^\"|\"$)//g;   # strip leading/trailing quotes from value if present
711                        next if ($v eq "");
712
713                        if ($f eq "title") {
714                                ; # nothing
715                        } elsif ($f eq "subtitle") {
716                                $data_cache->{$cache_key}->{'sub-title'} = [[ $v, $opt->{lang} ]];
717                        } elsif ($f eq "description") {
718                                $data_cache->{$cache_key}->{desc} = [[ $v, $opt->{lang} ]];
719                        } elsif ($f eq "genre") {
720                                push(@genre, translate_category($v));
721                        } elsif ($f eq "captions") {
722                                $data_cache->{$cache_key}->{subtitles} = [ { 'type' => 'teletext' } ] if ($v eq "true");
723                        } elsif ($f eq "start_date") {
724                                ; # nothing
725                        } elsif ($f eq "end_date") {
726                                ; # nothing
727                        } elsif ($f eq "rating") {
728                                ; # nothing
729                        } elsif ($f eq "channel") {
730                                ; # nothing
731                        } elsif ($f eq "hotpick") {
732                                ; # nothing
733                        } elsif ($f eq "venue_url") {
734                                ; # nothing
735                        } elsif ($f eq "url") {
736                                ; # nothing
737                        } elsif ($f eq "alt_url") {
738                                ; # nothing
739                        } elsif ($f eq "alt_text") {
740                                ; # nothing
741                        } elsif ($f eq "img") {
742                                ; # nothing
743                        } else {
744                                &log("unknown field '$f' in $url") if (!defined $d->{unknown_fields}->{$f});
745                                $d->{unknown_fields}->{$f} = 1;
746                        }
747
748                        $data_cache->{$cache_key}->{category} = [[ @genre ]] if ($#genre != -1);
749
750                } else {
751                        &log("unknown field format '$field_item' in details. Has the format changed?");
752                        $stats{unknown_details_field_format}++;
753                }
754        }
755
756        printf "DEBUG: cached entries for '$cache_key': ".Dumper($data_cache->{$cache_key})
757          if (defined $opt->{debug});
758}
759
760##############################################################################
761
762sub setup_socks
763{
764        use LWP::Protocol::http;
765        my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
766
767        # override LWP::Protocol::http's _new_socket method with our own
768        local($^W) = 0;
769        *LWP::Protocol::http::_new_socket = \&socks_new_socket;
770
771        # test that it works
772        &log("configured to use Tor, testing that it works by connecting to www.google.com ...");
773        my $data = &get_url("http://www.google.com/",10);
774        if (($data) && ($data =~ /Google/i)) {
775                &log("success.  Tor appears to be working!");
776                return;
777        }
778
779        &log("ERROR: Could not connect to www.google.com via Tor, disabling Tor.");
780        &log("       DATA FETCHING WILL BE VERY SLOW.");
781        &log("       DISABLING DETAILS-FETCHING BECAUSE OF THIS - SIGNIFICANTLY LOWER DATA QUALITY!!");
782
783        $opt->{no_details} = 1;
784        delete $opt->{anon_socks};
785        $stats{fallback_to_non_tor}++;
786
787        *LWP::Protocol::http::_new_socket = $orig_new_socket;
788}
789
790##############################################################################
791# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
792
793sub socks_new_socket
794{
795        my($self, $host, $port, $timeout) = @_;
796
797        my ($socks_ip,$socks_port) = split(/:/,$opt->{anon_socks});
798        $socks_ip = "127.0.0.1" if (!defined $socks_ip);
799        $socks_port = "9050" if (!defined $socks_port);
800
801        local($^W) = 0;  # IO::Socket::INET can be noisy
802        my $sock = $self->socket_class->new(
803                PeerAddr => $socks_ip,
804                PeerPort => $socks_port,
805                Proto    => 'tcp');
806
807        unless ($sock) {
808                # IO::Socket::INET leaves additional error messages in $@
809                $@ =~ s/^.*?: //;
810                &log("Can't connect to $host:$port ($@)");
811                return undef;
812        }
813
814        # perl 5.005's IO::Socket does not have the blocking method.
815        eval { $sock->blocking(0); };
816
817        # establish connectivity with socks server - SOCKS4A protocol
818        print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
819                (pack 'x') .
820                $host . (pack 'x');
821
822        my $received = "";
823        my $timeout_time = time + $timeout;
824        while ($sock->sysread($received, 8) && (length($received) < 8) ) {
825                select(undef, undef, undef, 0.25);
826                last if ($timeout_time < time);
827        }
828
829        if ($timeout_time < time) {
830                &log("Timeout ($timeout) while connecting via SOCKS server");
831                return $sock;
832        }
833
834        my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
835        &log("Connection via SOCKS4A server rejected or failed") if ($req_status == 0x5b);
836        &log("Connection via SOCKS4A server because client is not running identd") if ($req_status == 0x5c);
837        &log("Connection via SOCKS4A server because client's identd could not confirm the user") if ($req_status == 0x5d);
838
839        $sock;
840}
841
842##############################################################################
843
844sub parse_time
845{
846        my ($hr, $min, $ampm) = @_;
847
848        $hr = 0 if ($hr == 12);
849        $hr += 12 if ($ampm =~ /p/i);
850
851        return(($hr*60*60)+($min*60));
852}
853
854##############################################################################
Note: See TracBrowser for help on using the browser.