#!/usr/bin/perl -w
#
# FIXME -T should be on but Date::Manip is currently broken under
# taint mode.
#
# tv_pick.cgi
#
# Web page for the user to pick which programmes he wants to watch.
#
# The idea is to get TV listings for the next few days and store them
# as XML in the file $LISTINGS.  Then 'run' this program (install it
# as a CGI script and view it in a web browser, or use Lynx's
# CGI emulation) to pick which programmes you want to watch.
#
# Your preferences will be stored in the file $PREFS_FILE, and if a
# programme title is listed in there, you won't be asked about it.  So
# although you may get hundreds of programmes to wade through the
# first time, the second time round most of them will be listed in the
# preferences file and you'll be asked only about new ones.
#
# So to use this CGI script to plan your TV viewing, here's what
# you'll typically need to do:
#
# - Get listings for the next few days using the appropriate backend,
# for example if you want British listings do:
#
# % tv_grab_uk_rt >tv.xml
#
# - Optionally, filter these listings to remove programmes which have
# already been broadcast:
#
# % filter_shown <tv.xml >tmp; mv tmp tv.xml
#
# - Install this file as a CGI script, and make sure that the
# Configuration section below points to the correct filenames.
#
# - View the page from a web browser, and choose your preferences for
# the shows listed.  If you choose 'never' or 'always' as your
# preference, you won't be asked about that programme ever again, so
# 'no' or 'yes' would be a more cautious choice, since that will mean
# you are asked again next time.
#
# - Submit the form and go on to the next page.  Repeat until you have
# got to the end of the listings ('Finished').  You can now download
# an XMLTV file with the programmes you want to watch.  You might want
# to print out this XML file:
#
# % tv_to_latex <towatch.xml >towatch.tex
# % latex towatch.tex
# % dvips towatch.dvi
# % lpr towatch.ps
#
# - Also look at $PREFS_FILE to see all the programmes you have
# killfiled (including those you 'always' want to see without
# prompting).  This list can only get bigger, there's currently no way
# to unkill a programme except by editing the file by hand.
#
# The first time you do this, you might find that you accidentally say
# 'never' to a programme you wanted to watch.  So it would be best to
# print out a full copy of the TV listings from tv.xml and
# double-check that everything you want is listed in towatch.xml.
# Remember, once you've said 'never' to watch a programme, it becomes
# as if it does not exist at all!
#
# -- Ed Avis, ed@membled.com
#

# If taint checking were turned on (which used to be the case, and is
# planned for future versions) we'd need these lines.
#
# Keep the taint checking happy (the Cwd module runs pwd(1))
#$ENV{PATH} = '/bin:/usr/bin';
#
# The PERL5LIB environment variable is ignored, so you might need
#use lib '.';

use strict;
use XMLTV qw<best_name write_data>;
use Fcntl ':flock';
use Date::Manip;
use File::Copy;

# Use Log::TraceMessages if installed.
BEGIN {
    eval { require Log::TraceMessages };
    if ($@) {
	*t = sub {};
	*d = sub { '' };
    }
    else {
	*t = \&Log::TraceMessages::t;
	*d = \&Log::TraceMessages::d;
	Log::TraceMessages::check_argv();
	$Log::TraceMessages::CGI = 1;
    }
}

sub ordinate {
    for ($_[0]) {
	/1$/ && return $_ . 'st';
	/2$/ && return $_ . 'nd';
	/3$/ && return $_ . 'rd';
	return $_ . 'th';
    }
}

# Load CGI last of all so that harmless failures in loading
# not-really-needed modules don't produce errors.
#
use CGI qw<:standard -newstyle_urls>;
use CGI::Carp qw<fatalsToBrowser carpout>; BEGIN { carpout(\*STDOUT) }

########
# Configuration

# Maximum number of programmes to display in a single page.
my $CHUNK_SIZE = 100;

# Input file containing all TV listings.
my $LISTINGS = 'tv.xml';

# Scratch file for storage between requests (this should really be
# done with form data or cookies).
#
my $TOWATCH = 'towatch.tmp';

# Final output file
my $OUTPUT = 'towatch.xml';

# Input file containing preferences (killfiled programmes, etc).
my $PREFS_FILE = 'tvprefs';

# Preferred languages - if information is available in several
# languages, the ones in this list are used if possible.  List in
# order of preference.  Passed to best_name().
#
# FIXME should find this out from HTTP headers.
#
my @PREF_LANGS;

# Hopefully the environment variable $LANG will be set
my $el = $ENV{LANG};
if (defined $el and $el =~ /\S/) {
    $el =~ s/\..+$//; # remove character set
    @PREF_LANGS = ($el);
}
else {
    @PREF_LANGS = ('en'); # change for your language - or just set $LANG
}

########
# End of configuration

