root/grabbers/yahoo7web @ 555

Revision 555, 27.3 kB (checked in by lincoln, 6 years ago)

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