root/grabbers/rex @ 584

#!/usr/bin/perl -w
#
# "Rex"

my $version  = '3.5.0';

# An Australian TV Guide Grabber (a.k.a. tv_grab_au)
# by Max Barry
# http://www.maxbarry.com
# 
# Based on the long-serving but currently defunct NMSN Australian TV grabber 
# by Michael 'Immir' Smith
# 
# Use --help for command-line options.
# 
# A current version of this script, plus a README file, might be here:
# http://www.whuffy.com/tv_grab_au/
#
# To install Perl dependencies (like XMLTV.pm), you generally need to
# do this (as root): perl -MCPAN -e 'install <whatever>'
# E.g. perl -MCPAN -e 'install XMLTV::Ask'
# 
# Changelog:
# 0.1.0   : Let there be code
# 0.2.0   : Better caching (fewer HTTP connections)
# 0.3.0   : Aborted attempt to use proxy caches
# 0.4.0   : Reverted to non-proxy version; switched datasources
# 1.0.0   : --configure works; code released
# 1.0.1   : Bugfix : --config-file now works
# 1.1.0   : Feature: --stats option
# 1.1.1   : Bugfix : Download Pay TV show details properly
# 1.1.2   : Bugfix : Replaced non-working --static with --test; 
#                    put sport and free-to-air movies in correct category 
#                    for MythTV
# 1.1.3   : Bugfix : Don't die on a failed download, just report
# 1.2.0   : Feature: --cache-file option
# 1.2.1   : Bugfix : Better explanation for config-file failure
# 1.2.2   : Bugfix : Get more than 1 day's data for Pay TV channels
# 1.2.3   : Bugfix : Translate some category names for MythTV
# 1.2.4   : Bugfix : Better handling of config file locations
# 1.2.5   : Bugfix : Corrected typo in a category name
# 2.0.0   : Datasource change: August 29th, 2006
# 2.1.0   : Feature: Interpret javascript
# 2.1.1   : Bugfix : Try to avoid replacing good data with poisoned data
# 2.1.2   : Bugfix : Minor code tidy
# 2.2.0   : Feature: --help option
# 2.2.1   : Bugfix : Don't overwrite cache if no shows found (e.g. net failure)
# 2.3.0   : Feature: Better detection of changes to pre-fetched guide data
# 2.3.1   : Bugfix : adapted precache to non-fatal datasource change
# 2.4.0   : Feature: --quick option
# 2.4.1   : Bugfix : removed --quick (too hard to accurately parse stop time);
#                    code tidy
# 2.4.2   : Bugfix : progress stats on by default
# 2.5.0   : Feature: altered/added --ignore-cache, --nowrite-cache, and
#                    --rebuild-cache options; exit on unknown option
# 3.0.0   : Shepherd compliance
# 3.1.0   : Feature: --ready option
# 3.2.0   : Feature: gzip compression, report KB downloaded
# 3.2.1   : Bugfix : handle failed downloads properly
# 3.2.2   : Bugfix : no empty sub-titles in cache; no output buffering
# 3.3.0   : Feature: categorize HDTV, premieres, repeats, original airdates,
#                    and widescreen broadcats correctly in XMLTV (not all
#                    supported by MythTV, alas)
# 3.3.1   : Bugfix : stop dumping cache items unnecessarily
# 3.3.2   : Bugfix : fixed regexp weirdness
# 3.3.3   : Bugfix : more regexp tweaking; fixed premiere tag
# 3.3.4   : Bugfix : tweaked Rex's name in XMLTV output
# 3.3.5   : Bugfix : support opt_channels (HDTV in Shepherd)
# 3.3.6   : Bugfix : neater options parsing
# 3.3.7   : Bugfix : now runs from current dir, not ~/.rex/
# 3.3.8   : Bugfix : better handling of failed downloads & parses
# 3.3.9   : Bugfix : more descriptive dies
# 3.4.0   : Feature: micrograbbing (--gaps_file)
# 3.4.1   : Bugfix : don't die on bad web data
# 3.4.2   : Bugfix : use stop data in cache verification (much better)
# 3.4.3   : Bugfix : don't die on corrupted cache file
# 3.4.4   : Bugfix : --dump-cache works
# 3.4.5   : Bugfix : support regions with multiple channels of same name

