#!/usr/bin/perl -w

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


#my $default_root_url = 'http://www.teleguide.info/download/new3/xmltv.xml.gz';
#my $default_root_url = 'http://izbushka.kiev.ua/xmltv/listing.xml';
my $default_root_url = 'http://www.star.poltava.ua/files_tv/tvprogram_ukr.zip';
my $default_cachedir = get_default_cachedir();
my $default_reformatxmltv = 'yes';
my $usecache;

use strict;
use Encode;


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;
    }
    eval { require HTTP::Cache::Transparent };
    if ($@) {
    	$usecache = 0;
    } else {
    	$usecache = 1;
    }
} # BEGIN

use XMLTV;
use XMLTV::Ask;
use XMLTV::ProgressBar;
use XMLTV::Options qw/ParseOptions/;
use XMLTV::Configure::Writer;
use XMLTV::Memoize; XMLTV::Memoize::check_argv 'get';
use XMLTV::Supplement qw/GetSupplement/;

use Date::Manip;
use File::Path;
use File::Basename;
use LWP::Simple qw($ua get);
use HTTP::Request::Common;

$ua->agent("xmltv/$XMLTV::VERSION");

sub t;
sub reformat_programmes (@);
sub add_channel_icons ($);

my $warnings = 0;
my $bar = undef;

my ($opt, $conf) = ParseOptions({
	grabber_name		=> "tv_grab_ua",
	capabilities		=> [qw/baseline manualconfig tkconfig 
				    apiconfig cache preferredmethod/],
	stage_sub		=> \&config_stage,
	listchannels_sub	=> \&list_channels,
	load_old_config_sub	=> \&load_old_config,
	version			=> '$Id: tv_grab_ua 29 2010-08-09 16:12:01Z tipok $',
	description		=> "Ukraine (www.star.poltava.ua)",
	defaults		=> { days => -999 },	# all days
	preferredmethod		=> 'allatonce',
});

if (not defined ($conf->{'root-url'})) {
	print STDERR "No root-url defined.\n" .
	             "Please run the grabber with --configure.\n";
	exit(1);
}

my $reformatxmltv;

if (!defined ($conf->{'reformat-xmltv'})) {
	$reformatxmltv = $default_reformatxmltv;
} else {
	if ($conf->{'reformat-xmltv'} =~ /(y|yes|1|on)/i) {
		$reformatxmltv = 1;
	} elsif ($conf->{'reformat-xmltv'} =~ /(n|no|0|off)/i) {
		$reformatxmltv = 0;
	} else	{
		print STDERR "Illegal reformat-xmltv value\n" .
		             "Please run the grabber with --configure.\n";
		exit(1);
	}
}

if ($usecache && not defined ($conf->{'cachedir'})) {
	print STDERR "No cachedir defined.\n" .
	             "Please run the grabber with --configure.\n";
	exit(1);
}

init_cachedir($conf->{cachedir}->[0]) if ($usecache);

if ($usecache) {
	HTTP::Cache::Transparent::init({ 
		BasePath	=> $conf->{cachedir}->[0],
		NoUpdate	=> 15 * 60,
		Verbose		=> $opt->{debug},
		});
}

my ($encoding, $credits, $ch, $progs) = fetch_channels($conf);

my @alldata;
my $conf_ch;

foreach my $channel_id (@{$conf->{channel}}) {
    if (exists $ch->{$channel_id}) {
        t "\$conf_ch->{$channel_id} = " .$ch->{$channel_id}->{'display-name'}[0][0];
	$conf_ch->{$channel_id} = $ch->{$channel_id};
    }
}

add_channel_icons($ch);

$bar = new XMLTV::ProgressBar({
	name	=> 'parsing listings',
	count	=> scalar(@{ $progs }),
}) if (not $opt->{quiet}) && (not $opt->{debug});

foreach my $program (@{ $progs }) {
    my $prg_chid = $program->{channel};
    if (exists $conf_ch->{$prg_chid}) {
	push @alldata, $program;
    }
    $bar->update() if defined $bar;
}
$bar->finish() if defined $bar;


my %w_args;

if (($opt->{offset} != 0) || ($opt->{days} != -999)) {
	$w_args{offset} = $opt->{offset};
	$w_args{days} = ($opt->{days} == -999) ? 100 : $opt->{days};
	$w_args{cutoff} = '000000';
}

# XML::Writer doesn't use default ouput but STDOUT directly if not specified.
# In case of --output option, select() returns $XMLTV::Options::fd
if (defined $opt->{output}) {
	my $fd = select();		# in case of --output option, this
	$w_args{OUTPUT} = $fd;		# is $XMLTV::Options::fd
}

