Changeset 709

Show
Ignore:
Timestamp:
05/29/07 01:44:12 (6 years ago)
Author:
lincoln
Message:

first pass at new ten_website grabber, not enabled yet as not yet finished

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • grabbers/ten_website

    r600 r709  
    55#    for channel TEN only 
    66#  * this does NOT use any config file - all settings are passed in from shepherd 
    7 #  * idea based on OCR::PerfectCR CPAN module 
    87 
    98use strict; 
    109 
    1110my $progname = "ten_website"; 
    12 my $version = "0.07"; 
    13  
    14 use LWP::UserAgent; 
    15 use LWP::ConnCache; 
     11my $version = "1.00"; 
     12 
    1613use XMLTV; 
    1714use POSIX qw(strftime mktime); 
    1815use Getopt::Long; 
     16use Data::Dumper; 
     17use Storable; 
     18use Shepherd::Common; 
     19use XML::DOM; 
     20use XML::DOM::NodeList; 
    1921use HTML::TreeBuilder; 
    20 use Data::Dumper; 
    21 use Compress::Zlib; 
    22 use GD; 
    23 use Digest::MD5; 
    24 use Storable; 
    2522 
    2623# 
    … …  
    3330my $channels, my $opt_channels, my $gaps; 
    3431my $data_cache; 
    35 my $ua; 
    36 my $conn_cache; 
    37 my $prev_url; 
    3832my $d; 
    3933my $opt; 
    40 my %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ); 
    4134 
    4235 
    … …  
    4740$opt->{days} =          7;                      # default 
    4841$opt->{outputfile} =    "output.xmltv";         # default 
    49 $opt->{cache_file} =    $progname.".storable.cache";    # default 
     42$opt->{cache_file} =    $progname.".storable2.cache";   # default 
    5043$opt->{lang} =          "en"; 
    5144$opt->{region} =        94; 
    … …  
    7063        'obfuscate'     => \$opt->{obfuscate}, 
    7164 
    72         'ocr-learn-mode' => \$opt->{ocr_learn_mode}, 
    73  
    7465        'help'          => \$opt->{help}, 
    7566        'verbose'       => \$opt->{help}, 
    … …  
    110101        (defined $opt->{no_cache} ? ", without caching" : ", with caching")); 
    111102 
     103# normalize starttime to an hour.. 
     104my $starttime = time; 
     105my $endtime = $starttime + ($opt->{days} * 86400); 
     106$starttime += (86400 * $opt->{offset}) if (defined $opt->{offset}); 
     107 
     108# set defaults 
     109Shepherd::Common::set_default("debug", $opt->{debug}) if (defined $opt->{debug}); 
     110Shepherd::Common::set_default("webwarper", 1) if (defined $opt->{warper}); 
     111Shepherd::Common::set_default("squid", 1) if (defined $opt->{obfuscate}); 
     112Shepherd::Common::set_default("referer", "last"); 
     113Shepherd::Common::set_default("retry_delay", 10); 
     114Shepherd::Common::setup_ua('cookie_jar' => 1, 'fake' => 1); 
     115 
    112116# read channels file 
    113117if (-r $opt->{channels_file}) { 
    … …  
    135139&read_cache unless (defined $opt->{no_cache}); 
    136140 
    137 &set_ua; 
    138 &setup_charset; 
    139  
    140 &set_region; 
    141  
    142 &get_summary_pages; 
     141&get_summary_page; 
    143142&get_detail_pages unless (defined $opt->{no_details}); 
    144143 
    … …  
    178177        --gaps_file=file        micro-fetch gaps only 
    179178 
    180         --ocr-learn-mode        put $progname into OCR learning mode to learn the text 
    181  
    182179EOF 
    183180; 
    … …  
    207204sub write_cache 
    208205{ 
     206        # delete cache file from older OCR-based ten_website grabber 
     207        my $old_cache_file = $progname.".storable.cache"; 
     208        unlink($old_cache_file) if (-f $old_cache_file); 
     209 
    209210        # cleanup old entries from cache 
    210         for my $k (keys %{($data_cache->{id_cache})}) { 
    211                 if ($data_cache->{id_cache}->{$k}->{last_used} < (time-(86400*14))) { 
    212                         delete $data_cache->{id_cache}->{$k}; 
    213                         $stats{expired_from_cache}++; 
    214                 } 
    215         } 
    216  
    217         for my $k (keys %{($data_cache->{detail_cache})}) { 
    218                 if ($data_cache->{detail_cache}->{$k}->{last_used} < (time-(86400*14))) { 
    219                         delete $data_cache->{detail_cache}->{$k}; 
     211        for my $k (keys %{($data_cache->{prog_cache})}) { 
     212                if ($data_cache->{prog_cache}->{$k}->{last_used} < (time-(86400*14))) { 
     213                        delete $data_cache->{prog_cache}->{$k}; 
    220214                        $stats{expired_from_cache}++; 
    221215                } 
    … …  
    228222 
    229223############################################################################## 
    230 # logic to fetch a page via http 
    231 #  retries up to $retrycount times to get a page with 10 second pauses inbetween 
    232  
    233 sub get_url 
    234 { 
    235         my ($url,$retrycount,$referer,$reqtype,$postvars) = @_; 
    236         my $request; 
    237         my $response; 
    238         my $attempts = 0; 
    239         my ($raw, $page, $base); 
    240  
    241         $reqtype = "GET" if (!defined $reqtype); 
    242  
    243         $retrycount = 5 if ($retrycount == 0); 
    244         $url =~ s#^http://#http://webwarper.net/ww/# if (defined $opt->{warper}); 
    245  
    246         if ($reqtype eq "GET") { 
    247                 $request = HTTP::Request->new(GET => $url); 
    248         } elsif ($reqtype eq "HEAD") { 
    249                 $request = HTTP::Request->new(HEAD => $url); 
    250         } elsif ($reqtype eq "POST") { 
    251                 $request = HTTP::Request->new(POST => $url); 
    252                 $request->header('Content-type' => 'application/x-www-form-urlencoded'); 
    253                 $request->add_content($postvars); 
    254         } 
    255  
    256         if (defined $referer) { 
    257                 $request->header('Referer' => $referer); 
    258         } else { 
    259                 $request->header('Referer' => $prev_url) if (defined $prev_url); 
    260         } 
    261         $prev_url = $url; 
    262  
    263         $request->header('Accept-Encoding' => 'gzip'); 
    264  
    265         if ($opt->{obfuscate}) { 
    266                 my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1); 
    267                 $request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)'); 
    268                 $request->header('X-Forwarded-For' => $randomaddr); 
    269         } 
    270  
    271         my $status; 
    272         for (1..$retrycount) { 
    273                 $response = $ua->request($request); 
    274  
    275                 if ((defined $opt->{log_http}) && (open(F,">>http_log.txt"))) { 
    276                         printf F "\n----------------------------------------------------\n"; 
    277                         printf F "request: %s %s %s\n",$reqtype,$url,(defined $postvars ? $postvars : ""); 
    278                         printf F "referer: %s\n", ($request->header('Referer') ? $request->header('Referer') : "(none)"); 
    279                         printf F "response: %s\n",$response->status_line; 
    280                         print F $response->content; 
    281                         close F; 
    282                 } 
    283  
    284                 if ($response->is_success) { 
    285                         if ($response->content =~ /we are unable to process your request/) { 
    286                                 $status = "fail: 999: Service unavailable"; # CPAN's LWP lied to us 
    287                         } else { 
    288                                 $status = "good"; 
    289                                 last; 
    290                         } 
    291                 } else { 
    292                         $status = "fail: ".$response->status_line; 
    293                 } 
    294  
    295                 $stats{http_failed_requests}++; 
    296                 $attempts++; 
    297  
    298                 my $sleep_for = 60; 
    299  
    300                 &log("attempt $attempts of $retrycount failed to fetch $url, sleeping for $sleep_for secs: $status"); 
    301  
    302                 unless ($attempts == $retrycount) 
    303                 { 
    304                     $stats{slept_for} += $sleep_for; 
    305                     sleep $sleep_for; 
    306                 } 
    307         } 
    308         if ($status !~ /^good/) { 
    309                 &log("aborting after $attempts attempts to fetch url $url"); 
    310                 return undef; 
    311         } 
    312  
    313         $prev_url = $response->base; 
    314         $prev_url =~ s#^http://webwarper.net/ww/#http://# if (defined $opt->{warper}); 
    315  
    316         $stats{bytes_fetched} += do {use bytes; length($response->content)}; 
    317         $stats{http_successful_requests}++; 
    318  
    319         if ($reqtype eq "HEAD") { 
    320                 return $response->header("Content-Length"); 
    321         } 
    322  
    323         if ($response->header('Content-Encoding') && 
    324             $response->header('Content-Encoding') eq 'gzip') { 
    325                 $stats{compressed_pages} += do {use bytes; length($response->content)}; 
    326                 $response->content(Compress::Zlib::memGunzip($response->content)); 
    327         } 
    328         return $response->content; 
    329 } 
    330  
    331 ############################################################################## 
    332224 
    333225sub log 
    … …  
    346238        } 
    347239        printf "\n"; 
    348 } 
    349  
    350 ############################################################################## 
    351 # descend a structure and clean up various things, including stripping 
    352 # leading/trailing spaces in strings, translations of html stuff etc 
    353 #   -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au 
    354  
    355 sub cleanup { 
    356         my $x = shift; 
    357         if    (ref $x eq "REF")   { cleanup($_) } 
    358         elsif (ref $x eq "HASH")  { cleanup(\$_) for values %$x } 
    359         elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x } 
    360         elsif (defined $$x) { 
    361                 $$x =~ s/&(#(\d+)|(.*?));/ $2 ? chr($2) : $amp{$3}||' ' /eg; 
    362                 $$x =~ s/[^\x20-\x7f]/ /g; 
    363                 $$x =~ s/(^\s+|\s+$)//g; 
    364         } 
    365240} 
    366241 
    … …  
    387262 
    388263        foreach my $prog (@{($d->{progs})}) { 
    389                 # convert epoch starttime into XMLTV starttime 
    390                 next if (!defined $prog->{starttime}); 
    391                 $prog->{start} = strftime "%Y%m%d%H%M", localtime($prog->{starttime}); 
    392                 delete $prog->{starttime}; 
    393  
    394                 # convert epoch stoptime into XMLTV stoptime 
    395                 next if (!defined $prog->{stoptime}); 
    396                 $prog->{stop} = strftime "%Y%m%d%H%M", localtime($prog->{stoptime}); 
    397                 delete $prog->{stoptime}; 
    398  
    399                 delete $prog->{details}; 
    400                 delete $prog->{id}; 
    401  
    402                 &cleanup($prog); 
     264                delete $prog->{link}; 
     265 
     266                Shepherd::Common::cleanup($prog); 
    403267                printf "DEBUG: programme xmltv: ".Dumper($prog) if (defined $opt->{debug}); 
    404268                $writer->write_programme($prog); 
    … …  
    410274############################################################################## 
    411275 
    412 sub set_ua 
    413 { 
    414         my @agent_list = ( 
    415                 'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)', 
    416                 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)', 
    417                 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; FunWebProducts)', 
    418                 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322)', 
    419                 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)', 
    420                 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Q312466)', 
    421                 'Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)', 
    422                 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85.8.5 (KHTML, like Gecko) Safari/85.8.1', 
    423                 'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.4) Gecko/20060508 Firefox/1.5.0.4', 
    424                 'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox', 
    425                 'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.8) Gecko/20061025 Firefox/1.5.0.8', 
    426                 'Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1) Gecko/20061010 Firefox/2.0', 
    427                 'Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)', 
    428                 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412', 
    429                 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-us) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3', 
    430                 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; fr) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3', 
    431                 'Opera/9.00 (Windows NT 5.1; U; en)'); 
    432  
    433         $ua = undef; 
    434         $conn_cache = LWP::ConnCache->new; 
    435         $ua = LWP::UserAgent->new('conn_cache' => $conn_cache, 'timeout' => 30, 'agent' => $agent_list[(int(rand($#agent_list+1)))] ); 
    436         $ua->env_proxy; 
    437         $ua->cookie_jar({ }); 
    438  
    439  
    440         $prev_url = undef; # reset referer 
    441 } 
    442  
    443 ############################################################################## 
    444  
    445 sub urlify 
    446 { 
    447         my $str = shift; 
    448         $str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; 
    449         $str =~ s/%20/+/g; 
    450         $str =~ s/%2D/-/g; 
    451         return $str; 
    452 } 
    453  
    454 ############################################################################## 
    455  
    456 sub translate_category 
    457 { 
    458         my $genre = shift; 
    459         my %translation = ( 
    460                 'Sport' => 'sports', 
    461                 'Soap Opera' => 'Soap', 
    462                 'Science and Technology' => 'Science/Nature', 
    463                 'Real Life' => 'Reality', 
    464                 'Cartoon' => 'Animation', 
    465                 'Family' => 'Children', 
    466                 'Murder' => 'Crime' ); 
    467  
    468         return $translation{$genre} if defined $translation{$genre}; 
    469         return $genre; 
    470 } 
    471  
    472 ############################################################################## 
    473  
    474 sub set_region 
    475 { 
    476         &log("setting region"); 
    477  
    478         my $url = sprintf "http://www.ten.com.au/citySelect.aspx?change=true"; 
    479         my $data = &get_url($url,5); 
    480         if (!$data) { 
    481                 &log("CRITICAL ERROR: Could not set region because of error fetching '$url'"); 
    482                 exit(1); 
    483         } 
    484  
    485         my $tree = HTML::TreeBuilder->new_from_content($data); 
    486         if (!$tree) { 
    487                 &log("CRITICAL ERROR: url '$url' doesn't seem to contain any valid HTML: has the format changed?"); 
    488                 exit(1); 
    489         } 
    490  
    491         $opt->{viewstate} = $_->attr('value') if ($_ = $tree->look_down('_tag' => 'input', 'type' => 'hidden', 'name' => '__VIEWSTATE')); 
    492         if (!defined $opt->{viewstate}) { 
    493                 &log(" has the format changed? could not find 'viewstate'..."); 
    494                 $stats{viewstate_not_found}++; 
    495                 $opt->{viewstate} = ""; 
    496         } 
    497  
    498         my $reg = 1;                                                    # sydney 
    499         $reg = 2 if ($opt->{region} =~ /^9/);                           # melbourne 
    500         $reg = 3 if ($opt->{region} =~ /(75|78|79|114|74|108)/);        # brisbane 
    501         $reg = 4 if ($opt->{region} =~ /(101|102)/);                    # perth 
    502         $reg = 5 if ($opt->{region} =~ /(81|82|83|85|86|107)/);         # adelaide 
    503  
    504         my $postvars = "__VIEWSTATE=".urlify($opt->{viewstate})."&new_site_id=".$reg."&_ctl1.x=0&_ctl1.y=0"; 
    505         $data = &get_url($url, 5, undef, "POST", $postvars); 
    506  
    507         $stats{programmes} = 0 if (!defined $stats{programmes}); 
    508 } 
    509  
    510 ############################################################################## 
    511  
    512 sub get_summary_pages 
    513 { 
    514         my $starttime = time; 
    515         my $day_num = 0; 
    516         my $skip_days = 0; 
    517  
    518         $skip_days = $opt->{offset} if (defined $opt->{offset}); 
    519         while ($day_num < $opt->{days}) { 
    520                 my $currtime = $starttime + (60*60*24 * $day_num); 
    521                 $day_num++; 
    522  
    523                 # skip if --offset applies against this day 
    524                 if ($skip_days > 0) { 
    525                         $skip_days--; 
     276sub get_summary_page 
     277{ 
     278        my $reg = "sydney";                                                     # sydney 
     279        $reg = "melbourne" if ($opt->{region} =~ /^9/);                         # melbourne 
     280        $reg = "brisbane" if ($opt->{region} =~ /(75|78|79|114|74|108)/);       # brisbane 
     281        $reg = "perth" if ($opt->{region} =~ /(101|102)/);                      # perth 
     282        $reg = "adelaide" if ($opt->{region} =~ /(81|82|83|85|86|107)/);        # adelaide 
     283 
     284        &log("fetching summary page"); 
     285 
     286        my $url = "http://ten.com.au/tv-schedule/full?location=".$reg."&uid="; 
     287        my $tries = 5; 
     288        my ($data, $success, $status_msg, $bytes_fetched, $seconds_slept, $failed_attempts, $mime_type) = 
     289          Shepherd::Common::get_url(url => $url, retries => ($tries-1)); 
     290 
     291        $stats{failed_requests} += $failed_attempts; 
     292        $stats{slept_for} += $seconds_slept; 
     293        $stats{bytes_fetched} += $bytes_fetched; 
     294 
     295        if ((!$data) || (!$success)) { 
     296                &log("Failed to fetch '$url' after $tries attempts.\nAborting: likely format change or blocked!"); 
     297                exit(10); 
     298        } 
     299 
     300        $stats{http_successful_requests}++; 
     301 
     302        my $parser = new XML::DOM::Parser; 
     303        my $tree = $parser->parse($data); 
     304        my $guide = $tree->getElementsByTagName("tvguide"); 
     305        my $progs = $guide->item(0)->getElementsByTagName("program"); 
     306        for (my $i = 0; $i < $progs->getLength; $i++) { 
     307                my $p; 
     308                foreach my $field ("duration", "endTime", "is_series", "link", "program_name", "schedule_id", "series_id", "startTime") { 
     309                        my $attr = $progs->item($i)->getAttributeNode($field); 
     310                        $p->{$field} = $attr->getValue if (defined $attr); 
     311 
     312                } 
     313 
     314                if ((!defined $p->{startTime}) || (!defined $p->{endTime})) { 
     315                        $stats{prog_bad_time}++; 
    526316                        next; 
    527317                } 
    528  
    529                 my @timeattr = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst 
    530                 $timeattr[0] = 0; # zero sec 
    531                 $timeattr[1] = 0; # zero min 
    532                 $timeattr[2] = 0; # midnight 
    533                 my $day_start = mktime(@timeattr); 
    534  
    535                 &log("fetching day $day_num summary page"); 
    536                 &parse_summary_page($day_start, $day_num); 
    537         } 
    538 } 
    539  
    540 ############################################################################## 
    541  
    542 sub parse_summary_page 
    543 { 
    544         my ($day_start, $day_num) = @_; 
    545         my %seen_prog; 
    546  
    547         my $url = "http://www.ten.com.au/programGuide.aspx?section=programGuide"; 
    548         my $postvars = "__VIEWSTATE=".urlify($opt->{viewstate}). 
    549                 "&newDate=".urlify(POSIX::strftime("%Y-%m-%d %H:%M:%S",localtime($day_start))).".000". 
    550                 "&newTime=&newGenre=&newKeyword=&filterButton.x=0&filterButton.y=0&sq="; 
    551         $postvars .= "&storeDate=".urlify($opt->{storedate}) if (defined $opt->{storedate}); 
    552  
    553         &log("parse_summary_page debug: day_start $day_start day_num $day_num POST $postvars") if (defined $opt->{debug} && $opt->{debug} > 2); 
    554  
    555         my $data = &get_url($url, 5, undef, "POST", $postvars); 
    556         if (!$data) { 
    557                 &log("url '$url' (POST $postvars) doesn't seem to contain any valid response."); 
    558                 $stats{bad_response}++; 
    559                 return; 
    560         } 
    561  
    562         my $tree = HTML::TreeBuilder->new_from_content($data); 
    563         if (!$tree) { 
    564                 &log("url '$url' (POST $postvars) doesn't seem to contain any valid HTML: has the format changed?"); 
    565                 $stats{bad_html}++; 
    566                 return; 
    567         } 
    568  
    569         if (my $viewstate_field = $tree->look_down('_tag' => 'input', 'type' => 'hidden', 'name' => '__VIEWSTATE')) { 
    570                 my $new_viewstate = $viewstate_field->attr('value'); 
    571                 $opt->{viewstate} = $new_viewstate if (defined $new_viewstate); 
    572         } 
    573  
    574         if (my $storedate_field = $tree->look_down('_tag' => 'input', 'type' => 'hidden', 'name' => 'storeDate')) { 
    575                 my $page_date = $storedate_field->attr('value'); 
    576                 $opt->{storedate} = $page_date if (defined $page_date); 
    577         } 
    578  
    579         my $progs_in_day = 0; 
    580  
    581         my @tree_rows = $tree->look_down('_tag' => 'tr'); 
    582         foreach my $tree_pg (@tree_rows) { 
    583                 my $yellow_row_count = 0; 
    584                 my $prog_bg; 
    585                 my $prog_fg; 
    586                 my $prog_details; 
    587                 my $prog_rating; 
    588                 my $prog_cc; 
    589                 my $prog_hd; 
    590  
    591                 foreach my $prog_td ($tree_pg->look_down('_tag' => 'td')) { 
    592                         my $prog_td_class = $prog_td->attr('class'); 
    593                         if ((defined $prog_td_class) && ($prog_td_class eq "pgimgcell") && (!defined $prog_bg)) { 
    594                                 if (my $style_tag = $prog_td->attr('style')) { 
    595                                         if ($style_tag =~ /^background:url\((.*)\) /) { 
    596                                                 $prog_bg = $1; 
    597                                                 &log("got prog_bg '$prog_bg'") if (defined $opt->{debug} && $opt->{debug} > 1); 
    598                                         } 
    599                                 } 
    600  
    601                                 if ((!defined $prog_fg) && (my $img_tag = $prog_td->look_down('_tag' => 'img', 'class' => 'pgimg'))) { 
    602                                         $prog_fg = $img_tag->attr('src'); 
    603                                         &log("got prog_fg '$prog_fg'") if (defined $opt->{debug} && $opt->{debug} > 1); 
    604                                 } 
    605  
    606                                 if ((!defined $prog_details) && (my $link_tag = $prog_td->look_down('_tag' => 'a', 'href' => '#'))) { 
    607                                         my $link_url = $link_tag->attr('onClick'); 
    608                                         if ($link_url =~ /^window\.open\('(.+?)'/) { 
    609                                                 $prog_details = $1; 
    610                                                 &log("got prog_details '$prog_details'") if (defined $opt->{debug} && $opt->{debug} > 1); 
    611                                         } 
    612                                 } 
    613                         } elsif ((defined $prog_td_class) && ($prog_td_class eq "yellow")) { 
    614                                 $yellow_row_count++; 
    615                                 if ($yellow_row_count == 1) {           # HD flag 
    616                                         if ($prog_td->as_text() =~ /HD/) { 
    617                                                 $prog_hd = 1; 
    618                                                 &log("prog is in HD") if (defined $opt->{debug} && $opt->{debug} > 1); 
    619                                         } else { 
    620                                                 $prog_hd = 0; 
    621                                         } 
    622                                 } elsif ($yellow_row_count == 2) {      # CC flag 
    623                                         if ($prog_td->as_text() =~ /Y/) { 
    624                                                 $prog_cc = 1; 
    625                                                 &log("prog has closed captions") if (defined $opt->{debug} && $opt->{debug} > 1); 
    626                                         } else { 
    627                                                 $prog_cc = 0; 
    628                                         } 
    629                                 } elsif ($yellow_row_count == 3) {      # rating 
    630                                         $prog_rating = $prog_td->as_text(); 
    631                                         &log("prog has rating '$prog_rating'") if (defined $opt->{debug} && $opt->{debug} > 1); 
    632                                 } 
    633                         } 
    634                 } 
    635  
    636                 &log("finished evaluating row") if (defined $opt->{debug} && $opt->{debug} > 1); 
    637  
    638                 if ((defined $prog_fg) && (defined $prog_bg) && (defined $prog_details)) { 
    639                         next if (defined $seen_prog{$prog_details}); 
    640                         $seen_prog{$prog_details}++; 
    641  
    642                         $progs_in_day++; 
    643                         &parse_one_summary_prog($day_start, $day_num, $progs_in_day, $prog_fg, $prog_bg, $prog_details, $prog_rating, $prog_hd, $prog_cc); 
    644                 } 
    645         } 
    646  
    647         &log("WARNING: Only $progs_in_day programmes seen on day $day_num in '$url' (POST $postvars). ". 
    648           "Data may be bad.") if ($progs_in_day < 10); 
    649  
    650         unless (defined $opt->{fast}) { 
    651                 my $sleep_for = 10 + int(rand(5)); 
    652                 &log(" .. found $progs_in_day programmes on day $day_num, sleeping for $sleep_for seconds."); 
    653                 sleep $sleep_for; 
    654                 $stats{slept_for} += $sleep_for; 
    655         } 
    656 } 
    657  
    658 ############################################################################## 
    659 # given a summary-line of a programme, turn it into a prog entry 
    660  
    661 sub parse_one_summary_prog 
    662 { 
    663         my ($day_start, $day_num, $progs_in_day, $prog_fg, $prog_bg, $prog_details, $prog_rating, $prog_hd, $prog_cc) = @_; 
    664         my $prog; 
    665  
    666         my $id; 
    667         $id = $1 if ($prog_bg =~ /id=(\d+)$/); 
    668  
    669         my $s; 
    670  
    671         if (!defined $data_cache->{id_cache}->{$id}) { 
    672                 $s = &ocr_image($id, "http://www.ten.com.au".$prog_fg, "http://www.ten.com.au".$prog_bg, 3, ($day_num == 1 ? 6 : 14), 0); 
    673                 $data_cache->{id_cache}->{$id}->{ocr_text} = $s; 
    674         } else { 
    675                 $s = $data_cache->{id_cache}->{$id}->{ocr_text}; 
    676                 $stats{used_cached_items}++; 
    677         } 
    678         $data_cache->{id_cache}->{$id}->{last_used} = time; 
    679  
    680         if ($s =~ /\s*(\d+):(\d+)\s*(A|P)M\s+(.*)$/) { 
    681                 my $prog_hr = $1; 
    682                 $prog_hr = 0 if ($prog_hr == 12); 
    683  
    684                 $prog->{starttime} = (($prog_hr * 60) + $2) * 60; # seconds 
    685                 $prog->{starttime} += (60*60*12) if (lc($3) eq "p"); 
    686  
    687                 $prog->{title} = [[ $4, $opt->{lang} ]]; 
    688         } elsif ($s =~ /\s*(\d+)\.(\d+)\.(\d+)\s+(\d+):(\d+)\s*(A|P)M\s+(.*)$/) { 
    689                 my $prog_hr = $4; 
    690                 $prog_hr = 0 if ($prog_hr == 12); 
    691  
    692                 $prog->{starttime} = (($prog_hr * 60) + $5) * 60; # seconds 
    693                 $prog->{starttime} += (60*60*12) if (lc($6) eq "p"); 
    694  
    695                 $prog->{title} = [[ $7, $opt->{lang} ]]; 
    696         } 
    697  
    698         if (!defined $prog->{title}) { 
    699                 &log("could not parse progname from OCR string '$s'. Format changed?"); 
    700                 $stats{unparsable_name}++; 
    701                 return; 
    702         } 
    703         if (!defined $prog->{starttime}) { 
    704                 &log("could not parse start time from OCR string '$s'. Format changed?"); 
    705                 $stats{unparsable_time}++; 
    706                 return; 
    707         } 
    708  
    709         if ($prog->{starttime} < (12*60*60)) { 
    710                 $prog->{starttime} += (24*60*60) if (defined $d->{seen_pm}->[$day_num]); 
    711         } else { 
    712                 $d->{seen_pm}->[$day_num] = 1 if (!defined $d->{seen_pm}->[$day_num]); 
    713         } 
    714         $prog->{starttime} += $day_start; 
    715  
    716         $prog->{id} = $id; 
    717         $prog->{details} = $prog_details; 
    718         $prog->{channel} = $channels->{TEN}; 
    719  
    720         if ((defined $prog_rating) && ($prog_rating ne "")) { 
    721                 my @ratings; 
    722                 push(@ratings, [$prog_rating, 'ABA', undef]); 
    723                 $prog->{rating} = [ @ratings ]; 
    724         } 
    725  
    726         $prog->{subtitles} = [ { 'type' => 'teletext' } ] if ($prog_cc); 
    727         if ($prog_hd) { 
    728                 $prog->{video}->{aspect} = "16:9";      # widescreen 
    729                 $prog->{video}->{quality} = "HDTV" unless (defined $opt->{no_hdtv_flags}); 
    730         } 
    731  
    732  
    733         # if we are fetching microgaps, skip if this isn't 
    734         # in a micro-gap. 
    735         # note: that this isn't as precise as it could be as its only working on start times! 
    736         if (defined $opt->{gaps_file}) { 
    737                 my $found_gap_match = 0; 
    738                 foreach my $g (@{($gaps->{'TEN'})}) { 
    739                         my ($s, $e) = split(/-/,$g); 
    740                         $found_gap_match = 1 if 
    741                           ((($s >= $prog->{starttime}) && ($e >= $prog->{starttime})) || 
    742                            (($s <= $prog->{starttime}) && ($e >= $prog->{starttime}))); 
    743                 } 
    744                 if (!$found_gap_match) { 
    745                         $stats{gaps_skipped}++; 
    746                         return; 
    747                 } else { 
    748                         $stats{gaps_included}++; 
    749                 } 
    750         } 
    751  
    752         push(@{($d->{progs})},$prog); 
    753  
    754         if ($stats{programmes} > 0) { 
    755                 # set previous stoptime based on this starttime 
    756                 $d->{progs}->[($stats{programmes}-1)]->{stoptime} = $prog->{starttime}; 
    757         } 
    758         $stats{programmes}++; 
    759  
    760         &log("parse_one_summary_prog: d".$day_num."p".$progs_in_day." ".$prog_details.": start:".$prog->{starttime}." name:".$prog->{title}->[0]->[0]) if (defined $opt->{debug}); 
    761  
     318                if (!defined $p->{program_name}) { 
     319                        $stats{prog_no_title}++; 
     320                        next; 
     321                } 
     322 
     323                my $prog_start = substr($p->{startTime},0,10); 
     324                my $prog_stop =  substr($p->{endTime},0,10); 
     325                if (($prog_start < $starttime) || ($prog_start > $endtime)) { 
     326                        $stats{prog_outside_window}++; 
     327                        next; 
     328                } 
     329 
     330                my $prog; 
     331                $prog->{channel} = $channels->{TEN} if (defined $channels->{TEN}); 
     332                $prog->{channel} = $opt_channels->{TEN} if (defined $opt_channels->{TEN}); 
     333                $prog->{start} = POSIX::strftime("%Y%m%d%H%M", localtime($prog_start)); 
     334                $prog->{stop} =  POSIX::strftime("%Y%m%d%H%M", localtime($prog_stop)); 
     335                $prog->{length} = ($p->{duration} * 60) if (defined $p->{duration}); 
     336                $prog->{title} = [[ $p->{program_name}, $opt->{lang} ]]; 
     337 
     338                my @categories; 
     339                push(@categories, [ "series", $opt->{lang} ] ) if ((defined $p->{is_series}) && ($p->{is_series} eq "true")); 
     340                if (defined $p->{link}) { 
     341                        $prog->{link} = $p->{link}; 
     342                        if (($p->{link} =~ /id=Hillsong/) || 
     343                            ($p->{link} =~ /id=This_Is_Your_Day_With_Benny_Hinn/) || 
     344                            ($p->{link} =~ /id=Christian_City_TV/)) { 
     345                                push(@categories, [ "Religion", $opt->{lang} ] ); 
     346                        } elsif ($p->{link} =~ /id=Home_Shopping/) { 
     347                                push(@categories, [ "Shopping", $opt->{lang} ] ); 
     348                        } 
     349                } 
     350                $prog->{'category'} = [ @categories ] if ((scalar @categories) > 0); 
     351                # "schedule_id", "series_id" 
     352 
     353                push(@{($d->{progs})}, $prog); 
     354                $stats{programmes}++; 
     355        } 
     356 
     357        print " - fetched ".$stats{programmes}." programs: ".Dumper($d) if (defined $opt->{debug}); 
    762358} 
    763359 
    … …  
    771367 
    772368        foreach my $prog (@{($d->{progs})}) { 
     369                my $url = $prog->{link}; 
    773370                my $was_in_cache = 0; 
    774  
    775371                $prog_count++; 
    776                 my $details = $prog->{details}; 
     372                next if ((!defined $url) || ($url eq "")); 
     373 
     374                if (($url =~ /id=Home_Shopping/) || 
     375                    ($url =~ /id=Hillsong/) || 
     376                    ($url =~ /id=This_Is_Your_Day_With_Benny_Hinn/) || 
     377                    ($url =~ /id=Christian_City_TV/)) { 
     378                        $stats{skipped_detail_pages}++; 
     379                        next; 
     380                } 
    777381 
    778382                if (($prog_count % 10) == 1) { 
    … …  
    780384                } 
    781385 
    782                 if (!defined $data_cache->{detail_cache}->{$details}) { 
    783                         my $url = "http://www.ten.com.au/".$details; 
    784                         my $data = &get_url($url,5); 
    785                         my $tree = HTML::TreeBuilder->new_from_content($data) if (defined $data); 
    786                         if ((!$data) || (!$tree)) { 
    787                                 &log("url '$url' doesn't seem to contain any valid details. Has the format changed?"); 
     386                if (!defined $data_cache->{prog_cache}->{$url}) { 
     387                        my $url = "http://ten.com.au".$url; 
     388                        my $tries = 3; 
     389 
     390                        &log("fetching prog ".$prog_count." [".$url."] ..") if (defined $opt->{debug} && $opt->{debug} > 1); 
     391 
     392                        my ($data, $success, $status_msg, $bytes_fetched, $seconds_slept, $failed_attempts, $mime_type) = 
     393                          Shepherd::Common::get_url(url => $url, retries => ($tries-1)); 
     394 
     395                        $stats{failed_requests} += $failed_attempts; 
     396                        $stats{slept_for} += $seconds_slept; 
     397                        $stats{bytes_fetched} += $bytes_fetched; 
     398 
     399                        if ((!$data) || (!$success)) { 
     400                                &log("Failed to fetch '$url' after $tries attempts. Has the format changed?"); 
    788401                                $stats{bad_detail_response}++; 
    789                                 return; 
    790                         } 
    791  
    792                         # parse description from first 'class=info' table cell 
    793                         my $prog_desc = $tree->look_down('_tag' => 'td', 'class' => 'info', 'style' => 'text-align:justify;'); 
     402                                next; 
     403                        } 
     404 
     405                        $stats{http_successful_requests}++; 
     406 
     407                        # parse details 
     408                        my $tree = HTML::TreeBuilder->new_from_content($data); 
     409 
     410                        # prog description 
     411                        my $prog_desc = $tree->look_down('_tag' => 'td', 'class' => 'bottom-row'); 
    794412                        if (defined $prog_desc) { 
    795                                 $data_cache->{detail_cache}->{$details}->{desc} = [[ $prog_desc->as_text(), $opt->{lang} ]]; 
    796                                 &log("got desc '".$prog_desc->as_text()."'") if (defined $opt->{debug} && $opt->{debug} > 1); 
    797                         } 
    798  
    799                         my $genre_group = &get_url("http://www.ten.com.au/pgutil/epfront.ashx?cd=2&id=".$prog->{id},3,undef,"HEAD"); 
    800                         if ((defined $genre_group) && ($genre_group ne "")) { 
    801                                 if (defined $d->{gset}->{$genre_group}) { 
    802                                         $data_cache->{detail_cache}->{$details}->{category} = [[ translate_category($d->{gset}->{$genre_group}), $opt->{lang} ]]; 
    803                                 } else { 
    804                                         $data_cache->{detail_cache}->{$details}->{category} = [[ $genre_group, $opt->{lang} ]]; 
    805                                         &log("unknown genre group '$genre_group' for prog '".$prog->{title}->[0]->[0]."'"); 
    806                                         $stats{unknown_genre}++; 
    807                                 } 
    808                         } 
    809  
    810                         if ($data =~ /EPISODE:/) { 
    811                                 my $s = &ocr_image($prog->{id}, "http://www.ten.com.au/pgutil/epfront.ashx?cd=1&id=".$prog->{id}, "http://www.ten.com.au/pgutil/epback.ashx?cd=1&id=".$prog->{id}, 3, 0, 1); 
    812                                 if ((defined $s) && ($s ne "")) { 
    813                                         $data_cache->{detail_cache}->{$details}->{'sub-title'} = [[ $s, $opt->{lang} ]]; 
     413                                $data_cache->{prog_cache}->{$url}->{desc} = [[ $prog_desc->as_text(), $opt->{lang} ]]; 
     414                                &log("  got desc '".$prog_desc->as_text()."'") if (defined $opt->{debug} && $opt->{debug} > 1); 
     415                        } 
     416 
     417                        # closed captions 
     418                        if ($data !~ /No closed captions/) { 
     419                                $data_cache->{prog_cache}->{$url}->{subtitles} = [ { 'type' => 'teletext' } ]; 
     420                                &log("  got closed-captions") if (defined $opt->{debug} && $opt->{debug} > 1); 
     421                        } 
     422 
     423                        # HD 
     424                        if ($data !~ /Not high definition/) { 
     425                                $data_cache->{prog_cache}->{$url}->{video}->{aspect} = "16:9";      # widescreen 
     426                                $data_cache->{prog_cache}->{$url}->{video}->{quality} = "HDTV" unless (defined $opt->{no_hdtv_flags}); 
     427                                &log("  got HD") if (defined $opt->{debug} && $opt->{debug} > 1); 
     428                        } 
     429 
     430                        # Rating 
     431                        if ($data =~ /"Rated ([A-Z0-9a-z]+)"/) { 
     432                                my $prog_rating = $1; 
     433                                if ((defined $prog_rating) && ($prog_rating ne "")) { 
     434                                        my @ratings; 
     435                                        push(@ratings, [$prog_rating, 'ABA', undef]); 
     436                                        $data_cache->{prog_cache}->{$url}->{rating} = [ @ratings ]; 
     437                                        &log("  got rating ".$prog_rating) if (defined $opt->{debug} && $opt->{debug} > 1); 
    814438                                } 
    815439                        } 
    … …  
    818442                        $was_in_cache = 1; 
    819443                } 
    820  
    821                 $data_cache->{detail_cache}->{$details}->{last_used} = time; 
    822  
    823                 $prog->{desc} = $data_cache->{detail_cache}->{$details}->{desc} 
    824                     if (defined $data_cache->{detail_cache}->{$details}->{desc}); 
    825  
    826                 $prog->{category} = $data_cache->{detail_cache}->{$details}->{category} 
    827                     if (defined $data_cache->{detail_cache}->{$details}->{category}); 
    828  
    829                 $prog->{'sub-title'} = $data_cache->{detail_cache}->{$details}->{'sub-title'} 
    830                     if (defined $data_cache->{detail_cache}->{$details}->{'sub-title'}); 
     444                $data_cache->{prog_cache}->{$url}->{last_used} = time; 
     445 
     446                # augment prog details based on cache 
     447                foreach my $field ("desc", "subtitles", "video", "rating") { 
     448                        if (defined $data_cache->{prog_cache}->{$url}->{$field}) { 
     449                                $prog->{$field} = $data_cache->{prog_cache}->{$url}->{$field}; 
     450                        } 
     451                } 
    831452 
    832453                unless ((defined $opt->{fast}) || ($was_in_cache)) { 
    … …  
    838459} 
    839460 
    840 ############################################################################## 
    841  
    842 sub parse_characters 
    843 { 
    844         my ($imgname,$i,$space_threshold) = @_; 
    845  
    846         my ($width, $height) = $i->getBounds; 
    847         my $bg = $i->getPixel(0,0); 
    848  
    849         # flatten image colours 
    850         my @bgcolour; 
    851         foreach my $index (0..$i->colorsTotal) { 
    852                 my @r = $i->rgb($index); 
    853                 my $total = $r[0]+$r[1]+$r[2]; 
    854  
    855                 if ($total > (240*3)) { 
    856                         $bgcolour[$index] = 1; 
    857                 } else { 
    858                         $bgcolour[$index] = 0; 
    859                 } 
    860         } 
    861  
    862         my $char_x1 = 0; 
    863         my $char_x2 = 0; 
    864         my $last_char_x = 0; 
    865         my $done = 0; 
    866         my $charnum = 0; 
    867         my $s = ""; 
    868  
    869         while (!$done) { 
    870                 $char_x2++; 
    871                 $done = 1 if ($char_x2 >= ($width-1)); 
    872  
    873                 my $blank_line = 1;     # until proven otherwise 
    874                 my $char_y = 0; 
    875                 while (($char_y < ($height-1)) && ($blank_line)) { 
    876                         my $index = $i->getPixel($char_x2,$char_y); 
    877                         $blank_line = 0 if ($bgcolour[($i->getPixel($char_x2,$char_y))] == 0); 
    878                         $char_y++; 
    879                 } 
    880  
    881                 if (($blank_line) || ($char_x2 == ($width-1))) { 
    882                         if (($char_x2 - $char_x1) == 1) { 
    883                                 $char_x1 = $char_x2 + 1; 
    884                                 $char_x2++; 
    885                                 next; 
    886                         } 
    887  
    888                         if (($char_x1 - $last_char_x) >= 3) { 
    889                                 if (($charnum > $space_threshold) || (($char_x1 - $last_char_x) >= 4)) { 
    890                                         $s .= " "; 
    891                                         $charnum++; 
    892                                 } 
    893                         } 
    894                         $last_char_x = $char_x2; 
    895  
    896                         my $str = pack('N',($char_x2-$char_x1)); 
    897                         foreach my $x ($char_x1..$char_x2) { 
    898                                 foreach my $y (0..($height-1)) { 
    899                                         $str .= pack('N', $bgcolour[($i->getPixel($x, $y))]); 
    900                                 } 
    901                         } 
    902                         my $md5 = Digest::MD5::md5_hex($str); 
    903                         $charnum++; 
    904  
    905                         if ((!defined $d->{charset}->{$md5}) || ($d->{charset}->{$md5} eq "?")) { 
    906                                 if (defined $opt->{ocr_learn_mode}) { 
    907                                         $d->{charset}->{$md5} = "[".$md5."]"; 
    908                                         $s .= "[".$md5."]"; 
    909                                 } else { 
    910                                         $s .= "?"; 
    911                                 } 
    912                         } else { 
    913                                 $s .= $d->{charset}->{$md5}; 
    914                         } 
    915  
    916                         $char_x1 = $char_x2+1; 
    917                         $char_x2++; 
    918                 } 
    919         } 
    920  
    921         return $s; 
    922 } 
    923  
    924 ############################################################################## 
    925  
    926 sub setup_charset 
    927 { 
    928         my %charset = qw{ 
    929                 87b7de3dbbeda572e883253803f73a78 e caa8c600dd0aecf49f445753963e97b5 : 46854a6efed48426f1018828cca41ac2 o 
    930                 f64db65ec25ba73bdced42fcf01be00a r d0ec43eddec59827259b46c460386ae0 l d4fb05e2702c4199a73794b5def96ec2 G 
    931                 ca1cbc6861523c4608f19365cac6dde0 0 a49667c09e9d4be0b595578d51eeb60d M 1a9de7fb6f1c93f3ffaa15816549e43a 6 
    932                 fbec6375cab7ff5b9d4b4783c7aab13b s b1465cc2781264fff5a55a9e9b3d8064 A b61b8c026407890a23276d41125d7e98 h 
    933                 8e2a682942360201f924e694dc70fa43 T c1e402fec1d35694b1898b1f1dbb16bb w bed2eaba5e16b7246bb1f5b94d44b61c h 
    934                 c0107f886a27e42ce8fd2eca63a5ebcc D 8300a291d7dae2e876126878c98af6d1 S 7edd9f81d7da6577d57da07f93f95b87 E 
    935                 ec5d1b2140213fdbbf3c837400b2d3c5 e 14e3c224bd590504ffa95a1987ac3fbc n 55ced8bf6a2a2482f578bc988b60b5ed a 
    936                 51bc70bfed877b2bf7300a5023a88634 o 5ae0c7cc64eb457ed198ee008fcd52f9 d 8769704a7c47684c74d841673664f942 V 
    937                 763602fa61fe36273a3492f3fbae0ff8 t 0efb2ccf6c4e8b3084e56da89ad6629b 7 70dddd8427594526c8fd308b6151d673 i 
    938                 75419c36d52e0f29143d4ecf3c5fd2fd W 592559bccc3f515e5d2a93622320a1a2 m 4e4073891b344c07deceee07cd6ba348 g 
    939                 9e2f28787475e105da5221e20eb7a137 r f7e8dade3df2070be62dd206ef0cc8f1 5 62982338ad7a6b499056bac67f840d83 N 
    940                 97fd0fdcedad187e8bf877adc5d580c5 2 35f9e067a546f3ae0057065223fe4c33 3 97f15e1d2ad1cb232147d0b6f01c8022 O 
    941                 4c52033ce6a724d184d9c8d23a960d6e P 9fbd3153eb8e55a0a1f453ee33e6bafd i e7a5cbb21f17f35f2f141e63f37a45fb c 
    942                 f7e8dade3df2070be62dd206ef0cc8f1 5 646db1d6726727e809ed1eb7ea11f545 8 c5ed676c18b62bc6885e34bf527e66af Y 
    943                 99bea8c75f15219ca16a7229b3938665 u a9ea989899145834e84daf0abc5964f0 ! 8113592ffa186852672d458f5bd86135 k 
    944                 fec8880342772dd7e83ca9ffeed0e216 l 185a57d42d98c6cbd85135d9e8295501 D 606bf5428471cfd5de3434374c281334 y 
    945                 50692dc12cde0fae151d9a0c2563c81d J f3045893d14fbb5f20e215a38617aee4 0 cf78a362c08ef3b9284ade8113e670d7 R 
    946                 0de173cf09ded97fff935aa24f7f8bfe z cf63706b1f8eaa1c9120e1f9794918c3 T f9f2e0d23af08cb6fbeacb686992f633 v 
    947                 c1777c45a7d53a5d557c5da145bea080 ' 88f4902f74cf89846318c96003466835 p 2b821839a93b75e470d04a5e2c1971b3 J 
    948                 120cfb2dcf74d7900dc22d44bea9db09 H 298b488eb21a879c4cf9007c05283a15 s 08021ebe5ef72c0ed41b438fd794e71e tt 
    949                 b24415f6bccb3a9ad482156a524dbf1e y 6c27fb8ed1d2d451785d957138ca0902 u 5a6e6307a1b18b409618616556a327e5 E 
    950                 8d4430c7857a01d4805b4666c54fe114 b cf9c23550ff1fde3b19b593966fdd391 S 97986e54d74ef7047eebc1169134564f B 
    951                 561fda757040c25038687752394d39a8 M 8015f8d4c3d6574c9ec73b412ece2013 L 7fdc4d50db244ad00f11d7c362f10b8f 9 
    952                 73f0455d71b4156ab2bbebb7fac004ca 4 401ccf9844fe6399f13597cb458abedb a 28de7104f0f94e161104c407071a5e91 m 
    953                 cc282e429660787afc4a292a6e35cb2a F 449bb458f502dbb10cf71673d1bd7ac4 5 eb6c72d1cb3b32bfcf646e2c5dafc4d2 N 
    954                 aa364cab095bc5f46f855c9772619f5e 1 6aadacaa0e0b622fe755be8615f67f87 2 0f87f473885da54c2a7c886ae92f0ddd R 
    955                 17d10978ffc796cc024c68afa3fb463c I 70b21817f2611845e464f8b551c73b71 1 f5a215139fdc4921b4fad687e0899fdc H 
    956                 8b9e1cc11d23773ca68afaea3064902a A 6adf28b9140e9b236394bd6956638630 9 0d2eeea7b20edb640d5556ea8528ba67 K 
    957                 3503cdc59df22be3b6242db35cfe3482 f b5856240a388696d55ea99fad53166ce W 4b8e08032dde00ced51e8435820be5e1 n 
    958                 38b1c7da79cbbac219c590129f40cca1 k 1697c04376dac187f028f240cb0ccc9a C 2e03a06a91a1993a5c6e15b43784e5c3 3 
    959                 840e43645d65217fd0d57914321db2bf : 5e871ec322ade9e74d44285c3ddad972 L e3bcb0065109e004bc6b18b1403fb810 rt 
    960                 9f32b9cd5083733eead4380bb6551ac5 B 148cafcb02f1a203866f583dbdb253af & 519cc9d317d1a6db113c0da6e5560e71 d 
    961                 40ec9716cfe72fe54201dae866e70ec5 V ace17452c10518e97caba9493898c910 U d244b3a33602a55c1ee8cf9c570dced9 - 
    962                 25ee9123a9fdb7c164b29dfaa50d10b7 6 a87bc5bc8b3e5df44df2e2405561dd83 . f6e64e873007d53c7bf7873d639f4678 . 
    963                 de8b17aa3cf358a1e8b9496dd99e20f1 7 21e73997781a1af8c506eded30c6143f 4 4518bf9cb085588761164be21442aa5d F 
    964                 c38b4e845130be00f1a27a023241a500 ! f5a9cba4badf510bbde66e1012647c8c O c67d0abf9dd1bf2352613c243de4649b P 
    965                 453b59cf0cb2813958d5518fc668639c Z 3dad6dcdedabfbb99ef2067f38d6bd67 B b2da7f7ca8c9be23ca445a7df954a4f2 8 
    966                 8a3bf2c9eb10c811e50c91759e6e57cc G f9e0333c0725c22b198bc0c3a7aa4a51 x 61ea6df7256f910d1cb031979d7d1eda C 
    967                 588b076556aa1b58810fe1f97fa77371 Y 8a3bf2c9eb10c811e50c91759e6e57cc G 61ea6df7256f910d1cb031979d7d1eda C 
    968  
    969                 5892305501d6d7b3c944edcdfac487b0 W cb28d04e3bbe3bfd0bf0086b5b50b50e a d9f38cfa215b61b0baf8d3232ab71e5a c 
    970                 bcfbf5865682d0d691b0ba7ad34b4e5f k 0ff718ec0df83d26df8ef58f27af3e1d y df27299772b1c1fa25bc74e3e0b28519 M 
    971                 e74795b60c312f1fa48d956433cffd67 d e1bcd7c44b8fd705281926db43eae7f2 n c677cf0e0d2124629e224628a01a96fe e 
    972                 df74545eacbaf90dc1206ef81be97bbb s 118dfa4e0e53dbde0a74554c16f4b6e8 A 6ac1a637edb8d167b9b0263b72d30d50 B 
    973                 ab0135e45bdc858357c40d35e2a6d662 l 202c9276948bf52699ef2521988c2ed0 z f65810bb9e22c25d31a442b3ff1ec3e8 i 
    974                 f079edc2a2167e5c3b5a0250130ad3cc g 6ac1a637edb8d167b9b0263b72d30d50 B 238d4f228563b5efcd46fdb0ee0fa367 ttl 
    975                 df74545eacbaf90dc1206ef81be97bbb s acf02f7463a907c98ccfdaf1364e506a ( 761086404df3dd6a879c15722e6b5c72 P 
    976                 f932ec8ddd3f2edd739a715090614687 1 ff8c0771c4dc7c6a1867ada5d47c1446 ) 26e1d6a4efa3a6e7d107a7003924ad9f rt 
    977                 27e56f6930a29f7ccb1f2ed98c2c99be G 168527e83abcaee41f74514b627b651a ra 9ab22051e33a6755e407cc69ea9d02b4 a 
    978                 9ab22051e33a6755e407cc69ea9d02b4 p 0e6e0a842f847b0997de866dcb69fd7d th 98dee45f3aa315b8d6d1c2a83208e158 u 
    979                 90b5c188102f105c0cab2556d27b0788 rd 154690fb8d4578148e1513ab0f921076 P 34065c67fbb12cce0561001cd462d573 a 
    980                 1d58b69f2b50b50daacfb7645a0fdd18 rt 13f9bf707f893bc39e10ce0475e151a7 I 3af52f596fd1c33743a59d7fa816aaa3 ts 
    981                 2e1e8bd83e52ee09bb58297aeb1da158 Th 1e128beba3aff04a49fba2b291603579 Re aa296120499cf1ee8868ec6759895f9b m 
    982                 f74eae3e6c5426b5da01fb1ad236e1a2 Tw faa3822c5ea6489c829cafc96ba86271 o a507f381a52898da1b4c63a3252559ef N 
    983                 0e07a84d610ae1d5f823c02573825438 h 49b35e005120197a73685301f17ddd92 b f66ffe4a80deebe8ffca678d33e33f7b rs 
    984                 2e1e8bd83e52ee09bb58297aeb1da158 Th 28a61bb021be4f7b4d43c3a995207169 re 33f3092e1d836e03bbbe45cf77f46183 S 
    985                 517c4ccbb8292617db5d758e868023a0 M ac8de377a8f7d07007d10ad37eeaa88b r e42460162dfa7d0d9ad67efe32f9505c . 
    986                 7f84b8c690c3b0412a0514e117a04c69 S fd84447f45a91a443e1863fa7a2c830e p 1e92bddfb0b4813630d147a38863543d ri 
    987                 84db1131cd6f3ed6f630e58b879f781f tz 0fd741130b71b082f1eeebda6e2e2811 G a26fbebcec2437f07bad0ad6f6dc2313 o 
    988                 29f53067840a08d6ca5c34834ad14e77 e 673324edd255d182fad9267db821f230 s d3f8a87a788b91db4886c6a4c0e5a82d To 
    989                 11a9bc26a268f7cd5787ccae1a3a7fd6 to a68667571be8a5b2aaf5fd4f4f429d41 D 8d4c375b6b8db04ccee5077e5ba33863 Re 
    990                 ed445642499ca8148938c51518771540 e a1d72e973b08017846fcd70a732b3143 i 70a7a183ec29e18634005ddde569f65d a 
    991                 29dc936fcdb2723b69c638a022135ff2 tch 3961534a0448ed072632dce5dba32d2a e e27d84de85414214f105583f45d406d7 d 
    992                 0dc0ef29925f3ddffb70ce1107ca1b4d ri b46e207278c9048939ff4eb56d1aa847 t 53f78e0dc0417e0f6a455299e15dca0c V 
    993                 ef32aff5c88702eb5ed51c3a6836a583 7 732b43290b91d76547d1e4dd5e85ab8f - ade03db1bcb287d34d4ca9c9bd82c227 r 
    994                 2f49cdc45bf918107fd3001a57d334cc U 96ab55702d9094de2f158ec3a5f1dd00 n a1a6c673257c30fe6b02ed3a5de7acec to 
    995                 222c34badb06b16ff61a3bfdbd2087c5 l b6e528d8cb510fceabfcb1d280e539d9 W bd4a858bb84721b3c83498f9e4e33b20 a 
    996                 222c34badb06b16ff61a3bfdbd2087c5 l a49e3b56b645aa6dc1de7a81898c92ba th b2c89ec08fe126b2e147bc3fceb5b72e S 
    997                 05dd472da0bb30cf7eb463c5eea42aca u ce6488a8ce8ae8a8e81bdc631880780d c 000312319671d8f7f93eb9461828c238 s 
    998                 49ba6d6bfe0d856eb6808ab901bf0ec3 F 207d6b243ade809ae1cad6507711d528 ro 37138974a7027ed973547cce5fba5db7 m 
    999                 c458ef3d193bfddaecd9970d9a57f844 P bd4a858bb84721b3c83498f9e4e33b20 a af722d233b9e8ae897b72d15fd8b5bc4 ti 
    1000                 7f76b9fb361c686de8ec1c828c71da4b v 4dcdd7bc37f7b3dae2943ddb8618bbc1 9 8fc445dd8da1ee8f8542ca18a4816109 V 
    1001                 5eee84d45d3263e5db81dfcc62d101fa 2 51b4a925ee708b2f6050b725027e8fce C 6757bd902890a015a7187ea6af564ba3 E 
    1002                 a2a73ec9775aa11219b7ef2c641bec99 rn b9a410fec13a6d2bcef569ed0a0f3be8 Z 6ee428b070cd640780d97ad7cddddc34 o 
    1003                 a5b90eb61c4dba3e90cf1a4c845ef57e ft ba6a993239ab750cf9ebc2409e47bdee Ro 21301919d35af079f6304c4f2a6369be k 
    1004                 c0ee576773017a3997e92c21084a2d75 E 53daff24c12468ffed61af47a05f35f3 x 0f37e15b434799497cf9d55a7a6762ec tr 
    1005                 acf9a544b03d5517dd4ef56b31f5b6c6 a 2b8c1a24fb22ed3195e8215986761031 c d22458ed1392293e4b93b65062e4b070 ti 
    1006                 625890d2b6bc9c8335478b8ad0c94c8d on 1afac41e2a078eaf3969c3cf6135470e D 6ee428b070cd640780d97ad7cddddc34 o 
    1007                 6ee428b070cd640780d97ad7cddddc34 a 
    1008  
    1009                 5d0f4810540757a126f8258d74a73003 3 dc34163485c9a2eca2c7ab2b5f61b96c 9 ce9143a33f5445fa47bc0075aec77136 / 
    1010                 5cba572685cd08ffd428894877e9eaf3 4 78b9b0dd4be899f45090481719ad3d39 te 0e98c1eae7e2f8fbbc07e8ba8840e8f8 B 
    1011                 0cbcd03fb1247b70dc8265db22d9bf7d ru 6308d839b3c78268493481cf36dd59e5 fa 1160d2f51cf8259379c2436f0e82fbab t 
    1012                 2bdea6db720cd4c6be4d5e8749589671 b eaf198c7946cbff27c55e4e5bac89bc4 H 9386db443505042567131bb97f6d12d4 r' 
    1013  
    1014  
    1015                 }; 
    1016         $d->{charset} = \%charset; 
    1017  
    1018  
    1019         my %gset = qw{ 
    1020                 491 News 508 Children 531 Entertainment 496 Drama 533 Infotainment 
    1021                 507 Religion 494 Sport}; 
    1022         $d->{gset} = \%gset; 
    1023 } 
    1024  
    1025 ############################################################################## 
    1026  
    1027 sub ocr_image 
    1028 { 
    1029         my ($id, $fg_url, $bg_url, $tries, $space_width, $multiline) = @_; 
    1030         $multiline = 0 if (!defined $multiline); 
    1031  
    1032         my $fg_gif_image = &get_url($fg_url, $tries); 
    1033         my $bg_png_image = &get_url($bg_url, $tries); 
    1034  
    1035         my $fg_image = GD::Image->newFromGifData($fg_gif_image); 
    1036         my $bg_image = GD::Image->newFromPngData($bg_png_image); 
    1037  
    1038         $bg_image->copyMerge($fg_image, 0, 0, 0, 0, $fg_image->width, $fg_image->height, 100); 
    1039  
    1040         if (!$multiline) { 
    1041                 # remove underline 
    1042                 my $white = $bg_image->colorExact(255,255,255); 
    1043                 $bg_image->filledRectangle(0, 14, $fg_image->width, $fg_image->height, $white); 
    1044  
    1045                 return parse_characters($id, $bg_image, $space_width); 
    1046         } 
    1047  
    1048         return parse_multiline_characters($id, $bg_image); 
    1049 } 
    1050  
    1051 ############################################################################## 
    1052  
    1053 sub parse_multiline_characters 
    1054 { 
    1055         my ($imgname,$i) = @_; 
    1056  
    1057         my ($width, $height) = $i->getBounds; 
    1058         my $bg = $i->getPixel(0,0); 
    1059         &log("image bounds: x=$width, y=$height") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1060  
    1061         # flatten image colours 
    1062         my @bgcolour; 
    1063         foreach my $index (0..$i->colorsTotal) { 
    1064                 my @r = $i->rgb($index); 
    1065                 my $total = $r[0]+$r[1]+$r[2]; 
    1066  
    1067                 if ($total > (240*3)) { 
    1068                         $bgcolour[$index] = 1; 
    1069                 } else { 
    1070                         $bgcolour[$index] = 0; 
    1071                 } 
    1072         } 
    1073  
    1074         my $last_char_x; 
    1075         my $charnum = 0; 
    1076         my $s = ""; 
    1077  
    1078         my $done = 0; 
    1079         my $char_y1 = 0; 
    1080         my $char_y2 = 0; 
    1081  
    1082         while (!$done) { 
    1083                 # 1. find first non-blank horizontal 
    1084                 $char_y1 = $char_y2; 
    1085                 my $blank_y_line = 1;   # until proven otherwise 
    1086                 while (($blank_y_line) && ($char_y1 < ($height-1))) { 
    1087                         my $char_x = 0; 
    1088                         while ($char_x < ($width-1)) { 
    1089                                 my $index = $i->getPixel($char_x, $char_y1); 
    1090                                 $blank_y_line = 0 if ($bgcolour[($i->getPixel($char_x,$char_y1))] == 0); 
    1091                                 $char_x++; 
    1092                         } 
    1093                         if ($blank_y_line) { 
    1094                                 &log("[1] whole-of-line y $char_y1 was blank!") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1095                                 $char_y1++; 
    1096                         } 
    1097                 } 
    1098                 if ($blank_y_line) { 
    1099                         &log("[1] reached end of image without finding anymore non-blank y lines. end of image!") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1100                         $done = 1; 
    1101                         next; 
    1102                 } 
    1103                 &log("[1] non-blank horizontal line found: y1=$char_y1") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1104  
    1105                 # 2. find first blank horizontal 
    1106                 $char_y2 = $char_y1; 
    1107                 my $nonblank_y_line = 0; 
    1108                 while (($nonblank_y_line == 0) && ($char_y2 < ($height-1))) { 
    1109                         my $char_x = 0; 
    1110                         $nonblank_y_line = 1; 
    1111                         while ($char_x < ($width-1)) { 
    1112                                 my $index = $i->getPixel($char_x, $char_y2); 
    1113                                 $nonblank_y_line = 0 if ($bgcolour[($i->getPixel($char_x,$char_y2))] == 0); 
    1114                                 $char_x++; 
    1115                         } 
    1116                         if ($nonblank_y_line == 0) { 
    1117                                 &log("[2] whole-of-line y $char_y2 was nonblank!") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1118                                 $char_y2++; 
    1119                         } 
    1120                 } 
    1121                 &log("[2] blank horizontal line found: y2=$char_y2") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1122  
    1123                 my $done_line = 0; 
    1124                 my $char_x1 = 0; 
    1125                 my $char_x2 = 0; 
    1126                 while (!$done_line) { 
    1127                         # 3. find first non-blank vertical between char_y1 and char_y2 
    1128                         $char_x1 = $char_x2; 
    1129                         my $blank_x_line = 1;   # until proven otherwise 
    1130                         while (($blank_x_line) && ($char_x1 < ($width-1))) { 
    1131                                 my $char_y = $char_y1; 
    1132                                 while ($char_y < $char_y2) { 
    1133                                         my $index = $i->getPixel($char_x1,$char_y); 
    1134                                         $blank_x_line = 0 if ($bgcolour[($i->getPixel($char_x1,$char_y))] == 0); 
    1135                                         $char_y++; 
    1136                                 } 
    1137                                 if ($blank_x_line) { 
    1138                                         &log("[3] whole-of-line x $char_x1 was blank!") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1139                                         $char_x1++; 
    1140                                 } 
    1141                         } 
    1142                         if ($blank_x_line) { 
    1143                                 &log("[3] end of this line (x1 is $char_x1), looking for next line...") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1144                                 $done_line = 1; 
    1145                                 $s .= " " if ($s ne ""); 
    1146                                 next; 
    1147                         } 
    1148                         &log("[3] non-blank vertical line found: x1=$char_x1") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1149  
    1150                         # 4. find first blank vertical between char_y1 and char_y2 
    1151                         $char_x2 = $char_x1; 
    1152                         my $nonblank_x_line = 0; 
    1153                         while (($nonblank_x_line == 0) && ($char_x2 < ($width-1))) { 
    1154                                 my $char_y = $char_y1; 
    1155                                 $nonblank_x_line = 1; 
    1156                                 while ($char_y < $char_y2) { 
    1157                                         my $index = $i->getPixel($char_x2,$char_y); 
    1158                                         $nonblank_x_line = 0 if ($bgcolour[($i->getPixel($char_x2,$char_y))] == 0); 
    1159                                         $char_y++; 
    1160                                 } 
    1161                                 if ($nonblank_x_line == 0) { 
    1162                                         &log("[4] whole-of-line x $char_x2 wasn't blank!") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1163                                         $char_x2++; 
    1164                                 } 
    1165                         } 
    1166                         &log("blank vertical line found: x2=$char_x2") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1167  
    1168                         &log("looking at character between: x1,y1 $char_x1,$char_y1 and x2,y2 $char_x2,$char_y2 ........") if ((defined $opt->{debug}) && ($opt->{debug} > 3)); 
    1169                         # 5. insert spaces 
    1170                         if ((defined $last_char_x) && (($char_x1 - $last_char_x) >= 3)) { 
    1171                                 $s .= " "; 
    1172                                 $charnum++; 
    1173                         } 
    1174                         $last_char_x = $char_x2; 
    1175  
    1176                         # 6. md5 char 
    1177                         my $str = pack('NN',($char_x2-$char_x1),($char_y2-$char_y1)); 
    1178                         foreach my $x ($char_x1..($char_x2-1)) { 
    1179                                 foreach my $y ($char_y1..($char_y2-1)) { 
    1180                                         $str .= pack('N', $bgcolour[($i->getPixel($x, $y))]); 
    1181                                 } 
    1182                         } 
    1183                         my $md5 = Digest::MD5::md5_hex($str); 
    1184                         $charnum++; 
    1185  
    1186                         # 7. insert char 
    1187                         if ((!defined $d->{charset}->{$md5}) || ($d->{charset}->{$md5} eq "?")) { 
    1188                                 if (defined $opt->{ocr_learn_mode}) { 
    1189                                         $d->{charset}->{$md5} = "[".$md5."]"; 
    1190                                         $s .= "[".$md5."]"; 
    1191                                 } else { 
    1192                                         $s .= "?"; 
    1193                                 } 
    1194                         } else { 
    1195                                 $s .= $d->{charset}->{$md5}; 
    1196                         } 
    1197                 } 
    1198         } 
    1199  
    1200         &log("multiline ocr got '$s'") if (defined $opt->{debug} && $opt->{debug} > 1); 
    1201         return $s; 
    1202 }