use strict;
use Getopt::Long;
use HTTP::Request::Common;
use LWP::UserAgent;
use Date::Manip;
use File::Path;
use File::Basename;
use Data::Dumper;
use HTML::TreeBuilder;
use JavaScript;
use Storable;
use POSIX;

use XMLTV;
use XMLTV::Ask;

# ---------------------------------------------------------------------------
# --- Global Variables

my $progname = "Rex";
my $lang = "en";

my ($count_dl, $count_detail, $count_bad, $count_cache, $count_changes, $count_kb, $count_bad_parse) = (0) x 7;

my $DATASOURCE             = "http://www.yourtv.com.au";
my $DATASOURCE_SETUP       = "$DATASOURCE/profile/index.cfm?action=saveRegions";
my $DATASOURCE_GUIDE       = "$DATASOURCE/guide/index.cfm";
my $DATASOURCE_GUIDE_TODAY = "$DATASOURCE/guide/index.cfm?action=restofday";
my $DATASOURCE_DETAIL      = "$DATASOURCE/guide/index.cfm";
my $WW                     = "http://webwarper.net/ww/";

my $runtime = time();
my $laststats = $runtime;
my $firstfetch;
my $debug = 0;
my $opt = { };
my $channels = {};
my $opt_channels = {};
my $gaps;
my %chanid;
my $cached;
my $lastpids;
my $precache;
my $ua;
my $sid;
my $jsc;
my %shows;
my $numshows;
my $dcount;

# ---------------------------------------------------------------------------
# --- Setup

print "$progname $version\n";

$| = 1;

Getopt::Long::Configure(qw/pass_through/);

get_command_line_options();

print "Ignoring --config-file option.\n" if ($opt->{'config-file'});

exit 0 if ($opt->{version});

help() if ($opt->{help});

set_defaults();

read_channels_file();
read_gaps_file();

if ($opt->{test})
{
  print "Test mode: won't write XML or cache.\n";
  $opt->{output} = undef;
}
        
build_channel_map();

if ($opt->{'show-channels'})
{
  show_channels();
  exit 0;
}

if ($debug or $opt->{'show-config'})
{
  show_config();
  exit 0 if ($opt->{'show-config'});
}

restore_cache();

if ($opt->{'dump-cache'})
{
  dump_cache();
  exit 0;
}

setup_javascript();

# ---------------------------------------------------------------------------
# --- Go!

get_guide_data();

get_details_data();

save_cache() if ($numshows);

write_xml();

print stats(1);

exit 0;

# ---------------------------------------------------------------------------
# --- Stop!


#
# Subs!
# 

sub get_guide_data
{
  print "Grabbing data for days " . ($opt->{offset} + 1) .
        " - $opt->{days}" . 
        ($opt->{output} ? " into " . $opt->{output} : '') .
        ".\n";

  refresh_ua() unless ($ua);

  my ($guidedata, $date);

  for my $day ($opt->{offset} .. $opt->{days} - 1)
  {
    $date = Ymd(DateCalc("today", "+ $day days"));
    print "Day $day.\n" if ($debug);

    if (!$day)
    {
      # Special bandwidth-saving URL for day 0

      $guidedata = get_page($DATASOURCE_GUIDE_TODAY);
      parse_guide($guidedata, $date) if ($guidedata);
    }
    else
    {
      # Need to grab day in 6-hour chunks.
      my $rid = $opt->{region};
      for (1 .. 4)
      {
        $guidedata = post_page($DATASOURCE_GUIDE,
                        [ 'action' => "sessionTimes",
                          'region_id' => $rid,
                          'date' => $date,
                          'period' => $_,
                          'submit' => 'submit'
                        ]);
        parse_guide($guidedata, $date, $_) if ($guidedata);
      }
    }
  }
  $numshows = scalar(keys %$precache);
  print "Shows found: $numshows.\n";
}

#
# This sub fills up %shows with details, either from the cache or
# from the web.
#
sub get_details_data
{
  $firstfetch = time();
  my $show;
  foreach my $pid (keys %$precache)
  {
    if ($cached->{$pid})
    {
      print "Cached: " . $cached->{$pid}->{title}[0][0] . ".\n" if ($debug);
      if (verify_cache($pid))
      {
        $shows{$pid} = $cached->{$pid};
        $count_cache++;
      }
      else
      {
        print "Cache has stale data for \"" . $cached->{$pid}->{title}[0][0] .
              "\": fetching fresh data.\n" if ($debug);
        $count_changes++;
      }
    }
    unless ($shows{$pid})
    {
      $show = download_show($pid);
      if ($show)
      {
        $shows{$pid} = $show;
        $cached->{$pid} = $show;
        $count_detail++;
      }
      else
      {
        print "Failed to parse show $pid.\n";
      }
      sleep int(2 + rand(5));
    }
    if ($opt->{stats} and time() - $laststats >= $opt->{stats})
    {
      print stats();
    }
  }
}

