root/trunk/references/Shepherd/Common.pm @ 1044

Revision 1044, 33.9 kB (checked in by paul, 5 years ago)

flag_aus_hdtv: use new site http://www.dtvforum.info/index.php?showtopic=28574

support Prime HD and falling back on Nine HD if not present
force "CSI: Crime Scene Investigation", "Without a Trace" as HD

Common.pm: add function to get_mirror_file if less then days_good and decompress if needed
sbsnews_website: use get_mirror_file
Line 
1#!/usr/bin/perl
2#
3# Shepherd::Common library
4
5my $version = '0.35';
6
7#
8# This module provides some library functions for Shepherd components,
9# relieving them of the need to duplicate functionality.
10#
11# To use this library, components simply need to include the line:
12#
13#   use Shepherd::Common;
14
15package Shepherd::Common;
16
17use LWP::UserAgent;
18use HTTP::Request;
19use HTTP::Request::Common;
20use Compress::Zlib;
21use Storable;
22use Data::Dumper;
23use POSIX qw(strftime mktime);
24use Getopt::Long;
25
26my $gmt_offset;
27my $ua;
28my $socks_ip, my $socks_port;
29my %defaults;
30my $prev_referer = "";
31my ($last_request, $last_failed_request) = (0, 0);
32
33sub program_begin
34{
35        my ($oo, $program_name, $version_number, $stats) = @_;
36        my $o = $$oo;
37
38        $o->{program_name}      = $program_name;
39        $o->{version_number}    = $version_number;
40        $o->{script_start_time} = time;
41
42        $o->{offset}            = 0                     if !defined $o->{offset};
43        $o->{days}              = 7                     if !defined $o->{days};
44        $o->{outputfile}        = "output.xmltv"        if !defined $o->{outputfile};
45        $o->{cache_file}        = $program_name.".storable.cache" if !defined $o->{cache_file};
46        $o->{lang}              = "en"                  if !defined $o->{lang};
47        $o->{region}            = 75                    if !defined $o->{region};
48
49        GetOptions(
50                'log-http'      => \$o->{log_http},
51                'region=i'      => \$o->{region},
52                'days=i'        => \$o->{days},
53                'offset=i'      => \$o->{offset},
54                'timezone=s'    => \$o->{timezone},
55                'channels_file=s' => \$o->{channels_file},
56                'gaps_file=s'   => \$o->{gaps_file},
57                'output=s'      => \$o->{outputfile},
58                'cache-file=s'  => \$o->{cache_file},
59                'fast'          => \$o->{fast},
60                'no-cache'      => \$o->{no_cache},
61                'no-details'    => \$o->{no_details},
62                'debug+'        => \$o->{debug},
63                'all_channels'  => \$o->{all_channels},
64                'warper'        => \$o->{warper},
65                'lang=s'        => \$o->{lang},
66                'obfuscate'     => \$o->{obfuscate},
67                'anonsocks=s'   => \$o->{anon_socks},
68                'help'          => \$o->{help},
69                'verbose'       => \$o->{help},
70                'version'       => \$o->{version},
71                'ready'         => \$o->{version},
72                'v'             => \$o->{version});
73
74        if ($o->{version}) {
75                Shepherd::Common::log(sprintf "%s v%s",$o->{program_name},$o->{version_number});
76                exit(0);
77        }
78
79        &help($o) if ($o->{help});
80
81        Shepherd::Common::log(sprintf "%s v%s going to %sgrab %d days%s of data into %s (%s%s%s)",
82                $o->{program_name}, $o->{version_number},
83                (defined $o->{gaps_file} ? "micro-gap " : ""),
84                $o->{days},
85                ($o->{offset} ? " (skipping first $o->{offset} days)" : ""),
86                $o->{outputfile},
87                (defined $o->{fast} ? "with haste" : "slowly"),
88                (defined $o->{anon_socks} ? ", via multiple endpoints" : ""),
89                (defined $o->{warper} ? ", anonymously" : ""),
90                (defined $o->{no_details} ? ", without details" : ", with details"),
91                (defined $o->{no_cache} ? ", without caching" : ", with caching"));
92
93
94        Shepherd::Common::set_default("debug", (defined $o->{debug} ? 2 : 0));
95        Shepherd::Common::set_default("webwarper", 1) if (defined $o->{warper});
96        Shepherd::Common::set_default("squid", 1) if (defined $o->{obfuscate});
97        Shepherd::Common::set_default("referer", "last");
98        Shepherd::Common::set_default("delay" => "0-4") if (!defined $o->{fast} && !defined $o->{debug});
99        Shepherd::Common::set_default("retry_delay", 10);
100        Shepherd::Common::set_default("cookie_jar" => 1);
101        Shepherd::Common::set_default("referer" => "last");
102        Shepherd::Common::set_default(stats => $stats);
103        Shepherd::Common::setup_socks($o->{anon_socks}) if (defined $o->{anon_socks});
104
105        $$oo = $o;
106}
107
108sub help
109{
110        my $o = shift;
111
112        print<<EOF
113$o->{program_name} v$o->{version_number}
114
115options are as follows:
116        --help                  show these help options
117        --days=N                fetch 'n' days of data (default: $o->{days})
118        --output=file           send xml output to file (default: "$o->{outputfile}")
119        --no-cache              don't use a cache to optimize (reduce) number of web queries
120        --no-details            don't fetch detailed descriptions (default: do)
121        --cache-file=file       where to store cache (default "$o->{cache_file}")
122        --fast                  don't run slow - get data as quick as you can - not recommended
123        --anonsocks=(ip:port)   use SOCKS4A server at (ip):(port) (for Tor: recommended)
124
125        --debug                 increase debug level
126        --warper                fetch data using WebWarper web anonymizer service
127        --obfuscate             pretend to be a proxy servicing multiple clients
128        --lang=[s]              set language of xmltv output data (default $o->{lang})
129
130        --channels_file=file    where to get channel data from
131        --gaps_file=file        micro-fetch gaps only
132        --region=N              set region for where to collect data from (default: $o->{region})
133
134EOF
135;
136
137        exit(0);
138}
139
140sub read_channels
141{
142        my ($o, @supported_channels) = @_;
143
144        die "No channel file specified, see --help for instructions.\n", if (!$o->{channels_file});
145
146        my ($channels, $opt_channels);
147        if (-r $o->{channels_file}) {
148                local (@ARGV, $/) = ($o->{channels_file});
149                no warnings 'all'; eval <>; die "$@" if $@;
150        } else {
151                die "Channels file $o->{channels_file} could not be read: $!\n";
152        }
153
154        if (@supported_channels > 0) {
155                my $found = 0;
156                foreach (@supported_channels) {
157                        if (exists $channels->{$_} || exists $opt_channels->{$_}) {
158                                $found = 1;
159                                last;
160                        }
161                }
162                die "No supported channels found. (channels:".
163                                join(",", keys %$channels).", opt_channels:".
164                                join(",", keys %$opt_channels).")\n"
165                                if ($found != 1);
166        }
167
168        my $gaps;
169        if (defined $o->{gaps_file}) {
170                if (-r $o->{gaps_file}) {
171                        local (@ARGV, $/) = ($o->{gaps_file});
172                        no warnings 'all'; eval <>; die "$@" if $@;
173                } else {
174                        die "Gaps file $o->{gaps_file} could not be read: $!\n";
175                }
176
177                if (@supported_channels > 0) {
178                        my $found = 0;
179                        foreach (@supported_channels) {
180                                if (exists $gaps->{$_}) {
181                                        $found = 1;
182                                        last;
183                                }
184                        }
185                        die "No supported channels in gaps file found. (channels:".
186                                        join(",", keys %$gaps).")\n"
187                                        if ($found != 1);
188                }
189        }
190
191        return ($channels, $opt_channels, $gaps);
192}
193
194sub program_end
195{
196        my ($o, %stats) = @_;
197        printf "STATS: %s v%s completed in %d seconds",
198                        $o->{program_name}, $o->{version_number}, (time - $o->{script_start_time});
199        foreach my $key (sort keys %stats) {
200                printf ", %d %s",$stats{$key},$key;
201        }
202        printf "\n";
203}
204
205##########################################################################
206# get_url
207#
208# Simple version:
209# $content = Shepherd::Common::get_url('http://www.example.com');
210#
211# Or send a hash of options:
212# $content = Shepherd::Common::get_url(url => 'http://www.example.com',
213#                                      retries => 0, retry_delay => 60);
214#
215# May also call in list context for more status info (see below):
216# @response = Shepherd::Common::get_url(url => 'http://www.example.com',
217#                                       fake => 0, debug => 5);
218#
219# Takes a hash of options. Only 'url' is required; all others are optional:
220#   url           : The URL to fetch
221#   method        : GET, POST or HEAD (default: GET, unless sent 'postvars')
222#   mirror        : stores into the given filename, updating only when non-existing or newer
223#   postvars      : variables to send in a POST (default: <none>)
224#   retries       : # of times to try to fetch URL (default: 2)
225#   delay         : seconds to sleep between fetches (default: 0)
226#   retry_delay   : seconds to sleep between failed fetches (default: 10)
227#   webwarper     : whether to use webwarper (default: 0)
228#   referer       : what to set 'Referer' string to (default: <none>)
229#   ua            : a LWP::UserAgent object (default: <will create new one>)
230#   fake          : fake User Agent to imitate a random browser (default: 1)
231#   squid         : obfuscate IP by imitating Squid proxy (default: 0)
232#   gzip          : GZip compression support (default: 1)
233#   headers       : ref to array of any additional headers (default: <none>)
234#   debug         : set debug level; 0 = silent, 5 = noisy (default: 1)
235#   stats         : reference to stats hash (see below)
236#
237# If called in list context, returns an array:
238# 0. content (string)
239# 1. success (boolean: 1 indicates success)
240# 2. status/error_message (string)
241# 3. bytes fetched (integer)
242# 4. seconds_slept_for (integer)
243# 5. number of failed attempts (integer)
244# 6. HTTP::Response object
245#
246# If called in scalar context, returns the content downloaded, or undef if
247# the download failed (which includes getting things like 401 pages).
248#
249# 'stats'
250# If sent a reference as an arg to 'stats' (eg: stats => \%stats), will
251# populate with statistics for:
252#   slept_for           Number of seconds spent sleeping
253#   bytes_fetched       Number of bytes downloaded
254#   failed_requests     Number of failed attempted downloads
255#   successful_requests Number of pages sucessfully downloaded
256# If any of these fields already exist, they will be modified, not
257# overwritten -- so you can send along your existing stats hash and
258# it won't be reset, just added to.
259#
260# 'delay' and 'retry_delay'
261# This library tracks how long it has been since the last request
262# and makes sure not to launch a new request more often than every X
263# seconds. The time to sleep can be specified either as an integer
264# (EG: delay => 10) or a string range (EG: delay => "1-5"), in which
265# case a random integer is chosen from that range. Upon failure,
266# we will sleep for 'retry_delay' if that is specified; otherwise
267# for 'delay'.
268#
269# It makes sense to set many/most of these variables once only via the
270# set_default() or set_defaults() functions. EG:
271#   Shepherd::Common::set_defaults( stats => \%stats, delay => "5-10");
272#
273sub get_url
274{
275    my %cnf;
276    if (@_ == 1)
277    {
278        $cnf{url} = shift;
279    }
280    else
281    {
282        %cnf = @_;
283    }
284
285    # App defaults
286    foreach my $k (keys %defaults) {
287        $cnf{$k} = $defaults{$k} unless (defined $cnf{$k});
288    }
289
290    # Defaults
291    $cnf{method} = 'GET' unless (defined $cnf{method});
292    $cnf{retries} = 2 unless (defined $cnf{retries});
293    $cnf{fake} = 1 unless (defined $cnf{fake});
294    $cnf{gzip} = 1 unless (defined $cnf{gzip});
295    $cnf{delay} = 0 unless (defined $cnf{delay});
296    $cnf{retry_delay} = 10 unless (defined $cnf{retry_delay} or $cnf{delay});
297    $cnf{debug} = 1 unless (defined $cnf{debug});
298
299    $this_url = $cnf{url};
300
301    # User Agent
302    $ua = $cnf{ua} if ($cnf{ua});
303    &setup_ua(%cnf) unless (ref $ua);
304
305    # Webwarper
306    if ($cnf{webwarper})
307    {
308        $cnf{url} =~ s#^http://#http://webwarper.net/ww/#;
309        print "Using WebWarper.\n" if ($cnf{debug} > 2);
310    }
311
312    # Method
313    my $request;
314    if ($cnf{method} eq "HEAD") 
315    {
316        $request = HEAD $cnf{url};
317    }
318    elsif ($cnf{method} eq "POST" or $cnf{postvars}) 
319    {
320        $request = POST $cnf{url}, Content => $cnf{postvars};
321    }
322    else
323    {
324        $request = GET $cnf{url};
325    }
326
327    # GZip Compression
328    $request->header('Accept-Encoding' => 'gzip') unless (!$cnf{gzip});
329
330    # Referer
331    if (defined $cnf{referer})
332    {
333        if ($cnf{referer} eq "last")
334        {
335            $request->header('Referer' => $prev_referer) if ($prev_referer ne "");
336        } else {
337            $request->header('Referer' => $cnf{referer});
338        }
339    }
340
341    # Squid IP masking
342    if ($cnf{squid})
343    {
344        my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1);
345        $request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)');
346        $request->header('X-Forwarded-For' => $randomaddr);
347    }
348
349    # Don't print out passwords
350    my $urlname = $cnf{url};
351    $urlname =~ s/:[^:]+@/:********@/g;
352
353    # Additional Headers
354    if ($cnf{headers})
355    {
356        foreach my $additional_header (@{$cnf{headers}})
357        {
358            my ($header, $value) = split(/: /,$additional_header);
359            $request->header($header, $value);
360        }
361    }
362
363    if ($cnf{debug} > 4)
364    {
365        print "Prepared request: " . Dumper($request) . "\n";
366    }
367
368    # Sleep if less than specified delay since last request
369    my $slept_for = check_delay(\%cnf);
370
371    # Fetch!
372    my $response;
373    my $success;
374    my $failures = 0;
375    my $bytes;
376    for (0 .. $cnf{retries}) 
377    {
378        if ($cnf{debug})
379        {
380            print "Fetching $urlname";
381            printf "%s...\n",
382                   ($cnf{debug} > 1 ? " (attempt ".($failures+1)." of ".($cnf{retries}+1).")" : '');
383        }
384
385        if (not $cnf{mirror}) {
386            $response = $ua->request($request);
387        } else {
388            $response = mirror($ua, $request, $cnf{mirror}); # use our mirror
389        }
390        $last_request = time;
391        if ($cnf{debug} > 2)
392        {
393            print "Response: " . $response->status_line . "\n";
394        }
395
396        $bytes = do { use bytes; length($response->content) };
397        $bytes = 0 if ($cnf{mirror} && !$response->is_success && !$response->is_error);
398        add_stat('bytes', $bytes, $cnf{stats});
399
400        $success = 1 unless ($response->is_error);
401        last if ($success);
402
403        $success = 0;   # Make it boolean, not an empty string
404        $failures++;
405        $last_failed_request = time;
406        add_stat('failed_requests', 1, $cnf{stats});
407        print "Attempt $failures failed to fetch $urlname\n";
408        if ($failures <= $cnf{retries})
409        {
410            $slept_for += check_delay(\%cnf, 'retry_delay');
411        }
412        else
413        {
414            print "Failed to retrieve $urlname: " . $response->status_line . "\n";
415        }
416    }
417
418    if ($response->header('Content-Encoding') && 
419        $response->header('Content-Encoding') eq 'gzip') 
420    {
421        $response->content(Compress::Zlib::memGunzip($response->content));
422    }
423
424    if ($success)
425    {
426        add_stat('successful_requests', 1, $cnf{stats});
427        if ($cnf{debug})
428        {
429            printf "Successfully fetched %s.\n",
430               ($bytes >= 1024 ? (int($bytes/1024) . " KB") : "$bytes bytes");
431        }
432    }
433
434    # Record last URL we fetched
435    $prev_referer = $this_url;
436
437    # If called in list context, return all our goodies
438    if (wantarray)
439    {
440        return ($response->content,
441                $success,
442                $response->status_line,
443                $bytes,
444                $slept_for,
445                $failures,
446                $response);
447    }
448
449    # If called in scalar context, just return content or undef
450    return $response->content if ($success);
451    return undef;
452}
453
454# our mirror uses a $request object and returns content
455sub mirror
456{
457    my($self, $request, $file) = @_;
458
459    if (-e $file) {
460        my($mtime) = (stat($file))[9];
461        if($mtime) {
462            $request->header('If-Modified-Since' =>
463                             HTTP::Date::time2str($mtime));
464        }
465    }
466    my $tmpfile = "$file-$$";
467
468    my $response = $self->request($request, $tmpfile);
469    if ($response->is_success) {
470
471        my $file_length = (stat($tmpfile))[7];
472        my($content_length) = $response->header('Content-length');
473
474        if (defined $content_length and $file_length < $content_length) {
475            unlink($tmpfile);
476            die "Transfer truncated: " .
477                "only $file_length out of $content_length bytes received\n";
478        }
479        elsif (defined $content_length and $file_length > $content_length) {
480            unlink($tmpfile);
481            die "Content-length mismatch: " .
482                "expected $content_length bytes, got $file_length\n";
483        }
484        else {
485            # OK
486            if (-e $file) {
487                # Some dosish systems fail to rename if the target exists
488                chmod 0777, $file;
489                unlink $file;
490            }
491            rename($tmpfile, $file) or
492                die "Cannot rename '$tmpfile' to '$file': $!\n";
493
494            if (my $lm = $response->last_modified) {
495                # make sure the file has the same last modification time
496                utime $lm, $lm, $file;
497            }
498        }
499    }
500    else {
501        unlink($tmpfile);
502    }
503
504    if (!$response->is_error) {
505        my $data;
506        open(FILE, $file) || die "Can't read $file: $!";
507        binmode(FILE); # DOS / Windows rubbish
508        read(FILE, $data, -s FILE);
509        close(FILE);
510        $response->content($data);
511    }
512
513    return $response;
514}
515
516# if mirror file not too old then read it in and uncompress
517sub get_mirror_file
518{
519        my ($file, $days_good) = @_;
520
521        my $data;
522        if (-r $file) {
523                my $mirror_age = int(((time - (stat($file))[9]) / (24*60*60)) + 0.5); # days old
524                if ($mirror_age <= $days_good) {
525                        if (open(FILE, $file)) {
526                                binmode(FILE); # DOS / Windows rubbish
527                                read(FILE, $data, -s FILE);
528                                close(FILE);
529       
530                                # If the original web page was sent gzipped then the mirror file
531                                # is gzipped and should be unpacked
532                                if ($data =~ m/^\037\213/) {    # magic number at start of gzip file
533                                        $data = Compress::Zlib::memGunzip($data);
534                                }
535                        }
536                } else {
537                        printf("Mirror file to old at %d days and needs to be less then %d days.\n",$mirror_age, $days_good);
538                }
539        }
540        return $data;
541}
542
543# Sleep if it's been less than the specified min. seconds since our
544# last request.
545sub check_delay
546{
547    my ($cnf, $type) = @_;
548
549    my $delay = (($type and defined $cnf->{$type}) ? $cnf->{$type} : $cnf->{delay});
550    if ($delay =~ /(\d+)-(\d+)/)
551    {
552        $delay = int($1 + rand($2 - $1) + 0.5);
553    }
554    $delay -= time - (($type and $type eq 'retry_delay') ? $last_failed_request : $last_request);
555    return 0 unless ($delay > 0);
556    print "Sleeping for $delay seconds...\n" if ($cnf->{debug});
557    sleep $delay;
558    add_stat('slept_for', $delay, $cnf->{stats});
559    return $delay;
560}
561
562sub add_stat
563{
564    my ($name, $val, $statref) = @_;
565    if (ref $statref)
566    {
567        if ($statref->{$name})
568        {
569            $statref->{$name} += $val;
570        }
571        else
572        {
573            $statref->{$name} = $val;
574        }
575    }
576}
577
578# Creates a user-agent object to be used for all future get_url() calls.
579sub setup_ua
580{
581    my %cnf = @_;
582    $cnf{debug} = 1 if (!defined $cnf{debug});
583
584    print "Establishing user agent.\n" if ($cnf{debug} > 3);
585
586    $ua = LWP::UserAgent->new( keep_alive => 1 );
587    $ua->env_proxy();
588
589    my @agent_list = (
590        'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.3) Gecko/20070309 Firefox/2.0.0.3',
591        'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.11) Gecko/20070312 Firefox/1.5.0.11',
592        'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-GB; rv:1.8.1.3) Gecko/20070309 Firefox/2.0.0.3',
593        'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.3) Gecko/20061201 Firefox/2.0.0.3 (Ubuntu-feisty)',
594        'Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US; rv:1.8.1.3) Gecko/20070309 Firefox/2.0.0.3',
595        'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
596        'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)',
597        'Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322)',
598        'Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1)',
599        'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85.8.5 (KHTML, like Gecko) Safari/85.8.1',
600        'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox',
601        'Opera/9.10 (X11; Linux i686; U; en)',
602        'Opera/9.10 (Windows NT 5.2; U; en)',
603        'Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)',
604        'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412',
605        'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-us) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
606        'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; fr) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3'
607    );
608
609    my $agent = ($cnf{fake} ? $agent_list[int(rand($#agent_list+1))] : ($cnf{agent} ? $cnf{agent} : 'Shepherd'));
610    $ua->agent($agent);
611               
612    print "User Agent string set to \"" . $ua->agent() . "\".\n" if ($cnf{debug} > 3); 
613
614    $ua->cookie_jar({}) if (defined $cnf{cookie_jar});
615
616    push @{ $ua->requests_redirectable }, 'POST';
617
618    return $ua;
619}
620
621##########################################################################
622# helper routine to set default settings so they don't need to be passed
623# in every time
624
625# EG: Shepherd::Common::set_default("squid", 1)
626sub set_default
627{
628        my ($name, $value) = @_;
629        $value = 0 if ($name eq 'debug' and !defined $value);
630        $defaults{$name} = $value;
631}
632
633# EG: Shepherd::Common::set_defaults( squid => 1, retries => 2)
634sub set_defaults
635{
636    my %h = @_;
637    foreach (keys %h)
638    {
639        set_default($_, $h{$_});
640    }
641}
642
643##########################################################################
644# descend a structure and clean up various things, including stripping
645# leading/trailing spaces in strings, translations of html stuff etc
646#   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
647
648sub cleanup {
649    my $x = shift;
650    my $desc = shift;
651
652    if    (ref $x eq "REF")   { cleanup($$x, $desc) }
653    elsif (ref $x eq "HASH")  {
654        while (my ($k, $v) = each %$x) {
655           cleanup(\$v, $k eq "desc");
656        }
657    }
658    elsif (ref $x eq "ARRAY") { cleanup(\$_, $desc) for @$x }
659    elsif (defined $$x) {
660        my %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } );
661
662        $$x =~ s/&(#((x?)\d+)|(.*?));/ $2 ? ($3 ? chr("0".$2) : chr($2)) : $amp{$4} || ' ' /eg;
663        $$x =~ s/\xA0/ /g; # &nbsp; can be &#160; == &#xA0;
664        $$x =~ s/^\s+//s;
665        $$x =~ s/\s+$//s;
666        if (!$desc) { # if desc leave in \n etc
667            $$x =~ s/\s+/ /g;
668        }
669    }
670}
671
672
673##########################################################################
674# strptime type date parsing - BUT - if no timezone is present, treat
675# time as being in localtime rather than the various other perl
676# implementation which treat it as being in UTC/GMT
677
678sub parse_xmltv_date
679{
680    my $datestring = shift;
681    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
682    my $tz_offset = 0;
683
684    # work out GMT offset - we only do this once
685    if (!$gmt_offset) {
686        my $tzstring = strftime("%z", localtime(time));
687
688        $gmt_offset = (60*60) * int(substr($tzstring,1,2));     # hr
689        $gmt_offset += (60 * int(substr($tzstring,3,2)));       # min
690        $gmt_offset *= -1 if (substr($tzstring,0,1) eq "-");    # +/-
691    }
692
693    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
694        ($t[5],$t[4],$t[3],$t[2],$t[1],$t[0]) = (int($1)-1900,int($2)-1,int($3),int($4),int($5),0);
695        ($t[6],$t[7],$t[8]) = (-1,-1,-1);
696
697        # if input data has a timezone offset, then offset by that
698        if ($datestring =~ /\+(\d{2})(\d{2})/) {
699            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
700        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
701            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
702        }
703
704        my $e = mktime(@t);
705        return ($e+$tz_offset) if ($e > 1);
706    }
707    return undef;
708}
709
710##########################################################################
711# setup SOCKS proxy override for LWP and test that it works
712
713sub setup_socks
714{
715    $socks_server = shift;
716    ($socks_ip,$socks_port) = split(/:/,$socks_server);
717
718    use LWP::Protocol::http;
719    my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
720
721    # override LWP::Protocol::http's _new_socket method with our own
722    local($^W) = 0;
723    *LWP::Protocol::http::_new_socket = \&socks_new_socket;
724
725    # test that it works
726    my $data = &get_url(url => "http://www.google.com/", retries => 10);
727    return 1 if (($data) && ($data =~ /Google/i));
728
729    # failed
730    *LWP::Protocol::http::_new_socket = $orig_new_socket;
731    return 0;
732}
733
734##############################################################################
735# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
736
737sub socks_new_socket
738{
739    my($self, $host, $port, $timeout) = @_;
740
741    $socks_ip = "127.0.0.1" if (!defined $socks_ip);
742    $socks_port = "9050" if (!defined $socks_port);
743
744    local($^W) = 0;  # IO::Socket::INET can be noisy
745    my $sock = $self->socket_class->new(
746        PeerAddr => $socks_ip,
747        PeerPort => $socks_port,
748        Proto    => 'tcp');
749
750    unless ($sock) {
751        # IO::Socket::INET leaves additional error messages in $@
752        $@ =~ s/^.*?: //;
753        printf "Can't connect to $host:$port ($@)\n";
754        return undef;
755    }
756
757    # perl 5.005's IO::Socket does not have the blocking method.
758    eval { $sock->blocking(0); };
759
760    # establish connectivity with socks server - SOCKS4A protocol
761    print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) . (pack 'x') . $host . (pack 'x');
762
763    my $received = "";
764    my $timeout_time = time + $timeout;
765    while ($sock->sysread($received, 8) && (length($received) < 8) ) {
766        select(undef, undef, undef, 0.25);
767        last if ($timeout_time < time);
768    }
769
770    if ($timeout_time < time) {
771        printf "Timeout ($timeout) while connecting via SOCKS server\n";
772        return $sock;
773    }
774
775    my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
776    printf "Connection via SOCKS4A server rejected or failed\n" if ($req_status == 0x5b);
777    printf "Connection via SOCKS4A server because client is not running identd\n" if ($req_status == 0x5c);
778    printf "Connection via SOCKS4A server because client's identd could not confirm the user\n" if ($req_status == 0x5d);
779
780    $sock;
781}
782
783##########################################################################
784
785sub urlify
786{
787    my $str = shift;
788    $str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
789    $str =~ s/%20/+/g;
790    $str =~ s/%2D/-/g;
791    return $str;
792}
793
794##############################################################################
795
796sub translate_category
797{
798    my $genre = shift;
799    my %translation = (
800        'Sport' => 'sports',
801        'Soap Opera' => 'Soap',
802        'Science and Technology' => 'Science/Nature',
803        'Real Life' => 'Reality',
804        'Cartoon' => 'Animation',
805        'Family' => 'Children',
806        'Murder' => 'Crime' );
807    return $translation{$genre} if defined $translation{$genre};
808    return $genre;
809}
810
811##########################################################################
812
813# if no category then guess from title for Sport, News, Infomercial
814# translates the words in category
815# types (final,premiere,return,live) are prepend to category
816# types (movie,sports,series,tvshow) are appended to category list
817sub generate_category
818{
819    my ($title, $category, %type) = @_;
820
821    $type{sports} = 1 if ($title && $title=~/(^|\W)Sports?(\W|$)/i);
822    $type{sports} = 1 if ($category && $category=~/(^|\W)Sports?(\W|$)/i);
823
824    if ($category) {
825        if ($category eq "movie") {
826            $category = "Movie";
827            $type{movie} = 1;
828        } elsif ($category eq "sports") {
829            $category = "Sports";
830            $type{sports} = 1;
831        } elsif ($category eq "series") {
832            $category = "Series";
833            $type{series} = 1;
834        } elsif ($category eq "tvshow") {
835            $category = "TVShow";
836            $type{tvshow} = 1;
837        }
838        $category =~ s/Soap Opera/Soap/ig;
839        $category =~ s/Science and Technology/Science\/Nature/ig;
840        $category =~ s/Real Life/Reality/ig;
841        $category =~ s/Cartoon/Animation/ig;
842        $category =~ s/Family/Children/ig;
843        $category =~ s/Murder/Crime/ig;
844    } else { # !$category
845        if ($title) {
846            if ($title=~/(^|\W)News(\W|$)/i) {
847                $category = "News";
848            } elsif ($title=~/(^|\W)Infomercials?(\W|$)/i) {
849                $category = "Infotainment";
850            }
851        }
852        if (!$category) {
853            if ($type{movie}) {
854                $category = "Movie";
855            } elsif ($type{sports}) {
856                $category = "Sports";
857            } elsif ($type{series}) {
858                $category = "Series";
859            } elsif ($type{tvshow}) {
860               $category = "TVShow";
861            }
862        }
863    }
864
865    $category = "" if (!$category);
866    $category = "Live $category" if ($type{live});
867    $category = "Return $category" if ($type{return});
868    $category = "Premiere $category" if ($type{premiere});
869    $category = "Final $category" if ($type{final});
870    $category =~ s/^\s*(.*?)\s*$/$1/;
871
872    my @result;
873    @result = [ $category, "en"] if $category;
874    push(@result, [ "movie"  ]) if $type{movie};
875    push(@result, [ "sports" ]) if $type{sports};
876    push(@result, [ "series" ]) if $type{series};
877    push(@result, [ "tvshow" ]) if $type{tvshow};
878
879    return @result;
880}
881
882##########################################################################
883
884# (Adult Themes)
885# (Some Violence, Adult Themes, Supernatural Themes)
886# (Drug References, Adult Themes)
887# (Very Coarse Language, Sexual References, Drug References, Adult Themes, Nudity)
888# (Some Violence)
889# (Drug Use, Strong Adult Themes)
890# (Some Violence, Adult Themes)
891# (Some Coarse Language)
892# (Sexual References)
893# (Mild Coarse Language, Sexual References)
894# (Sex Scenes, Adult Themes, Supernatural Themes)
895# (Adult Themes, Medical Procedures)
896## (Qualifying - Sat)
897sub subrating
898{
899  my $string = shift || "";
900
901  my @subrating;
902  push(@subrating, "v") if $string =~ /Violence/i;
903  push(@subrating, "l") if $string =~ /Language/i;
904  push(@subrating, "s") if $string =~ /Sex/i;
905  push(@subrating, "d") if $string =~ /Drug/i;
906  push(@subrating, "a") if $string =~ /Adult/i;
907  push(@subrating, "n") if $string =~ /Nudity/i;
908  push(@subrating, "h") if $string =~ /Horror|Supernatural/i;
909  push(@subrating, "m") if $string =~ /Medical/i;
910
911  return join(",",@subrating);
912}
913
914##########################################################################
915
916sub log
917{
918        my ($entry) = @_;
919        printf "%s\n",$entry;
920}
921
922##########################################################################
923
924sub print_stats
925{
926        my ($progname, $version, $script_start_time, %stats) = @_;
927        my $now = time;
928        printf "STATS: %s v%s completed in %d seconds",
929          $progname, $version, ($now-$script_start_time);
930        foreach my $key (sort keys %stats) {
931                printf ", %d %s",$stats{$key},$key;
932        }
933        printf "\n";
934}
935
936##########################################################################
937# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
938# and indication of whether the duration is over its threshold or not
939
940sub pretty_duration
941{
942    my ($d,$crit) = @_;
943    my $s = "";
944    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
945    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if ($d > (60*60));
946    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if ($d > 60);
947    $s .= sprintf "%ds",int($d % 60) if ($d > 0);
948    $s .= "[!]" if ((defined $crit) && ($d > $crit));
949    return $s;
950}
951
952##########################################################################
953# pass $filename as reference to allow new names
954# unwritable and unreadable caches are ignored and new filename returned
955# broken caches are ignored and over written
956
957sub read_cache
958{
959    my ($filename) = shift;
960
961    my ($store, $filenametmp, $count) = ({}, $filename, 0);
962    $filenametmp = $$filename if ref($filename);
963    while (1) {
964        if (-e $filenametmp && !(-r $filenametmp && -w $filenametmp)) {
965            &log("WARNING: Cache file $filenametmp exists but not readable and writeable.");
966        } else {
967            if (-e $filenametmp) {
968                eval { $store = Storable::retrieve($filenametmp); };
969                &log("WARNING: Unable to read cache from file $filenametmp: $@") if ($@);
970            } else {
971                &log("WARNING: No cache file $filenametmp have to fetch all details.");
972            }
973            $store = {} if !ref($store);
974            eval { Storable::store($store, $filenametmp); };
975            if ($@) {
976                &log("WARNING: Unable to write cache to file $filenametmp: $@");
977            } else {
978                last;
979            }
980        }
981        if ((!ref($filename)) || $count > 2) {
982            die("ERROR: Shepherd::Common::read_cache($filenametmp) Can't find or create readable and writeable cache.");
983        }
984        $filenametmp = $$filename . "." . $count++;
985    }
986    $$filename = $filenametmp if ref($filename);
987
988    return $store;
989}
990
991##########################################################################
992# wont die when can't write
993
994sub write_cache
995{
996    my ($filename, $store) = @_;
997    eval { Storable::store($store, $filename); };
998    &log("WARNING: Unable to write cache to file $filename: $@") if ($@);
999}
1000
1001##########################################################################
1002
1003sub which_state
1004{
1005        my $region = shift;
1006
1007        my $state;
1008        if ($region =~ /^(93|94|95|90|98)$/) {
1009                $state = "VIC";
1010        } elsif ($region =~ /^(73|66|67|63|69|71|106|184|259|261|262|263|264)$/) {
1011                $state = "NSW";
1012        } elsif ($region =~ /^(75|78|255|256|258|254|253|257|79|114)$/) {
1013                $state = "QLD";
1014        } elsif ($region =~ /^(101|102)$/) {
1015                $state = "WA";
1016        } elsif ($region =~ /^(81|82|83|85|86|107)$/) {
1017                $state = "SA";
1018        } elsif ($region =~ /^(74|108)$/) {
1019                $state = "NT";
1020        } elsif ($region =~ /^(126)$/) {
1021                $state = "ACT";
1022        } elsif ($region =~ /^(88)$/) {
1023                $state = "TAS";
1024        } else {
1025                $state = "QLD";
1026        }
1027
1028        return $state;
1029}
1030
1031##########################################################################
1032
1033# Convert yyyymmddhhmmss +hhmm format to calendar time.
1034# Use $zone to override with true timezone name. eg. ':localtime', ':Australia/Sydney', ':UTC'.
1035# Use $default_zone to set a zone when none if found in $xmltv. Defaults to localtime.
1036# Returns $time in UTC and $z is its zone.
1037# eg. my @timez = xmltvtimez("200706021800 +1100", ":Australia/Sydney");
1038sub xmltvtimez {
1039    my ($xmltv, $zone, $default_zone) = @_;
1040
1041    my ($Y, $M, $D, $h, $m, $s, $z) =
1042            $xmltv =~ /(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})? ?([+-]\d{4})?/ or
1043            die "Can't interprete xmltvtime \"$xmltv\".";
1044
1045    $z = $zone || ( $z ? "aus$z" : $default_zone ); 
1046
1047    local %ENV;
1048    if (defined $z and $z !~ "local") { $ENV{TZ} = $z; POSIX::tzset(); }
1049    my $time = POSIX::mktime($s?$s:0,$m,$h,$D,$M-1,$Y-1900,0,0,0) or
1050            die "Can't mktime from xmltvtime \"$xmltv\".";
1051    if (defined $z and $z !~ "local") { local %ENV; POSIX::tzset(); }
1052
1053    return ($time, $z);
1054}
1055
1056# Move to a different timezone.
1057#$timez[1] = ":localtime";          # Move to local time
1058#$timez[1] = ":Australia/Sydney";   # Move to Australia/Sydney time
1059#$timez[1] = ":UTC";                # Move to utc time
1060#$timez[1] = "utc+0000";            # Move to utc time
1061
1062# Convert calendar time to yyyymmddhhmmss +hhmm format.
1063# $time is in UTC and $z is its zone.  Changing $z moves to a new timezone.
1064# eg. print timezxmltv(@timez);
1065# eg. print timezxmltv($time);  # Defaults to localtime.
1066sub timezxmltv {
1067    my ($time, $z) = @_;
1068
1069    local %ENV;
1070    if (defined $z and $z !~ "local") { $ENV{TZ} = $z; POSIX::tzset(); }
1071        my $xmltv = POSIX::strftime("%Y%m%d%H%M%S %z", localtime($time));
1072    if (defined $z and $z !~ "local") { local %ENV; POSIX::tzset();  }
1073
1074    return $xmltv;
1075}
1076
1077# Show it all works ok.
1078sub testxmltvtimez {
1079  print POSIX::strftime("%Y%m%d%H%M%S %z\t\t\tStart time\n\n", localtime());
1080
1081  my $str = "200706022000";
1082  my @timez = xmltvtimez($str);
1083  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\t\tOriginal time\n";
1084  @timez = xmltvtimez("$str", ":UTC");
1085  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tOverride with utc\n";
1086  @timez = xmltvtimez("$str", ":Australia/Sydney");
1087  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\tOverride with Australia/Sydney\n\n";
1088
1089  @timez = xmltvtimez($str);
1090  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\t\tOriginal time\n";
1091  $timez[1] = ":UTC";
1092  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tMove to utc time\n";
1093  $timez[1] = ":localtime";
1094  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tMove to local time\n";
1095  $timez[1] = "utc+0000";
1096  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tMove to utc time\n";
1097  $timez[1] = ":Australia/Sydney";
1098  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\tMove to Australia/Sydney\n";
1099
1100  print POSIX::strftime("\n%Y%m%d%H%M%S %z\t\t\tEnd time.\n", localtime());
1101}
1102
1103##########################################################################
1104
11051;
Note: See TracBrowser for help on using the browser.