xmltv-util 0.5.67-0.1 / usr / bin / tv_grab_fr

#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

=head1 NAME

tv_grab_fr - Grab TV listings for France.

=head1 SYNOPSIS

 To configure:
   tv_grab_fr --configure [--config-file FILE] [--gui OPTION]
 To grab listings:
   tv_grab_fr [--config-file FILE] [--output FILE] [--days N]
    [--offset N] [--quiet] [--debug]
 To list available channels:
   tv_grab_fr --list-channels
 To show capabilities:
   tv_grab_fr --capabilities
 To show version:
   tv_grab_fr --version
 Help:
   tv_grab_fr --help

=head1 DESCRIPTION

Output TV listings for many channels available in France (Orange,
Free, cable/ADSL/satellite, Canal+ Sat).  The data comes from
telestar.fr.  The default is to grab 7 days, but there are usually
14 days of listings available from the current day onwards.

Grabbing speed varies, but is typically 1-2 minutes/day/channel.

B<--configure> Choose which bouquets/channels to grab listings data for.

B<--list-channels> List all available channels.

B<--config-file FILE> Use FILE as config file instead of the default config
file. This allows for different config files for different applications.

B<--gui OPTION> Use this option to enable a graphical interface to be used.
OPTION may be 'Tk', or left blank for the best available choice.
Additional allowed values of OPTION are 'Term' for normal terminal output
(default) and 'TermNoProgressBar' to disable the use of Term::ProgressBar.

B<--output FILE> Write to FILE rather than standard output.

B<--days N> Grab N days (default 7, maximum 14) starting from today.

B<--offset N> Start grabbing N days from today, rather than starting
today.

B<--quiet> Suppress the progress messages normally written to standard
error.

B<--debug> Provide additional debugging messages during processing.

B<--capabilities> Show which capabilities the grabber supports. For more
information, see L<http://wiki.xmltv.org/index.php/XmltvCapabilities>.

B<--version> Show the version of the grabber.

B<--help> Print a help message and exit.

=head1 SEE ALSO

L<xmltv(5)>

=head1 AUTHOR

The current version of the script was rewritten by Nick Morrott,
knowledgejunkie at gmail dot com, to support the new telestar.fr site.

The original author was Sylvain Fabre, centraladmin at lahiette dot com,
with patches from:
  - Francois Gouget, fgouget at free dot fr,
  - Geoff Westcott, honir999 at gmail dot com,
  - Karl Dietz, dekarl at spaetfruehstuecken dot org,
  - Niel Markwick, nielm at bigfoot dot com,
  - Zubrick, zubrick at number6 dot ch,
  - and many more!

=cut

# TODO
# ====
#
# - convert to use ParseOptions
#
# - perhaps we should internationalize messages and docs?
#
# - try to detect the language based on the country so we can make use of the
#   set the VO, VF and original title markers
#
# - investigate how to better handle France 5 and Arte as they share a single
#   channel for over-the-air broadcasts, but each have their own channel on
#   cable, satellite and ADSL. See the thread at:
#   http://sourceforge.net/mailarchive/message.php?msg_id=15181920
#
# - Add caching via HTTP::Cache::Transparent

use XMLTV::Usage <<END
$0: get French television listings in XMLTV format
To configure: tv_grab_fr --configure [--config-file FILE]
To grab listings: tv_grab_fr [--config-file FILE] [--output FILE] [--days N]
 [--offset N] [--quiet] [--debug]
To list available channels: tv_grab_fr --list-channels
To show capabilities: tv_grab_fr --capabilities
To show version: tv_grab_fr --version
Help: tv_grab_fr --help
END
  ;

use warnings;
use strict;
use XMLTV::Version '$Id: tv_grab_fr,v 1.107 2015/08/15 06:09:48 knowledgejunkie Exp $ ';
use XMLTV::Capabilities qw/baseline manualconfig cache/;
use XMLTV::Description 'France';
use XMLTV;
use XMLTV::Ask;
use XMLTV::ProgressBar;
use XMLTV::Mode;
use XMLTV::Config_file;
use XMLTV::DST;
use XMLTV::Get_nice qw(get_nice);
$XMLTV::Get_nice::ua->parse_head(0);
$XMLTV::Get_nice::FailOnError = 0;

use XMLTV::Memoize;
XMLTV::Memoize::check_argv('XMLTV::Get_nice::get_nice_aux');

use DateTime;
use DateTime::Duration;
use Encode qw(decode_utf8 encode_utf8);
use Getopt::Long;
use HTML::Entities;
use HTML::TreeBuilder;
use IO::File;

