tv_pick

#!/usr/bin/perl
use warnings;
use strict;
use File::Slurp;
use Date::Manip;
use HTML::Entities;
use Glib qw<TRUE FALSE>;
use Gtk2 '-init';
use Log::TraceMessages qw(t d); Log::TraceMessages::check_argv();
use XMLTV qw<best_name write_data>;

# Use Lingua::EN::Numbers::Ordinate if possible, else homebrew.
sub my_ordinate {
    for ($_[0]) {
	/1$/ && return $_ . 'st';
	/2$/ && return $_ . 'nd';
	/3$/ && return $_ . 'rd';
	return $_ . 'th';
    }
}
BEGIN {
    eval { require Lingua::EN::Numbers::Ordinate };
    if ($@) { *ordinate = \&my_ordinate }
    else { *ordinate = \&Lingua::EN::Numbers::Ordinate::ordinate }
}

# 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().
#
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
}

# This callback quits the program
sub delete_event {
    Gtk2->main_quit;
    return FALSE;
}

# Create a new window
my $window = Gtk2::Window->new('toplevel');

# Set the window title
$window->set_title("Table");

# Set a handler for delete_event that immediately exits GTK.
$window->signal_connect(delete_event => \&delete_event);

# Sets the border width of the window.
$window->set_border_width(20);

my $vbox = new Gtk2::VBox;
$window->add($vbox);
show $vbox;

my $scrolled_window = new Gtk2::ScrolledWindow;
$scrolled_window->set_policy('never', 'automatic');
$vbox->add($scrolled_window);
show $scrolled_window;

my @choices = qw(never no yes always);

# 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;
    return undef if not defined;
    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);
}

sub get_title {
    my %h = %{shift()};
    return best_name(\@PREF_LANGS, $h{title})->[0];
}
sub get_full_details {
    my %h = %{shift()};
    my $title     = get_title \%h;
    my $date      = $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};
	
    # Ignore date for now.

    my $credits = '';
    if ($h{credits}) {
	foreach (sort keys %{$h{credits}}) {
	    my @v = @{$h{credits}->{$_}};
	    $credits .= "$_: @v";
	}
    }
	
    my $clump = clumpidx_to_english($h{clumpidx});

    my @stuff = ([ $title, 'b' ],
		 [ $date ],
		 [ $category ],
		 [ $sub_title, 'i' ],
		 [ $desc ],
		 [ $credits, 'i' ],
		 [ $clump ],
	);
    my @bits;
    foreach (@stuff) {
	my ($text, $style) = @$_;
	next if not defined $text;
	$text = encode_entities($text, '<>&"');
	if (defined $style) {
	    die "bad style $style" if $style !~ /\A[a-z]+\z/;
	    $text = "<$style>$text</$style>";
	}
	push @bits, $text;
    }
    return join('. ', @bits);
}

my ($listings_data, $prefs_data);

sub get_pref {
    my $p = shift;
    die if not defined $p;
    my $title = get_title $p;
    return $prefs_data->{$title};
}

sub exclude_programme {
    my $pref = get_pref shift;
    return 0 if not defined $pref;
    return 1 if $pref eq 'always';
    return 1 if $pref eq 'never';
    return 0;
}

sub keep_same_title_together {
    my @titles = map { get_title $_ } @_;
    my %by_title;
    foreach my $i (0 .. $#_) {
	push @{$by_title{$titles[$i]}}, $_[$i];
    }
    my @r;
    foreach my $i (0 .. $#_) {
	my $title = $titles[$i];
	for ($by_title{$title}) {
	    next if not defined;
	    push @r, @$_;
	    undef $_;
	}
    }
    die if @r != @_;
    return @r;
}

