prefs results from the CPAN

xmltv
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;
    }
}

# 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 }
}

# 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()
#
( run in 2.218 seconds using v1.01-cache-2.11-cpan-5c0b1e786e0 )