sub verify_cache
{
  my $pid = shift;

  my @c = ( 
            [ 
              'Title', 
              $cached->{$pid}->{title}[0][0], 
              $precache->{$pid}->{title} 
            ],
            [ 
              'Start time',
              $cached->{$pid}->{start},
              $precache->{$pid}->{start}
            ],
            [
              'Stop time',
              $cached->{$pid}->{stop},
              $precache->{$pid}->{stop}
            ],
            [
              'Subtitle',
              ($cached->{$pid}->{'sub-title'} ? $cached->{$pid}->{'sub-title'}[0][0] : undef),
              $precache->{$pid}->{'sub-title'}
            ]
          ); 
  foreach my $cmp (@c)
  {
    return 0 unless compare_caches($cmp->[0], $cmp->[1], $cmp->[2]);
  }
  return 1;
}

sub compare_caches
{
  my ($name, $arg1, $arg2) = @_;

  # Special case for subtitles.
  return 1 if ($name eq 'Subtitle' and !$arg2);
  
  $arg1 = '--missing--' unless $arg1;
  $arg2 = '--missing--' unless $arg2;

  return 1 if $arg1 eq $arg2;

  print "$name mismatch: \"$arg1\" vs \"$arg2\".\n" if ($debug);
  return 0;
}

sub download_show
{
  my ($pid, $recurse_count) = @_;

  $recurse_count ||= 0;
  return undef if ($recurse_count > 2);
 
  $dcount++;
  refresh_ua() if ($dcount % 20 == 0); # don't wait for error page

  my $result;

  print "Downloading # $pid.\n" if ($debug);
  my $detailsdata = get_page($DATASOURCE_DETAIL .
                      '?action=session_info&event_id=' . $pid .
                      '&sid=' . $sid . '&loc=grid');
  $result = parse_details($detailsdata) if ($detailsdata);
  unless ($detailsdata and $result)
  {
    sleep(5);
    refresh_ua();
    return download_show($pid, $recurse_count+1);
  }

  return $result;
}

sub save_cache
{
  return if ($opt->{test} or $opt->{nowrite_cache});
  print "Saving cache.\n";
  Storable::store($cached, $opt->{'cache-file'});
}

sub write_xml
{
  return if ($opt->{test});
  
  my %writer_args = ( encoding => 'ISO-8859-1' );

  print "Writing XML.\n";

  if ($opt->{output}) 
  {
    my $fh = new IO::File(">" . $opt->{output})  
             or die "Can't open " . $opt->{output} . ": $!";
    $writer_args{OUTPUT} = $fh;
  }

  my $writer = new XMLTV::Writer(%writer_args);

  $writer->start
    ( { 'source-info-url'    => $DATASOURCE,
        'source-info-name'   => "Datasource Name",
        'generator-info-name' => "$progname $version"} );

  for my $channel (sort keys %$channels) 
  {
    my $chanid = $chanid{lc $channel};
    $writer->write_channel( { 'display-name' => [[$channel, $lang]],
                              'id' => $chanid } );
  } 

  foreach my $pid (keys %shows)
  {
    print "- " . $shows{$pid}->{'title'}[0][0] . "\n" if ($debug);
    $writer->write_programme($shows{$pid});
  }

  $writer->end();
}

sub refresh_ua
{
  print "Refreshing UA.\n" if ($debug);
  
  if ($ua)
  {
     print stats() if ($debug and $opt->{stats});
     print "Sleeping...\n" if ($debug);
     sleep 5 + int(rand(20));
  }

  my $agent = 
    ( 
    'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
    'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.4) Gecko/20060508 Firefox/1.5.0.4',
    'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox',
    'Opera/9.00 (Windows NT 5.1; U; en)',
    'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412'
    )[int(rand(5))];
               
  $ua = LWP::UserAgent->new
    ('timeout' => 30,
     'keep_alive' => 1,
     'agent' => $agent);
  $ua->env_proxy;
  $ua->cookie_jar({});

  # Set initial cookie
  get_page($DATASOURCE);

  # Set region/service cookie
  post_page($DATASOURCE_SETUP,
        [ 'fta_region_id' => $opt->{'region'} ]);

  $ua->cookie_jar()->scan(\&refresh_sid);

  $dcount = 0;
}