my @buttons;
my @labels;
my @programmes_shown_in_table;
our $doing_magic = 0;
sub populate_window {
    return if not $listings_data;
    return if not $prefs_data;

    my $encoding = $listings_data->[0];
    @programmes_shown_in_table
      = keep_same_title_together
	grep { not exclude_programme $_ }
	  @{$listings_data->[3]};

    my $num_desc_cols = 2;
    my $num_rows = scalar @programmes_shown_in_table;
    my $num_cols = $num_desc_cols + scalar @choices;
    my $table = Gtk2::Table->new($num_rows, $num_cols);
    $scrolled_window->add_with_viewport($table);
    show $table;

    my %first_programme_with_title;
    my %buttons_for_title;
    foreach my $row (0 .. $num_rows - 1) {
	my $programme = $programmes_shown_in_table[$row];
	my $title = get_title $programme;
	for ($first_programme_with_title{$title}) {
	    $_ = $programme if not defined;
	}
	my $skip_always_and_never
	  = $programme ne $first_programme_with_title{$title};

	my $label = new Gtk2::Label();
	$label->set_markup(get_full_details $programme);
	$label->set_justify('left');
	$label->set_line_wrap(TRUE);
	$label->set(xalign => 0);
	$table->attach_defaults($label, 0, 1, $row, $row + 1);
	show $label;
	$labels[$row] = $label;

	my $prev_button;
	my $col = $num_desc_cols;
	my $pref = get_pref $programme;
	$pref = 'never' if not defined $pref;
	my %buttons_by_choice;
	foreach my $choice (@choices) {
	    my $button;
	    my $show = 1;
	    $show = 0 if $skip_always_and_never
	      and ($choice eq 'always' or $choice eq 'never');

	    if ($show) {
		if (not $prev_button) {
		    $button = Gtk2::RadioButton->new_with_label(undef, $choice);
		}
		else {
		    $button = Gtk2::RadioButton->new_with_label_from_widget($prev_button, $choice);
		}

		if ($button) {
		    $table->attach_defaults($button, $col, $col + 1, $row, $row + 1);
		    $prev_button = $button;
		    $button->set_active(1) if $pref eq $choice;
		    show $button;
		    $buttons_by_choice{$choice} = $button;
		}
	    }
	    push @{$buttons[$row]}, $button;
	    ++$col;
	}
	push @{$buttons_for_title{$title}}, \%buttons_by_choice;
    }

    # Now set up interaction between different programmes with the
    # same title.
    #
    foreach my $title (sort keys %buttons_for_title) {
	my @rows = @{$buttons_for_title{$title}};
	next if @rows == 1;
	die if not @rows;
	my $first_row = shift @rows;

	my @noes = map { $_->{no} } @rows;
	die if grep { not defined } @noes;
	my @yeses = map { $_->{yes} } @rows;
	die if grep { not defined } @yeses;
	
	$first_row->{never}->signal_connect(clicked => sub {
						return if $doing_magic;
						local $doing_magic = 1;
						$_->set_active(1) for @noes;
					    });
	$first_row->{always}->signal_connect(clicked => sub {
						 return if $doing_magic;
						 local $doing_magic = 1;
						 $_->set_active(1) for @yeses;
					     });
	foreach (@noes) {
	    $_->signal_connect(clicked => sub {
				   return if $doing_magic;
				   local $doing_magic = 1;
				   $first_row->{yes}->set_active(1)
				     if $first_row->{always}->get_active
				 });
	}
	foreach (@yeses) {
	    $_->signal_connect(clicked => sub {
				   return if $doing_magic;
				   local $doing_magic = 1;
				   $first_row->{no}->set_active(1)
				     if $first_row->{never}->get_active
				 });
	}
    }
}

sub parse_prefs_file {
    my $prefs_file = shift;
    my %wanted;
    foreach (read_file $prefs_file) {
	s/\#.*//; s/^\s+//; s/\s+$//;
	next if not length;
	if (/^(never|no|yes|always): (.+)$/) {
	    my ($pref, $prog) = ($1, $2);

	    # For some reason my prefs file has duplicate entries: be
	    # conservative.
	    #
	    $wanted{$prog} = unify_prefs($pref, $wanted{$prog});
	}
	else { die "$prefs_file: bad line $_" }
    }
    return \%wanted;
}

if (@ARGV) {
    die "usage: $0\nor $0 listings-file prefs-file\n"
      if @ARGV != 2;
    my ($listings_file, $prefs_file) = @ARGV;
    $listings_data = XMLTV::parsefile $listings_file;
    $prefs_data = parse_prefs_file $prefs_file;
    populate_window;
}

sub show_details {
    my $row = shift;
    my $label = $labels[$row];
    my $programme = $listings_data->[3]->[$row];
    $label->set_label(get_full_details $programme);
}

sub unify_prefs {
    die if @_ != 2;
    my ($a, $b) = @_;
    return $a if not defined $b;
    return $b if not defined $a;
    # Pick the safest alternative.
    foreach (qw(yes no always never)) {
	return $_ if $a eq $_ or $b eq $_;
    }
    die;
}

sub get_filename {
    my ($action, $desc, $callback) = @_;
    die "bad action '$action'" if $action ne 'open' and $action ne 'save';
    my $chooser = new Gtk2::FileChooserDialog(ucfirst($action) . " $desc file",
					      $window,
					      'GTK_FILE_CHOOSER_ACTION_' . uc($action),
					      'gtk-cancel' => 'GTK_RESPONSE_CANCEL',
					      "gtk-$action" => 'GTK_RESPONSE_OK');
    my $result = run $chooser;
    t 'chooser gave result: ' . d $result;
    my $filename;
    $filename = $chooser->get_filename if $result eq 'ok';
    destroy $chooser;
    t 'returning filename: ' . d $filename;
    return $filename;
}