#***************************************************************************
# Main declarations
#***************************************************************************
my $ROOT_URL                = 'http://www.telestar.fr';
my $GRID_FOR_CHANNEL        = "$ROOT_URL/programme-tv/";
my $GRID_BY_CHANNEL_PER_DAY = "$ROOT_URL/programme-tv/grille-chaine/";

my $ENCODING = 'utf-8';
my $LANG = "fr";
my $MAX_RETRY = 5;

my %GridType = ( "Grandes Chaines"        => "grandes-chaines-et-tnt",
                 "Orange"                 => "orange",
                 "Free"                   => "free",
                 "Bouygues"               => "bouygues",
                 "SFR"                    => "sfr",
                 "Numéricable"            => "numericable",
                 "Canal+"                 => "canal",
                 "Câble, ADSL, Satellite" => "cable-adsl-satellite",
                 "Canal+ et Canalsat"     => "canal-et-canalsat",
                 "Belgique"               => "belgique",
                 "Hors bouquet"           => "hors-bouquet",
               );

#***************************************************************************
# Global variables allocation according to options
#***************************************************************************

my ( $opt_config_file,  $opt_days,  $opt_offset,        $opt_output,
     $opt_gui,          $opt_quiet, $opt_list_channels, $opt_configure,
     $opt_help,         $opt_debug, );

# Default to non-quiet, non-debug mode
$opt_quiet  = 0;
$opt_debug  = 0;

# Although the website is able to provide up to fourteen days of listings,
# parsing pages is slow so we set the default grab to 7 days. You can
# specify up to 14 days via the --days option.
my $default_opt_days = 7;

# Default to STDOUT
$opt_output = '-';

GetOptions( 'days=i'    => \$opt_days,
            'help'      => \$opt_help,
            'output=s'  => \$opt_output,
            'offset=i'  => \$opt_offset,
            'quiet'     => \$opt_quiet,
            'configure' => \$opt_configure,
            'gui:s'     => \$opt_gui,
            'debug'     => \$opt_debug,
            'config-file=s' => \$opt_config_file,
            'list-channels' => \$opt_list_channels,
    )
    or usage(0);

#***************************************************************************
# Options processing, warnings, checks and default parameters
#***************************************************************************
die 'Number of days must not be negative'  if (defined $opt_days && $opt_days < 0);
die 'Number of days must be less than 15'  if (defined $opt_days && $opt_days > 14);
die 'Offset must not be negative' if (defined $opt_offset && $opt_offset < 0);
die 'Offset must be less than 14' if (defined $opt_offset && $opt_offset > 13);
die 'Offset+days must be less than 15' if (defined $opt_offset && defined $opt_days && ($opt_offset + $opt_days > 14));

die 'Error: You cannot specify --quiet with --debug, exiting' if ($opt_quiet && $opt_debug);

usage(1) if $opt_help;

XMLTV::Ask::init($opt_gui);

# The days/offset options can be used, but we default them if not set.
$opt_offset = 0 if not defined $opt_offset;
$opt_days = $default_opt_days if not defined $opt_days;

if ( (($opt_offset + $opt_days) > $default_opt_days) or ($opt_offset > $default_opt_days) ) {
    $opt_days = $default_opt_days - $opt_offset;
    if ($opt_days < 0) {
        $opt_offset = 0;
        $opt_days = $default_opt_days;
    }
    say <<END
The website does not handle more than $default_opt_days days.
So, the grabber is now configured with --offset $opt_offset and --days $opt_days
END
;
}

#***************************************************************************
# Last init before doing real work
#***************************************************************************

# Detect if we are in configure mode
my $mode = XMLTV::Mode::mode('grab', # default
                             $opt_configure => 'configure',
                             $opt_list_channels => 'list-channels'
                            );

# File that stores which channels to download
my $config_file = XMLTV::Config_file::filename($opt_config_file, 'tv_grab_fr', $opt_quiet);

#***************************************************************************
# Subroutines
#***************************************************************************
sub get_dates_to_grab;
sub get_listings_page_start_date;
sub get_data_for_available_days;
sub get_data_for_filtered_days;
sub process_channel_row;
sub process_program;
sub get_channels;
sub debug_print;
sub trim;
sub tidy_html;
sub parse_name_list;
sub get_tree;
sub get_country_code;
sub get_date_today;
sub get_date_today_with_offset;