sub refresh_sid
{
  my ($version, $key, $val) = @_;

  $sid = $val if ($key eq 'CFID');
}

sub setup_javascript 
{
  print "Initializing JavaScript interpreter.\n" if ($debug);
  $jsc = new JavaScript::Runtime->create_context();
  $jsc->set_error_handler( sub { } );
  $jsc->eval(qq{
    var doc = '';
    function Location() { this.href  = '$DATASOURCE'; }
    function Document() { this.write = function(x) { doc += x; } }
    function Window()   { this.___ww = 0 }
    location = new Location;
    document = new Document;
    window   = new Window;
  });
}

sub restore_cache
{
  unless ($opt->{'ignore-cache'} or $opt->{'rebuild-cache'})
  {
    if (-r $opt->{'cache-file'})
    {
        eval 
        {
            $cached = Storable::retrieve($opt->{'cache-file'});
        };
        if ($@) 
        {
            print "Error reading cache file:\n$@";
        }
    }
    else
    {
      print "Unable to read cache file: " . $opt->{'cache-file'} . ".\n";
    }
  }
  if ($cached)
  {
    print "Retrieved " . keys(%$cached) . " cached items from file.\n";
    clean_cache();
  }
  else
  {
    $cached = { };
    print "Not using cache.\n";
  }
}

sub clean_cache
{
    my $r = expand_date(localtime(time() - 3600)."");
    my $c = 0;
    print "Removing cache items that finish earlier than $r.\n" if ($debug);
    foreach (keys %$cached)
    {
        if (Date_Cmp($r, $cached->{$_}->{stop}) == 1)
        {
            print "Removing $cached->{$_}->{title}[0][0].\n" if ($debug);
            delete $cached->{$_};
            $c++;
        }
    }
    print "Removed $c stale items from cache.\n";
}

sub dump_cache
{
  print "Cache: " . Dumper($cached) . "\n";
}

sub stats
{
  my $finished = shift;

  my $t = time() - $runtime;
  
  my $ret = "$progname $version " . 
            ($finished ? "finished" : "in progress") .
            ":\n";
  $ret .= sprintf(
        " %d shows grabbed\n" .
        " %d downloads, including %d detail pages (%d KB)\n" .
        " %d cache hits, %d changes from cache\n" .
        " %d failed downloads, %d failed parses\n",
        scalar(keys %shows),
        $count_dl, $count_detail, $count_kb, 
        $count_cache, $count_changes, 
        $count_bad, $count_bad_parse);
  $ret .= " Time elapsed: " . timestats($t) . "\n";
  unless ($finished or !$count_detail)
  {
    $t = ((((time() - $firstfetch) * ($numshows - $count_cache)) / $count_detail)) - $t;
    
    $ret .= " Estimated time remaining: " . timestats($t) . "\n";
  }
  $laststats = time();
  return $ret;
}

sub timestats
{
  my $t = shift;

  my $ret = '';
  if ($t >= 3600)
  {
    $ret .= sprintf("%d hr ", $t / 3600);
    $t = $t % 3600;
  }
  $ret .= sprintf("%d min %d sec", $t / 60, $t % 60);
  return $ret;
}


sub get_page
{
  my ($url) = @_;
  my $request = GET $url;
  return fetch_page($request);
}

sub post_page
{
  my ($url, $headers) = @_;
  my $request = POST $url, $headers;
  return fetch_page($request);
}