sub eval_with_message {
    my ($code, $desc) = @_;
    my $ok = eval {
	t 'running code inside eval block';
	$code->();
	t 'code completed';
	1;
    };
    return 1 if $ok;
    t 'eval failed';

    my $err = $@ // 'unknown error';
    die $err if not defined $window;
    my $dialog = new Gtk2::MessageDialog($window,
					 'destroy-with-parent',
					 'error',
					 'cancel',
					 "$desc: $err");
    $dialog->$_ for qw(show run destroy);
    return 0;
}

sub show_load_dialog {
    my ($file_desc, $parser, $dest_ref) = @_;
    my $file = get_filename 'open', ucfirst($file_desc);
    return if not defined $file;
    my $got;
    my $ok = eval_with_message sub { $got = $parser->($file) }, "Loading $file_desc file";
    return 0 if not $ok;
    $$dest_ref = $got;
    populate_window;
    return 1;
}

my $hbox;
sub add_load_button {
    my ($file_desc, $parser, $dest_ref) = @_;
    return if $$dest_ref; # already loaded
    if (not $hbox) {
	$hbox = new Gtk2::HBox;
	$vbox->add($hbox);
	show $hbox;
    }
    my $button = new Gtk2::Button("Load $file_desc");
    $button->signal_connect(clicked =>
			sub { show_load_dialog $file_desc, $parser, $dest_ref });
    $hbox->add($button);
    show $button;
}

add_load_button 'listings', \&XMLTV::parsefile, \$listings_data;
add_load_button 'preferences', \&parse_prefs_file, \$prefs_data;

sub find_active_choice {
    my $row_num = shift;
    my @row = @{$buttons[$row_num]};
    die if @row != @choices;
    my @active = grep { $row[$_] && $row[$_]->get_active } 0 .. $#row;
    die if @active != 1;
    return $choices[$active[0]];
}

sub save_listings_event {
    my $filename = get_filename 'save', 'New listings';

    my @all_programmes = @{$listings_data->[3]};
    my %is_in_table;
    $is_in_table{$_}++ && die foreach @programmes_shown_in_table;
    my @programmes_not_in_table = grep { not $is_in_table{$_} } @all_programmes;
    my %to_write;

    die if @programmes_shown_in_table != @buttons;
    foreach my $i (0 .. $#programmes_shown_in_table) {
	my $p = $programmes_shown_in_table[$i];
	die if exists $to_write{$p};
	my $a = find_active_choice $i;
	if ($a eq 'never' or $a eq 'no') {
	    $to_write{$p} = 0;
	}
	elsif ($a eq 'yes' or $a eq 'always') {
	    $to_write{$p} = 1;
	}
	else { die }
    }

    foreach my $p (@programmes_not_in_table) {
	my $pref = get_pref $p;
	die if not defined $pref;
	if ($pref eq 'never') {
	    $to_write{$p} = 0;
	}
	elsif ($pref eq 'always') {
	    $to_write{$p} = 1;
	}
	else {
	    die 'not shown in table, so should be always or never';
	}
    }

    die if keys %to_write != @all_programmes;
    my @new_data = @$listings_data;
    $new_data[3] = [ grep { $to_write{$_} } @all_programmes ];

    my $ok = eval_with_message sub {
	my $f = new IO::File ">$filename";
	die "cannot write $filename: $!" if not $f;
	XMLTV::write_data(\@new_data, OUTPUT => $f);
    }, 'Writing new listings file';
    return $ok;
}

sub save_preferences_event {
    # First update $prefs_data based on the current buttons.
    # We look only at the first programme with each title.
    #
    die if @programmes_shown_in_table != @buttons;
    my %seen_title;
    foreach my $i (0 .. $#programmes_shown_in_table) {
	my $p = $programmes_shown_in_table[$i];
	my $title = get_title $p;
	$seen_title{$title}++ && next;
	$prefs_data->{$title} = find_active_choice $i;
    }

    # Now we can write it.
    my $filename = get_filename 'save', 'New preferences';
    return if not defined $filename;
    my $ok = eval_with_message sub {
	open my $fh, '>', $filename or die "cannot write $filename: $!";
	print $fh <<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
	  or die $!;
	foreach (sort keys %$prefs_data) {
	    my $pref = $prefs_data->{$_};
	    print $fh "$pref: $_\n" or die $!;
	}
	close $fh or die $!;
    }, 'Writing new preferences file';
    return $ok;
}

$hbox = new Gtk2::HBox;
$vbox->add($hbox);
show $hbox;

my $button = new Gtk2::Button('Save to-watch listings');
$button->signal_connect(clicked => \&save_listings_event);
$hbox->add($button);
show $button;

$button = new Gtk2::Button('Save updated preferences');
$button->signal_connect(clicked => \&save_preferences_event);
$hbox->add($button);
show $button;

show $window;
Gtk2->main;