# Prototype declarations
sub store_prefs($$);
sub display_form($);
sub print_date_for($;$);
sub clumpidx_to_english($);
sub download_xml();

# Load data into globals $data and @programmes.
my $data = XMLTV::parsefile($LISTINGS);
my $encoding = $data->[0];
my @programmes = @{$data->[3]};

if (url_param('download')) {
    download_xml();
    exit();
}

# Newer versions of CGI.pm have support for <meta http-equiv> stuff.
# But for the moment, we'll keep compatibility with older ones.
#
# We assume the encoding used for listings data is a superset of
# ASCII.
#
print header({ expires => 'now',
	       'Content-Type' => "text/html; charset=$encoding" });

print <<END
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
	      "http://www.w3.org/TR/html4/loose.dtd">
<html>
  <head>
    <meta http-equiv="Content-Type" content="text/html; charset=$encoding">
    <title>TV listings</title>
    <!-- I should be grateful if someone could tell me how to get
      left-aligned text and right-aligned text *on the same line*.
      I am trying to do that with 'category' but I cannot make it
      work. -->
    <style type="text/css"> <!--
        .job { font-weight: bolder }
        .category { float: right; font-style: italic }
        .clumpidx { font-weight: bolder }
    --> </style>
  </head>
END
;

# %wanted
#
# Does the user wish to watch a programme?
#
# Maps title to:
#   undef     -  this programme is not known
#   'never'   -  no, the user never watches this programme
#   'no'      -  probably not, but ask
#   'yes'     -  probably, but ask
#   'always'  -  yes, the user always watches this programme
#
# Read in from the file $PREFS_FILE.
#
my %wanted = ();

# Open for 'appending' - but really we just want to create an empty
# file if needed.
#
open(PREFS, "+>>$PREFS_FILE") or die "cannot open $PREFS_FILE: $!";
flock(PREFS, LOCK_SH);
seek PREFS, 0, 0;
while (<PREFS>) {
    s/\#.*//; s/^\s+//; s/\s+$//;
    next if $_ eq '';
#    t("got line from $PREFS_FILE: " . d($_));
    if (/^(never|no|yes|always): (.+)$/) {
	my ($pref, $prog) = ($1, $2);
	$wanted{$prog} = $pref;
    }
    else { die "$PREFS_FILE:$.: bad line (remnant is $_)\n" }
}
#t('\%wanted=' . d(\%wanted));

my ($skip, $next) = (url_param('skip'), url_param('next'));
foreach ($skip, $next) {
    die "bad URL parameter $_" if defined and tr/0-9//c;
}
#t('$skip=' . d($skip) . ', $next=',  d($next));

if (defined $skip and defined $next) {
    # Must be that the user has submitted some preferences.
    store_prefs($skip, $next);
}
elsif (defined $skip and not defined $next) {
    # This is one of the form pages, skipping some programmes already
    # seen.
    #
    close PREFS;
    display_form($skip);
}
elsif (not defined $skip and not defined $next) {
    # Initial page, corresponding to skip=0.
    if (-e $TOWATCH) {
	if (-M _ < -M $LISTINGS) {
	    print p <<END
The temporary file $TOWATCH already exists and is newer than $LISTINGS -
refusing to overwrite it.
END
  ;
	    print end_html();
	    exit();
	}
	else {
	    unlink $TOWATCH or die "cannot unlink $TOWATCH: $!";
	}
    }

    # Should really have file locking here.
    open(TOWATCH, ">>$TOWATCH")
      or die "cannot append to $TOWATCH: $!";
    print TOWATCH <<END
# 'towatch.tmp' file
#
# This file was created by $0 and contains the numbers of programmes
# that the user has chosen to watch, either by giving a preference of
# 'yes' or 'always', or because the stored preference for that
# programme was 'always'.
#
# The format is 'filename/number' on each line.
#
# When the user has finished picking programmes, $0 should reread this
# file and make an XML file to download.
#

END
  ;
    close TOWATCH;

    close PREFS;
    display_form(0);
}
else { die 'bad URL parameters' }