sub fetch_page
{
  my ($request) = @_;
  
  $request->uri() =~ s/^http:\/\//$WW/ if $opt->{warper};

  $request->header('Accept-Encoding' => 'gzip');

  print "Fetching: " . $request->as_string() . "\n" if ($debug);
  my $response;
  for my $c (1..2) {
    print "Attempt #$c.\n" if ($debug);
    $response = $ua->request($request);
    last unless ($response->is_error());
    $count_bad++;
    print stats() if ($debug);
    sleep 5;
  }
  if ($response->is_error())
  {
    print "ERROR! Failed to retrieve page: " . $request->uri() . ".\n";
    if ($debug and (my $r = $response)->previous) 
    {
        print "GET_CONTENT_BASE redirection backtrace:\n";
        while ($r) { print "    ", $r->base, "\n"; $r = $r->previous }
    }
    # Network down
    if ($count_bad > 10 and $count_dl == 0)
    {
        print "ERROR! Unable to download anything useful. Smells like a " .
              "network problem. Exiting.\n";
        print stats(1);
        die "No connectivity";
    }
    return undef;
  }
  $count_dl++;
  my $page = $response->content();
  $count_kb += (do {use bytes; length($page)}) / 1024;

  if ($response->header('Content-Encoding')
      and
      $response->header('Content-Encoding') eq 'gzip') 
  {
      $page = Compress::Zlib::memGunzip($response->content());
  }

  $page =~ s/&nbsp;/ /g;
  return $page;
}