#***************************************************************************
# Configure mode
#***************************************************************************
if ($mode eq 'configure') {
    XMLTV::Config_file::check_no_overwrite($config_file);
    open(CONF, ">$config_file") or die "Cannot write to $config_file: $!";

    # Choose which bouquets to configure channels for
    my @gts = sort keys %GridType;
    my @gtnames = map { $GridType{$_} } @gts;
    my @gtqs = map { "Get channels type : $_?" } @gts;
    my @gtwant = ask_many_boolean(1, @gtqs);

    # Get channels for each requested bouquet
    my $bar = new XMLTV::ProgressBar('getting channel lists',
                                    scalar grep { $_ } @gtwant)
                    if not $opt_quiet;
    my %channels_for;
    foreach my $i (0 .. $#gts) {
        my ($gt, $gtw, $gtname) = ($gts[$i], $gtwant[$i], $gtnames[$i]);
        next if not $gtw;
        my %channels = get_channels( $gtname );
        print STDERR 'WARNING: No channels could be found'."\n" if not %channels;
        $channels_for{$gt} = \%channels;
        update $bar if not $opt_quiet;
    }
    $bar->finish() if not $opt_quiet;

    my %asked;
    foreach (@gts) {
        my $gtw = shift @gtwant;
        my $gtname = shift @gtnames;
        if ($gtw) {
            my %channels = %{$channels_for{$_}};
            say "Channels for $_";

            # Ask about each channel (unless already asked).
            my @chs = grep { not $asked{$_}++ } sort keys %channels;
            my @names = map { $channels{$_}{name} } @chs;
            my @qs = map { "add channel $_?" } @names;
            my @want = ask_many_boolean(1, @qs);
            foreach (@chs) {
                my $w = shift @want;
                warn("cannot read input, stopping channel questions"), last if not defined $w;
                # Print a config line, but comment it out if channel not wanted.
                print CONF '#' if not $w;
                print CONF "channel $channels{$_}{name}\n";
            }
        }
    }
    close CONF or warn "cannot close $config_file: $!";
    say("Finished configuration.");
    exit();
}

#***************************************************************************
# Check mode
#***************************************************************************
die if $mode ne 'grab' and $mode ne 'list-channels';

#***************************************************************************
# Prepare the XMLTV writer object
#***************************************************************************
my %w_args;
if (defined $opt_output) {
    my $fh = new IO::File(">$opt_output");
    die "cannot write to $opt_output: $!" if not defined $fh;
    $w_args{OUTPUT} = $fh;
}

$w_args{encoding} = "$ENCODING";
$w_args{days}     = "$opt_days";
$w_args{offset}   = "$opt_offset";
$w_args{cutoff}   = "000000";

my $writer = new XMLTV::Writer(%w_args);
$writer->start
  ({ 'source-info-url'     => "$ROOT_URL/",
     'source-data-url'     => "$ROOT_URL/",
     'generator-info-name' => 'XMLTV',
     'generator-info-url'  => 'http://xmltv.org/',
   });

#***************************************************************************
# List channels only case
#***************************************************************************
if ($mode eq 'list-channels') {
    # Get a list of all available channels, for all bouquets
    #
    # Unlike channel configuration in --configure, we do not ask the user
    # for any input to select bouquets, we list everything
    my @gts = sort keys %GridType;
    my @gtnames = map { $GridType{$_} } @gts;
    my %seen;
    foreach (@gts) {
        my $gtname = shift @gtnames;
        my %channels = get_channels( $gtname );
        print STDERR 'WARNING: No channels could be found'."\n" if (scalar(keys(%channels)) == 0);
        foreach my $ch_did (sort(keys %channels)) {
            my $ch_xid = $ch_did.".telestar.fr";
            $writer->write_channel({ id => $ch_xid,
                                     'display-name' => [[encode_utf8( $channels{$ch_did}{name} )]],
                                   })
            unless $seen{$ch_xid}++;
        }
     }
     $writer->end();
     exit();
}

#***************************************************************************
# Only grabbing beyond here...
#***************************************************************************
die if $mode ne 'grab';

#***************************************************************************
# Read configuration file
#***************************************************************************
my @config_lines;
@config_lines = XMLTV::Config_file::read_lines($config_file);

my (%channels, $chname);
my $line_num = 1;
foreach (@config_lines) {
    ++ $line_num;
    next if not defined;

    # We store the channel name as the identifier in the config file
    if (/^channel (\w+)$/) {
        $chname = $1;
        $channels{$line_num} = { 'name'=>$chname };
    } else {
        warn "$config_file:$line_num: bad line $_\n";
    }
}

