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

#!/usr/bin/perl -w

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

=pod

=head1 NAME

tv_grab_uk_bleb - Grab TV listings for the United Kingdom, from bleb.org

=head1 SYNOPSIS

tv_grab_uk_bleb --help

tv_grab_uk_bleb [--config-file FILE] --configure [--gui OPTION]

tv_grab_uk_bleb [--config-file FILE] [--output FILE] [--quiet]
                [--days N] [--offset N]

=head1 DESCRIPTION

Output TV and radio listings in XMLTV format for many stations
available in Britain.  The data comes from the bleb.org web site.

=head1 USAGE

First you must run B<tv_grab_uk_bleb --configure> to choose which
stations you want to receive.  Then running B<tv_grab_uk_bleb> with no
arguments will get about a week<39>s listings for the stations
you chose.

B<--configure> Prompt for which stations to download and write the
configuration file.

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<--config-file FILE> Set the name of the configuration file, the
default is B<~/.xmltv/tv_grab_uk_bleb.conf>.  This is the file written by
B<--configure> and read when grabbing.

B<--output FILE> When grabbing, write output to FILE rather than
standard output.

B<--days N> When grabbing, grab N days rather than as many as
possible.

B<--offset N> Start grabbing at today + N.  N may be negative.

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

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

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

=head1 SEE ALSO

L<xmltv(5)>, L<http://www.bleb.org/>

=head1 AUTHOR

Andy Balaam, axis3x3@users.sourceforge.net

Icon URLs collated by Lawrence, MagicLGH@aol.com

Based on tv_grab_nl_wolf by Ed Avis

=cut

use strict;

use XMLTV::Version '$Id: tv_grab_uk_bleb.in,v 1.22 2015/07/03 01:42:13 knowledgejunkie Exp $ ';
use XMLTV::Capabilities qw/baseline manualconfig/;
use XMLTV::Description 'United Kingdom (bleb.org)';

use Archive::Zip;
use IO::Scalar;

# Workaround from <http://rt.cpan.org/NoAuth/Bug.html?id=7855>.
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
Archive::Zip::setErrorHandler( sub { die @_ } );
use IO::Scalar;
BEGIN {
    # Override to allow seekable IO::Scalars
    no warnings;
    package Archive::Zip::Archive;
    sub _isSeekable {
	my $fh = shift;
	no warnings; # avoid '-f on unopened filehandle'
	return (-f $fh || UNIVERSAL::isa( $fh, 'IO::Scalar' ));
    }
    # Override to force print to use seekable IO::Scalars
    package IO::Scalar;
    sub print {
	my $self = shift;
	# *$self->{Pos} = length(${*$self->{SR}} .= join('', @_));
	my $pos = *$self->{Pos};
	my $buf = join('', @_);
	my $len = length($buf);
	substr(${*$self->{SR}}, $pos, $len) = $buf;
	*$self->{Pos} += $len;
	1;
    }
} # BEGIN

# Make sure you explicitly turn OFF the Data Descriptor.
# e.g. $member->hasDataDescriptor(0);

# We work by inheriting from XMLTV::Grab_XML and overriding certain
# methods.
#
use XMLTV::Grab_XML;

package Grab_XML_uk_bleb;
use base 'XMLTV::Grab_XML';

use Date::Manip;
use XMLTV::DST;

use XMLTV::Ask;
use XMLTV::Config_file;
use XMLTV::Date qw(parse_date);
use XMLTV::Get_nice;
use XMLTV::TZ   qw(tz_to_num);
#use XMLTV::Supplement qw/GetSupplement/;

BEGIN {
    if (int(Date::Manip::DateManipVersion) >= 6) {
        Date::Manip::Date_Init("SetDate=now,UTC");
    } else {
        Date::Manip::Date_Init("TZ=UTC");
    }
}

# Memoize one routine if possible.
eval { require Memoize };
unless ($@) {
    for ('tz_to_num') {
        Memoize::memoize($_) or warn "cannot memoize $_";
    }
}

sub country( $ ) {
    my $pkg = shift;
    return 'UK';
}

my $URL_HOST     = 'http://www.bleb.org';
my $URL_DIR      = '/tv/data/listings';
my $url_base     = "$URL_HOST$URL_DIR";
my $url_channels = "$URL_HOST$URL_DIR";

my $now = parse_date('now');

# Returns a hash mapping YYYYMMDD to URL.
sub urls_by_date( $$$ ) {
    my $pkg = shift;
    my $opt_config_file = shift;
    my $opt_quiet = shift;
    my $config_file = XMLTV::Config_file::filename($opt_config_file,
        'tv_grab_uk_bleb', $opt_quiet);

    my %ans; # This is a hash to return that is urls indexed by date

    my @channels; # This holds the names of channels

    # Do the channels from the config file
    foreach my $line (XMLTV::Config_file::read_lines($config_file, 0)) {
        next if not $line;

        # Remove whitespace and trailing comments
        if ($line =~ /\s*(.*?)#.*\s*/) {
            $line = $1;
        }
        push @channels, $line;
    }
    my $channels_string = join(',', @channels);

    # Do the dates
    for (my $off = -1; $off < 7; ++$off) {
        my $date = DateCalc($now, $off.' days');

        if ($date =~ /^(\d{8})/) {
            $date = $1;
        }
	else {
            warn("Strange.  No date found at beginning of 'now' string.");
        }

        $ans{$date} = $url_base.'?format=XMLTV&file=zip&channels='
            .$channels_string.'&days='.$off;
    }
    return %ans;
}

