root/grabbers/yahoo7web @ 538

Revision 538, 26.5 kB (checked in by lincoln, 6 years ago)

max noticed yahoo7web mishandled programmes spanning midnight
  • 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.11";
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                        # if we are fetching microgaps, skip this summary page if we aren't
483                        # interested in anything from it anyway
484                        next if ((defined $opt->{gaps_file}) && (!window_is_within_microgap($currtime,$currtime+(60*60*3))));
485
486                        my $url = sprintf "http://au.tv.yahoo.com/tv-guide/?hour=%s&min=%s&date=%s&mon=%s&year=%s&tvrg=%s&next=%s",
487                                POSIX::strftime("%H",localtime($starttime)),
488                                POSIX::strftime("%M",localtime($starttime)),
489                                POSIX::strftime("%d",localtime($starttime)),
490                                POSIX::strftime("%m",localtime($starttime)),
491                                POSIX::strftime("%Y",localtime($starttime)),
492                                $opt->{region}, $currtime;
493
494                        &log("fetching day $day_num summary page hour $hr ($url)");
495                        &parse_summary_page($url, $day_num, $day_start);
496
497                        die "couldn't fetch first summary page, network is probably down or format changed. aborting!"
498                          if ((!defined $stats{summary_pages_with_progs}) || ($stats{summary_pages_with_progs} == 0));
499       
500                        my $wait_for = 2;
501                        $stats{slept_for} += $wait_for;
502                        sleep($wait_for);
503                }
504
505                my $wait_for = 5 + int(rand(5));
506                $stats{slept_for} += $wait_for;
507                sleep($wait_for);
508        }
509}
510
511##############################################################################
512
513sub parse_summary_page
514{
515        my ($url, $day_num, $day_start) = @_;
516        my %chan_map = &build_channel_quirks_map;
517
518        my $data = &get_url($url,5);
519        return if (!$data);
520
521        my $tree = HTML::TreeBuilder->new_from_content($data);
522        if (!$tree) {
523                &log("url '$url' doesn't seem to contain any valid HTML: has the format changed?");
524                return;
525        }
526
527        my $tree_table = $tree->look_down('_tag' => 'table', 'id' => 'listing-table');
528        if (!$tree_table) {
529                &log("url '$url' doesn't seem to contain a TV table.  Has the format changed?");
530                return;
531        }
532
533        my $progs_in_table = 0;
534
535        for my $tree_tr ($tree_table->look_down('_tag' => 'tr', 'class' => 'lt-listing-row')) {
536                # get channel
537                my $this_chan = "";
538                if (my $channel_td = $tree_tr->look_down('_tag' => 'td', 'class' => 'lt-channel')) {
539                        $this_chan = $channel_td->as_text();
540                }
541
542                if ($this_chan eq "") {
543                        &log("ignoring blank channel in $url") if (defined $opt->{debug});
544                        $stats{blank_channels_ignored}++;
545                        next;
546                }
547
548                if (defined $chan_map{$this_chan}) {
549                        my $new_channame = splice(@{($chan_map{$this_chan})},0,1);
550                        &log("substituted channel name '$new_channame' for '$this_chan'") if (defined $opt->{debug});
551                        $stats{substituted_channels}++;
552                        $this_chan = $new_channame;
553                }
554
555                if (!defined $channels->{$this_chan}) {
556                        &log("skipping unlisted channel '$this_chan'") if (!defined $d->{skipped_channels}->{$this_chan});
557                        $d->{skipped_channels}->{$this_chan} = 1 if (!defined $opt->{debug});
558                        $stats{skipped_channels}++;
559                        next;
560                }
561
562                for my $tree_td ($tree_tr->look_down('_tag' => 'td', 'class' => 'lt-listing')) {
563                        if (my $listing_div = $tree_td->look_down('_tag' => 'div')) {
564                                next if ($listing_div->attr('class') !~ /^lt-listing-wrapper/i);
565
566                                my @listing_links = $listing_div->look_down('_tag' => 'a', 'class' => 'listing-link');
567                                my @listing_data = $listing_div->look_down('_tag' => 'strong');
568
569                                for (my $i=0; $i <= $#listing_links; $i++) {
570                                        my $prog;
571                                        $prog->{channel} = $channels->{$this_chan};
572
573                                        if ($listing_links[$i]->attr('rel') =~ /^(\d+)-(\d+)-(\d+)$/) {
574                                                $prog->{event_id} = $3;
575                                        }
576                                        $prog->{title} = [[ $listing_links[$i]->as_text(), $opt->{lang} ]];
577
578                                        my $listing_text = $listing_data[$i]->as_text();
579                                        if ($listing_text =~ /^(.*)\((\d+)\)(\d+):(\d+)(.)m - (\d+):(\d+)(.)m$/i) {
580                                                my ($rating_text, $prog_length, $start_sec, $stop_sec) = ($1, $2, parse_time($3, $4, $5), parse_time($6, $7, $8));
581                                                $stop_sec += (60*60*24) if ($stop_sec < $start_sec); # program wrap around midnight
582                                                $prog->{rating} = [[ $rating_text, 'ABA', undef ]] if ((defined $rating_text) && ($rating_text ne ""));
583                                                $prog->{length} = ($prog_length * 60) if ((defined $prog_length) && ($prog_length > 0));
584                                                $prog->{starttime} = $day_start + $start_sec;
585                                                $prog->{stoptime} = $day_start + $stop_sec;
586                                        } else {
587                                                &log("malformed listing_text '$listing_text' for prog '".$listing_links[$i]->as_text()."'; ignored.");
588                                                $stats{malformed_listing}++;
589                                                next;
590                                        }
591
592                                        $progs_in_table++;
593
594                                        # if we are fetching microgaps, skip if this isn't in a micro-gap.
595                                        if (defined $opt->{gaps_file}) {
596                                                next if (!window_is_within_microgap($prog->{starttime},$prog->{stoptime},$this_chan));
597                                                $stats{gaps_included}++;
598                                        }
599
600                                        # include programme
601                                        &log("found prog: '".$prog->{title}->[0]->[0]."', channel ".$prog->{channel}.
602                                          " start ".$prog->{starttime}." stop ".$prog->{stoptime}) if (defined $opt->{debug});
603
604                                        my $cache_key = sprintf "%d:%s:%s", $prog->{starttime}, $prog->{channel}, $prog->{title}->[0]->[0];
605                                        if (!defined $d->{progs}->{$cache_key}) {
606                                                $d->{progs}->{$cache_key} = $prog;
607                                                $stats{programmes}++;
608                                        }
609                                }
610                        }
611                }
612        }
613
614        $stats{summary_pages_with_progs}++ if ($progs_in_table > 0);
615
616        &log("WARNING: Data may be bad. Only $progs_in_table programmes seen in $url") if ($progs_in_table < 5);
617}
618
619##############################################################################
620# loop through our progs, fetching details where we don't have a pre-cached
621# entry for them.
622# write out XMLTV
623
624sub get_detailed_pages
625{
626        &log("fetching details for up to ".$stats{programmes}." programmes ...") if (!defined $opt->{no_details});
627
628        my $prog_count = 0;
629        my $added_to_cache = 0;
630        $stats{used_existing_cache_entry} = 0;
631        $stats{added_to_cache} = 0;
632
633        foreach my $cache_key (sort keys %{($d->{progs})}) {
634                my $prog = $d->{progs}->{$cache_key};
635                $prog_count++;
636
637                if ((!defined $data_cache->{$cache_key}) &&
638                    (!defined $opt->{no_details}) &&
639                    (defined $prog->{event_id}) &&
640                    ($prog->{title}->[0]->[0] ne "Station Close")) {
641                        &fetch_one_prog($cache_key, $prog->{event_id});
642                        &write_cache if ((($stats{added_to_cache} % 15) == 0) && (!defined $opt->{no_cache}));
643                } elsif (!defined $opt->{no_details}) {
644                        $stats{used_existing_cache_entry}++;
645                }
646
647                if ((($prog_count % 25) == 0) && (!defined $opt->{no_details})) {
648                        &log(" ... at ".$prog_count." of ".$stats{programmes}." programmes (used ".$stats{used_existing_cache_entry}." from cache)");
649                }
650
651                # if we got additional details from the cache, add them now
652                if (defined $data_cache->{$cache_key}) {
653                        foreach my $key (keys %{($data_cache->{$cache_key})}) {
654                                $prog->{$key} = $data_cache->{$cache_key}->{$key};
655                        }
656                }
657
658                # convert epoch starttime into XMLTV starttime
659                $prog->{start} = POSIX::strftime("%Y%m%d%H%M", localtime($prog->{starttime}));
660                delete $prog->{starttime};
661
662                # convert epoch stoptime into XMLTV stoptime
663                $prog->{stop} = POSIX::strftime("%Y%m%d%H%M", localtime($prog->{stoptime}));
664                delete $prog->{stoptime};
665
666                delete $prog->{event_id};
667                &cleanup($prog);
668
669                printf "DEBUG: programme xmltv: ".Dumper($prog) if ((defined $opt->{debug}) && ($opt->{debug} > 1));
670                $writer->write_programme($prog);
671        }
672}
673
674##############################################################################
675
676sub fetch_one_prog
677{
678        my ($cache_key, $event_id) = @_;
679        &log("fetching detail page for $cache_key with event_id $event_id") if (defined $opt->{debug});
680
681        my $url = "http://au.tv.yahoo.com/tv-guide/broker.html?event_id=".$event_id;
682        my $data = &get_url($url,5);
683
684        if ((!$data) || ($data !~ /^\{.*\}$/)) {
685                $stats{bad_details_page}++;
686                return;
687        }
688
689        $stats{added_to_cache}++;
690
691        if (($stats{added_to_cache} % 35) == 0) {
692                my $wait_for = 12 + int(rand(5));
693                $stats{slept_for} += $wait_for;
694                sleep $wait_for;
695        }
696
697        my @genre;
698
699        $data =~ s/(^\{|\}$)//g; # strip leading/trailing { and }
700        foreach my $field_item (split(/,"/,$data)) {
701                if ($field_item =~ /^([A-Za-z0-9\_\"]+):(.*)/) {
702                        my ($f, $v) = ($1, $2);
703                        $f =~ s/(^\"|\"$)//g;   # strip leading/trailing quotes from field if present
704                        $v =~ s/(^\"|\"$)//g;   # strip leading/trailing quotes from value if present
705                        next if ($v eq "");
706
707                        if ($f eq "title") {
708                                ; # nothing
709                        } elsif ($f eq "subtitle") {
710                                $data_cache->{$cache_key}->{'sub-title'} = [[ $v, $opt->{lang} ]];
711                        } elsif ($f eq "description") {
712                                $data_cache->{$cache_key}->{desc} = [[ $v, $opt->{lang} ]];
713                        } elsif ($f eq "genre") {
714                                push(@genre, translate_category($v));
715                        } elsif ($f eq "captions") {
716                                $data_cache->{$cache_key}->{subtitles} = [ { 'type' => 'teletext' } ] if ($v eq "true");
717                        } elsif ($f eq "start_date") {
718                                ; # nothing
719                        } elsif ($f eq "end_date") {
720                                ; # nothing
721                        } elsif ($f eq "rating") {
722                                ; # nothing
723                        } elsif ($f eq "channel") {
724                                ; # nothing
725                        } elsif ($f eq "hotpick") {
726                                ; # nothing
727                        } elsif ($f eq "venue_url") {
728                                ; # nothing
729                        } elsif ($f eq "url") {
730                                ; # nothing
731                        } elsif ($f eq "alt_url") {
732                                ; # nothing
733                        } elsif ($f eq "alt_text") {
734                                ; # nothing
735                        } elsif ($f eq "img") {
736                                ; # nothing
737                        } else {
738                                &log("unknown field '$f' in $url") if (!defined $d->{unknown_fields}->{$f});
739                                $d->{unknown_fields}->{$f} = 1;
740                        }
741
742                        $data_cache->{$cache_key}->{category} = [[ @genre ]] if ($#genre != -1);
743
744                } else {
745                        &log("unknown field format '$field_item' in details. Has the format changed?");
746                        $stats{unknown_details_field_format}++;
747                }
748        }
749
750        printf "DEBUG: cached entries for '$cache_key': ".Dumper($data_cache->{$cache_key})
751          if (defined $opt->{debug});
752}
753
754##############################################################################
755
756sub setup_socks
757{
758        use LWP::Protocol::http;
759        my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
760
761        # override LWP::Protocol::http's _new_socket method with our own
762        local($^W) = 0;
763        *LWP::Protocol::http::_new_socket = \&socks_new_socket;
764
765        # test that it works
766        &log("configured to use Tor, testing that it works by connecting to www.google.com ...");
767        my $data = &get_url("http://www.google.com/",10);
768        if (($data) && ($data =~ /Google/i)) {
769                &log("success.  Tor appears to be working!");
770                return;
771        }
772
773        &log("ERROR: Could not connect to www.google.com via Tor, disabling Tor.");
774        &log("       DATA FETCHING WILL BE VERY SLOW.");
775        &log("       DISABLING DETAILS-FETCHING BECAUSE OF THIS - SIGNIFICANTLY LOWER DATA QUALITY!!");
776
777        $opt->{no_details} = 1;
778        delete $opt->{anon_socks};
779        $stats{fallback_to_non_tor}++;
780
781        *LWP::Protocol::http::_new_socket = $orig_new_socket;
782}
783
784##############################################################################
785# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
786
787sub socks_new_socket
788{
789        my($self, $host, $port, $timeout) = @_;
790
791        my ($socks_ip,$socks_port) = split(/:/,$opt->{anon_socks});
792        $socks_ip = "127.0.0.1" if (!defined $socks_ip);
793        $socks_port = "9050" if (!defined $socks_port);
794
795        local($^W) = 0;  # IO::Socket::INET can be noisy
796        my $sock = $self->socket_class->new(
797                PeerAddr => $socks_ip,
798                PeerPort => $socks_port,
799                Proto    => 'tcp');
800
801        unless ($sock) {
802                # IO::Socket::INET leaves additional error messages in $@
803                $@ =~ s/^.*?: //;
804                &log("Can't connect to $host:$port ($@)");
805                return undef;
806        }
807
808        # perl 5.005's IO::Socket does not have the blocking method.
809        eval { $sock->blocking(0); };
810
811        # establish connectivity with socks server - SOCKS4A protocol
812        print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
813                (pack 'x') .
814                $host . (pack 'x');
815
816        my $received = "";
817        my $timeout_time = time + $timeout;
818        while ($sock->sysread($received, 8) && (length($received) < 8) ) {
819                select(undef, undef, undef, 0.25);
820                last if ($timeout_time < time);
821        }
822
823        if ($timeout_time < time) {
824                &log("Timeout ($timeout) while connecting via SOCKS server");
825                return $sock;
826        }
827
828        my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
829        &log("Connection via SOCKS4A server rejected or failed") if ($req_status == 0x5b);
830        &log("Connection via SOCKS4A server because client is not running identd") if ($req_status == 0x5c);
831        &log("Connection via SOCKS4A server because client's identd could not confirm the user") if ($req_status == 0x5d);
832
833        $sock;
834}
835
836##############################################################################
837
838sub parse_time
839{
840        my ($hr, $min, $ampm) = @_;
841
842        $hr = 0 if ($hr == 12);
843        $hr += 12 if ($ampm =~ /p/i);
844
845        return(($hr*60*60)+($min*60));
846}
847
848##############################################################################
849
850sub window_is_within_microgap
851{
852        my ($start, $stop, $channel) = @_;
853
854        return window_channel_is_within_microgap($start, $stop, $channel) if (defined $channel);
855
856        foreach my $ch (keys %{$channels}) {
857                return 1 if window_channel_is_within_microgap($start, $stop, $ch);
858        }
859        return 0;
860}
861
862sub window_channel_is_within_microgap
863{
864        my ($start, $stop, $channel) = @_;
865
866        if (defined $gaps->{$channel}) {
867                foreach my $g (@{($gaps->{$channel})}) {
868                        my ($s, $e) = split(/-/,$g);
869                        return 1 if
870                          ((($s >= $start) && ($s <= $stop)) ||
871                           (($e >= $start) && ($e <= $stop)) ||
872                           (($s <= $start) && ($e >= $stop)));
873                }
874        }
875        $stats{gaps_skipped}++;
876        return 0;
877}
878
879##############################################################################
Note: See TracBrowser for help on using the browser.