# store_prefs()
#
# Store the user's preferences for $CHUNK_SIZE programmes starting
# from 'skip'.
#
# Parameters:
#   number of programmes to skip from the beginning of @programmes
#   the new value of 'skip' for the next page in the list
#
sub store_prefs($$) {
    die 'usage: store_prefs(skip, next)' if @_ != 2;
    my ($skip, $next) = @_;

    for (my $i = 0; $i < @programmes; $i++) {
	my $val = param("prog$i");
	if (defined $val) {
	    # Check that this programme really did appear in the
	    # previous page.
	    #
	    die "bad programme number $i for skip $skip, next $next"
	      unless $skip <= $i and $i < $next;

	    my $title = best_name(\@PREF_LANGS, $programmes[$i]->{title})->[0];
	    print "$title: $val<br>\n";

	    my $found = 0;
	    foreach (qw[never no yes always]) {
		if ($val eq $_) {
		    $wanted{$title} = $val;
		    $found = 1;
		    last;
		}
	    }
	    die "bad preference '$val' for prog$i" unless $found;
	}
    }

    # Update $PREFS_FILE with preferences.  'yes' or 'no' preferences
    # are still worth storing because they let us pick the default
    # radio button next time.
    #
    copy($PREFS_FILE, "$PREFS_FILE.old")
      or die "cannot copy $PREFS_FILE to $PREFS_FILE.old: $!";
    flock(PREFS, LOCK_EX);
    truncate PREFS, 0 or die "cannot truncate $PREFS_FILE: $!";
    print PREFS <<END
# 'prefs' file
#
# This file contains stored preferences for programme titles, so that
# the user need never be bothered about these shows again.  It's like
# a killfile.  But as well as saying you 'never' want to watch 'That's
# Esther', you can have a preference of 'always' watching some
# programmes, without being asked.
#
# A 'yes' or 'no' preference will change the default choice, but the
# user will be asked again to check.
#
# Generated by $0.
#

END
  ;
    foreach (sort keys %wanted) {
	my $pref = $wanted{$_};
	print PREFS "$pref: $_\n";
    }

    print p(strong("Preferences saved in $PREFS_FILE"));

    # Write out the list of programmes that the user wants to watch
    # this week.  For the time being, we do this as a list of numbers
    # that must be processed later.
    #
    open(TOWATCH, ">>$TOWATCH") or die "cannot append to $TOWATCH: $!";
    flock(TOWATCH, LOCK_EX);
    for (my $i = $skip; $i < $next; $i++) {
	my $val = param("prog$i");
	my $title = best_name(\@PREF_LANGS, $programmes[$i]->{title})->[0];
	if ((defined $wanted{$title} and $wanted{$title} eq 'always')
            or (defined $val and $val eq 'yes') )
        {
	    print TOWATCH "$LISTINGS/$i\n";
	    print br(), "Planning to watch $title\n";
	}
    }
    close TOWATCH;
    print p(strong("List of programme numbers to watch added to $TOWATCH"));

    my $url = url(-relative => 1);
    if ($next >= @programmes) {
	write_output();
	print p <<END
Finished choosing listings.  You can now download
<a href="$OUTPUT">an XML file of the programmes to watch</a>.
END
  ;
    }
    else {
	print a({ href => "$url?skip=$next" }, "Next page");
    }
    print end_html();
    exit();
}


# display_form()
#
# Parameters:
#   number of programmes to skip at start of @programmes
#
sub display_form($) {
    die 'usage: display_form(skip)' if @_ != 1;
    my $skip = shift;

    my @nums_to_show = ();
    my $i;
    for ($i = $skip;
	 $i < @programmes and @nums_to_show < $CHUNK_SIZE;
	 $i++ )
    {
	my $prog = $programmes[$i];
	my $title = best_name(\@PREF_LANGS, $prog->{title})->[0];
	for ($wanted{$title}) {
	    if (not defined or $_ eq 'no' or $_ eq 'yes') {
		push @nums_to_show, $i;
	    }
	    elsif ($_ eq 'never' or $_ eq 'always') {
		# Don't bother the user with this programme
	    }
	    else { die }
	}
    }

    # Now actually print the things, we had to leave it until now
    # because we didn't know what the new 'skip' would be.
    #
    print start_form(-action => url(-relative => 1) .
		     "?skip=$skip;next=$i");

    print '<table border="1">', "\n";
    my $prev;
    foreach my $n (@nums_to_show) {
	my %h = %{$programmes[$n]};
	my ($start, $stop, $channel) = @h{qw(start stop channel)};
	$stop = '' if not defined $stop;
	my $title     = best_name(\@PREF_LANGS, $h{title})->[0];
	my $display_title = $title;
	$display_title .= " ($h{date})" if defined $h{date};
	my $category  = best_name(\@PREF_LANGS, $h{category})->[0]  if $h{category};
	my $sub_title = best_name(\@PREF_LANGS, $h{'sub-title'})->[0] if $h{'sub-title'};
	my $desc      = best_name(\@PREF_LANGS, $h{desc})->[0]      if $h{desc};

	if (defined $prev) {
	    print_date_for(\%h, $prev);
	}
	else {
	    print_date_for(\%h);
	}

	print "<tr>\n";
	print "<td>\n";
	print "<strong>$display_title</strong>\n";
	print "<span style='category'><i>", ucfirst($category),
	      "</i></span>\n"
		if defined $category;
	print "<br><em>$sub_title</em>\n" if defined $sub_title;
	print "<p>\n$desc\n</p>\n" if defined $desc;
	if ($h{credits}) {
	    # XMLTV.pm returns a hash mapping job to list of people.
	    our %credits; local *credits = $h{credits};
	    print "<table class='credits'>\n";
	    foreach (sort keys %credits) {
		print '<tr>';
		print td({ class => 'job' }, ucfirst($_));
		print join('</tr><tr><td></td>',
			   map { td({ class => 'person' }, $_) }
			   @{$credits{$_}} );
		print "</tr>\n";
	    }
	    print "</table>\n";
	}

	if (defined $h{clumpidx}) {
	    print "<span class='clumpidx'>",
	    clumpidx_to_english($h{clumpidx}), "</span><br>\n";
	}
	t d \%h;
	print "</td>\n";

	my $default;
	for ($wanted{$title}) {
	    if (not defined) {
		$default = 'never'; # Pessmistic!
	    }
	    elsif ($_ eq 'yes' or $_ eq 'no') {
		$default = $_;
	    }
	    else {
		die "bad pref for $title: $wanted{$title}";
	    }
	}

	foreach (qw<never no yes always>) {
	    print "<td>\n";
	    my $checked = ($_ eq $default) ? 'checked' : '';
	    print qq[<input type="radio" name="prog$n" $checked value="$_">$_</input>\n];
	    print "</td>\n";
	}
	print "</tr>\n";
	$prev = \%h;
    }

    print "</table>\n";
    print submit();
    print end_form();
    print end_html();
}