#***************************************************************************
# Process requested days
#***************************************************************************
warn "No working channels configured, so no listings\n" if not %channels;
my $script_duration = time();

my @to_get;
my $listings_page_start_date = get_listings_page_start_date();

# The telestar.fr website provides up to 14 days of listings for each
# channel. The first 7 days from today are on one page, the second
# 7 days on another.
debug_print("\nCreating list of pages to grab based on configured channels...");
foreach my $idx (sort { $a <=> $b } keys %channels) {
    my $chname = $channels{$idx}{name};
    my $xmltvid = $chname.".telestar.fr";
    my $url;
    my $dayoff;

    $writer->write_channel({ id => $xmltvid,
                             'display-name' => [[encode_utf8( $chname )]],
                           });

    debug_print("\n  <channel>: xmltvid=$xmltvid, name=$chname");
    debug_print("  Creating list of pages for " . $chname);

    my @urls;
    if ($opt_offset < 7) {
        $url = $GRID_BY_CHANNEL_PER_DAY . $chname;
        push @urls, $url;
        debug_print( "    adding: url=$url" );
    }
    if ($opt_offset + $opt_days >= 7) {
        $dayoff = get_date_today_with_offset(7)->strftime("%d-%m-%Y");
        $url = $GRID_BY_CHANNEL_PER_DAY . "$chname/$dayoff";
        push @urls, $url;
        debug_print( "    adding: url=$url" );
    }
    push @to_get, [\@urls, $chname];
}

debug_print("\nGenerating list of dates...\n");
my $dates_to_grab = get_dates_to_grab();

my $bar;
if (not $opt_quiet and not $opt_debug) {
    $bar = new XMLTV::ProgressBar('getting listings', scalar @to_get);
}

debug_print("\nProcessing list of pages to grab...\n");
CHANNEL:
foreach (@to_get) {
    # Each item in the @to_get listref is a listref for each channel
    # (a list of URLS to get, and the channel name).
    my ($urls, $chname) = @$_;
    my @data_for_available_days;

    foreach my $url (@$urls) {
        push @data_for_available_days, get_data_for_available_days($url, $chname);
    }

    my $data_for_filtered_days = get_data_for_filtered_days(\@data_for_available_days);

    debug_print("  Have " . scalar @{$data_for_filtered_days} . " days of data\n");
    debug_print("  Have " . scalar @{$dates_to_grab} . " dates to grab for\n");

    if (scalar @{$data_for_filtered_days} != scalar @{$dates_to_grab}) {
        if (not $opt_quiet) {
            print STDERR "ERROR: Not enough data available for requested number of days\n";
            print STDERR "  Have " . scalar @{$data_for_filtered_days} . " days of data\n";
            print STDERR "  Need " . scalar @{$dates_to_grab} . " days of data\n";
            print STDERR "  Skipping channel\n";
        }
        next CHANNEL;
    }
    # Store individual programmes in a list and write each channel in full.
    # No stop times are given in the listings (only inaccurate durations), so
    # we can use the start time of a following programme as the stop time of
    # the previous programme. (May fail if channel does not have listings
    # for full 24hrs).
    my @programmes = ();

    foreach my $i (0 .. (scalar @{$data_for_filtered_days} - 1)) {
        debug_print("  Getting listings for day " . ($i+1));
        push @programmes, @{ process_channel_row( $chname, $data_for_filtered_days->[$i], $dates_to_grab->[$i] ) };
    }

    # Update programme stop times
    @programmes = @{ update_programme_stop_times(\@programmes) };

    # Write the channel's programme elements to output
    foreach my $prog (@programmes) {
        $writer->write_programme($prog);
    }

    if (not $opt_quiet and not $opt_debug) {
        update $bar;
    }
}

$writer->end();

if (not $opt_quiet and not $opt_debug) {
    $bar->finish();
}

# Print the script's execution time
$script_duration = time() - $script_duration;
print STDERR "Grabber process finished in " . $script_duration . " seconds.\n" if not $opt_quiet;

#***************************************************************************
# Subroutines
#***************************************************************************

