root/trunk/grabbers/rex @ 1061

Revision 1061, 30.2 kB (checked in by paul, 5 years ago)

regions 90 and 98 change and new regions 266,267,268
remove Prime (Regional Victoria),Prime (Albury) and Prime Canberra/Sth Coast
add TEN HD to region 74 darwin
other cleanups
Line 
1#!/usr/bin/perl -w
2#
3# "Rex"
4
5my $version  = '3.6.8';
6
7# An Australian TV Guide Grabber (a.k.a. tv_grab_au)
8# by Max Barry
9# http://www.maxbarry.com
10#
11# Based on the long-serving but currently defunct NMSN Australian TV grabber
12# by Michael 'Immir' Smith
13#
14# Use --help for command-line options.
15#
16# A current version of this script, plus a README file, might be here:
17# http://www.whuffy.com/tv_grab_au/
18#
19# To install Perl dependencies (like XMLTV.pm), you generally need to
20# do this (as root): perl -MCPAN -e 'install <whatever>'
21# E.g. perl -MCPAN -e 'install XMLTV::Ask'
22#
23# Changelog:
24# 0.1.0   : Let there be code
25# 0.2.0   : Better caching (fewer HTTP connections)
26# 0.3.0   : Aborted attempt to use proxy caches
27# 0.4.0   : Reverted to non-proxy version; switched datasources
28# 1.0.0   : --configure works; code released
29# 1.0.1   : Bugfix : --config-file now works
30# 1.1.0   : Feature: --stats option
31# 1.1.1   : Bugfix : Download Pay TV show details properly
32# 1.1.2   : Bugfix : Replaced non-working --static with --test;
33#                    put sport and free-to-air movies in correct category
34#                    for MythTV
35# 1.1.3   : Bugfix : Don't die on a failed download, just report
36# 1.2.0   : Feature: --cache-file option
37# 1.2.1   : Bugfix : Better explanation for config-file failure
38# 1.2.2   : Bugfix : Get more than 1 day's data for Pay TV channels
39# 1.2.3   : Bugfix : Translate some category names for MythTV
40# 1.2.4   : Bugfix : Better handling of config file locations
41# 1.2.5   : Bugfix : Corrected typo in a category name
42# 2.0.0   : Datasource change: August 29th, 2006
43# 2.1.0   : Feature: Interpret javascript
44# 2.1.1   : Bugfix : Try to avoid replacing good data with poisoned data
45# 2.1.2   : Bugfix : Minor code tidy
46# 2.2.0   : Feature: --help option
47# 2.2.1   : Bugfix : Don't overwrite cache if no shows found (e.g. net failure)
48# 2.3.0   : Feature: Better detection of changes to pre-fetched guide data
49# 2.3.1   : Bugfix : adapted precache to non-fatal datasource change
50# 2.4.0   : Feature: --quick option
51# 2.4.1   : Bugfix : removed --quick (too hard to accurately parse stop time);
52#                    code tidy
53# 2.4.2   : Bugfix : progress stats on by default
54# 2.5.0   : Feature: altered/added --ignore-cache, --nowrite-cache, and
55#                    --rebuild-cache options; exit on unknown option
56# 3.0.0   : Shepherd compliance
57# 3.1.0   : Feature: --ready option
58# 3.2.0   : Feature: gzip compression, report KB downloaded
59# 3.2.1   : Bugfix : handle failed downloads properly
60# 3.2.2   : Bugfix : no empty sub-titles in cache; no output buffering
61# 3.3.0   : Feature: categorize HDTV, premieres, repeats, original airdates,
62#                    and widescreen broadcats correctly in XMLTV (not all
63#                    supported by MythTV, alas)
64# 3.3.1   : Bugfix : stop dumping cache items unnecessarily
65# 3.3.2   : Bugfix : fixed regexp weirdness
66# 3.3.3   : Bugfix : more regexp tweaking; fixed premiere tag
67# 3.3.4   : Bugfix : tweaked Rex's name in XMLTV output
68# 3.3.5   : Bugfix : support opt_channels (HDTV in Shepherd)
69# 3.3.6   : Bugfix : neater options parsing
70# 3.3.7   : Bugfix : now runs from current dir, not ~/.rex/
71# 3.3.8   : Bugfix : better handling of failed downloads & parses
72# 3.3.9   : Bugfix : more descriptive dies
73# 3.4.0   : Feature: micrograbbing (--gaps_file)
74# 3.4.1   : Bugfix : don't die on bad web data
75# 3.4.2   : Bugfix : use stop data in cache verification (much better)
76# 3.4.3   : Bugfix : don't die on corrupted cache file
77# 3.4.4   : Bugfix : --dump-cache works
78# 3.4.5   : Bugfix : support regions with multiple channels of same name
79# 3.4.6   : Bugfix : more reliable dying on network failure
80# 3.4.7   : Bugfix : eliminate possible memory leak
81# 3.4.8   : Bugfix : datasource change for region 79, patch from Paul
82# 3.4.9   : Bugfix : remove overly verbose messages
83# 3.5.0   : Code change: use Shepherd::Common
84# 3.5.1   : Bugfix : exit on missing channels_file
85# 3.5.2   : Bugfix : honour webwarper option
86# 3.5.3   : Bugfix : hand over sleeping duties to Shepherd::Common
87# 3.5.4   : Bugfix : suppress useless warning
88# 3.5.5   : Bugfix : add Encode to dependency list
89# 3.5.6   : Bugfix : channel name changes
90# 3.5.7   : Bugfix : parse "rest of day" guide page correctly
91# 3.5.8   : Bugfix : don't die on failed cache write
92# 3.5.9   : Code change: use Shepherd::Common::read/write cache
93# 3.5.10  : Bugfix : don't exit on unknown option
94# 3.6.0   : Code change: use Shepherd::Common::print_stats
95#           Feature: cache guide pages for 3 hours, add subratings,
96#           Feature: capture director, writer, country, language
97#           Bugfix : fix previously-shown, aspect, subtitles, premiere, quality
98# 3.6.1   : Feature: don't split category, still add 'sport' and 'movie',
99#                    support 'LIVE' by appending to beginning of category,
100#                    use Shepherd::Common::translate_category
101# 3.6.2   : Feature: use new Common::generate_category, don't add 'advisory',
102#                    add 'length', add 'final' and 'return' (unseen)
103
104use strict;
105use Getopt::Long;
106use Date::Manip;
107use File::Path;
108use File::Basename;
109use Data::Dumper;
110use HTML::TreeBuilder;
111use JavaScript;
112use POSIX;
113use Encode;
114
115use XMLTV;
116use XMLTV::Ask;
117
118use Shepherd::Common;
119
120# ---------------------------------------------------------------------------
121# --- Global Variables
122
123my $progname = "Rex";
124my $lang = "en";
125
126my $DATASOURCE             = "http://www.yourtv.com.au";
127my $DATASOURCE_SETUP       = "$DATASOURCE/profile/index.cfm?action=saveRegions";
128my $DATASOURCE_GUIDE       = "$DATASOURCE/guide/index.cfm";
129my $DATASOURCE_GUIDE_TODAY = "$DATASOURCE/guide/index.cfm?action=restofday";
130my $DATASOURCE_DETAIL      = "$DATASOURCE/guide/index.cfm";
131
132my $runtime = time();
133my $laststats = $runtime;
134my $firstfetch;
135my $debug = 0;
136my $opt = { };
137my $channels;
138my $opt_channels;
139my $gaps;
140my %chanid;
141my $cached;
142my $lastpids;
143my $precache;
144my $ua;
145my $sid;
146my $jsc;
147my %shows;
148my $numshows;
149my %stats;
150my $dcount;
151
152# ---------------------------------------------------------------------------
153# --- Setup
154
155print "$progname $version\n";
156
157$| = 1;
158
159Getopt::Long::Configure(qw/pass_through/);
160
161get_command_line_options();
162
163print "Ignoring --config-file option.\n" if ($opt->{'config-file'});
164
165exit 0 if ($opt->{version});
166
167help() if ($opt->{help});
168
169set_defaults();
170read_channels_file();
171unless ($channels)
172{
173    print "ERROR: No channels requested. Please use --channels_file.\n";
174    exit 2;
175}
176
177read_gaps_file();
178
179if ($opt->{test})
180{
181  print "Test mode: won't write XML or cache.\n";
182  $opt->{output} = undef;
183}
184       
185build_channel_map();
186
187if ($opt->{'show-channels'})
188{
189  show_channels();
190  exit 0;
191}
192
193if ($debug or $opt->{'show-config'})
194{
195  show_config();
196  exit 0 if ($opt->{'show-config'});
197}
198
199restore_cache();
200
201if ($opt->{'dump-cache'})
202{
203  dump_cache();
204  exit 0;
205}
206
207initialize_stats();
208setup_javascript();
209
210# ---------------------------------------------------------------------------
211# --- Go!
212
213get_guide_data();
214
215get_details_data();
216
217save_cache() if ($numshows);
218
219write_xml();
220
221print stats(1);
222
223Shepherd::Common::print_stats($progname, $version, $runtime, %stats);
224
225exit 0;
226
227# ---------------------------------------------------------------------------
228# --- Stop!
229
230
231#
232# Subs!
233#
234
235sub get_guide_data
236{
237  print "Grabbing data for days " . ($opt->{offset} + 1) .
238        " - $opt->{days}" . 
239        ($opt->{output} ? " into " . $opt->{output} : '') .
240        ".\n";
241
242  refresh_ua() unless ($ua);
243
244  my ($guidedata, $date);
245
246  for my $day ($opt->{offset} .. $opt->{days} - 1)
247  {
248    $date = Ymd(DateCalc("today", "+ $day days"));
249    print "Day $day.\n" if ($debug);
250
251    if (!$day)
252    {
253      # Special bandwidth-saving URL for day 0
254
255      my $cacheid = $DATASOURCE_GUIDE_TODAY;
256      if ($cached->{$cacheid}) {
257        $guidedata = $cached->{$cacheid}->{data};
258      } else {
259        $guidedata = get_page($DATASOURCE_GUIDE_TODAY);
260        if ($guidedata) {
261          $cached->{$cacheid}->{data} = $guidedata;
262          $cached->{$cacheid}->{stop} = POSIX::strftime("%Y%m%d%H%M%S", localtime($runtime));
263          $cached->{$cacheid}->{title}[0][0] = $cacheid;
264        }
265      }
266      parse_guide($guidedata, $date) if ($guidedata);
267    }
268    else
269    {
270      # Need to grab day in 6-hour chunks.
271      my $rid = $opt->{region};
272      for (1 .. 4)
273      {
274        my $cacheid = "${DATASOURCE_GUIDE}?r=${rid}&d=${date}&p=$_";
275        if ($cached->{$cacheid}) {
276          $guidedata = $cached->{$cacheid}->{data};
277        } else {
278          $guidedata = get_page(url => $DATASOURCE_GUIDE,
279                        postvars =>
280                        [ 'action' => "sessionTimes",
281                          'region_id' => $rid,
282                          'date' => $date,
283                          'period' => $_,
284                          'submit' => 'submit'
285                        ]);
286          if ($guidedata) {
287            $cached->{$cacheid}->{data} = $guidedata;
288            $cached->{$cacheid}->{stop} = POSIX::strftime("%Y%m%d%H%M%S", localtime($runtime));
289            $cached->{$cacheid}->{title}[0][0] = $cacheid;
290          }
291        }
292        parse_guide($guidedata, $date, $_) if ($guidedata);
293      }
294    }
295  }
296  $numshows = scalar(keys %$precache);
297  print "Shows found: $numshows.\n";
298}
299
300#
301# This sub fills up %shows with details, either from the cache or
302# from the web.
303#
304sub get_details_data
305{
306  $firstfetch = time();
307  my $show;
308  foreach my $pid (keys %$precache)
309  {
310    if ($cached->{$pid})
311    {
312      print "Cached: " . $cached->{$pid}->{title}[0][0] . ".\n" if ($debug);
313      if (verify_cache($pid))
314      {
315        $shows{$pid} = $cached->{$pid};
316        $stats{cache_hits}++;
317      }
318      else
319      {
320        print "Cache has stale data for \"" . $cached->{$pid}->{title}[0][0] .
321              "\": fetching fresh data.\n" if ($debug);
322        $stats{cache_changes}++;
323      }
324    }
325    unless ($shows{$pid})
326    {
327      $show = download_show($pid);
328      if ($show)
329      {
330        $show->{channel}=$precache->{$pid}->{channel}; # this is a fix for undistinguished channels
331        $shows{$pid} = $show;
332        $cached->{$pid} = $show;
333        $stats{detail_pages}++;
334      }
335      else
336      {
337        print "Failed to parse show $pid.\n";
338      }
339    }
340    if ($opt->{stats} and time() - $laststats >= $opt->{stats})
341    {
342      print stats();
343    }
344  }
345}
346
347sub verify_cache
348{
349  my $pid = shift;
350
351  my @c = ( 
352            [ 
353              'Title', 
354              $cached->{$pid}->{title}[0][0], 
355              $precache->{$pid}->{title} 
356            ],
357            [ 
358              'Start time',
359              $cached->{$pid}->{start},
360              $precache->{$pid}->{start}
361            ],
362            [
363              'Stop time',
364              $cached->{$pid}->{stop},
365              $precache->{$pid}->{stop}
366            ],
367            [
368              'Subtitle',
369              ($cached->{$pid}->{'sub-title'} ? $cached->{$pid}->{'sub-title'}[0][0] : undef),
370              $precache->{$pid}->{'sub-title'}
371            ]
372          ); 
373  foreach my $cmp (@c)
374  {
375    return 0 unless compare_caches($cmp->[0], $cmp->[1], $cmp->[2]);
376  }
377  return 1;
378}
379
380sub compare_caches
381{
382  my ($name, $arg1, $arg2) = @_;
383
384  # Special case for subtitles.
385  return 1 if ($name eq 'Subtitle' and !$arg2);
386  # Special case for no precache stop.
387  return 1 if ($name eq 'Stop time' and !$arg2);
388 
389  $arg1 = '--missing--' unless $arg1;
390  $arg2 = '--missing--' unless $arg2;
391
392  return 1 if $arg1 eq $arg2;
393
394  print "$name mismatch: \"$arg1\" vs \"$arg2\".\n" if ($debug);
395  return 0;
396}
397
398sub download_show
399{
400  my ($pid, $recurse_count) = @_;
401
402  $recurse_count ||= 0;
403  return undef if ($recurse_count > 2);
404 
405  $dcount++;
406  refresh_ua() if ($dcount % 20 == 0); # don't wait for error page
407
408  my $result;
409
410  print "Downloading # $pid.\n" if ($debug);
411  my $detailsdata = get_page($DATASOURCE_DETAIL .
412                      '?action=session_info&event_id=' . $pid .
413                      '&sid=' . $sid . '&loc=grid');
414  $result = parse_details($detailsdata) if ($detailsdata);
415  unless ($detailsdata and $result)
416  {
417    refresh_ua();
418    return download_show($pid, $recurse_count+1);
419  }
420
421  return $result;
422}
423
424sub save_cache
425{
426  return if ($opt->{test} or $opt->{nowrite_cache});
427  print "Saving cache.\n";
428  Shepherd::Common::write_cache($opt->{'cache-file'}, $cached);
429}
430
431sub write_xml
432{
433  return if ($opt->{test});
434 
435  my %writer_args = ( encoding => 'ISO-8859-1' );
436
437  print "Writing XML.\n";
438
439  if ($opt->{output}) 
440  {
441    my $fh = new IO::File(">" . $opt->{output}) 
442             or die "Can't open " . $opt->{output} . ": $!";
443    $writer_args{OUTPUT} = $fh;
444  }
445
446  my $writer = new XMLTV::Writer(%writer_args);
447
448  $writer->start
449    ( { 'source-info-url'    => $DATASOURCE,
450        'source-info-name'   => "Datasource Name",
451        'generator-info-name' => "$progname $version"} );
452
453  for my $channel (sort keys %$channels) 
454  {
455    my $chanid = $chanid{lc $channel};
456    $writer->write_channel( { 'display-name' => [[$channel, $lang]],
457                              'id' => $chanid } );
458  } 
459
460  foreach my $pid (keys %shows)
461  {
462    print "- " . $shows{$pid}->{'title'}[0][0] . "\n" if ($debug);
463    $writer->write_programme($shows{$pid});
464  }
465
466  $writer->end();
467}
468
469sub refresh_ua
470{
471  print "Refreshing UA.\n" if ($debug);
472 
473  if ($ua)
474  {
475     print stats() if ($debug and $opt->{stats});
476     print "Sleeping...\n" if ($debug);
477     sleep_for(5 + int(rand(20)));
478  }
479
480  $ua = Shepherd::Common::setup_ua( cookie_jar => 1 );
481
482  # Set initial cookie
483  unless (get_page(url => $DATASOURCE, retries => 4)) # Try hard to fetch main page
484  {
485      print "Unable to fetch main datasource page. No connectivity? Exiting.\n";
486      print stats(1);
487      die "Can't fetch front page.\n";
488  }
489
490  # Set region/service cookie
491  unless (get_page(url => $DATASOURCE_SETUP, postvars => [ 'fta_region_id' => $opt->{'region'} ]))
492  {
493      print "ERROR: Unable to set region/service cookie.\n";
494      print stats(1);
495      die "Can't set region/service cookie.";
496  }
497
498  $ua->cookie_jar()->scan(\&refresh_sid);
499
500  $dcount = 0;
501}
502
503sub refresh_sid
504{
505  my ($version, $key, $val) = @_;
506
507  $sid = $val if ($key eq 'CFID');
508}
509
510sub setup_javascript 
511{
512  print "Initializing JavaScript interpreter.\n" if ($debug);
513  $jsc = new JavaScript::Runtime->create_context();
514  $jsc->set_error_handler( sub { } ) if (exists(&JavaScript::Context::set_error_handler));
515  $jsc->eval(qq{
516    var doc = '';
517    function Location() { this.href  = '$DATASOURCE'; }
518    function Document() { this.write = function(x) { doc += x; } }
519    function Window()   { this.___ww = 0 }
520    location = new Location;
521    document = new Document;
522    window   = new Window;
523  });
524}
525
526sub restore_cache
527{
528  unless ($opt->{'ignore-cache'} or $opt->{'rebuild-cache'})
529  {
530    $cached = Shepherd::Common::read_cache(\$opt->{'cache-file'});
531  }
532  if ($cached)
533  {
534    print "Retrieved " . keys(%$cached) . " cached items from file.\n";
535    clean_cache();
536  }
537  else
538  {
539    $cached = { };
540    print "Not using cache.\n";
541  }
542}
543
544sub clean_cache
545{
546    my $r = expand_date(localtime(time() - 3*3600)."");
547    my $c = 0;
548    print "Removing cache items that finish earlier than $r.\n" if ($debug);
549    foreach (keys %$cached)
550    {
551        if (Date_Cmp($r, $cached->{$_}->{stop}) == 1)
552        {
553            print "Removing $cached->{$_}->{title}[0][0].\n" if ($debug);
554            delete $cached->{$_};
555            $c++;
556        }
557    }
558    print "Removed $c stale items from cache.\n";
559}
560
561sub dump_cache
562{
563  print "Cache: " . Dumper($cached) . "\n";
564}
565
566sub initialize_stats
567{
568    %stats = ( );
569    foreach (qw( successful_requests failed_requests slept_for bytes detail_pages cache_hits cache_changes failed_parses ))
570    {
571        $stats{$_} = 0;
572    }
573}
574
575sub stats
576{
577  my $finished = shift;
578
579  my $t = time() - $runtime;
580 
581  my $ret = "$progname $version " . 
582            ($finished ? "finished" : "in progress") .
583            ":\n";
584  $ret .= sprintf
585        " %d shows grabbed\n" .
586        " %d downloads, including %d detail pages (%d KB)\n" .
587        " %d cache hits, %d changes from cache\n" .
588        " %d failed downloads, %d failed parses\n",
589        scalar(keys %shows),
590        $stats{successful_requests}, $stats{detail_pages}, ($stats{bytes}/1024),
591        $stats{cache_hits}, $stats{cache_changes},
592        $stats{failed_requests}, $stats{failed_parses};
593  $ret .= sprintf " Time elapsed: %s (spent sleeping: %s)\n",
594                  timestats($t), timestats($stats{slept_for});
595  unless ($finished or !$stats{detail_pages})
596  {
597    $t = ((((time() - $firstfetch) * ($numshows - $stats{cache_hits})) / $stats{detail_pages})) - $t;
598   
599    $ret .= " Estimated time remaining: " . timestats($t) . "\n";
600  }
601  $laststats = time();
602  return $ret;
603}
604
605sub timestats
606{
607  my $t = shift;
608
609  my $ret = '';
610  if ($t >= 3600)
611  {
612    $ret .= sprintf("%d hr ", $t / 3600);
613    $t = $t % 3600;
614  }
615  $ret .= sprintf("%d min %d sec", $t / 60, $t % 60);
616  return $ret;
617}
618
619sub get_page
620{
621  my $ret = Shepherd::Common::get_url(@_);
622  if ($stats{successful_requests} and $stats{failed_requests} > ($stats{successful_requests} * 5))
623  {
624      printf "Exiting: %d failed network requests vs %d successes.\n",
625             $stats{failed_requests}, $stats{successful_requests};
626      print stats(1);
627      die "Too many network failures.";
628  }
629  $ret =~ s/&nbsp;/ /g if ($ret);
630  return $ret;
631}
632
633sub parse_guide
634{
635  my ($guidedata, $date, $phase) = @_;
636
637  print "Parsing guide page.\n" if ($debug);
638
639  $phase ||= 0;
640
641  $guidedata = readjs(Encode::decode_utf8($guidedata));
642
643  my $tree = HTML::TreeBuilder->new_from_content($guidedata);
644  my $curchan = '';
645  my @channels_seen;
646  my ($pid, $block, $line, $link, $title);
647  my $c = 0;
648  foreach my $tag ($tree->look_down('_tag' => 'td', 'class' => 'venue'))
649  {
650    # Some screens repeat channel name
651    next if ($tag->left);
652
653    $c++;
654    my $channame = $tag->as_text();
655    my $curchan = translate_channel_name($tag->as_text(), scalar(grep($_ eq $channame, @channels_seen)));
656    push @channels_seen, $channame;
657    if (!$channels->{$curchan})
658    {
659      print "Ignoring unsubscribed channel $curchan.\n" if ($debug);
660      next;
661    }
662    print "Channel: $curchan.\n" if ($debug);
663    $block = $tag->parent();
664    foreach $line ($block->look_down('_tag' => 'td', 'class' => undef))
665    {
666      my ($pid, $title, $start, $pextra);
667      foreach my $bit ($line->look_down('_tag' => 'div'))
668      {
669        if ($bit->attr('class') eq 'ptime')
670        {
671          if ($start)
672          {
673            addme($pid, $title, $start, $pextra, $curchan);
674            $pextra = undef;
675            $title = undef;
676            $pid = undef;
677          }
678          $start = $bit->as_text();
679          if ($phase and $phase == 1 and $start =~ /pm/)
680          {
681            $start = expand_date($start ." ". Ymd(DateCalc($date, "- 1 day")));
682          }
683          else
684          {
685            $start = expand_date("$start $date");
686          }
687        }
688        elsif ($bit->attr('class') eq 'pname')
689        {
690          $title = strip_whitespace($bit->as_text());
691          if (HTML::Entities::decode($bit->as_HTML()) =~ /session_info\('(\d+)/) 
692          {
693            $pid = $1;
694          }
695        }
696        elsif ($bit->attr('class') eq 'pextra')
697        {
698          $pextra = strip_whitespace($bit->as_text());
699        }
700      }
701      if ($pid)
702      {
703        addme($pid, $title, $start, $pextra, $curchan);
704      }
705      else
706      {
707        bad_parse("No pid found in guide data block");
708      }
709    }
710  }
711  bad_parse("No shows found on guide page ($date phase $phase)") unless ($c);
712  $tree->delete();
713}
714
715sub addme
716{
717  my ($pid, $title, $start, $pextra, $curchan) = @_;
718 
719  if ($precache->{$pid})
720  {
721    print "Duplicate: $title ($pid).\n" if ($debug);
722  }
723  else
724  {
725    print "New: $title " . ($pextra ? "($pextra) " : '') . 
726          "($pid) $start\n" if ($debug);
727    if ($pextra and $pextra =~ /\(\d\d\d\d\)/)
728    {
729      print "Ignoring detail.\n" if ($debug);
730      $pextra = undef;
731    }
732    $precache->{$pid} = { 'title' => $title, 
733                          'start' => $start,
734                          'sub-title' => $pextra,
735                          'channel' => $channels->{$curchan}
736                        };
737    my $lastpid = $lastpids->{$curchan};
738    if ($lastpid)
739    {
740        $precache->{$lastpid}->{stop} = $start;
741        if ($start < $precache->{$lastpid}->{start}) 
742        {
743            print "Oddness detected in \"" .
744                  $precache->{$lastpid}->{title} .
745                  "\" (pid $pid), starting at " .
746                  $precache->{$lastpid}->{start} .
747                  ".\n";
748            delete $precache->{$lastpid} if ($gaps);
749        }
750        elsif ($gaps)
751        {
752            if (is_outside_gaps($curchan, $precache->{$lastpid}->{start}, $precache->{$lastpid}->{stop}))
753            {
754                delete $precache->{$lastpid};
755            }
756        }
757    }
758    $lastpids->{$curchan} = $pid;
759  }
760}
761
762# The guide pages for some regions don't provide any way to distinguish
763# between (eg) "Prime (Regional)" and "Prime (Albury)" in the same region,
764# other than the order in which they're listed. (They're both called
765# simply "Prime".) This func tracks which is which.
766sub translate_channel_name
767{
768    my ($chan, $seen_before) = @_;
769
770    my $rchans;
771#     $rchans = {
772#       90 => { 'Prime' => [ 'Prime (Regional Victoria)', 'Prime (Albury)' ] },
773#       };
774
775    my $region = $opt->{region};
776    return $chan unless ($rchans->{$region} and $rchans->{$region}->{$chan});
777    return $rchans->{$region}->{$chan}->[$seen_before];
778}
779
780sub parse_details 
781{
782  my $detailsdata = shift;
783
784  my ($show, $str, @rows, $block, $start, $stop, $date, @extra, @items);
785
786  $detailsdata = readjs(Encode::decode_utf8($detailsdata));
787
788  my $tree = HTML::TreeBuilder->new_from_content($detailsdata);
789
790  $block = $tree->find('h1');
791  return bad_parse("Mising title") unless ($block);  # site is probably sending that block page
792
793  $show->{'title'} = [[ strip_whitespace($block->as_text()), $lang ]];
794  $str = $tree->find('h2');
795  if ($str)
796  {
797    $show->{'sub-title'} = [[ strip_whitespace($str->as_text()), $lang ]];
798  }
799
800  $block = $tree->find('h3') or return bad_parse("Missing section");
801  @rows = $block->look_down('_tag' => 'div');
802  $date = $rows[1]->as_text();
803  if($rows[0]->as_HTML() =~ /(\b[\d\.]+[ap]m)\s+.*?\s+([\d\.]+[ap]m)\b/)
804  {
805    ($start, $stop) = ($1, $2);
806    $show->{'start'} = expand_date("$start $date");
807    $show->{'stop'} = expand_date("$stop $date");
808  }
809  else
810  {
811    return bad_parse("Missing times");  # Failed to parse
812  }
813  if (Date_Cmp($show->{'start'}, $show->{'stop'}) == 1)
814  {
815     $show->{'stop'} = expand_date(DateCalc($show->{'stop'}, "+ 1 day"));
816     print "Adjusted STOP time.\n" if ($debug);
817  }
818  $show->{'channel'} = $chanid{lc($rows[0]->find('span')->as_text())}; # this fails for undistinguished channels
819
820  $block = $tree->find('_tag' => 'hr', 'noshade') or return bad_parse("Missing subsection");
821  $block = $block->right();
822  if ($block->as_text())
823  {
824    $show->{'desc'} = [[ strip_whitespace($block->as_text()), $lang ]];
825    $block = $block->right()->right();
826  }
827  else
828  {
829    $block = $block->right();
830  }
831  my ($category, %type);
832  foreach my $tag ($block->look_down('_tag' => 'tr'))
833  {
834    $str = $tag->as_text();
835    if ($str =~ /Genre:(.+)/)
836    {
837      $category = strip_whitespace($1);
838      $str = $tree->find('h5');
839      $type{movie} = 1 if ($str and $str->as_text() =~ /movie/i);
840    }
841    elsif ($str =~ /Rating:(.+)/)
842    {
843      $str = strip_whitespace($1);
844      $str =~ /(.*?)\s*\[(.+)\]/;
845      $str = $1;
846      my $sr = $2;
847      if ($sr) {
848        $sr =~ s/or medical procedures//ig;
849        $sr = &Shepherd::Common::subrating($sr);
850      }
851      $show->{'rating'} = [[ $sr ? "$str $sr" : $str, 'ABA', undef]];
852    }
853    elsif ($str =~ /Cast: (.+)/)
854    {
855      $show->{'credits'}{'actor'} = [ split(/, /, strip_whitespace($1)) ];
856    }
857    elsif ($str =~ /Director: (.+)/)
858    {
859      $show->{'credits'}{'director'} = [ split(/, /, strip_whitespace($1)) ];
860    }
861    elsif ($str =~ /Writer: (.+)/) # unseen
862    {
863      $show->{'credits'}{'writer'} = [ split(/, /, strip_whitespace($1)) ];
864    }
865    elsif ($str =~ /Year:\s*(\d+)/)
866    {
867      $show->{'date'} = strip_whitespace($1);
868    }
869    elsif ($str =~ /Country: (.+)/)
870    {
871      $show->{'country'} = [[ split(/, /, strip_whitespace($1)) ]];
872    }
873    elsif ($str =~ /Language: (.+)/)
874    {
875      $show->{'language'} = [ strip_whitespace($1) ];
876    }
877    elsif ($str =~ /Duration:\s(\d+)/)
878    {
879      $show->{'length'} = $1 * 60;
880    }
881    elsif ($str =~ /Other:(.+)/)
882    {
883      next unless (strip_whitespace($1));
884      $str = $tag->as_HTML();
885      @extra = split(/<br ?\/?>/, $tag->as_HTML());
886      my %video;
887      foreach my $bit (@extra)
888      {
889        $bit =~ s/<.*>//;
890        $bit = strip_whitespace($bit);
891        next unless ($bit);
892        if ($bit eq 'Repeat')
893        {
894            $show->{'previously-shown'} = { };
895        }
896        elsif ($bit eq 'Widescreen')
897        {
898            $video{'aspect'} = '16:9';
899        }
900        elsif ($bit eq 'High Definition')
901        {
902            $video{'quality'} = 'HDTV';
903        }
904        elsif ($bit eq 'Closed Captions')
905        {
906            $show->{'subtitles'} = [ { 'type' => 'teletext' } ];
907        }
908        elsif ($bit eq 'New Episode')
909        {
910            $show->{'premiere'} = [ $bit ];
911        }
912        elsif ($bit eq 'Premiere')
913        {
914            $show->{'premiere'} = [ $bit ];
915            $type{premiere} = 1;
916        }
917        elsif ($bit eq 'LIVE' || $bit eq 'Live')
918        {
919            $type{live} = 1;
920        }
921        elsif ($bit eq 'Final' || $bit eq 'Finale')
922        {
923            $type{final} = 1;
924        }
925        elsif ($bit eq 'Return') # unseen
926        {
927            $type{return} = 1;
928        }
929        $show->{'video'} = \%video if (%video);
930      }
931    }
932  }
933  $show->{'category'} = [ &Shepherd::Common::generate_category(
934      $show->{'title'}[0][0], $category, %type) ];
935
936  $tree->delete();
937  print Dumper($show) if ($debug);
938  return $show;
939}
940
941sub bad_parse
942{
943  my $msg = shift;
944  print "Parsing error: $msg.\n";
945  $stats{failed_parses}++;
946  if ($stats{failed_parses} > 4 and !scalar(keys %shows))
947  {
948      print "ERROR! Unable to parse any shows! Looks like a major problem. " .
949            "Exiting.\n";
950      print stats(1);
951      die "Major parsing error";
952  }
953  return 0;
954}
955
956sub is_outside_gaps
957{
958  my ($ch, $start, $stop) = @_;
959
960  $start = udate_to_epoch($start);
961  $stop = udate_to_epoch($stop);
962
963  foreach my $gap (@{$gaps->{$ch}})
964  {
965      if ($gap =~ /(\d+)-(\d+)/)
966      {
967          return 0 if ($stop > $1 and $start < $2);
968      }
969  }
970  return 1;
971}
972
973sub udate_to_epoch
974{
975    my $udate = shift;
976
977    if ($udate =~ /(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/)
978    {
979        my ($year, $month, $day, $hour, $minute, $second) = ($1, $2, $3, $4, $5, $6);
980        $month--;
981        $year -= 1900;
982        return POSIX::strftime("%s", $second, $minute, $hour, $day, $month, $year);
983    }
984    die "Unable to parse udate $udate!";
985}
986
987sub readjs {
988  my $data = shift;
989  $data =~ s{<script type="?text/javascript"?[^>]*>(.*?)</script>}{
990    my $x = $1;
991    $jsc->eval(qq{ doc = '' });
992    $jsc->eval($x);
993    $jsc->eval(qq{ doc }) || '';
994  }isge;
995  $data;
996}
997 
998sub read_channels_file 
999{
1000    read_config_file('channels', 'channels_file');
1001}
1002
1003sub read_gaps_file
1004{
1005    read_config_file('gaps', 'gaps_file');
1006}
1007
1008sub read_config_file
1009{
1010    my ($name, $arg) = @_;
1011
1012    return unless ($opt->{$arg});
1013    print "Reading $name file: $opt->{$arg}\n";
1014    if (-r $opt->{$arg})
1015    {
1016        local (@ARGV, $/) = ($opt->{$arg});
1017        no warnings 'all';
1018        eval <>;
1019        die "Can't parse $name file: $@" if ($@);
1020    }
1021    else
1022    {
1023        print "Unable to read $name file.\n";
1024    }
1025}
1026
1027sub get_command_line_options
1028{
1029  GetOptions($opt, qw(
1030                        help
1031                        debug
1032                        output=s
1033                        days=i
1034                        offset=i
1035                        region=i
1036                        show-config
1037                        show-channels
1038                        rebuild-cache
1039                        ignore-cache
1040                        nowrite-cache
1041                        dump-cache
1042                        cache-file=s
1043                        config-file=s
1044                        channels_file=s
1045                        gaps_file=s
1046                        stats=i
1047                        test
1048                        desc
1049                        version
1050                        warper
1051                    ));
1052  $debug = $opt->{debug};   
1053
1054  if (@ARGV)
1055  {
1056    print "\nWARNING: Ignoring unknown option(s): @ARGV\n\n";
1057  }
1058}
1059
1060sub show_config
1061{
1062  my $short = shift;
1063 
1064  print "\nConfiguration\n".
1065          "-------------\n";
1066  unless ($short)
1067  {
1068    print "Debug mode : " . is_set($debug) . "\n" .
1069          "Test mode  : " . is_set($opt->{test}) . "\n" .
1070          "Webwarping : " . is_set($opt->{warper}) . "\n" .
1071          "Cache file : " . $opt->{'cache-file'};
1072    print ' (not reading)' if ($opt->{'ignore-cache'} or $opt->{'rebuild-cache'});
1073    print ' (not updating)' if ($opt->{test} or $opt->{'ignore-cache'} or $opt->{'nowrite-cache'});
1074    print "\n" .
1075          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1076          "Chann file : $opt->{channels_file}\n" .
1077          ($opt->{gaps_file} ? "Gaps file  : " . $opt->{gaps_file} . "\n" : '') .
1078          "Statistics : " . ($opt->{stats} ? "every " . $opt->{stats} . " seconds" : "off") . "\n";
1079  }
1080  print   "Region ID  : $opt->{region}\n" .
1081          "Days wanted: $opt->{days} (offset: $opt->{offset})\n";
1082  show_channels();
1083  print "\n";
1084}
1085
1086sub is_set
1087{
1088  my $arg = shift;
1089  return $arg ? "Yes" : "No";
1090}
1091
1092sub show_channels
1093{
1094  print "Subscribed channels:\n";
1095  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
1096}
1097
1098sub build_channel_map
1099{
1100  # --- extract sorted subscribed channel list from config-file hash;
1101  # also compute canonicalised lowercased channel to xmltvid hash
1102  %chanid = map { lc $_, $channels->{$_} } keys %$channels;
1103}
1104
1105sub set_defaults
1106{
1107  my $defaults = {
1108          'days' => 7,
1109          'offset' => 0,
1110          'region' => 94,
1111          'stats' => 90,
1112          'output' => getcwd() . '/output.xmltv',
1113          'cache-file' => getcwd() . '/cache.dat',
1114          'channels_file' => getcwd() . '/channels.conf'
1115  };
1116                                             
1117  foreach (keys %$defaults)
1118  {
1119    unless (defined $opt->{$_})
1120    {
1121      $opt->{$_} = $defaults->{$_};
1122    }
1123  }
1124
1125  $opt->{'days'} = 7 if ($opt->{'days'} > 7);
1126
1127  Shepherd::Common::set_defaults(
1128        stats => \%stats, 
1129        delay => "1-5",
1130        debug => $debug,
1131        webwarper => $opt->{warper}
1132    );
1133}
1134
1135sub expand_date
1136{
1137  my $t = shift;
1138  $t =~ s/\./:/;
1139  my $ret = ParseDate($t);
1140
1141  # --- append timezone and strip colons
1142#  ($ret .= " $opt->{TZ}") =~ tr/://d;
1143  $ret =~ tr/://d;
1144
1145  return $ret;
1146}
1147
1148sub Ymd { UnixDate($_[0], "%Y-%m-%d") or die "Date problem in Ymd($_[0])" }
1149
1150sub strip_whitespace 
1151{ 
1152  my $str = shift; 
1153  $str =~ s/^\s*(.*?)\s*$/$1/; 
1154  return $str;
1155}
1156
1157sub sleep_for
1158{
1159    my $n = shift;
1160    return unless ($n);
1161    sleep $n;
1162    $stats{slept_for} += $n;
1163}
1164
1165sub help
1166{
1167  print q{
1168Command-line options:
1169    --help                 Print this message
1170
1171    --version              Show current version
1172    --show-channels        Show subscribed channels & exit
1173    --show-config          Show configuration details & exit
1174    --dump-cache           Show cache & exit
1175               
1176    --cache-file <file>    Use the specified cache file
1177    --output <file>        Write XML into the specified file
1178    --channels_file <file> Read channel subscriptions from file
1179    --gaps_file <file>     Read gaps from file
1180
1181    --region <n>           Grab data for region code <n>
1182    --days <n>             Grab <n> days of data (today being day 1)
1183    --offset <n>           Skip the first <n> days
1184
1185    --stats <n>            Print stats every n secs (0=off)
1186    --debug                Print lots of debugging output
1187
1188    --warper               Use webwarper.net anonymizer
1189
1190    --test                 Don't write any output or update cache
1191    --ignore-cache         Neither read nor update cache
1192    --nowrite-cache        Read but don't update cache
1193    --rebuild-cache        Destroy and rebuild cache
1194};
1195  exit 0;
1196}
Note: See TracBrowser for help on using the browser.