my $data;

$data->[0] = $encoding;
$data->[1]{'generator-info-name'} = '$Id: tv_grab_ua 29 2010-08-09 16:12:01Z tipok $';
$data->[1]{'generator-info-url'} = 'adm@host';
$data->[2] = $conf_ch;

if ($reformatxmltv) {
	$data->[3] = reformat_programmes(\@alldata);
} else {
	$data->[3] = \@alldata;
}

$bar = new XMLTV::ProgressBar({
	name	=> 'writing XMLTV',
	count	=> 1,
	}) if (not $opt->{quiet}) && (not $opt->{debug});

XMLTV::write_data($data, %w_args);

$bar->update() if defined $bar;
$bar->finish() if defined $bar;

# Signal that something went wrong if there were warnings.
exit(1) if $warnings;

# All data fetched ok.
t 'Exiting without warnings.';
exit(0);

##############################################################################

sub t
{
	my ($message) = @_;
	print STDERR $message . "\n" if $opt->{debug};
}

sub warning
{
	my ($message) = @_;
	print STDERR $message . "\n";
	$warnings++;
}

sub fetch_channels
{
    my ($conf) = @_;
    
    t 'Fetching channels';

    $bar = new XMLTV::ProgressBar({
		name	=> 'downloading XMLTV',
		count	=> 4,
		}) if (not $opt->{quiet}) && (not $opt->{debug});

        
    my $response = $ua->request(GET $conf->{'root-url'}->[0])
	or die 'Failed to fetch ' . $conf->{'root-url'}->[0];

    $bar->update() if defined $bar;

    my $filetype = $response->{"_headers"}{"content-type"};
    my $xmldata;
    if ($filetype eq "application/zip") {
        t "extracting xml data from zipped file";

        my $fake_filehandle = IO::Scalar->new(\$response->content);
        my $zip = Archive::Zip->new();
	$zip->readFromFileHandle($fake_filehandle);
	my @membernames = $zip->membersMatching( '.*\.xml' );
	if (scalar(@membernames) == 0) {
	    @membernames = $zip->membersMatching( '.*\.xmltv' );
	}

	if (scalar(@membernames) == 0) {
	    die "No .xml or .xmltv files found";
	}

	my $data_file = $membernames[0];
        $xmldata = $data_file->contents();
    } elsif ($filetype eq "application/x-gzip"){
        t "extracting xml data from gzipped file";
        
	$xmldata = Compress::Zlib::memGunzip(\$response->content);
    } elsif ($filetype eq "application/xml") {
        $xmldata = \$response->content;
    } else {
	die "Unknown downloaded file type $filetype";
    
    }


    $bar->update() if defined $bar;

    # remove illegal '<desc> </desc>'
    $xmldata =~ s/<desc\s*?(lang=[^>]+)?>\s*?<\/desc>//g;

    # remove illegal '\x08' in "Eesti Televisioon" program content
    $xmldata =~ s/\x08/ /g;

    $bar->update() if defined $bar;

    my $data = XMLTV::parse($xmldata);
    
    $bar->update() if defined $bar;
    $bar->finish() if defined $bar;
    return @$data;
}

sub add_channel_icons ($) {
    my $ch = shift;    
    my %channel_urls;
    
    my $str = GetSupplement( 'tv_grab_ua', '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;
    }
    
    foreach (sort keys %$ch) {
	$ch->{$_}->{icon} = [{ 'src' => $channel_urls{ $_ } }] if defined $channel_urls{ $_ };
    }
}

sub list_channels ($$)
{
	my ($conf, $opt) = @_;

	my $result;
	my %w_args;

	my ($encoding, $credits, $ch, $progs) = fetch_channels($conf);
	add_channel_icons($ch);

	$w_args{encoding} = $encoding;
	$w_args{OUTPUT} = \$result;
	
	my $writer = new XMLTV::Writer(%w_args);
	$writer->start($credits);
	foreach (sort keys %$ch) {
		foreach my $item (@{ $ch->{$_}->{'display-name'} }) {
		    @{ $item }[0] = decode("utf8", @{ $item }[0]);
		}
		$writer->write_channel($ch->{$_});
	}
	$writer->end();
	
	return $result;
}

sub config_stage ($$)
{
	my ($stage, $conf) = @_;

	if ($stage eq 'start') {
		return config_stage_start($stage, $conf);
	} else {
		die "Unknown stage $stage";
	}
}