sub get_dates_to_grab {
    my @dates_to_grab = ();
    # First date to grab listings for
    my $grab_start_date = get_date_today_with_offset($opt_offset);
    push @dates_to_grab, $grab_start_date;
    # Remaining dates to grab listings for
    for (my $offset = 1; $offset < $opt_days; $offset++) {
        push @dates_to_grab, $grab_start_date + DateTime::Duration->new( days => $offset );
    }

    debug_print("Will grab listings for following dates:");
    if ($opt_debug) {
        foreach (@dates_to_grab) {
            # print STDERR "  " . $_->strftime("%a, %d %b %Y %H:%M:%S %z") . "\n";
            print STDERR "  " . $_->strftime("%a, %d %b %Y") . "\n";
        }
    }
    debug_print("\n");

    return \@dates_to_grab;
}

# Each week of listings for a channel is provided on a single page.
#
# * if we are grabbing with no starting offset (today) or an offset less than
#   7 days into the future, we'll start with the default page (starts today).
#
# * if we are grabbing with a starting offset of at least 7 days, we'll
#   start with next week's page.
#
sub get_listings_page_start_date {
    my $start_date;

    if ($opt_offset < 7) {
        $start_date = get_date_today();
        debug_print("get_listings_page_start_date(): " . $start_date->strftime("%d-%m-%Y"));
    }
    else {
        $start_date = get_date_today_with_offset(7);
        debug_print("get_listings_page_start_date(): " . $start_date->strftime("%d-%m-%Y"));
    }

    return $start_date;
}

sub get_data_for_available_days {
    my ($url, $chname) = @_;

    debug_print("get_available_days(): url=$url");

    # Get the page's tree
    my $t = get_tree($url);
    if (not defined $t) {
        debug_print("*** Error: Could not get tree for '" . $url . "' ***");
        return;
    }

    # Return all available day elements ( <div class="channel"...> )
    my @nodes = $t->look_down('_tag', 'div', 'class', 'channel');
    debug_print("get_available_days():   Found " . scalar @nodes . " days of data\n");
    return @nodes;
}

sub get_data_for_filtered_days {
    my $available_days = shift;
    my @filtered_days;

    AVAILABLE:
    foreach my $i (0 .. scalar @$available_days) {
        next AVAILABLE if ($i < $opt_offset);
        last AVAILABLE if ($i == $opt_offset + $opt_days);
        push @filtered_days, $available_days->[$i];
    }

    debug_print("filter_days(): Will get listings for " . scalar @filtered_days . " days\n");
    undef $available_days;
    return \@filtered_days;
}

sub process_channel_row {
    my ($chname, $row, $dt) = @_;

    my $dateindex = $dt->strftime("%Y%m%d");

    debug_print("  ###############################################################");
    debug_print("  process_row: processing listings for: chname=$chname, dateindex=$dateindex");
    debug_print("  ###############################################################\n");

    my @programmes = ();
    PROGRAMME:
    foreach my $programme ($row->look_down('_tag', 'div', 'class', qr/program /) ) {
        # skip empty program cells
        if ($programme->attr('class') =~ /no-program/) {
            debug_print("        Skipping 'no-program' entry\n");
            next PROGRAMME;
        }
        # extract the programme data
        push @programmes, process_program($chname, $programme, $dateindex);
        debug_print("\n");
    }

    return \@programmes;
}

