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

Revision 1221, 34.3 kB (checked in by mbarry, 4 years ago)

Shepherd::Common: Set defaults in UA setup, not just get_url
Line 
1#!/usr/bin/perl
2#
3# Shepherd::Common library
4
5my $version = '0.38';
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    # App defaults
585    foreach my $k (keys %defaults) {
586        $cnf{$k} = $defaults{$k} unless (defined $cnf{$k});
587    }
588    # Defaults
589    $cnf{method} = 'GET' unless (defined $cnf{method});
590    $cnf{retries} = 2 unless (defined $cnf{retries});
591    $cnf{fake} = 1 unless (defined $cnf{fake});
592    $cnf{gzip} = 1 unless (defined $cnf{gzip});
593    $cnf{delay} = 0 unless (defined $cnf{delay});
594    $cnf{retry_delay} = 10 unless (defined $cnf{retry_delay} or $cnf{delay});
595    $cnf{debug} = 1 unless (defined $cnf{debug});
596                                     
597    print "Establishing user agent.\n" if ($cnf{debug} > 3);
598
599    $ua = LWP::UserAgent->new( keep_alive => 1 );
600    $ua->env_proxy();
601
602    my @agent_list = (
603        'Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US; rv:1.9.1.2) Gecko/20090729 Firefox/3.5.2 (.NET CLR 3.5.30729)',
604        'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.9) Gecko/2008061004 Firefox/3.0',
605        'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-GB; rv:1.8.1.15) Gecko/20080623 Firefox/2.0.0.15',
606        'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.9.0) Gecko/2008061600 SUSE/3.0-0.2 Firefox/3.0',
607        'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.9) Gecko/20080617 Firefox/3.0',
608        'Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.5; en-US; rv:1.9) Gecko/2008061004 Firefox/3.0',
609
610        'Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.0; .NET CLR 2.0.50727)',
611        'Mozilla/5.0 (Windows; U; MSIE 7.0; Windows NT 6.0; en-US)',
612        'Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322)',
613        'Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1)',
614
615        'Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US) AppleWebKit/530.5 (KHTML, like Gecko) Chrome/2.0.172.39 Safari/530.5',
616        'Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US) AppleWebKit/525.18 (KHTML, like Gecko) Version/3.1.1 Safari/525.17',
617        'Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_5_4; en-us) AppleWebKit/525.18 (KHTML, like Gecko) Version/3.1.2 Safari/525.20.1',
618
619        'Opera/9.63 (Windows NT 5.1; U; en)',
620        'Opera/9.51 (Windows NT 6.0; U; en)',
621        'Opera/9.51 (Windows NT 5.1; U; en)'
622    );
623
624    my $agent = ($cnf{fake} ? $agent_list[int(rand($#agent_list+1))] : ($cnf{agent} ? $cnf{agent} : 'Shepherd'));
625    $ua->agent($agent);
626    print "User Agent string set to \"" . $ua->agent() . "\".\n" if ($cnf{debug} > 3); 
627
628    $ua->cookie_jar({}) if (defined $cnf{cookie_jar});
629
630    push @{ $ua->requests_redirectable }, 'POST';
631
632    return $ua;
633}
634
635##########################################################################
636# helper routine to set default settings so they don't need to be passed
637# in every time
638
639# EG: Shepherd::Common::set_default("squid", 1)
640sub set_default
641{
642        my ($name, $value) = @_;
643        $value = 0 if ($name eq 'debug' and !defined $value);
644        $defaults{$name} = $value;
645}
646
647# EG: Shepherd::Common::set_defaults( squid => 1, retries => 2)
648sub set_defaults
649{
650    my %h = @_;
651    foreach (keys %h)
652    {
653        set_default($_, $h{$_});
654    }
655}
656
657##########################################################################
658# descend a structure and clean up various things, including stripping
659# leading/trailing spaces in strings, translations of html stuff etc
660#   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
661
662sub cleanup {
663    my $x = shift;
664    my $desc = shift;
665
666    if    (ref $x eq "REF")   { cleanup($$x, $desc) }
667    elsif (ref $x eq "HASH")  {
668        while (my ($k, $v) = each %$x) {
669           cleanup(\$v, $k eq "desc");
670        }
671    }
672    elsif (ref $x eq "ARRAY") { cleanup(\$_, $desc) for @$x }
673    elsif (defined $$x) {
674        my %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } );
675
676        $$x =~ s/&(#((x?)\d+)|(.*?));/ $2 ? ($3 ? chr("0".$2) : chr($2)) : $amp{$4} || ' ' /eg;
677        $$x =~ s/\xA0/ /g; # &nbsp; can be &#160; == &#xA0;
678        $$x =~ s/^\s+//s;
679        $$x =~ s/\s+$//s;
680        if (!$desc) { # if desc leave in \n etc
681            $$x =~ s/\s+/ /g;
682        }
683    }
684}
685
686
687##########################################################################
688# strptime type date parsing - BUT - if no timezone is present, treat
689# time as being in localtime rather than the various other perl
690# implementation which treat it as being in UTC/GMT
691
692sub parse_xmltv_date
693{
694    my $datestring = shift;
695    my @t; # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
696    my $tz_offset = 0;
697
698    # work out GMT offset - we only do this once
699    if (!$gmt_offset) {
700        my $tzstring = strftime("%z", localtime(time));
701
702        $gmt_offset = (60*60) * int(substr($tzstring,1,2));     # hr
703        $gmt_offset += (60 * int(substr($tzstring,3,2)));       # min
704        $gmt_offset *= -1 if (substr($tzstring,0,1) eq "-");    # +/-
705    }
706
707    if ($datestring =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/) {
708        ($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);
709        ($t[6],$t[7],$t[8]) = (-1,-1,-1);
710
711        # if input data has a timezone offset, then offset by that
712        if ($datestring =~ /\+(\d{2})(\d{2})/) {
713            $tz_offset = $gmt_offset - (($1*(60*60)) + ($2*60));
714        } elsif ($datestring =~ /\-(\d{2})(\d{2})/) {
715            $tz_offset = $gmt_offset + (($1*(60*60)) + ($2*60));
716        }
717
718        my $e = mktime(@t);
719        return ($e+$tz_offset) if ($e > 1);
720    }
721    return undef;
722}
723
724##########################################################################
725# setup SOCKS proxy override for LWP and test that it works
726
727sub setup_socks
728{
729    $socks_server = shift;
730    ($socks_ip,$socks_port) = split(/:/,$socks_server);
731
732    use LWP::Protocol::http;
733    my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
734
735    # override LWP::Protocol::http's _new_socket method with our own
736    local($^W) = 0;
737    *LWP::Protocol::http::_new_socket = \&socks_new_socket;
738
739    # test that it works
740    my $data = &get_url(url => "http://www.google.com/", retries => 10);
741    return 1 if (($data) && ($data =~ /Google/i));
742
743    # failed
744    *LWP::Protocol::http::_new_socket = $orig_new_socket;
745    return 0;
746}
747
748##############################################################################
749# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
750
751sub socks_new_socket
752{
753    my($self, $host, $port, $timeout) = @_;
754
755    $socks_ip = "127.0.0.1" if (!defined $socks_ip);
756    $socks_port = "9050" if (!defined $socks_port);
757
758    local($^W) = 0;  # IO::Socket::INET can be noisy
759    my $sock = $self->socket_class->new(
760        PeerAddr => $socks_ip,
761        PeerPort => $socks_port,
762        Proto    => 'tcp');
763
764    unless ($sock) {
765        # IO::Socket::INET leaves additional error messages in $@
766        $@ =~ s/^.*?: //;
767        printf "Can't connect to $host:$port ($@)\n";
768        return undef;
769    }
770
771    # perl 5.005's IO::Socket does not have the blocking method.
772    eval { $sock->blocking(0); };
773
774    # establish connectivity with socks server - SOCKS4A protocol
775    print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) . (pack 'x') . $host . (pack 'x');
776
777    my $received = "";
778    my $timeout_time = time + $timeout;
779    while ($sock->sysread($received, 8) && (length($received) < 8) ) {
780        select(undef, undef, undef, 0.25);
781        last if ($timeout_time < time);
782    }
783
784    if ($timeout_time < time) {
785        printf "Timeout ($timeout) while connecting via SOCKS server\n";
786        return $sock;
787    }
788
789    my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
790    printf "Connection via SOCKS4A server rejected or failed\n" if ($req_status == 0x5b);
791    printf "Connection via SOCKS4A server because client is not running identd\n" if ($req_status == 0x5c);
792    printf "Connection via SOCKS4A server because client's identd could not confirm the user\n" if ($req_status == 0x5d);
793
794    $sock;
795}
796
797##########################################################################
798
799sub urlify
800{
801    my $str = shift;
802    $str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
803    $str =~ s/%20/+/g;
804    $str =~ s/%2D/-/g;
805    return $str;
806}
807
808##############################################################################
809
810sub translate_category
811{
812    my $genre = shift;
813    my %translation = (
814        'Sport' => 'sports',
815        'Soap Opera' => 'Soap',
816        'Science and Technology' => 'Science/Nature',
817        'Real Life' => 'Reality',
818        'Cartoon' => 'Animation',
819        'Family' => 'Children',
820        'Murder' => 'Crime' );
821    return $translation{$genre} if defined $translation{$genre};
822    return $genre;
823}
824
825##########################################################################
826
827# if no category then guess from title for Sport, News, Infomercial
828# translates the words in category
829# types (final,premiere,return,live) are prepend to category
830# types (movie,sports,series,tvshow) are appended to category list
831sub generate_category
832{
833    my ($title, $category, %type) = @_;
834
835    $type{sports} = 1 if ($title && $title=~/(^|\W)Sports?(\W|$)/i);
836    $type{sports} = 1 if ($category && $category=~/(^|\W)Sports?(\W|$)/i);
837
838    if ($category) {
839        if ($category eq "movie") {
840            $category = "Movie";
841            $type{movie} = 1;
842        } elsif ($category eq "sports") {
843            $category = "Sports";
844            $type{sports} = 1;
845        } elsif ($category eq "series") {
846            $category = "Series";
847            $type{series} = 1;
848        } elsif ($category eq "tvshow") {
849            $category = "TVShow";
850            $type{tvshow} = 1;
851        }
852        $category =~ s/Soap Opera/Soap/ig;
853        $category =~ s/Science and Technology/Science\/Nature/ig;
854        $category =~ s/Real Life/Reality/ig;
855        $category =~ s/Cartoon/Animation/ig;
856        $category =~ s/Family/Children/ig;
857        $category =~ s/Murder/Crime/ig;
858    } else { # !$category
859        if ($title) {
860            if ($title=~/(^|\W)News(\W|$)/i) {
861                $category = "News";
862            } elsif ($title=~/(^|\W)Infomercials?(\W|$)/i) {
863                $category = "Infotainment";
864            }
865        }
866        if (!$category) {
867            if ($type{movie}) {
868                $category = "Movie";
869            } elsif ($type{sports}) {
870                $category = "Sports";
871            } elsif ($type{series}) {
872                $category = "Series";
873            } elsif ($type{tvshow}) {
874               $category = "TVShow";
875            }
876        }
877    }
878
879    $category = "" if (!$category);
880    $category = "Live $category" if ($type{live});
881    $category = "Return $category" if ($type{return});
882    $category = "Premiere $category" if ($type{premiere});
883    $category = "Final $category" if ($type{final});
884    $category =~ s/^\s*(.*?)\s*$/$1/;
885
886    my @result;
887    @result = [ $category, "en"] if $category;
888    push(@result, [ "movie"  ]) if $type{movie};
889    push(@result, [ "sports" ]) if $type{sports};
890    push(@result, [ "series" ]) if $type{series};
891    push(@result, [ "tvshow" ]) if $type{tvshow};
892
893    return @result;
894}
895
896##########################################################################
897
898# (Adult Themes)
899# (Some Violence, Adult Themes, Supernatural Themes)
900# (Drug References, Adult Themes)
901# (Very Coarse Language, Sexual References, Drug References, Adult Themes, Nudity)
902# (Some Violence)
903# (Drug Use, Strong Adult Themes)
904# (Some Violence, Adult Themes)
905# (Some Coarse Language)
906# (Sexual References)
907# (Mild Coarse Language, Sexual References)
908# (Sex Scenes, Adult Themes, Supernatural Themes)
909# (Adult Themes, Medical Procedures)
910## (Qualifying - Sat)
911sub subrating
912{
913  my $string = shift || "";
914
915  my @subrating;
916  push(@subrating, "v") if $string =~ /Violence/i;
917  push(@subrating, "l") if $string =~ /Language/i;
918  push(@subrating, "s") if $string =~ /Sex/i;
919  push(@subrating, "d") if $string =~ /Drug/i;
920  push(@subrating, "a") if $string =~ /Adult/i;
921  push(@subrating, "n") if $string =~ /Nudity/i;
922  push(@subrating, "h") if $string =~ /Horror|Supernatural/i;
923  push(@subrating, "m") if $string =~ /Medical/i;
924
925  return join(",",@subrating);
926}
927
928##########################################################################
929
930sub log
931{
932        my ($entry) = @_;
933        printf "%s\n",$entry;
934}
935
936##########################################################################
937
938sub print_stats
939{
940        my ($progname, $version, $script_start_time, %stats) = @_;
941        my $now = time;
942        printf "STATS: %s v%s completed in %d seconds",
943          $progname, $version, ($now-$script_start_time);
944        foreach my $key (sort keys %stats) {
945                printf ", %d %s",$stats{$key},$key;
946        }
947        printf "\n";
948}
949
950##########################################################################
951# given a duration (seconds), return it in a pretty "{days}d{hr}h{min}m" string
952# and indication of whether the duration is over its threshold or not
953
954sub pretty_duration
955{
956    my ($d,$crit) = @_;
957    my $s = "";
958    $s .= sprintf "%dd",int($d / (60*60*24)) if ($d >= (60*60*24));
959    $s .= sprintf "%dh",int(($d % (60*60*24)) / (60*60)) if ($d > (60*60));
960    $s .= sprintf "%dm",int(($d % (60*60)) / 60) if ($d > 60);
961    $s .= sprintf "%ds",int($d % 60) if ($d > 0);
962    $s .= "[!]" if ((defined $crit) && ($d > $crit));
963    return $s;
964}
965
966##########################################################################
967# pass $filename as reference to allow new names
968# unwritable and unreadable caches are ignored and new filename returned
969# broken caches are ignored and over written
970
971sub read_cache
972{
973    my ($filename) = shift;
974
975    my ($store, $filenametmp, $count) = ({}, $filename, 0);
976    $filenametmp = $$filename if ref($filename);
977    while (1) {
978        if (-e $filenametmp && !(-r $filenametmp && -w $filenametmp)) {
979            &log("WARNING: Cache file $filenametmp exists but not readable and writeable.");
980        } else {
981            if (-e $filenametmp) {
982                eval { $store = Storable::retrieve($filenametmp); };
983                &log("WARNING: Unable to read cache from file $filenametmp: $@") if ($@);
984            } else {
985                &log("WARNING: No cache file $filenametmp have to fetch all details.");
986            }
987            $store = {} if !ref($store);
988            eval { Storable::store($store, $filenametmp); };
989            if ($@) {
990                &log("WARNING: Unable to write cache to file $filenametmp: $@");
991            } else {
992                last;
993            }
994        }
995        if ((!ref($filename)) || $count > 2) {
996            die("ERROR: Shepherd::Common::read_cache($filenametmp) Can't find or create readable and writeable cache.");
997        }
998        $filenametmp = $$filename . "." . $count++;
999    }
1000    $$filename = $filenametmp if ref($filename);
1001
1002    return $store;
1003}
1004
1005##########################################################################
1006# wont die when can't write
1007
1008sub write_cache
1009{
1010    my ($filename, $store) = @_;
1011    eval { Storable::store($store, $filename); };
1012    &log("WARNING: Unable to write cache to file $filename: $@") if ($@);
1013}
1014
1015##########################################################################
1016
1017sub which_state
1018{
1019        my $region = shift;
1020
1021        my $state;
1022        if ($region =~ /^(93|94|95|90|98|266|267|268)$/) {
1023                $state = "VIC";
1024        } elsif ($region =~ /^(73|66|67|63|69|71|106|184|259|261|262|263|264)$/) {
1025                $state = "NSW";
1026        } elsif ($region =~ /^(75|78|255|256|258|254|253|257|79|114)$/) {
1027                $state = "QLD";
1028        } elsif ($region =~ /^(101|102)$/) {
1029                $state = "WA";
1030        } elsif ($region =~ /^(81|82|83|85|86|107)$/) {
1031                $state = "SA";
1032        } elsif ($region =~ /^(74|108)$/) {
1033                $state = "NT";
1034        } elsif ($region =~ /^(126)$/) {
1035                $state = "ACT";
1036        } elsif ($region =~ /^(88)$/) {
1037                $state = "TAS";
1038        } else {
1039                $state = "QLD";
1040        }
1041
1042        return $state;
1043}
1044
1045##########################################################################
1046
1047# Convert yyyymmddhhmmss +hhmm format to calendar time.
1048# Use $zone to override with true timezone name. eg. ':localtime', ':Australia/Sydney', ':UTC'.
1049# Use $default_zone to set a zone when none if found in $xmltv. Defaults to localtime.
1050# Returns $time in UTC and $z is its zone.
1051# eg. my @timez = xmltvtimez("200706021800 +1100", ":Australia/Sydney");
1052sub xmltvtimez {
1053    my ($xmltv, $zone, $default_zone) = @_;
1054
1055    my ($Y, $M, $D, $h, $m, $s, $z) =
1056            $xmltv =~ /(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})? ?([+-]\d{4})?/ or
1057            die "Can't interprete xmltvtime \"$xmltv\".";
1058
1059    $z = $zone || ( $z ? "aus$z" : $default_zone ); 
1060
1061    local %ENV;
1062    if (defined $z and $z !~ "local") { $ENV{TZ} = $z; POSIX::tzset(); }
1063    my $time = POSIX::mktime($s?$s:0,$m,$h,$D,$M-1,$Y-1900,0,0,0) or
1064            die "Can't mktime from xmltvtime \"$xmltv\".";
1065    if (defined $z and $z !~ "local") { local %ENV; POSIX::tzset(); }
1066
1067    return ($time, $z);
1068}
1069
1070# Move to a different timezone.
1071#$timez[1] = ":localtime";          # Move to local time
1072#$timez[1] = ":Australia/Sydney";   # Move to Australia/Sydney time
1073#$timez[1] = ":UTC";                # Move to utc time
1074#$timez[1] = "utc+0000";            # Move to utc time
1075
1076# Convert calendar time to yyyymmddhhmmss +hhmm format.
1077# $time is in UTC and $z is its zone.  Changing $z moves to a new timezone.
1078# eg. print timezxmltv(@timez);
1079# eg. print timezxmltv($time);  # Defaults to localtime.
1080sub timezxmltv {
1081    my ($time, $z) = @_;
1082
1083    local %ENV;
1084    if (defined $z and $z !~ "local") { $ENV{TZ} = $z; POSIX::tzset(); }
1085        my $xmltv = POSIX::strftime("%Y%m%d%H%M%S %z", localtime($time));
1086    if (defined $z and $z !~ "local") { local %ENV; POSIX::tzset();  }
1087
1088    return $xmltv;
1089}
1090
1091# Show it all works ok.
1092sub testxmltvtimez {
1093  print POSIX::strftime("%Y%m%d%H%M%S %z\t\t\tStart time\n\n", localtime());
1094
1095  my $str = "200706022000";
1096  my @timez = xmltvtimez($str);
1097  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\t\tOriginal time\n";
1098  @timez = xmltvtimez("$str", ":UTC");
1099  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tOverride with utc\n";
1100  @timez = xmltvtimez("$str", ":Australia/Sydney");
1101  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\tOverride with Australia/Sydney\n\n";
1102
1103  @timez = xmltvtimez($str);
1104  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\t\tOriginal time\n";
1105  $timez[1] = ":UTC";
1106  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tMove to utc time\n";
1107  $timez[1] = ":localtime";
1108  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tMove to local time\n";
1109  $timez[1] = "utc+0000";
1110  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\t\tMove to utc time\n";
1111  $timez[1] = ":Australia/Sydney";
1112  print timezxmltv(@timez) . " " . ($timez[1] || "") . "\tMove to Australia/Sydney\n";
1113
1114  print POSIX::strftime("\n%Y%m%d%H%M%S %z\t\t\tEnd time.\n", localtime());
1115}
1116
1117##########################################################################
1118
11191;
Note: See TracBrowser for help on using the browser.