sub config_stage_start ($$)
{
	my ($stage, $conf) = @_;

	die "Unknown stage $stage" if $stage ne "start";
	my $result;
	
	if (!ask_boolean( "(re)create config?", 0 )) {
	    print STDERR "Config not created\n";
	    exit(0);
	}
	
	my $writer = new XMLTV::Configure::Writer(OUTPUT   => \$result,
	                                          encoding => 'utf-8');
	$writer->start({grabber => 'tv_grab_ua'});
	$writer->write_string({
		id		=> 'root-url',
		title		=> [
				     [ 'Root URL for grabbing data',	'en' ],
				     [ 'Вкажіть URL з якого буде ' .
				       'завантажуватись телепрограма', 'ua' ],
				     [ 'Укажите URL с котороко загружать ' .
				       'телепрограмму', 'ru' ]
				   ],
		description	=> [
				     [ 'This URL describes root directory ' .
				       'where channels file and all ' .
				       'channel data can be found.' .
				       'Try this known URL\'s:' .
				       'http://www.teleguide.info/download/new3/xmltv.xml.gz, ' .
				       'http://izbushka.kiev.ua/xmltv/listing.xml, ' .
				       'http://www.star.poltava.ua/files_tv/xmltv.zip', 'en' ],
				     [ 'Файл з цього URL містить ' .
				       'програму для доступних телеканалів ' .
				       'та їх список.' .
				       'Спробуйте ці, відомі URL:' .
				       'http://www.teleguide.info/download/new3/xmltv.xml.gz, ' .
				       'http://izbushka.kiev.ua/xmltv/listing.xml, ' .
				       'http://www.star.poltava.ua/files_tv/xmltv.zip', 'ua' ],
				     [ 'Файл, загружаемый с этого URL ' .
				       'должен содержать программу и ' .
				       'список доступных каналов. ' .
				       'Попробуйте следующие URL из списка:' .
				       'http://www.teleguide.info/download/new3/xmltv.xml.gz, ' .
				       'http://izbushka.kiev.ua/xmltv/listing.xml, ' .
				       'http://www.star.poltava.ua/files_tv/xmltv.zip', 'ru' ],
          
				   ],
		default		=> $default_root_url,
	});
	$writer->write_string({
		id		=> 'cachedir',
		title		=> [
				     [ 'Directory to store the cache in', 'en' ],
				     [ 'Директорія для зберігання кешу', 'ua' ],
				     [ 'Папка для хранения кеша', 'ru' ]
				   ],
		description	=> [
				     [ 'Please specify where to cache ' .
				       'already downloaded data ',	'en' ],
				     [ 'tv_grab_ua використовує ' .
				       'кешовані файли, які вже загружені ' .
				       'з серверу. Вкажіть, де ці ' .
				       'файли зберігати. ', 'ua' ],
				     [ 'tv_grab_ua использует кеш для ' .
				       'файлов, которые были загрудены и не ' .
				       'требуют обновления. Укажите место, ' .
				       'где хранить кеш. ', 'ru' ]
				   ],
		default		=> $default_cachedir,
	}) if ($usecache);
	$writer->write_string({
		id		=> 'reformat-xmltv',
		title		=> [
				     [ 'Reformat original XMLTV',	'en' ],
				     [ 'Переформатувати оригінальный XMLTV', 'ua' ],
				     [ 'Переформатировать оригинальный XMLTV', 'ru' ]
				   ],
		description	=> [
				     [ 'Original XMLTV data is very geneal ' .
				       'and often inconsistent. This option ' .
				       'enables XMLTV postprocessing and ' .
				       'reformatting in grabber. Update grabber ' .
				       'more often when enabled.',	'en' ],
				     [ 'Оригінальний XMLTV не містить достатньої' .
				       ' інформації про програму. Ця опція ' .
				       'включає додаткову обробку та ' .
				       'переформатування в граббері.', 'ua' ],
				     [ 'Оригинальный XMLTV может содержать ' .
				       'неполную информацию о программе. ' .
				       'Эта опция включает дополнительную ' .
				       'обработку внутри граббера.',	'ru' ],
				   ],
		default		=> $default_reformatxmltv,
	});

	$writer->end('select-channels');

	return $result;
}