sub process_program {
    my ($chname, $programme, $dateindex) = @_;

    my $title_text;
    my $prog_page;
    my $title = $programme->look_down('_tag', 'p', 'class', 'title');
    if ($title) {
        if ($title->as_text() =~ /\w+/) {
            $title_text = trim($title->as_text());
            debug_print("        Found programme title '" . $title_text . "'");

            #FIXME for all prog types
            my $link = $title->look_down('_tag', 'a', 'class', 'lien-fiche');
            if ($link and $link->attr('href') =~ /programme-tv/) {
                $prog_page = $ROOT_URL . $link->attr('href');
                debug_print("        Programme subpage found '" . $prog_page . "'");
            }
        }
        else {
            debug_print("        No programme title text found, skipping programme");
            return undef; # REQUIRED
        }
    }
    else {
        debug_print("        No programme title found, skipping programme");
        return undef; # REQUIRED
    }

    my $start_time;
    my $duration_mins;
    my $start = $programme->look_down('_tag', 'p', 'class', 'time');
    if ($start) {
        if ($start->as_text() =~ /(\d\d)h(\d\d)/) {
            my ($hh, $mm) = ($1, $2);
            $start_time = $dateindex.$hh.$mm."00";
            debug_print("        Found programme start '" . $hh."h".$mm . "'");
        }
        else {
            debug_print("        Start time not parsed, skipping programme'");
            return undef; # REQUIRED
        }

        # Programme durations are given, but rarely agree with the difference
        # between this programme's start time and the next
        $duration_mins = $start->look_down('_tag', 'span');
        if ($duration_mins) {
            if ($duration_mins->as_text() =~ /\((\d+) min\)/) {
                $duration_mins = $1;
                debug_print("        Found programme duration '" . $duration_mins ." mins'");
            }
            else {
                debug_print("        No programme duration found");
            }
        }
    }
    else {
        debug_print("        No start time found, skipping programme'");
        return undef; # REQUIRED
    }

    debug_print("        Creating programme hash for '" . $title_text . " / " . $start_time);
    my %prog = (channel => $chname.".telestar.fr",
                title   => [ [ encode_utf8( trim($title_text) ) ] ], # lang unknown
                start   => utc_offset($start_time, "+0100"),
                );

    # Store some temp data for later processing. A leading underscore in
    # a key name means the data is not written by XMLTV::Writer
    if ($duration_mins and $duration_mins > 0) {
        $prog{'_duration_mins'} = $duration_mins;
    }
    if ($prog_page) {
        $prog{'_prog_page'} = $prog_page;
    }

    my $episodenumber = $programme->look_down('_tag', 'p', 'class', 'title-episode');
    if ($episodenumber) {
        if ($episodenumber->as_text() =~ /Saison (\d+) Episode (\d+)/) {
            my ($season_num, $episode_num) = ($1, $2);
            # Season/episode number is zero-indexed. (Totals are one-indexed.)
            # Sometimes, a series or episode number of 0 is seen, so we ignore it
            if ($season_num == 0) {
                $season_num = "";
            }
            else {
                $season_num--;
            }
            if ($episode_num == 0) {
                $episode_num = "";
            }
            else {
                $episode_num--;
            }
            $episodenumber = $episodenumber->as_text();
            $prog{'episode-num'} = [ [ $season_num . "." . $episode_num . ".", "xmltv_ns" ] ];
            debug_print("        Found programme episodenumber '" . $episodenumber . "'");
        }
        # Likely the programme's sub-title if not an episode number
        elsif ($episodenumber->as_text() =~ /\w+/) {
            $episodenumber = $episodenumber->as_text();
            $prog{'sub-title'} = [ [ encode_utf8( $episodenumber ) ] ];
            debug_print("        Found programme sub-title '" . $episodenumber . "'");
        }
    }
    else {
        debug_print("        No episodenumber found");
    }

    my $category = $programme->look_down('_tag', 'p', 'class', 'category');
    if ($category and $category->as_text() =~ /\w+/) {
        $category = trim($category->as_text());
        $prog{category} = [ [ encode_utf8( $category ), $LANG ] ];
        debug_print("        Found programme genre '" . $category . "'");
    }
    else {
        debug_print("        No category found");
    }

    my $synopsis = $programme->look_down('_tag', 'p', 'class', 'synopsis');
    if ($synopsis and $synopsis->as_text() =~ /\w+/) {
        $synopsis = trim($synopsis->as_text());
        $prog{desc} = [ [ encode_utf8( $synopsis ), $LANG ] ];
        debug_print("        Found programme synopsis '" . $synopsis . "'");
    }
    else {
        debug_print("        No synopsis found");
    }

    my $rating = $programme->look_down('_tag', 'span', 'class', 'pastille csa');
    if ($rating and trim($rating->as_text()) =~ /^(-(?:10|12|16|18))$/) {
        $rating = $1;;
        $prog{rating} = [ [ $rating, "CSA" ] ];
        debug_print("        Found programme rating '" . $rating . "'");
    }
    else {
        debug_print("        No rating found");
    }

    my $thumbnail = $programme->look_down('_tag', 'img', 'class', 'thumbnail');
    if ($thumbnail) {
        my $url = $thumbnail->attr('src');
        push @{$prog{icon}}, {src => $url};
        debug_print("        Found programme icon: '" . $url . "'");
    }

    if ($prog_page) {
        process_programme_page(\%prog);
    }

    return \%prog;
}