# Unzip the data and return it
sub xml_from_data( $$ ) {
    my $pkg = shift;
    my $zipped_data = shift;

    my $fake_filehandle = IO::Scalar->new(\$zipped_data);

    my $zip = Archive::Zip->new();
    $zip->readFromFileHandle($fake_filehandle);

    my $data_file = $zip->memberNamed('data.xml');
    my $xml = $data_file->contents();

    $xml = correct_emptydescs($xml);
    $xml = correct_timezones($xml);
    # $xml = add_channel_icons($xml);

    return Grab_XML_uk_bleb->remove_early_stop_times($xml);
}

# Disabled 2010-09-01 as most icons URLs are broken
sub add_channel_icons( $ ) {
    my $xml = shift;

    my %channel_urls;

    my $str = GetSupplement( 'tv_grab_uk_bleb', 'icon_urls' );
    foreach (split( /\n/, $str )) {
        s/#.*//;
        tr/\r//d;
        next if m/^\s*$/;
        my @fields = split;
        my ($channel_id, $channel_url) = @fields;

        $channel_urls{$channel_id} = $channel_url;

    }

    # Do the regex to put in icons
    $xml =~ s{(<channel id=\")(.*?)(\">.*?)(</display-name>)}
             {$1.$2.$3.$4.'<icon src="'.$channel_urls{$2}.'" />'}esg;

    return $xml;
}

# Removes description tags which are empty.
sub correct_emptydescs( $ ) {
    my @lines = split /\n/, shift;
    foreach my $line (@lines) {
        if ($line =~ /<desc lang="en"><\/desc>/) {

            # Just remove the line
            $line =~ s/.*//;

        }
    }
    return join("\n", @lines);
}

# Adds timezones which are guessed at by DST
sub correct_timezones( $ ) {
    my @lines = split /\n/, shift;
    foreach my $line (@lines) {
        if ($line =~ /<programme/) {

            # Check for times without timezones
            $line =~ s/(start|stop)="(\d+)"/qq'$1="'.utc_offset($2, "+0000").qq'"'/eg;

        }
    }
    return join("\n", @lines);
}

sub configure( $$$ ) {
    my $pkg = shift;
    my $opt_config_file = shift;
    my $opt_quiet = shift;

    my $config_file = XMLTV::Config_file::filename($opt_config_file,
        'tv_grab_uk_bleb', $opt_quiet);

    XMLTV::Config_file::check_no_overwrite($config_file);

    open(CONF, ">$config_file") or die "cannot write to $config_file: $!";

    my $bar = new XMLTV::ProgressBar('getting available channels', 1)
        if not $opt_quiet;

    my $page = get_nice($url_channels);
    $bar->update() if not $opt_quiet;
    $bar->finish() if not $opt_quiet;

    if ($page =~ /Available channels are: <tt id="channels">(.*?)<\/tt>/) {
        my @channels = split(', ', $1);

        # Actively filter out unavailable channels (as of 2015-07-02)
        my @unavailable_channels = (
            '4seven',               'al_jazeera_english',             'bbc7',
            'bbc_6music',           'bbc_radio1',                     'bbc_radio1_xtra',
            'bbc_radio2',           'bbc_radio3',                     'bbc_radio4',
            'bbc_radio5_live',      'bbc_radio5_live_sports_extra',   'bbc_radio_scotland',
            'bbc_world_service',    'bravo',                          'citv',
            'discovery_real_time',  'itv1',                           'itv1_hd',
            'itv2',                 'itv3',                           'itv4',
            'men_and_motors',       'nick_junior',                    'oneword',
            's4c2',                 'sky_movies_classics',            'sky_movies_hd1',
            'sky_movies_hd2',       'sky_travel',                     'teachers_tv',
            'virgin1',              'yesterday',
        );
        my %available_channels;
        @available_channels{ @channels } = undef;
        delete @available_channels{ @unavailable_channels };
        @channels = sort keys %available_channels;

        my @questions;

        foreach my $chan (@channels) {
            push @questions, "Add channel $chan? ";
        }
        my @answers = ask_many_boolean(1, @questions);

        for (my $i=0; $i < $#channels; $i++) {
            if ($answers[$i]) {
                print CONF $channels[$i]."\n";
            }
        }
        say("Configuration complete.");
    }
    else {
        say("Unable to download channels list from $url_channels.");
        die;
    }
}

Grab_XML_uk_bleb->go();