sub load_old_config
{
	my ($config_file) = @_;

	t 'Loading old config format';
	my @lines = XMLTV::Config_file::read_lines($config_file);

	my $conf = {};
	$conf->{'root-url'}->[0] = $default_root_url;
	$conf->{'cachedir'}->[0] = $default_cachedir if ($usecache);
	$conf->{'channel'} = [];
	$conf->{'no_channel'} = [];

	foreach my $line (@lines) {
		next unless defined $line;
		my( $command, $param ) = split( /\s+/, $line, 2 );
		if ($command !~ /^(#?)channel/) {
			t 'Illegal config line "' . $command . '"';
			next;
		}
		my $status = $1;
		my $oldchan = $param;
		if ($status eq '') {
			push @{$conf->{'channel'}}, "$oldchan";
			t 'Converting ' . $line . ' -> ' . "channel=$oldchan";
		} else {
			push @{$conf->{'no_channel'}}, "$oldchan";
			t 'Converting ' . $line . ' -> ' . "channel!$oldchan";
		}
	}
	return $conf;
}

sub get_default_cachedir
{
	my $winhome = $ENV{HOMEDRIVE} . $ENV{HOMEPATH}
		if defined($ENV{HOMEDRIVE}) and defined($ENV{HOMEPATH});

	my $home = $ENV{HOME} || $winhome || ".";

	return "$home/.xmltv/cache";
}

sub init_cachedir
{
	my ($path) = @_;
	if (not -d $path) {
		mkpath($path) or die "Failed to create cache-directory $path: $@";
	}
}


##############################################################################
# Optional functions to parse, reformat and extract useful information
# from simple XMLTV data
##############################################################################

sub setcategory ($$) { #Try to guess type of the programme
    my ($pr_name, $pr_lang) = @_;

    my %cat = ( '(Х\/ф|Худ\.фильм|Художественный фильм|Остросюжетный|Комедия|Мелодрама|Детектив|Драма|Фантастика|Триллер|Боевик|Ужасов|Ужастик|Повесть|Сказка|Кинофильм|Телефильм)' => 'Художественный фильм',
                '(Т\/с|Телесериал|Сериал)' => 'Телесериал',
	        '(М\/с|Мультсериал|Мультипликационный сериал)' => 'Мультипликационный сериал',
                '(М\/ф|Мультфильм|Мультипликационный фильм)' => 'Мультфильм',
                '(Д\/с|Док\.сериал|Документальный сериал)' => 'Документальный сериал',
                '(Д\/ф|Док\.фильм|Документальный фильм|Кинофильм|Телефильм)' => 'Документальный фильм',
                '(Фильм-спектакль|Спектакль)' => 'Спектакль',
                'Концерт' => 'Концерт',
                'Комедия' => 'Комедия',
                'Мелодрама' => 'Мелодрама',
    	        'Триллер' => 'Триллер',
                'Боевик' => 'Боевик',
                '(Ужасов|Ужастик)' => 'Фильм ужасов',
                '(новостей|Новини|^Репортер$|^Итоги$|24 часа|Вісті|Новости|Вести|Время|Факты)' => 'Новости',
                '(^Бокс|спорт|Спортивн|Хоккей|НХЛ|NHL|Баскетбол|НБА|NBA|Теннис|Tennis|волейбол|Чемпионат|Гран-При|Формула-1|Футбол)' => 'Спорт'
                #       'Шоу'
            );

    
    #Х/ф "Тень сомнения". (3 категория).
    my $rating;
    if ( $pr_name =~ m/\s+\((\d{1}) категория\)\.$/i ) {
	    $rating = $1;
    }
    
    my @pr_cat;
    foreach (sort (keys %cat)) {
	if ( $pr_name =~ m/$_/i ) {
	    push @pr_cat, $cat{$_};
	}
    }
    
    return \@pr_cat, $rating;
}


sub parseCountryYear ($$) {
    my ($desc, $lang) = @_;

    my $country_str;
    my @countries;
    my $year;

    #"Дюба-дюба". (Россия, 1992г.)
    #"Беглец". (США, 1993г.)
    #"Маленькая Вера". (к/ст им. М. Горького, 1988г.)
    if ($desc =~ /\s+\((.*?), (\d{4})г\.\)$/) {
	$country_str = $1;
	$year = $2;
    }
    
    if(defined $country_str){
	@countries = split(" - ", $country_str);
    }
    
    return (\@countries, $year);
}

sub parseDesc ($$) {
    my ($desc, $lang) = @_;
    my @actors;
    my $actors_str;
    my $director;
    my $producer;

    # TEXT SAMPLES:
    #Или почти все. Режиссер: Дмитрий Светозаров В ролях: Андрей Толубеев, Андрей Краско, Владимир Яковлев, Михаил Пореченков Продюсер: Александр Капица"
    #-------------------
    #... Звезды кино: Дмитрий Гольдман, Светлана Кузнецова, Юлия Пожидаева
    #-------------------
    #...рама. Маленькая Вера - отвязлизма?
    #Режиссер: В. Пичул.
    #В ролях: Н. Негода, А. Соколов, Ю. Назаров, Л. Зайцева, А. Алексеев-Негреба, А. Табакова.
    #-------------------
    #.... Режиссер: Брайан Де Пальма. В ролях: Мелани Гриффит, Дебора Шелтон, Деннис Франц, Ги Бойд, Крейг Уоссон, Грегг Хенри, Гай Бойд, Ребекка Стэнли и др. Актер Джейк сн
    
    if ($desc =~ /\s+Продюсер: (.*?)\.?$/) {
	$producer = $1;
    }

    if (defined $producer && $desc =~ /\s+(В ролях:\s|Звезды кино:\s)(.*?)( и др)?\.?\s+Продюсер:\s/) {
	    $actors_str = $2;
    } elsif ($desc =~ /\s+(В ролях:\s|Звезды кино:\s)(.*?) и др\./) {
	    $actors_str = $2;
    } elsif ($desc =~ /\s+(В ролях:\s|Звезды кино:\s)(.*?)\.?$/) {
	    $actors_str = $2;
    }

    if (defined $actors_str && $desc =~ /\s+Режиссер:\s+(.*?)\.?\s+(В ролях:\s|Звезды кино:\s)/) {
	    $director = $1;
    } elsif (defined $producer && $desc =~ /\s+Режиссер:\s+(.*?)\.?\s+Продюсер:\s+/) {
	    $director = $1;
    } elsif ($desc =~ /\s+Режиссер:\s+(.*?)\.?$/){
	    $director = $1;
    }

    @actors = split(", ", $actors_str) if defined $actors_str;
    return ($director, \@actors, $producer);
}

sub reformat_programmes (@)
{
	my ($programmes) = @_;

	$bar = new XMLTV::ProgressBar({
		name	=> 'reformatting XMLTV',
		count	=> scalar(@{$programmes}),
		}) if (not $opt->{quiet}) && (not $opt->{debug});


	my @newprogrammes;

	t 'Parsing programme\'s titles.';

	foreach (@$programmes) {
		my @titles;
		my @categories;
		my @country;
		my @age_rating;
		my $date;
		my $director;
		my $actors;
		my $producer;
		
		#tryin to find category
		foreach (@{$_->{'title'}}) {
			my ($desc, $lang) = @$_;
			my ($cat_ptr, $age_r_val) = setcategory($desc, $lang);
			foreach (@{ $cat_ptr }) {
				push @categories, [ $_, $lang];
			}
			
			if(defined $age_r_val) {
				#TV-G - green " (1 категория)."
				#TV-PG - yellow " (2 категория)."
				#TV-MA - red " (3 категория)."
				if ($age_r_val == 1){
					push @age_rating, [ "TV-G", "VCHIP" ];
				} elsif ($age_r_val == 2){
					push @age_rating, [ "TV-PG", "VCHIP" ];
				} elsif ($age_r_val == 3){
					push @age_rating, [ "TV-MA", "VCHIP" ];
				}
			}
		}

		#find country and year
		foreach (@{$_->{'sub-title'}}) {
		    my ($desc, $lang) = @$_;
		    my $countries;
		    ($countries, $date) = parseCountryYear($desc, $lang);
		    foreach (@{ $countries }) {
			push @country, [ $_, $lang];
		    }
		}
		
		# it is not needed to check $_->{'desc'} existence
		# desc added only for movies
		foreach (@{$_->{'desc'}}) {
		    my ($desc, $lang) = @$_;
		    $desc =~ s/^ //g;
		    $desc =~ s/ $//g;
		    $desc =~ s/[\r\n]/ /g;
		    
		    ($director, $actors, $producer) = parseDesc($desc, $lang);
		    
		    #if category is still empty, add movie description
		    if (!scalar(@categories)) {
		        push @categories, [ 'Художественный фильм', $lang];
		    }
		}
		
		$_->{'rating'} = \@age_rating if @age_rating;
		$_->{'title'} = \@titles if @titles;
		$_->{'category'} = \@categories if @categories;
		$_->{'country'} = \@country if @country;
		$_->{'date'} = $date if (defined $date);
		
		$_->{credits}->{actor} = $actors if ($actors && scalar( @{$actors} ));
		push( @{$_->{credits}->{producer}}, $producer)  if $producer;
		push( @{$_->{credits}->{director}}, $director)  if $director;

		push @newprogrammes, $_;
		$bar->update() if defined $bar;
	}
	$bar->finish() if defined $bar;

	return \@newprogrammes;
}