# Process a page of detailed programme information for stored url and
# update the given programme hash with any extra information extracted
# from the page
#
sub process_programme_page {
    my $prog = shift;
    my $prog_page = $prog->{'_prog_page'};

    debug_print("        process_programme_page(): url=$prog_page");

    # Get the page's tree
    my $t = get_tree($prog_page);
    if (not defined $t) {
        debug_print("        *** Error: Could not get tree for '" . $prog_page . "' ***");
        return $prog;
    }

    my $prog_info = $t->look_down('_tag', 'div', 'class', qr/program-informations/);
    if ($prog_info) {
        my $episode_name = $prog_info->look_down('_tag', 'h2', 'class', 'underlined red');
        if ($episode_name) {
            if ($episode_name->as_text() =~ /Saison \d+ Episode \d+ : (\w.*)$/) {
                $episode_name = trim($1);
                $prog->{'sub-title'} = [ [ encode_utf8( $episode_name ), $LANG ] ];
                debug_print("        Found programme sub-title '" . $episode_name . "'");
            }
            elsif ($episode_name->as_text() =~ /\w+/) {
                $episode_name = trim($episode_name->as_text());
                $prog->{'sub-title'} = [ [ encode_utf8( $episode_name ), $LANG ] ];
                debug_print("        Found programme sub-title '" . $episode_name . "'");
            }
        }
        my $date_created = $prog_info->look_down('_tag', 'span', 'itemprop', 'dateCreated');
        if ($date_created) {
            if ($date_created->as_text() =~ /^\d{4}$/) {
                $date_created = trim($date_created->as_text());
                $prog->{'date'} = $date_created;
                debug_print("        Found programme year '" . $date_created . "'");
            }
        }
        my $genre = $prog_info->look_down('_tag', 'span', 'itemprop', 'genre');
        if ($genre) {
            my $subgenre;
            ($genre, $subgenre) = split(/,|\s-\s/, $genre->as_text() );
            if (defined $genre && $genre =~ /\w+/) {
                $genre = trim($genre);
                debug_print("        Found programme genre '" . $genre . "'");

                if (defined $subgenre && $subgenre =~ /\w+/) {
                    $subgenre = trim($subgenre);
                    debug_print("        Found programme sub-genre '" . $subgenre . "'");

                    $prog->{category} = [ [ encode_utf8( $genre ), $LANG ],
                                        [ encode_utf8( $subgenre ), $LANG ] ];
                }
                else {
                    $prog->{category} = [ [ encode_utf8( $genre ), $LANG ] ];
                }
            }
        }
    }
    my $synopsis = $t->look_down('_tag', 'p', 'class', qr/synopsis/);
    if ($synopsis) {
        $synopsis = trim($synopsis->as_text());
        $prog->{desc} = [ [ encode_utf8( $synopsis ), $LANG ] ];
        debug_print("        Found programme synopsis '" . $synopsis . "'");
    }

    # Casting information on the default programme information page is
    # typically limited to series.
    #
    # A separate "Casting" page is available for many programmes which may
    # include casting information for the given programme, but typically
    # includes all casting information for the whole series of programmes so is
    # not currently used.
    my $casting = $t->look_down('_tag', 'div', 'class', qr/block-casting/);
    if ($casting) {
        my @directors = $casting->look_down('_tag', 'a', 'itemprop', 'producer');
        foreach my $director (@directors) {
            $director = trim($director->as_text());
            push @{$prog->{credits}{director}}, encode_utf8( $director );
            debug_print("        Found programme director '" . $director . "'");
        }

        my @actors = $casting->look_down('_tag', 'a', 'itemprop', 'actor');
        foreach my $actor (@actors) {
            $actor = trim($actor->as_text());
            push @{$prog->{credits}{actor}}, encode_utf8( $actor );
            debug_print("        Found programme actor '" . $actor . "'");
        }

        my @writers   = $casting->look_down('_tag', 'a', 'itemprop', 'author');
        foreach my $writer (@writers) {
            $writer = trim($writer->as_text());
            push @{$prog->{credits}{writer}}, encode_utf8( $writer );
            debug_print("        Found programme writer '" . $writer . "'");
        }
    }

    return $prog;
}