# print_date_for()
#
# Print the date for a programme as part of the form, so that the
# reader will have some idea of when the programmes will be shown.
#
# Printing the date ends the current table, prints the date, and then
# starts a new table.  But it won't happen unless it is needed, ie the
# date has changed since the previous programme.
#
# Parameters:
#   (ref to) programme to print
#   (optional) (ref to) previous programme
#
# If the previous programme is not given, the date will always be
# printed.
#
# Printing the date also (at least ATM) ends the current HTML table
# and begins a new one after the date.
#
sub print_date_for($;$) {
#    local $Log::TraceMessages::On = 0;
    die 'usage: print_date_for(programme, [prev programme])'
      unless 1 <= @_ and @_ < 3;
    my ($prog, $prev) = @_;
    t('$prog=' . d($prog));
    t('$prev=' . d($prev));

    my $DAY_FMT = '%A'; # roughly as for date(1)

    my $day = UnixDate($prog->{start}, $DAY_FMT);
    my $prev_day = defined $prev ? UnixDate($prev->{start}, $DAY_FMT) : undef;
    t('$day=' . d($day));
    t('$prev_day=' . d($prev_day));

    if ((not defined $prev_day) or ($day ne $prev_day)) {
	print "</table>\n";
	print h1($day);
	print '<table border="1">', "\n";
    }
}


# clumpidx_to_english()
#
# Convert a series-episode-part number like '2/3 . 4/10 . 0/2' to an
# English description like '3rd series of 3; 5th episode of 10; 1st
# part of 2'.
#
sub clumpidx_to_english($) {
    local $_ = shift;
    s/\s+//g;
    my @bits = split /\./;
    unshift @bits, undef until @bits >= 3;
    my ($series, $episode, $part) = @bits;

    sub of($$) {
	my $name = shift;
	local $_ = shift;
	if (m!^(\d+)/(\d+)$!) {
	    return ordinate($1 + 1) . " $name of $2";
	}
	elsif (m!^\d+$!) {
	    return ordinate($_ + 1);
	}
	else {
	    die "bad number-of-number $_";
	}
    }

    my @r;
    push @r, of('series', $series) if defined $series;
    push @r, of('episode', $part) if defined $episode;
    push @r, of('part', $part) if defined $part;

    return join('; ', @r);
}


# write_output()
#
# After all the programmes have been picked, convert the 'towatch'
# file (which is really just a list of numbers) to an XML document for
# the user to download.
#
sub write_output() {
    die 'usage: write_output()' if @_;

    # Find programme numbers to keep
    my %nums;
    open(TOWATCH, $TOWATCH) or die "cannot open $TOWATCH: $!";
    while (<TOWATCH>) {
	s/\#.*//; s/^\s*//; s/\s*$//;
	next if $_ eq '';
	m!^\Q$LISTINGS\E/(\d+)$! or die "$TOWATCH:$.: bad line $_";
	$nums{$1}++ && die "$TOWATCH:$.: already seen number $1";
    }

    # We read the original XML file and weed out <programme> elements.
    my @new_programmes;
    for (my $i = 0; $i < @programmes; $i++) {
	push @new_programmes, $programmes[$i] if $nums{$i};
    }

    my $output = new IO::File(">$OUTPUT");
    die "cannot write to $OUTPUT" if not $output;
    XMLTV::write_data([ $data->[0], $data->[1], $data->[2], \@new_programmes ],
		     OUTPUT => $output);
}