sub parse_guide
{
  my ($guidedata, $date, $phase) = @_;

  print "Parsing guide page.\n" if ($debug);

  $guidedata = readjs(Encode::decode_utf8($guidedata));

  my $tree = HTML::TreeBuilder->new_from_content($guidedata);
  my $curchan = '';
  my @channels_seen;
  my ($pid, $block, $line, $link, $title);
  my $c = 0;
  foreach my $tag ($tree->look_down('_tag' => 'td', 'class' => 'venue'))
  {
    $c++;
    my $channame = $tag->as_text();
    my $curchan = translate_channel_name($tag->as_text(), grep($_ eq $channame, @channels_seen));
    push @channels_seen, $channame;
    if (!$channels->{$curchan})
    {
      print "Ignoring unsubscribed channel $curchan.\n" if ($debug);
      next;
    }
    print "Channel: $curchan.\n" if ($debug);
    $block = $tag->parent();
    foreach $line ($block->look_down('_tag' => 'td', 'class' => undef))
    {
      my ($pid, $title, $start, $pextra);
      foreach my $bit ($line->look_down('_tag' => 'div'))
      {
        if ($bit->attr('class') eq 'ptime')
        {
          if ($start)
          {
            addme($pid, $title, $start, $pextra, $curchan);
            $pextra = undef;
            $title = undef;
            $pid = undef;
          }
          $start = $bit->as_text();
          if ($phase and $phase == 1 and $start =~ /pm/)
          {
            $start = expand_date($start ." ". Ymd(DateCalc($date, "- 1 day")));
          }
          else
          {
            $start = expand_date("$start $date");
          }
        }
        elsif ($bit->attr('class') eq 'pname')
        {
          $title = strip_whitespace($bit->as_text());
          if (HTML::Entities::decode($bit->as_HTML()) =~ /session_info\('(\d+)/) 
          {
            $pid = $1;
          }
        }
        elsif ($bit->attr('class') eq 'pextra')
        {
          $pextra = strip_whitespace($bit->as_text());
        }
      }
      if ($pid)
      {
        addme($pid, $title, $start, $pextra, $curchan);
      }
      else
      {
        bad_parse("No pid found in guide data block");
      }
    }
  }
  bad_parse("Missing data") unless ($c);
}

sub addme
{
  my ($pid, $title, $start, $pextra, $curchan) = @_;
  
  if ($precache->{$pid})
  {
    print "Duplicate: $title ($pid).\n" if ($debug);
  }
  else
  {
    print "New: $title " . ($pextra ? "($pextra) " : '') . 
          "($pid) $start\n" if ($debug);
    if ($pextra and $pextra =~ /\(\d\d\d\d\)/)
    {
      print "Ignoring detail.\n" if ($debug);
      $pextra = undef;
    }
    $precache->{$pid} = { 'title' => $title, 
                          'start' => $start,
                          'sub-title' => $pextra
                        };
    my $lastpid = $lastpids->{$curchan};
    if ($lastpid)
    {
        $precache->{$lastpid}->{stop} = $start;
        if ($start < $precache->{$lastpid}->{start}) 
        {
            print "Oddness detected in \"" .
                  $precache->{$lastpid}->{title} .
                  "\" (pid $pid), starting at " .
                  $precache->{$lastpid}->{start} .
                  ".\n";
            delete $precache->{$lastpid} if ($gaps);
        }
        elsif ($gaps)
        {
            if (is_outside_gaps($curchan, $precache->{$lastpid}->{start}, $precache->{$lastpid}->{stop}))
            {
                delete $precache->{$lastpid};
            }
        }
    }
    $lastpids->{$curchan} = $pid;
  }
}

# The guide pages for some regions don't provide any way to distinguish
# between (eg) "Prime (Regional)" and "Prime (Albury)" in the same region,
# other than the order in which they're listed. (They're both called
# simply "Prime".) This func tracks which is which.
sub translate_channel_name
{
    my ($chan, $seen_before) = @_;

    my $rchans = {
        71 => { 'TEN' => [ 'TEN (NSW: Southern NSW)', 'TEN (Mildura Digital)' ],
                'Prime' => [ 'Prime (Canberra/Wollongong/South Coast)', 'Prime (Wagga Wagga/Orange)' ] },
        79 => { 'WIN' => [ 'WIN (QLD: Regional)', 'WIN (Mackay/Wide Bay)' ],
                'Seven' => [ 'Seven (Cairns/Townsville/Mackay/Wide Bay/Sunshine Coast)', 'Seven (Rockhampton/Toowoomba)' ] },
        90 => { 'Prime' => [ 'Prime (Regional)', 'Prime (Albury)' ] }
        };

    my $region = $opt->{region};
    return $chan unless ($rchans->{$region} and $rchans->{$region}->{$chan});
    $seen_before = ($seen_before ? 1 : 0);
    return $rchans->{$region}->{$chan}->[$seen_before];
}

sub parse_details 
{
  my $detailsdata = shift;

  my ($show, $str, @rows, $block, $start, $stop, $date, @extra, @items);

  $detailsdata = readjs(Encode::decode_utf8($detailsdata));

  my $tree = HTML::TreeBuilder->new_from_content($detailsdata);

  $block = $tree->find('h1');
  return bad_parse("Mising title") unless ($block);  # site is probably sending that block page

  $show->{'title'} = [[ strip_whitespace($block->as_text()), $lang ]];
  $str = $tree->find('h2');
  if ($str)
  {
    $show->{'sub-title'} = [[ strip_whitespace($str->as_text()), $lang ]];
  }

  $block = $tree->find('h3') or return bad_parse("Missing section");
  @rows = $block->look_down('_tag' => 'div');
  $date = $rows[1]->as_text();
  if($rows[0]->as_HTML() =~ /(\b[\d\.]+[ap]m)\s+.*?\s+([\d\.]+[ap]m)\b/)
  {
    ($start, $stop) = ($1, $2);
    $show->{'start'} = expand_date("$start $date");
    $show->{'stop'} = expand_date("$stop $date");
  }
  else
  {
    return bad_parse("Missing times");  # Failed to parse
  }
  if (Date_Cmp($show->{'start'}, $show->{'stop'}) == 1)
  {
     $show->{'stop'} = expand_date(DateCalc($show->{'stop'}, "+ 1 day"));
     print "Adjusted STOP time.\n" if ($debug);
  }
  $show->{'channel'} = $chanid{lc($rows[0]->find('span')->as_text())};

  $block = $tree->find('_tag' => 'hr', 'noshade') or return bad_parse("Missing subsection");
  $block = $block->right();
  if ($block->as_text())
  {
    $show->{'desc'} = [[ strip_whitespace($block->as_text()), $lang ]];
    $block = $block->right()->right();
  }
  else
  {
    $block = $block->right();
  }
  foreach my $tag ($block->look_down('_tag' => 'tr'))
  {
    $str = $tag->as_text();
    if ($str =~ /Genre:(.+)/)
    {
      $str = strip_whitespace($1);
      if ($str eq 'N/A')
      {
        @extra = ( $str );
      }
      else
      {
        @extra = split(/\//, $str);
      }
      $str = $tree->find('h5');
      if ($str and $str->as_text() =~ /movie/i)
      {
        unshift (@extra, 'movie');
      }

      foreach (@extra)
      {
        $_ = [ translate_category($_), $lang ];
      }
      $show->{'category'} = [ @extra ];
    }
    elsif ($str =~ /Rating:(.+)/)
    {
      $str = strip_whitespace($1);
      if ($str =~ /(.*?)\s*\[(.+)\]/)
      {
        @extra = split(/, /, $2);
        foreach (@extra)
        {
          $_ = [ $_, 'advisory', undef ];
        }
        $show->{'rating'} = [[ $1, 'ABA', undef],  @extra ];
      }
      else
      {
        $show->{'rating'} = [[ $1, "ABA", undef]];
      }
    }
    elsif ($str =~ /Cast: (.+)/)
    {
      $show->{'credits'}{'actor'} = [ split(/, /, strip_whitespace($1)) ];
    }
    elsif ($str =~ /Year:\s*(\d+)/)
    {
      $show->{'date'} = strip_whitespace($1);
    }
    elsif ($str =~ /Other:(.+)/)
    {
      next unless (strip_whitespace($1));
      $str = $tag->as_HTML();
      @extra = split(/<br \/>/, $tag->as_HTML());
      my (@to_add, %video);
      foreach my $bit (@extra)
      {
        $bit =~ s/<.*>//;
        $bit = strip_whitespace($bit);
        next unless ($bit);
        if ($bit eq 'Repeat')
        {
            $show->{'previously-shown'} = { };
            next;   # Don't need this in the desc as well as it's
                    # highlighted by MythTV
        }
        elsif ($bit eq 'Widescreen')
        {
            $video{'aspect'} = '16:9';
        }
        elsif ($bit eq 'Closed Captions')
        {
            $show->{'subtitles'} = [ { 'type' => 'teletext' } ];
            next;   # Just clutters up the desc
        }
        elsif ($bit eq 'Premiere')
        {
            $show->{'premiere'} = [ $bit ];
        }
        elsif ($bit eq 'High Definition')
        {
            $video{'quality'} = 'HDTV';
        }
        push (@to_add, $bit);
        $show->{'video'} = \%video if (%video);
      }
      foreach (@to_add)
      {
        if ($show->{'desc'})
        {
          $show->{'desc'}[0][0] .= " $_.";
        }
        else
        {
          $show->{'desc'} = [[ "$_.", $lang ]];
        }
      }
    }
  }

  print Dumper($show) if ($debug);
  return $show;
}

sub bad_parse
{
  my $msg = shift;
  print "Parsing error: $msg.\n";
  $count_bad_parse++;
  if ($count_bad_parse > 4 and !scalar(keys %shows))
  {
      print "ERROR! Unable to parse any shows! Looks like a major problem. " .
            "Exiting.\n";
      print stats(1);
      die "Major parsing error";
  }
  return 0;
}

sub translate_category
{
  my %translation = (   'Sport' => 'sports',
                        'Soap Opera' => 'Soap',
                        'Science and Technology' => 'Science/Nature',
                        'Real Life' => 'Reality',
                        'Cartoon' => 'Animation',
                        'Family' => 'Children',
                        'Murder' => 'Crime' );
                        
  return $translation{$_} if $translation{$_};
  return $_;
}

sub is_outside_gaps
{
  my ($ch, $start, $stop) = @_;

  $start = udate_to_epoch($start);
  $stop = udate_to_epoch($stop);

  foreach my $gap (@{$gaps->{$ch}})
  {
      if ($gap =~ /(\d+)-(\d+)/)
      {
          return 0 if ($stop > $1 and $start < $2);
      }
  }
  return 1;
}

sub udate_to_epoch
{
    my $udate = shift;

    if ($udate =~ /(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/)
    {
        my ($year, $month, $day, $hour, $minute, $second) = ($1, $2, $3, $4, $5, $6);
        $month--;
        $year -= 1900;
        return POSIX::strftime("%s", $second, $minute, $hour, $day, $month, $year);
    }
    die "Unable to parse udate $udate!";
}

sub readjs {
  my $data = shift;
  $data =~ s{<script type="?text/javascript"?[^>]*>(.*?)</script>}{
    my $x = $1;
    $jsc->eval(qq{ doc = '' });
    $jsc->eval($x);
    $jsc->eval(qq{ doc }) || '';
  }isge;
  $data;
}
 
sub read_channels_file 
{
    read_config_file('channels', 'channels_file');
}

sub read_gaps_file
{
    read_config_file('gaps', 'gaps_file');
}

sub read_config_file
{
    my ($name, $arg) = @_;

    return unless ($opt->{$arg});
    print "Reading $name file: $opt->{$arg}\n";
    if (-r $opt->{$arg})
    {
        local (@ARGV, $/) = ($opt->{$arg});
        no warnings 'all';
        eval <>;
        die "Can't parse $name file: $@" if ($@);
    }
    else
    {
        print "Unable to read $name file.\n";
    }
}

sub get_command_line_options
{
  GetOptions($opt, qw(
                        help
                        debug
                        output=s
                        days=i
                        offset=i
                        region=i
                        show-config
                        show-channels
                        rebuild-cache
                        ignore-cache
                        nowrite-cache
                        dump-cache
                        cache-file=s
                        config-file=s
                        channels_file=s
                        gaps_file=s
                        stats=i
                        test
                        desc
                        version
                        warper
                    ));
  $debug = $opt->{debug};   

  if (@ARGV)
  {
    print "\nERROR: Unknown option(s): @ARGV\n";
    help();
  }
}

sub show_config
{
  my $short = shift;
  
  print "\nConfiguration\n".
          "-------------\n";
  unless ($short)
  {
    print "Debug mode : " . is_set($debug) . "\n" .
          "Test mode  : " . is_set($opt->{test}) . "\n" .
          "Webwarping : " . is_set($opt->{warper}) . "\n" .
          "Cache file : " . $opt->{'cache-file'};
    print ' (not reading)' if ($opt->{'ignore-cache'} or $opt->{'rebuild-cache'});
    print ' (not updating)' if ($opt->{test} or $opt->{'ignore-cache'} or $opt->{'nowrite-cache'});
    print "\n" .
          "Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
          "Chann file : $opt->{channels_file}\n" .
          ($opt->{gaps_file} ? "Gaps file  : " . $opt->{gaps_file} . "\n" : '') .
          "Statistics : " . ($opt->{stats} ? "every " . $opt->{stats} . " seconds" : "off") . "\n";
  }
  print   "Region ID  : $opt->{region}\n" .
          "Days wanted: $opt->{days} (offset: $opt->{offset})\n";
  show_channels();
  print "\n";
}

sub is_set
{
  my $arg = shift;
  return $arg ? "Yes" : "No";
}

sub show_channels
{
  print "Subscribed channels:\n";
  print "    $_ -> $channels->{$_}\n" for sort keys %$channels;
}

sub build_channel_map
{
  # --- extract sorted subscribed channel list from config-file hash;
  # also compute canonicalised lowercased channel to xmltvid hash
  %chanid = map { lc $_, $channels->{$_} } keys %$channels;
}

sub set_defaults
{
  my $defaults = {
          'days' => 7,
          'offset' => 0,
          'region' => 94,
          'stats' => 300,
          'output' => getcwd() . '/output.xmltv',
          'cache-file' => getcwd() . '/cache.dat',
          'channels_file' => getcwd() . '/channels.conf'
  };
                                              
  foreach (keys %$defaults)
  {
    unless (defined $opt->{$_})
    {
      $opt->{$_} = $defaults->{$_};
    }
  }

  $opt->{'days'} = 7 if ($opt->{'days'} > 7);
}

sub expand_date
{
  my $t = shift;
  $t =~ s/\./:/;
  my $ret = ParseDate($t);

  # --- append timezone and strip colons
#  ($ret .= " $opt->{TZ}") =~ tr/://d;
  $ret =~ tr/://d;

  return $ret;
}

sub Ymd { UnixDate($_[0], "%Y-%m-%d") or die "Date problem in Ymd($_[0])" }

sub strip_whitespace 
{ 
  my $str = shift; 
  $str =~ s/^\s*(.*?)\s*$/$1/; 
  return $str;
}

sub help
{
  print q{
Command-line options:
    --help                 Print this message

    --version              Show current version
    --show-channels        Show subscribed channels & exit
    --show-config          Show configuration details & exit
    --dump-cache           Show cache & exit
                
    --cache-file <file>    Use the specified cache file
    --output <file>        Write XML into the specified file
    --channels_file <file> Read channel subscriptions from file
    --gaps_file <file>     Read gaps from file

    --region <n>           Grab data for region code <n>
    --days <n>             Grab <n> days of data (today being day 1)
    --offset <n>           Skip the first <n> days

    --stats <n>            Print stats every n secs (0=off)
    --debug                Print lots of debugging output

    --warper               Use webwarper.net anonymizer

    --test                 Don't write any output or update cache
    --ignore-cache         Neither read nor update cache
    --nowrite-cache        Read but don't update cache
    --rebuild-cache        Destroy and rebuild cache
};
  exit 0;
}