# For each programme in the given programme listref, set the stop time
# of a given programme to the start time of the following programme. For
# the last programme in the list, set the stop time to start time plus
# its duration
sub update_programme_stop_times {
    my $programmes = shift;

    # Stop at antepenultimate programme
    foreach my $i (0 .. (scalar @{$programmes} -2)) {
        my $prog_current = $programmes->[$i];
        my $prog_next    = $programmes->[$i+1];

        $prog_current->{stop} = $prog_next->{start};
    }

    # Handle final programmes separately: add duration to start time
    my $prog_last = $programmes->[-1];
    my ($y, $m, $d, $hh, $mm, $ss) = $prog_last->{start} =~ /^(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/;
    my $prog_last_start = DateTime->new(
            year      => $y,  month     => $m,  day       => $d,
            hour      => $hh, minute    => $mm, second    => $ss,
            time_zone => 'Europe/Paris', );
    my $prog_last_duration = DateTime::Duration->new( minutes => $prog_last->{'_duration_mins'});
    my $prog_last_stop = $prog_last_start + $prog_last_duration;
    $prog_last->{stop} = utc_offset($prog_last_stop->strftime("%Y%m%d%H%M%S"), "+0100");

    # Return updates listref of programmes
    return $programmes;
}

# Return a hash of available channels for a given bouquet.
#
sub get_channels {
    my $bouquet = shift;
    my %bouquet_channels;

    return undef if not defined $bouquet;

    # Get the current page for the given bouquet
    # http://www.telestar.fr/programme-tv/grille/09-08-2015/grandes-chaines-et-tnt
    my $today = get_date_ddmmyyyy();
    my $url = $GRID_FOR_CHANNEL.'grille/'.$today.'/'.$bouquet;
    my $t = get_tree($url);
    debug_print("get_channels(): url = '" . $url . "'");
    if (!defined $t) {
        print STDERR "Unable to retrieve channels for $bouquet \n";
        return %bouquet_channels;
    }

    foreach my $cellTree ( $t->look_down( "_tag", "div", "class", "channel" ) ) {
        my $tag = $cellTree->look_down( "_tag", "a" );
        if (defined $tag) {
            my $progurl = $tag->attr('href');
            if ( $progurl =~ /^\/programme-tv\/grille-chaine\/(\w+)/ ) {
                # There are now no parsable channel names and icons
                # are given as a single site-wide imagemap instead of individual URLs:
                # http://css1.telestar.fr/extension/telestar/design/telestar/images/chaines/chaines.jpg
                my $chname = $1;
                debug_print("  Found channel: name = '" . $chname . "'");
                $bouquet_channels{$chname} = {'name' =>  $chname };
            }
        }
    }
    $t->delete(); undef $t;
    return %bouquet_channels;
}

# Prints a debug string when the --debug option is used
#
sub debug_print {
    if ($opt_debug) {
        my ($msg) = shift;
        print STDERR $msg . "\n";
    }
}

# Remove leading/trailing whitespace
#
sub trim {
    for (my $s = shift) {
        s/^\s*//;
        s/\s*$//;

        return $s;
    }
}

# Replaces specific HTML entities with text replacements, and then
# decodes any remaining entities in the string
#
sub tidy_html {
    for (my $s = shift) {
        # handle specific entities
        s/&nbsp;/ /g;
        s/\x8c/&OElig;/g;
        s/&OElig;/OE/g;
        s/\x9c/&oelig;/g;
        s/&oelig;/oe/g;
        s/&ldquo;|&rdquo;|&\#8219;|&\#8220;/\"/g;
        s/&lsquo;|&rsquo;|&\#8216;|&\#8217;|&\#8218;/\'/g;
        s/&\#8212;/--/g;
        s/\x85/.../g;
        s/&\#8230;/.../g;
        s/&\#8230;/.../g;
        s/&\#821[0123];/-/g;
        s/\xe2\x80\x99/\'/g;
        s/\x92/\'/g; # turn windows-1252 right single quotation mark into apostrophe
        s/\x80/&#x20ac;/g; # turn windows-1252 euro sign into real euro sign
        s/(&\#[0-9]{4,};)//g;
        # decode remaining entities
        decode_entities($s);

        return $s;
    }
}

# Returns a TreeBuilder instance for a given URL. The URL is retrieved
# via get_nice(), decoded into a Perl string, processed to remove HTML
# entities and then parsed into a HTML::TreeBuilder object
#
sub get_tree {
    my $url = shift;
    my $content;
    my $nbretry = 0;
    while ( (not defined($content = get_nice($url))) || (length($content) == 0) ) {
        ++$nbretry;
        return undef if $nbretry > $MAX_RETRY;
        debug_print("*** Retrying URL: '" . $url
                . "' (attempt " . $nbretry . " of " . $MAX_RETRY . ") ***");
    }
    $content = decode_utf8($content);
    $content = tidy_html($content);
    my $t = new HTML::TreeBuilder;
    $t->parse($content) or die "Cannot parse content of Tree\n";
    $t->eof;
    return $t;
}

# Return a DateTime object representing 'now'
#
sub get_date_today {
    return DateTime->now( time_zone  => 'Europe/Paris' );
}

# Return a DateTime object represent 'now' + $offset days
#
sub get_date_today_with_offset {
    my $offset = DateTime::Duration->new( days => shift );
    return get_date_today() + $offset;
}