#! /usr/bin/perl -w
package Games::GolfTest;
use strict;
use vars qw($tests);
$tests = {
  'perl' => '5.8.0',
  'holes' => [],
  'version' => 1
}
;

# CODE START
# Don't remove this comment block
# You normally shouldn't change anything below this point.
# If you *do* need to make changes, read about the require field

# Code part (*not* the hole data) copyright by Ton Hospel
# This file is made freely available under the same conditions as perl,
# GPL or artistic license, your choice.
# The latest skeleton can always be found at
# http://www.xs4all.nl/~thospel/golf/gentest.pl

# This is the version of the program, *not* the data. Update the dataset
# version in the $tests hash.
my $VERSION = "0.30";

# use Data::Dumper;
$Data::Dumper::Indent = 1;
use Errno;
use Fcntl;
use Getopt::Long;
Getopt::Long::config("bundling", "require_order");

my $FILE_VERSION = 2;
my $DEFAULT_TIE_DIGITS = 2;
my $VALID = q(\w\s,%@[]^{}~.+-);

# Storage formats
my $STORABLE = 0;
my $DUMPER   = 1; # Data::Dumper
my $COMBO    = 2; # Data::Dumper + gentest.pl
my $DRIVER   = 3; # Just gentest.pl
my $POD	     = 4;

my $BINMODE =1;

my ($unsafe, $help, $list, $binary, $markers, $norun, $nr_ties);
my (@files, @missing, $failed, $sum, %props, %programs, $missing, $ties);
my ($in_open, $show, $data_file, $do_set);
my $do_nr = 1;
my $do_tests = 1;

# By default backup in polish golfs
# my $backup = exists $ENV{GOLF_BACKUP} && $ENV{GOLF_BACKUP} ne "" ?
#     $ENV{GOLF_BACKUP} : 0.5;
my $backup = $ENV{GOLF_BACKUP};

my $marker = "|";
my $EXECUTOR = "/usr/bin/env";
my $GUNZIP   = "gunzip";

my $GENERIC_NAME = "gentest.pl";
my $ANY_SEPARATOR = "~~or~~";
# Maybe let user set format through GOLF_BACKUP env. Tainted though (think %n)
my $BACKUP_FORMAT = "%s-%06.2f-%s.pl";
my $NORMAL_RATIO  = 55;
my $generic = $0 =~ /\b\Q$GENERIC_NAME\E\z/;
$data_file = shift if $generic && @ARGV && $ARGV[0] !~ /^-/;

die "Could not parse your command line\n" unless
    GetOptions("unsafe!"	=> \$unsafe,
	       "U"		=> \$unsafe,
	       "help!"		=> \$help,
	       "h"		=> \$help,
	       "version!"	=> \my $version,
	       "markers!"	=> \$markers,
	       "m"		=> \$markers,
	       "binary!"	=> \$binary,
	       "backup!"	=> \$backup,
	       "b"		=> \$backup,
	       "data_file=s"	=> \$data_file,
	       "force!"		=> \my $force,
	       "stderr!"	=> \my $stderr,
	       "tie_digits=i"	=> \my $tie_digits,
	       "program=s"	=> \%programs,
	       "p=s"		=> \%programs,
	       "quiet!"		=> \my $quiet,
	       "full!"		=> \my $full,
	       "brief!"		=> \my $brief,
	       "list!"		=> \$list,
	       "l"		=> \$list,
	       "n"		=> \$norun,
	       "no_checks!"	=> \$norun,
	       "show!"		=> \$show,
	       "s"		=> \$show,
	       "nr!"		=> \$do_nr,
	       "names=s"	=> \my $names_file,
	       "dump=s"		=> \my $dump,
	       "save=s"		=> \my $save,
	       "single=s"	=> \my $single,
	       "driver=s"	=> \my $driver,
	       "pod=s"		=> \my $pod,
	       "fetch=s"	=> \my $fetch,
	       "update!"	=> \my $update,
	       "perl=s"		=> \my $wrapper,
	       "check!"		=> \my $check,
	       "model!"		=> \my $model,
	       "nop!"		=> \my $nop,
	       "debug!"		=> \my $debug,
	       );

my %set_map = (brief  => -1,
	       normal =>  0,
	       full   =>  1);

sub prepare {
    if ($version) {
	print<<"EOF";
test data set version $tests->{version}
generic perl golf tester version $VERSION
EOF
		$do_tests = 0;
    }

    if ($help) {
	require Config;
	$ENV{PATH} .= ":" unless $ENV{PATH} eq "";
	$ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
	my $file = find_script();
	$file =~ s/\.pl\z//i;
	$file .= ".pod.$$";
	save($file, $POD);
	system("perldoc", "-F", $unsafe ? "-U" : (), $file);
	unlink($file);
	$do_tests = 0;
    }

    die "Can't specifiy both --full and --brief\n" if $brief && $full;
    $do_set = $set_map{normal};
    $do_set = $set_map{brief} if $brief;
    $do_set = $set_map{full}  if $full;

    $wrapper = $^X unless defined($wrapper) && $wrapper =~ /^[^\0]/;
    load($data_file) if defined($data_file);

    data_check();

    if ($fetch) {
	load("$tests->{base_url}/$fetch");
	$do_tests = 0;
    }

    if ($update) {
	update();
	$do_tests = 0;
    }
    $do_tests = 0 if 
	!$model && (defined($dump) || defined($save) || defined($single)) ||
	defined($driver) || defined($pod) || $nop || $check;

    if ($list) {
	my $i;
	print "$0\n" if $debug;
	print "Course $tests->{course}\n\n" if defined($tests->{course});
	for my $test (@{$tests->{holes}}) {
	    printf "Hole %2d: %s\n", ++$i, $test->{name};
	}
	$do_tests = 0;
    }
}

sub new_file(*$;$) {
    my ($fh, $file, $mode) = @_;
    $mode = 0666 unless defined($mode);
    # avoid perlio bug where perl tries to warn that you open fd 0
    # for write, sending this directly to fd 2, which causes a coredump if
    # that is closed
    local $^W = 0;
    sysopen($fh, $file, O_CREAT | O_WRONLY | O_EXCL, $mode) ||
	die "Could not open $file for create: $!";
}

sub slurp {
    my ($file, $binary) = @_;
    local *FILE;
    local $/ = wantarray ? "\n" : undef;
    {
	local $^W = 0;	# Avoid perlio bitching
	open(FILE, "< $file") || die "Could not open $file: $!\n";
    }
    binmode FILE if $binary;
    if (wantarray) {
	my @all = <FILE>;
	close FILE;		# Avoid perlio assimilating low filedescriptors
	return @all;
    }
    my $all = <FILE>;
    close FILE;		# Avoid perlio assimilating low filedescriptors
    return $all;
}

sub lines {
    return [map"$_\n",@_];
}

# The tie for an empty program is always 0. That special case will already
# have been handled, so your tie functions can ignore it.

sub high_ascii {
    my ($code, $score) = @_;
    my $tie = 0;
    for ($code =~ /./sg) {
	$tie += ord if 127 > ord;
    }
    # tie is really $tie/=length($code)*126, but expand the middle to
    # make the normal range more distinctive. map [0,1] to [-1,1] and
    # take the cube root
    $tie = 1-$tie/$score/63;
    if ($tie < 0) {
	$tie = -((-$tie)**(1/3));
    } else {
	$tie = $tie**(1/3);
    }
    # Now recover [0,1] and map to [0, 0.99] so that the tie
    # can never change the main score
    return ($tie+1)*0.495;
}

sub same_chars {
    my ($code, $score) = @_;
    my $sum;
    for (0..255) {
	$_ = chr;
	my $count = $code =~ s/\Q$_//g;
	$sum += $count * $count;
    }
    return(1-sqrt($sum)/$score)**2;
}

sub letters_and_digits {
   my ($code, $score) = @_;
   my $sum = $code =~ tr/A-Za-z_0-9//;
   return 1 - 0.99 * $sum / $score;
}

sub modulo_100 {
    my ($code, $score) = @_;
    my $m = 0;
    $m += (ord $_) % 100 for $code =~ /./gs;
    return $m / 100 / $score;
}

my %tie_map =
    (high_ascii		=> \&high_ascii,
     same_chars		=> \&same_chars,
     letters_and_digits => \&letters_and_digits,
     modulo_100		=> \&module_100);

sub data_check_hole {
    my $hole_data = shift;

    $hole_data->{use_program} = defined($hole_data->{program}) ? 
        $hole_data->{program} : "$hole_data->{name}.pl";
    die sprintf("program name '%s' contains invalid characters like ".
		"'%s'(0x%02x)\n", $hole_data->{use_program}, $1, ord($1)) if
		$hole_data->{use_program} =~ /([^$VALID]|\s)/;
    die "'any_out' option must be 1, not '$hole_data->{any_out}'\n" if
	defined($hole_data->{any_out}) && $hole_data->{any_out} ne "1";
    die "'all_out' option must be 1, not '$hole_data->{all_out}'\n" if
	defined($hole_data->{all_out}) && $hole_data->{all_out} ne "1";
    die "'order_out' option must be 1, not '$hole_data->{order_out}'\n" if
	defined($hole_data->{order_out}) && $hole_data->{order_out} ne "1";
    die "Cannot have both 'all_out' and 'any_out'" if
	$hole_data->{all_out} && $hole_data->{any_out};
    if ($do_nr) {
	my $nr = 0;
	$_->{nr} = ++$nr for @{$hole_data->{check}};
    } else {
	delete $_->{nr} for @{$hole_data->{check}};
    }

    if ($names_file) {
	my %names;
	map { $names{lc($1)} = $1 if /^\s*(\w+)\s*$/ } split for slurp($names_file);
	defined($_->{name}) and delete $names{lc($_->{name})} for @{$hole_data->{check}};
	die "No names left after filtering $names_file\n" unless %names;
	my @names = values %names;
	for (@{$hole_data->{check}}) {
	    next if exists $_->{name};
	    die "Ran out of names to assign from $names_file\n" unless @names;
	    my $i = rand @names;
	    $_->{name} = $names[$i];
	    $names[$i] = $names[-1];
	    pop @names;
	}
    }
    my @regexes = grep {
	# Be careful not to fall for a qr// regex blessed to ARRAY or 0
	if (ref($hole_data->{$_ . "_regex"}) ne "") {
	    if (ref($hole_data->{$_ . "_regex"}) eq "Regexp") {
		die "${_}_regex: No qr// regexes allowed for security and portability\n" unless $unsafe;
	    } else {
		die "${_}_regex is a reference but not to an array\n" if
		    "$hole_data->{$_ . '_regex'}" !~ /^ARRAY/;
		if (ref($hole_data->{$_ . '_regex'})) {
		    for my $r (@{$hole_data->{$_ . '_regex'}}) {
			next if ref($r) eq "";
			die "${_}_regex element is a reference\n" if ref($r) ne "Regexp";
			die "${_}_regex element: No qr// regexes allowed for security and portability\n" unless $unsafe;
		    }
		}
	    }
	}
	defined $hole_data->{$_ . "_regex"};
    } qw(args in out err);

    return unless $check;
    # Extra developer checking after this point
    my (%names, %args_seen);
    my $nr = 0;
    for my $test (@{$hole_data->{check}}) {
	$nr++;
	eval {
	    if (defined $test->{name}) {
		die "Name $test->{name} already used for test $names{$test->{name}}\n" if exists $names{$test->{name}};
		$names{$test->{name}} = $nr;
		die "Name $test->{name} contains non-alpha characters like $1\n" if $test->{name} =~ /(\W)/
	    }

	    my $hash = "";
	    for (defined($test->{in}) ? "A" . join("", get_strings($hole_data, $test, "in")) : "B", @{get_args($test)}) {
		my $str = $_;
		$str =~ s/!/!!/g;
		$hash .= "$str!Z";
	    }
	    die "Input set already checked in test $args_seen{$hash}\n" if exists $args_seen{$hash};
	    $args_seen{$hash} = $nr;

	    for my $type (@regexes) {
		die "'${type}_regex' but no '$type' field\n" if !exists $test->{$type};
		my $value = $type eq "args" ?
		    join(" ", @{get_args($test)}) :
		    join("",  get_strings($hole_data, $test, $type));

		for my $regex (ref($hole_data->{$type . "_regex"}) ? @{$hole_data->{$type . "_regex"}} : $hole_data->{$type . "_regex"}) {
		    $value =~ /$regex/ || die "'$type' field does not match ${type}_regex /$regex/\n";
		}
	    }
	};
	die("Test $nr",
	    defined($test->{name}) ? " ($test->{name})" : "", ": $@") if $@;
    }
}

# Sanity check on $tests fields
sub data_check {
    if (defined($tests->{require})) {
	my ($order, $version, $extra) =
	    $tests->{require} =~ /^\s*([<>=!]+)\s*(\d+(?:\.\d+)?)(\S*)\s*$/
		or die "Could not parse required version $tests->{require}";
	my ($V, $E) = $VERSION =~ /^\s*(\d+(?:\.\d+)?)(\S*)\s*$/
	    or die "Could not parse $VERSION";
	if ($order eq ">=") {
	    die "Version $version required, but I'm only version $VERSION\n"
		unless $V >= $version;
	} elsif ($order eq "=" || $order eq "==") {
	    die "Version $version required, but I'm version $VERSION\n"
		unless $V == $version && $extra eq $E;
	} else {
	    die "Cannot yet handle order $order";
	}
    }
    $tests->{version} = 0 unless defined $tests->{version};
    die "version should be a natural number, not '$tests->{version}'\n"
	unless $tests->{version} =~ /^\d+\z/;
    $tests->{holes} = [] unless $tests->{holes};
    die "Course name '$tests->{course}' contains invalid characters like '$1'\n" if defined($tests->{course}) && $tests->{course} =~ /([^$VALID]|\n)/;
    my %hole_names;
    for my $hole_data (@{$tests->{holes}}) {
	$hole_data->{name} = "hole" unless defined($hole_data->{name});
	die sprintf("Hole name '%s' contains invalid characters like ".
		    "'%s'(0x%02x)\n", $hole_data->{name}, $1, ord($1)) if
		    $hole_data->{name} =~ /([^$VALID]|\s)/;
	die "Hole name $hole_data->{name} used multiple times\n" if
	    $hole_names{$hole_data->{name}}++;
	eval { data_check_hole($hole_data) };
	die "Hole $hole_data->{name}: $@" if $@;
	print STDERR "Hole $hole_data->{name} looks good.\n" if $check;
    }
}

sub permutations {
    return [] unless @_;
    return map {
	my $elem = $_;
	map [$elem, @$_], permutations(grep {$elem ne $_} @_);
    } @_;
}

sub md5_hex {
    my ($str) = @_;

    my @Y = (0x67452301, 0xEFCDAB89, 0x98BADCFE, 0x10325476);
    my @T = map int 2**32 * abs sin, 1..64;
    my @U = (7, 12, 17, 22, 5, 9, 14, 20, 4, 11, 16, 23, 6, 10, 15, 21);
    my $L = length $str;
    $str .=  pack 'Bx'.(63 & 55 - $L).'VV', 1, 8 * $L;

    $str =~ s!(\C{64})!
	my @V = unpack 'V16', $1;
	my @Z = @Y;
	for my $K (0..3) {
	    my $I = (0, 1, 5, 0)[$K];
	    for (0..15) {
		my ($C, $D, $A, $B) = @Z = @Z[-1..2];
		my $N = $U[$K * 4 + $_ % 4];
		$D = ($D +
			($A & $B | ~$A & $C,
			 $A & $C | $B & ~$C,
			 $A ^ $B ^ $C,
			 $A | ~$C ^ $B)[$K] % 2**32 +
		      $V[$I & 15]+
		      $T[$K * 16 + $_]) % 2**32;
		$Z[1] = ($A + ($D << $N | $D >> 32 - $N)) % 2**32;
		$I += (1, 5, 3, 7)[$K];
	    }
	}
	$Y[$_] = ($Y[$_] + $Z[$_]) % 2**32
	    for 0..3;
    !eg;
    return unpack 'H64', pack 'V4', @Y;
}

# Calculate the score for one hole
sub count {
    my ($hole, $tie) = @_;
    local $_ = slurp($props{$hole}{work}, $binary);
    if (/^\#!/) {
	s/^\#![\t ]?\S+// && s/\n//;
    }
    s/\s*\z//;
    my $md5	= md5_hex($_);
    my $score	= length;
    my $normal	= $score ? y/ -~\t\n// / $score : 1;
    if (defined($tie)) {
	defined(my $code = $tie_map{lc($tie)}) ||
	    die "Unknown tie function $tie\n";
	$score += $code->($_, $score)/$nr_ties if $score;
	$ties++;
    }
    return ($score, $md5, $normal*100);
}

sub order_words {
    for (@_) {
	my $end_nl = s/\n\z//;
	my $end_space = s/ \z//;
	$_ .= " " if $_ ne "";
	$_ = join(" ", sort /([^ ]*) /g);
	$_ .= " " if $end_space;
	$_ .= "\n" if $end_nl;
    }
}

sub compare {
    my ($context, $file, $expected, %options) = @_;
    my $got = slurp($file);
    $got = "" unless defined($got);
    my (@expected, $e);
    my $g = $got;
    if (ref($expected)) {
	@expected = map $options{newline} ? "$_\n" : $_, @$expected;
    } else {
	$e = $options{newline} ? "$expected\n" : $expected;
	@expected = $e =~ /.*\n?/g;
    }
    if ($options{order}) {
	$e = [@expected];
	my @g = $g =~ /.*\n?/g;
	order_words(@$e, @g);
	$g = join("", @g);
    } else {
	$e = \@expected;
    }
    if ($options{all}) {
	my $canonical_expected = join("", sort @$e);
	my $canonical_got      = join("", sort $g =~ /.*\n?/g);
	return if $canonical_expected eq $canonical_got;
	@expected = (join("", @expected));
    } elsif ($options{any}) {
	my %expected;
	$expected{$_}++ && die "Duplicate expected '$_'" for @expected;
	return if $expected{$g};
    } else {
	return if join("", @$e) eq $g;
	@expected = (join("", @expected));
    }
    $got =~ s/(?=\n)/$marker/g if $markers;
    $got =~ s/\n?\z//;
    for (@expected) {
	s/(?=\n)/$marker/g if $markers;
	s/\n?\z//;
    }
    die("Unexpected $context: Expected:\n",
	join("\n$ANY_SEPARATOR\n", @expected), "\nbut got:\n$got\n");
}

sub model {
    my ($test, $hole_data, $model_file, $type) = @_;
    my @lines = slurp($model_file);
    if (@lines == 0 && $type eq "err") {
	delete $test->{$type};
	return;
    }
    order_words(@lines)	 if $hole_data->{"order_$type"};
    @lines = sort @lines if $hole_data->{"all_$type"};

    if ($hole_data->{"all_$type"} || $hole_data->{"any_$type"}) {
	if ($hole_data->{"newline_$type"}) {
	    s/\n\z// || die "Asking for newline_$type but a line in model $type does not end on newline\n" for @lines;
	}
	$test->{$type} = @lines == 1 ? $lines[0] : \@lines;
    } else {
	my $line = join("", @lines);
	if ($hole_data->{"newline_$type"}) {
	    $line =~ s/\n\z// || die "Asking for newline_$type but model $type '$line' does not end on newline\n";
	}
	$test->{$type} = $line;
    }
}

# We need to get the args in several places. Make sure it's always the same.
sub get_args {
    defined(my $args = shift->{args}) || return [];
    return ref($args) ? $args : [split " ", $args];
}

sub get_strings {
    my ($hole_data, $test, $type) = @_;
    my $newline = $hole_data->{"newline_$type"};
    return map $newline ? "$_\n" : $_ ,ref($test->{$type}) ? @{$test->{$type}} : $test->{$type};
}

sub string_line {
    my ($prefix, $str, %options) = @_;
    $str = join("", @$str) if !$options{any} && ref($str);
    $str = [$str] unless ref($str);
    $str = join "$ANY_SEPARATOR\n" => map {
	my $str = $options{newline} ? "$_\n" : $_;
	$str =~ s/(?=\n)/$marker/g if $markers;
	$str =~ /\n\z/ ? $str : "$str\n";
    } @$str;
    return $prefix, $str =~ tr/\n// == 1 ? "" : "\n", $str;
}

sub show_string {
    my ($prefix, $str, %options) = @_;
    return unless defined($str);
    print ERR string_line($prefix, $str, %options);
}

# Show the input and wanted output for test $test (nr $nr) for hole $hole_data
# Will be called with STDOUT and STDERR closed. Use OUT and ERR instead.
sub show_single {
    my ($hole_data, $nr, $test) = @_;
    my $hole = $hole_data->{name};
    my $name = $test->{name};
    if (defined($name) && $name ne "") {
	$name = sprintf("%2d (%s)", $_, $name);
    } else {
	$name = sprintf("%2d", $_);
    }
    my $file = $props{$hole}{file};
    printf ERR "  $file: Showing test $name:\n";

    my $args = get_args($test);
    print ERR "	   ARGV:   @$args\n" if @$args;

    show_string("    STDIN:  ", $test->{in},
		newline => $hole_data->{newline_in});
    show_string("    STDOUT: ", $test->{out},
		newline => $hole_data->{newline_out},
		any	=> $hole_data->{any_out});
    show_string("    STDERR: ", $test->{err});
    print ERR "	   EXIT:   $test->{exit}\n" if defined($test->{exit});
}

# Run one test (properties in $test) for hole $hole_data. It's test nr $nr
# Must be called with STDOUT and STDERR closed. Will (again) be closed at exit.
# STDIN may be open (indicated by $in_open), and may be closed or open at exit,
# again indicated by $in_open
# Filehandles OUT and ERR are available instead of STDOUT and STDERR
sub run_single {
    my ($hole_data, $nr, $test) = @_;

    my $hole = $hole_data->{name};
    my $name = $test->{name};

    my $in_file	 = "$hole.in.$$";
    my $out_file = "$hole.out.$$";
    my $err_file = "$hole.err.$$";

    my (@perms, $shown);
    if ($nr == 1) {
	if (my $perm = $hole_data->{permuted_args}) {
	    @perms = permutations(@$perm);
	    $hole_data->{perm} = pop @perms;
	}
    }

  RETRY:
    my $args = get_args($test);
    if ($hole_data->{perm}) {
	my @args = @$args;
	@args[@{$hole_data->{perm}}] = @args[@{$hole_data->{permuted_args}}];
	$args = \@args;
    }

    my $start_time;
    my $time = 0;
    eval {
	# $SIG{HUP} =
	$SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub {
	    die "Argh. Killed by signal\n";
	};

	if (defined($name) && $name ne "") {
	    $name = sprintf("%2d (%s)", $_, $name);
	} else {
	    $name = sprintf("%2d", $_);
	}
	my $file = $props{$hole}{file};
	printf ERR "  %s: Running test %s ... ", $file, $name unless
	    $quiet || $shown++;

	die "Refused by config\n" if $test->{refuse};
	local $/;

	if (defined($test->{in})) {
	    if ($in_open) {
		close STDIN;
		$in_open = 0;
	    }

	    my $in = join "" => get_strings($hole_data, $test, "in");
	    new_file(local *FILE, $in_file);
	    print FILE $in;
	    close FILE;
	    my $all = slurp($in_file);
	    die "unexpected short read from $in_file. Disk full ?\n" if
		    $in ne $all;

	    open(STDIN, "< $in_file") || die "Could not open $in_file: $!\n";
	} elsif (!$in_open) {
	    # we need a placeholder so that a later dup to STDOUT/STDERR
	    # will not end on fd 0
	    open(STDIN, "<&IN") || die "Could not restore STDIN: $!";
	}
	$in_open = 1;

	new_file(*STDOUT, $out_file);
	new_file(*STDERR, $err_file) unless $stderr;

	# print ERR "$wrapper, ", $test->{taint} ? "-T, " : (), "--, $props{$hole}{work}, @$args\n";
	$start_time=time;
	my $rc = system($wrapper, $test->{taint} ? "-T" : (), "--",
			$props{$hole}{work}, @$args);
	die "Could not run '$wrapper': $!\n" if $rc == -1;
	($time, $start_time) = time() - $start_time;
	if ($rc & 0x80) {
	    print ERR "Program $file dumped core\n" unless $quiet;
	    $rc &= ~0x80;
	}
	if ($rc & 0x7f) {
	    die "Program $file killed by signal $rc\n" if $stderr;
	    my $all = slurp($err_file);
	    die "Program $file killed by signal $rc (STDERR empty)\n" if
		$all eq "";
	    die("Program $file killed by signal $rc, ",
		string_line("STDERR: ", $all));
	}
	$rc = $rc >> 8;
	if ($model) {
	    if ($rc) {
		$test->{exit} = "!0";
	    } else {
		delete $test->{exit};
	    }
	    model($test, $hole_data, $out_file, "out");
	    if ($stderr) {
		$test->{err} = undef;
	    } else {
		model($test, $hole_data, $err_file, "err");
	    }
	} else {
	    if (defined(my $exit = $test->{exit})) {
		if (my ($val) = $exit =~ /^!(.*)$/) {
		    die "Program '$file' should not finish with exitcode $rc\n" if $val == $rc;
		} else {
		    die "Program '$file' should finish with exitcode $exit, not $rc\n" if $exit != $rc;
		}
	    }

	    if (!$stderr &&
		defined(my $err	 = exists($test->{err}) ? $test->{err} : "")) {
		compare("STDERR", $err_file, $err);
	    }

	    if (defined(my $out = $test->{out})) {
		compare("STDOUT", $out_file, $out,
			newline => $hole_data->{newline_out},
			any	    => $hole_data->{any_out},
			all	    => $hole_data->{all_out},
			order	=> $hole_data->{order_out});
	    }
	}
    };
    $time = time()-$start_time if $start_time;

    unless ($stderr) {
	close STDERR;
	unlink($err_file);
    }
    close STDOUT;
    unlink($out_file);

    if (defined($test->{in})) {
	close STDIN;
	$in_open = 0;
	unlink($in_file);
    }

    if ($@) {
	unless ($@ =~ /killed by signal/i) {
	    if ($nr == 1 && $hole_data->{perm} && @perms) {
		$hole_data->{perm} = pop @perms;
		goto RETRY;
	    }
	}

	$failed = 1;
	push(@{$props{$hole}{failed}}, $nr);
	if (@$args) {
	    if ($nr == 1 && $hole_data->{perm}) {
		$@ = "(args: @$args (I also tried all other valid permutations, but none of them gave the expected output)) $@";
	    } else {
		$@ = "(args: @$args) $@";
	    }
	}
	unless ($force) {
	    print ERR "Failed test $nr", $time>1 ? " after $time seconds":"" if
		$quiet;
	    die $time>1 ? "(after $time seconds) " : "", $@;
	}
	print ERR $@ unless $quiet;
    } else {
	print ERR $model ? "Modelled" : "Ok", $time>1 ? " ($time seconds)" : "", "\n" unless $quiet;
    }
}

# Make a temporary work copy of the code for a hole
sub copy {
    my $hole_data = shift;
    my $hole = $hole_data->{name};
    $props{$hole}{work} = my $new = "$hole.$$";
    my $file = delete $programs{$hole};
    $file = $hole_data->{use_program} unless defined($file);
    $props{$hole}{file} = $file;
    local (*I, $_);
    unless (open(I, "< $file")) {
	die "Could not open $file: $!" unless $!{ENOENT};
	$props{$hole}{missing} = 1;
	return 0;
    }
    binmode(I);
    new_file(local *O, $new);
    binmode(O);
    print O while <I>;
    push(@files, $hole);
    return 1;
}

# Runs all tests in the array reference $to_test for the hole given by $hole_data
sub check_hole {
    my ($hole_data, $to_test) = @_;
    my $hole = $hole_data->{name};

    die "Already tested $hole\n" if exists $props{$hole};
    my $exists = copy($hole_data);
    @{$props{$hole}}{qw(count md5 normal)} = count($hole, $hole_data->{tie}) if
	$exists;
    print ERR "Hole '$hole'", $quiet ? "..." : "\n" if
	!$norun && $exists || $show;
    eval {
	close STDOUT;
	close STDERR unless $stderr;
	my $check = $hole_data->{check};
	for (@$to_test) {
	    show_single($hole_data, $_, $check->[$_-1]) if $show;
	    run_single( $hole_data, $_, $check->[$_-1]) if !$norun && $exists;
	}
	if ($exists) {
	    my $ratio = defined($hole_data->{normal_ratio}) ? $hole_data->{normal_ratio} : $NORMAL_RATIO;
	    if ($props{$hole}{normal} < $ratio) {
		$failed = 1;
		push(@{$props{$hole}{failed}}, "for normal character ratio");
		printf ERR "Only %.1f%% of the code matches / -~\\n\\t/, should be at least $ratio%%\n", $props{$hole}{normal}, $ratio unless $quiet;
	    }
	}
    };
    if ($in_open) {
	close STDIN;
	$in_open = 0;
    }
    open(STDIN, "<&IN") || die "Could not restore STDIN: $!";
    $in_open = 1;

    open(STDOUT, ">&OUT") || die "Could not restore STDOUT: $!";
    $stderr || open(STDERR, ">&ERR") || die "Could not restore STDERR: $!";

    die $@ if $@;
    if ($exists) {
	$sum += $props{$hole}{count};
    } else {
	push(@missing, $hole);
	print OUT
	    "  File $props{$hole}{file} does not (yet) exist. Skipping it\n";
	$missing = 1;
    }
    print ERR !$quiet ? "" : $props{$hole}{failed} ? "Failed test $props{$hole}{failed}[0]" : "Ok", "\n"
	unless $norun;
}

# Given an abbreviated hole name, find the full name
sub lookup_abbrev {
    my $name = shift;
    my @match = map $_->{name}, grep $_->{name} =~ /^\Q$name/i, @{$tests->{holes}};
    die "No hole names start with '$name'. Try $0 -l for an overview\n"
	unless @match;
    die("Multiple hole names start with '$name': ", join(", ", @match), "\n")
	if @match > 1;
    return $match[0];
}

# Parse user specified test ranges
sub parse_tests {
    my ($hole_data, $to_test) = @_;

    my $checks = $hole_data->{check};
    my (@to_test, $set);
    for my $range (split/,/, $to_test) {
	if ($range =~ /^([1-9]\d*)$/) {
	    die("You ask for test $1 in $hole_data->{name}, but it only has ",
		scalar(@$checks), " tests\n") if $1 > @$checks;
	    push(@to_test, $1);
	    next;
	}
	if (my ($from, $to) = $range =~ /^([1-9]\d*|)-([1-9]\d*|)$/) {
	    $from = 1 if $from eq "";
	    $to	  = @$checks if $to eq "";
	    die("You ask for test $to in $hole_data->{name}, but it only has ",
		scalar(@$checks), " tests\n") if $to > @$checks;

	    for my $nr ($from..$to) {
		my $test = $checks->[$nr-1];
		# use_set should be in %props, not in $hole_data
		if (defined($test->{set})) {
		    defined($set = $set_map{lc($test->{set})}) ||
			die "Hole $hole_data->{name}, test $nr: Unknown set type $test->{set}\n";
		} else {
		    $set  = $hole_data->{use_set};
		}
		next if $set > $do_set;
		push(@to_test, $nr);
	    }
	    next;
	}
	die "Cannot parse range $range\n";
    }
    return \@to_test;
}

# Main routine. For all holes dispatch the required work
sub do_holes {
    my (%work_programs, %holes);

    %programs = map {lookup_abbrev($_), $programs{$_}} keys %programs;

    for (@{$tests->{holes}}) {
	my $hole = lc($_->{name});
	die "Multiple holes named $hole\n" if $holes{$hole};
	$holes{$hole} = $_;
	$nr_ties++ if $_->{tie};
	if ($_->{set}) {
	    defined(my $set = $set_map{lc($_->{set})}) ||
		die "Unknown set type $_->{set} for hole $hole\n";
	    $_->{use_set} = $set;
	} else {
	    $_->{use_set} = -1;	# default is brief
	}
    }

    my @to_test;
    @_ = map $_->{name}, @{$tests->{holes}} unless @_;
    @to_test = map {
	my $to_test = s/:(.*)$// ? $1 : "-";
	my $hole_data = $holes{lookup_abbrev($_)} ||
	    die "Never heard of hole $_\n";
	[$hole_data, parse_tests($hole_data, $to_test)];
    } @_;

    # perl version check
    if (!$quiet && $tests->{perl}) {
	my ($main, $sub, $rel) = $tests->{perl} =~ /^(\d+)\.(\d+)\.(\d+)$/ or
	    die "Could not parse wanted perl version $tests->{perl}\n";
	my ($Main, $Sub, $Rel);
	if ($wrapper eq $^X) {
	    ($Main, $Sub, $Rel) = $] =~ /^(\d+)\.(\d{1,3})(\d*)$/ or
		die "Could not parse running perl version $]\n";
	} else {
	    my $out_file = "version.$$";
	    close STDOUT;
	    eval {
		new_file(*STDOUT, $out_file);
		my $rc = system($wrapper, "-v");
		close STDOUT;
		die "$wrapper -v returned $rc\n" if $rc;
		local $_;
		{
		    # Shut up perlio warning
		    local $^W = 0;
		    open(local *FILE, "< $out_file") ||
			die "Could not open $out_file: $!";
		    while (<FILE>) {
			last if /\S/;
		    }
		    close FILE;
		}
		chomp;
		die "Only empty lines from $wrapper -v\n" unless /\S/;
		($Main, $Sub, $Rel) = /v(\d+)\.(\d+)\.(\d+)\s/i or
		    die "Could not parse result of $wrapper -v ('$_')\n";
	    };
	    unlink($out_file);
	    open(STDOUT, ">&OUT") || die "Could not dup OUT: $!";
	    die $@ if $@;
	}
	$Main+=0;
	$Sub +=0;
	$Rel = $Rel eq "" ? 0 : $Rel+0;
	print ERR "Warning: Using perl version $Main.$Sub.$Rel, not the preferred $tests->{perl}\n" if $Main != $main || $Sub != $sub || $Rel != $rel;
    }

    eval {
	check_hole(@$_) for @to_test;
    };
    print ERR "\n" if $quiet && !$norun;
    for (@files) {
	if ($backup && ($backup >=1 || !$norun && !$props{$_}{failed})) {
	    my $new = sprintf($BACKUP_FORMAT,
			      $_, @{$props{$_}}{qw(count md5)});
	    unless (rename($props{$_}{work}, $new)) {
		print ERR "Cannot backup to $new: $!";
		unlink($props{$_}{work});
	    }
	} else {
	    unlink($props{$_}{work});
	}
    }
    die $@ if $@;

    if (@files) {
	my $header = "total";
	if ($ties) {
	    if (!defined($tie_digits)) {
		$tie_digits = $DEFAULT_TIE_DIGITS unless
		    defined($tie_digits = $tests->{tie_digits});
	    }
	} else {
	    $tie_digits = 0;
	}
	$sum = sprintf("%.*f", $tie_digits, $sum);
	my $count_length = length($sum);
	my $name_length	 = length($header);
	for my $hole (@files) {
	    next if $props{$hole}{missing};
	    $name_length = length($props{$hole}{file}) if
		length($props{$hole}{file}) > $name_length;
	}
	for my $hole (@files) {
	    next if $props{$hole}{missing};
	    printf OUT ("%-*s %*s strokes %s md5=%s\n",
			$name_length+1, "$props{$hole}{file}:",
			$count_length,
			sprintf("%.*f", $tie_digits, $props{$hole}{count}),
			$norun ? "" : $props{$hole}{failed} ?
			"(fail)," : "(ok),  ",
			$props{$hole}{md5},
			);
	}
	if (@files > 1) {
	    printf OUT ("%*s %s\n%-*s %*s strokes\n",
			$name_length+1, "",
			"-" x $count_length,
			$name_length+1, "$header:",
			$count_length, $sum);
	}
    }
    if (@missing) {
	print OUT
	    "You are still missing programs for: ", join(", ", @missing), "\n";
    } elsif (!$stderr && !$norun && @to_test == @{$tests->{holes}}) {
	if ($failed) {
	    print OUT "Some more work is needed to pass all tests (v$tests->{version} testsuite)\n";
	} elsif ($model) {
	    print OUT "Congratulations! All holes have been modeled (v$tests->{version} testsuite)\n";
	} else {
	    print OUT "Congratulations! All tests passed for all holes (v$tests->{version} testsuite)\n";
	}
    }
}

sub main {
    local *IN;
    open(IN,  "<&STDIN")  || die "Could not dup STDIN: $!";
    open(local *OUT, ">&STDOUT") || die "Could not dup STDOUT: $!";
    open(local *ERR, ">&STDERR") || die "Could not dup STDERR: $!";
    {
	my $fh = select(ERR);
	$|=1;
	select($fh);
    }
    $in_open = 1;

    eval {
	do_holes(@ARGV);
    };
    if ($@) {
	print ERR $@;
	exit 1;
    }
}

sub find_script {
    require FindBin;
    return "$FindBin::Bin/$FindBin::Script";
    $FindBin::Bin = $FindBin::Script; # Make -w happy
}

sub guess_format(*$) {
    my ($fh, $file) = @_;
    open($fh, "< $file") || die "Could not open $file for read: $!";
    defined(local $_ = <$fh>) || die "$file seems empty\n";
    if (/^\#! ?\S*perl\S*\s+(\S+)\s*$/) {
	# seems pure perl code
	my $magic = "# CODE START";
	while (<$fh>) {
	    return $COMBO if /^\Q$magic\E\s*$/o;
	}
	die "Perl file '$file' does not seem $GENERIC_NAME based\n";
    }
    return $POD if /^=/; # smells like pod
    # left are Storable or Data:Dumper
    defined($_ = <$fh>) || die "Unexpected short EOF from $file\n";
    if (my ($file_version) = /^file_version=(\d+)/) {
	die "$0 is designed for dump file version $FILE_VERSION, but '$file' is version $file_version\n" if $file_version != $FILE_VERSION;
	return $STORABLE;
    }
    return $DUMPER;
}

my %deprecated = (newline => "newline_out",
		  url	  => "data_url",
		  );
sub fixup_tests {
    my $safe = shift;

    for my $hole_data (@{$tests->{holes}}) {
	for (keys %deprecated) {
	    if (delete $hole_data->{$_}) {
		print STDERR "Hole $hole_data->{name}: option '$_' is deprecated. Replaced by '$deprecated{$_}'\n";
		$hole_data->{$deprecated{$_}} = 1;
	    }
	}
	next if $safe || $unsafe;
	my $i;
	for my $check (@{$hole_data->{check}}) {
	    $i++;
	    for (@{get_args($check)}) {
		if (/^\s*\+?[<>]/) {
		    $check->{refuse} .= "; auto-refused";
		    print STDERR "Hole $hole_data->{name}, test $i: Argument looks like a redirect. Added refuse option. Remove by hand if you think it's safe\n";
		} elsif (/^\s*\||\|\s*$/) {
		    $check->{taint} .= "; auto-tainted";
		    print STDERR "Hole $hole_data->{name}, test $i: Argument looks executable. Added taint option. Remove by hand if you think it's safe\n";
		}
	    }
	}
    }
}

sub restore {
    my ($file, $safe) = @_;
    my $format = guess_format(local *FILE, $file);
    $safe || $unsafe || $format == $STORABLE || die "Loading '$file' will run external code. Use the -U option if you trust it\n";
    if ($format == $COMBO) {
	my $program = substr($file, 0, 1) eq "/" ? $file : "./$file";
	my $rc = system($program, "--nop");
	die "Unexpected returncode $rc from $program --nop\n" if $rc;
    } elsif ($format == $POD) {
	# no sane pod checks currently
    } elsif ($format == $STORABLE) {
	require Storable;
	local $_;
	while (<FILE>) {
	    last unless /\S/;
	}
	$tests = Storable::fd_retrieve(*FILE);
	defined($_ = <FILE>) || die "$file seems truncated\n";
	$_ eq "\n" || die "$file seems damaged\n";
	defined($_ = <FILE>) || die "$file seems truncated\n";
	$_ eq "# end\n" || die "$file seems damaged\n";
    } elsif ($format == $DUMPER) {
	require $file;
    } else {
	die "Unknown format $format";
    }
    fixup_tests($safe);
}

sub fetch_file {
    my ($file, $url) = @_;
    require LWP::UserAgent;

    my $ua = LWP::UserAgent->new;
    $ua->env_proxy;
    $ua->agent("gentest.pl/$VERSION " . $ua->agent);

    print STDERR "Fetching $url ... ";
    my $request = HTTP::Request->new(GET => $url);
    my $res = $ua->request($request);
    $res->is_success ||
	die("Could not fetch '$url': ", $res->status_line, "\n");
    print STDERR "Ok\n";

    my $ext = "";
    $ext = ".gz" if substr($res->content, 0, 2) eq "\x1f\x8b";
    $ext = ".Z"	 if substr($res->content, 0, 2) eq "\x1f\x9d";
    my $new = "GPT$$";
    new_file(local *FILE, "$new$ext");
    eval {
	binmode FILE;
	# I don't trust perl I/O error reporting, real check follows
	print FILE $res->content;
	close FILE;

	my $line = slurp("$new$ext", $BINMODE);
	$line eq $res->content || die "'$new$ext' doesn't contain what just got written. Disk full ?\n";
	if ($ext) {
	    my $rc = system($GUNZIP, "$new$ext");
	    die "Unexpected returncode $rc from $GUNZIP $new$ext\n" if $rc;
	}

	rename($new, $file) || die "Could not rename $new to $file: $!";
    };
    if ($@) {
	unlink("$new$ext");
	unlink($new);
	die $@;
    }
}

sub is_url {
    return shift =~ /^[a-zA-Z][-a-zA-Z0-9+.]+:/;
}

sub load {
    my $file = shift;
    if (is_url($file)) {
	# Could very well be an url
	my $new = "load.new.$$";
	fetch_file($new, $file);
	eval {
	    restore($new);
	};
	unlink($new);
	die $@ if $@;
	$tests->{data_url} = $file;
    } else {
	restore($file, 1);
    }
}

sub save {
    my ($file, $format) = @_;
    my $new = "$file.new.$$";
    new_file(local *FILE, $new, 0777);
    binmode FILE;
    eval {
	if ($format != $STORABLE) {
	    unless ($format == $POD) {
		require Data::Dumper;
		$Data::Dumper::Indent = 1;
		$Data::Dumper::Terse = $Data::Dumper::Terse = 1;
		if ($format == $DUMPER) {
		    print FILE "#! $EXECUTOR $GENERIC_NAME\n";
		} else {
		    print FILE "#! /usr/bin/perl -w\n";
		}
		print FILE 'package Games::GolfTest;
use strict;
use vars qw($tests);
$tests = ', Data::Dumper::Dumper($format == $DRIVER ? {
    version => 1,
    perl => "5.8.0",
    holes => [],
} : $tests), ";\n";
	    }
	    if ($format != $DUMPER) {
		my $script = find_script;
		open(local *CODE, "< $script") ||
		    die "Could not open $script for read: $!";
		binmode CODE;
		my $magic = $format == $POD ? "__END__" : "# CODE START";
		local $_;
		while (<CODE>) {
		    last if /^\Q$magic\E\s*$/;
		}
		die "Could not find magic marker '$magic' in $script\n" unless
		    defined($_);
		if ($format == $POD) {
		    while(<CODE>) {
			last if /^=/;
		    }
		    die "Could not find actual pod in $script\n" unless
			defined($_);
		} else {
		    print FILE "\n";
		}
		print FILE;
		my $last = $_;
		while (<CODE>) {
		    print FILE;
		    $last = $_;
		}
		if ($last ne "=cut\n") {
		    print FILE "\n" if $last ne "\n";
		    print FILE "=cut\n";
		}
	    }
	} else {
	    require Storable;
	    # file_version must be first !
	    print FILE <<"EOF";
#! $EXECUTOR $GENERIC_NAME
file_version=$FILE_VERSION
data_version=$tests->{version}
program_version=$VERSION
EOF
    ;
	    print FILE "course=$tests->{course}\n" if
		defined($tests->{course});
	    print FILE "hole=$_->{name}\n" for @{$tests->{holes}};
	    print FILE "\n";
	    &Storable::nstore_fd($tests, *FILE);
	}
	print FILE "\n# end\n" if $format == $DUMPER || $format == $STORABLE;
	close FILE;

	# Let's try it
	restore($new, 1);

	rename($new, $file) || die "Could not rename $new to $file: $!";
    };
    if ($@) {
	unlink($new);
	die $@;
    }
}

sub update {
    defined($tests->{data_url}) && $tests->{data_url} ne "" ||
	die "No data url to update from has been defined\n";
    load($tests->{data_url});
    if (defined($data_file)) {
	if (is_url($data_file)) {
	    print STDERR "Not updating $data_file\n";
	} else {
	    my $format = guess_format(local *FILE, $data_file);
	    close FILE;
	    print STDERR "Updating $data_file ... ";
	    save($data_file, $format);
	    print STDERR "Ok\n";
	}
    } else {
	my $script = find_script();
	print STDERR "Updating $script ... ";
	save($script, $COMBO);
	print STDERR "Ok\n";
    }
}

prepare();
main() if $do_tests;
delete @$_{qw(use_set use_program)} for @{$tests->{holes}};
save($dump,   $STORABLE)if defined $dump;
save($save,   $DUMPER)	if defined $save;
save($single, $COMBO)	if defined $single;
save($driver, $DRIVER)	if defined $driver;
save($pod,    $POD)	if defined $pod;

1;

__END__

=head1 NAME

gentest.pl - Generic perl golf tester

=head1 SYNOPSIS

 gentest.pl
 gentest.pl [--model] [-b] [--binary] [-m] [--perl=binary] [--tie_digits=num] {-phole=file} [--force] [--stderr] [--full | --brief] [-n] [-s] {hole[:ranges]}
 gentest.pl -l
 gentest.pl --update
 gentest.pl --data_file data_file
 gentest.pl [--names=dict_file] [--nonr] [--dump file] [--save file] [--single file] [--driver file] [--pod file]
 gentest.pl --check
 gentest.pl [-U] [-h]
 gentest.pl --version
 gentest.pl --nop

=head1 DESCRIPTION

Use B<gentest.pl> to check perlgolf solutions. By default it will try to
run all defined standard tests for all holes, score the holes and give you
a grand total. By giving hole names as arguments you can restrict the
program to only a given set of holes. You can also select specific tests
by adding a colon and a set of comma separated number ranges, like:

    gentest.pl hole:-2,4,6-8,10-

The tests will be run using the same perl version that is running the script
itself. So you can use an alternative interpreter by doing

    other_perl gentest.pl

The program makes a local copy just before it starts testing a particular
hole, so it's ok to change the code for a hole and start a new test even if
the previous one has not finished yet.

In all places where you enter hole names, it's sufficient to specify enough
of the start letters to uniquely identify the hole. This can even be zero
characters, so if there is only one hole and you want to run test 2, you
can simply do:

    gentest.pl :2

If your current testprogram has the L<data_url|"data_url"> key defined and
you have L<LWP|LWP> and L<Storable|Storable> installed, you can update your
testprogram to the latest version with a simple:

    gentest.pl --update

Some more obscure options are described below.

=head1 OPTIONS

=over 4

=item -l, --list

List the holes in this course.

=item --program hole=file

=item -p hole=file

Runs a non-standard file for a given hole. E.g. if there is a hole named
"maze", the tester will normaly run F<maze.pl>. By giving the option
C<-p maze=foo.py>, it will run F<foo.py> instead.

=item -n, --no_checks

Just score the programs, don't run the checking code.

=item -s, --show

Show expected STDIN, STDOUT, STDERR and arguments. It will still run the
given test too unless you also give the L<-n|"-n"> option.

=item -b, --backup

Make a backup copy of the files. This gives you a log of your attempts.
You can turn this on by default by setting the environment variable
GOLF_BACKUP to 1.

Setting GOLF_BACKUP to 0.5 makes backups only if the tests being run succeeded.

Notice that option -b meant L<--binary|"--binary"> up to version 0.22.

=item --binary

Do the bytecounting of the files in binary. Strictly speaking on
windows you should remove the carriage return just before the linefeed
and do the test using this option. This is awkward, and usually there
will be no difference. But it will if you have B<extra> carriage returns
before the newline.

=item -m, --markers

Put a marker just before every newline when outputting a difference between
expected and gotten output. This makes seeing some differences easier.

=item --quiet

Be less verbose. In particular, don't tell about each single test being done.

=item --full

Use a more extended test-set (if one is defined).

=item --brief

Use a restricted test-set  (if one is defined).

=item --force

Keep running even after errors.

=item --stderr

Don't check STDERR for the right output, just pass it straight through. Very
convenient during debugging.

=item --tie_digits=num

Show num digits of the tiebreaker score (default 2).

=item --perl=binary

Gives the name of the binary that will be used to run the individual tests.
By default this will be the same perl as the one used to run gentest itself.
Can also be used to provide your own functionality like L<chroots|chroot(1)>,
ulimits etc.

The given program will normally be called as:

    binary -- arguments

or for the tainted case as:

    binary -T -- arguments

If you write a wrapper, you should pass any -T and the -- to the final
real perl you call (the arguments can start with -).

For version checks it can also be called as

    binary -v

and the first non-empty line of that should contain the word perl
followed by comma, a v and a version number representing the perl
that will in the end be called. So the output should basically
look like what you get if you do perl -v, e.g.

    This is perl, v5.7.1 built for i686-linux

=item --data_file data_file

Use the given external file as dataset. If not given, the data is assumed
to be inline in the program.

If data_file starts with at least 2 letters followed by a C<:>, it is assumed
to be an URL and the program will try to fetch it remotely (needs L<LWP|LWP>
installed). You can use this to directly run tests or generate a local version
of the dataset with commands like:

    gentest.pl http://remote/data/set --single local.pl

after which you can use F<local.pl> to run the tests.

If the data_file is an url, it will also override the L<data_url|"data_url">
tag in $tests.

A special case is if the program is called F<gentest.pl>. Then the first
argument is assumed to be the name of the datafile (this was used in the
example above).

All forms of loading a will internally add a consecutive L<nr|"nr"> entry to
each test, which will then be there after any form of storing. So any load and
dump combination can be used to fix up the L<nr|"nr">> entries (in particular,
you will have valid L<nr|"nr"> entries after doing a http fetch).

=item --names=dict_file

This is a developer option. It will read the given dict_file and collect all 
purely alphanumeric words from that. Then for a given hole it will assign
a random new word as name for each test that doesn't already have an existing 
name. To see the result you obviously also have to save it using
L<--save|"--save">, L<--dump|"--dump"> or L<--single|"--single">.

Typical use:

    gentest.pl --names=/usr/share/dict/words --save some_file

=item --model

This is a developer option. The program being tested is considered to be
the model for a correct solution. Instead of comparing the results to
whatever is defined in $tests, the entries in $tests will be replaced by 
the results. This is of course not very usefull unless you then save the new
$tests somewhere, so usually you will combine this option with 
L<--save|"--save">, L<--dump|"--dump"> or L<--single|"--single">.

The replacement will only be done for tests you actually run, all other tests
remain as they were, so you can also use this to selectively update tests.

The code is smart enough to know about L<newline_out|"newline_out">, 
L<all_out|"all_out"> and L<order_out|"order_out"> and do the appropiate thing.
It can't of course do L<any_out|"any_out"> since it cannot guess the extra 
solutions. But if your program outputs multiple lines, it will assume each line
is one of the alternatives.

If the returncode of the program is non-zero, it will currently assume any
non-zero returncode will do, and use: exit => '!0'

If you give the L<--stderr|"--stderr"> option, it will assume STDERR output is
irrelevant and set err => undef. Even though this is usually not what you want,
it's often still a good idea to do the first model run using 
L<--stderr|"--stderr"> because it allows you to see any errors in the model
program (otherwise the failure message will be demanded as L<err|"err"> 
output).

Example usage:

    gentest.pl --model --save some_file --stderr
    gentest.pl --data_file old_test_program.pl -p=model.pl --model --single new_test_program.pl :3

=item --check

Does a number of extra checks against the tests. In particular it checks
duplicate use of names for the individual tests for a hole, checks if some
input is tested multiple times and checks each test aginst the challenge
regexes if they are given (see L<args_regex|"args_regex">,
L<in_regex|"in_regex">, L<out_regex|"out_regex"> and L<err_regex|"err_regex">).

Using this option implies that no holes are actually run.

This option is mainly meant for test developers. Any dataset you get as a
player should already have been tested.

=item -h, --help

This help.

=item -U, --unsafe

Allows you to run this help as root. However, L<perldoc|perldoc> is not
designed to run as root, and you will also be calling several external programs
as root. Avoid it.

Also used when code is fetched from a remote site. Adding -U will indicate
you trust this remote code and are prepared to run it.

=item --version

Show the version number of this program and of the dataset.

=item --update

This will look up the L<data_url|"data_url"> key in the current dataset, and
if one is defined, will use L<LWP|LWP> to fetch a datfile from that url.

Next it will check if the file is in L<gzipped|gunzip(1)> or
L<compressed|compress(1)> format and uncompress it if so (this assumes you
have a L<gunzip|gunzip(1)> executable installed somewhere in your path).

Then it will load this file in the way the L<--data_file|"--data_file"> option
would, but only if the file is in L<Storable|Storable> format or you have
given the L<--unsafe|"--unsafe"> option.

Now it will take a quick look at the test data and filter out unsafe ones,
unless you had given the L<--unsafe|"--unsafe"> option (you can easily
fix the filtered entries by hand in the updated file if you decide to trust
them after inspection).

If you have used the L<--data_file|"--data_file"> option (or used the data_file
argument to F<gentest.pl>), it will next overwrite this datafile in the same
format as it used to be (or in fact do nothing if the datafile is a url).

Otherwise it will use L<FindBin|FindBin> to determine the calling program
and update that.

=item --nonr

Normally on save each test gets a L<nr|"nr"> entry. By giving this option
they are dropped, so your save files become more compact (but harder to
visually identify specific tests).

=item --dump file

Writes a standalone dataset to the given file. Needs L<Storable|Storable>.
Guaranteed not to execute foreign code on load.

The file will start with

    #! /usr/bin/env gentest.pl

so if you want to be able to run it from the commandline, gentest.pl should
be in your PATH.

Notice that the file format has not stabilized yet, so backward and forward
compatibility is currently not guaranteed.

=item --save file

Writes a standalone dataset as perl code to the given file.

The file will start with

    #! /usr/bin/env gentest.pl

so if you want to be able to run it from the commandline, gentest.pl should
be in your PATH.

Notice that the file format has not stabilized yet, so backward and forward
compatibility is currently not guaranteed.

=item --single file

Writes a standalone dataset as perl code followed by gentest.pl to the given
file. You can distribute this and won't need anything external (except perl
itself).

=item --driver file

Writes only the generic driver program to the given file. Should normally
be called F<gentest.pl>.

These last options can be combined in several ways. E.g. suppose you have
an old (or untrusted) standalone testprogram F<data.pl> and a new (or trusted)
standalone testprogram F<other.pl> and now want to have a standalone version
of the old data with the new code. You can do that by using (assuming . is
in the PATH):

    other.pl --driver gentest.pl	# New standalone program
    data.pl  --dump   old_data		# dump the old data
    gentest.pl old_data --single mix.pl # Generate the new program

(if data.pl is untrusted you must run it in some kind of jail. The load phase
itself however is secure if you use the L<--dump|"--dump"> format to move the
data)

=item --pod file

Writes the pod documentation to the given file. You can then run that as

    perldoc -F file

and get the same result as from directly using the --help option.

=item --nop

Don't do anything. This is used internally to test a generated single file.

=back

The docs on running the testprogram end here. The rest is for referees
setting up tests.

=head1 DATA FORMAT

At the top of the file there is a global variable named C<$tests>. This is
where holes and their tests get declared. Suppose you have two holes, one
(let's call it arginc) that expects a commandline argument and should
print that value followed by a newline to STDOUT and one (let's call it
filterinc) that reads lines from STDIN and prints to STDOUT what it reads
plus one, each time followed by a newline. An almost minimal datstructure
would be:

    $tests = {
	version => 1,
	holes =>
	    [
	     {name => "arginc",
	      check =>
		  [{args =>  4, out =>	"5\n"}
		   {args =>  0, out =>	"1\n"}
		   {args => -1, out =>	"0\n"}
		   {args => -8, out => "-7\n"}]},
	     {name => "filterinc",
	      check =>
		  [{in => "4\n0\n-1\n-8\n", out => "5\n1\n0\n-7\n"}
		   {in => "", out => "" }]},
	 ],
    }

though even this can be simplified, for example by using the
L<newline_out|"newline_out"> key.

$tests is a hash reference whose keys can be:

=over 4

=item version

Gives the dataset version. Users will use this to see if their testset is
up to date or not. Defaults to 0, but you should really specify it.

=item course

An optional field giving the global name of this course. Should not contain
too icky characters (the program will warn you about bad ones).

=item perl

An optional field giving the official perl version for this course.
If given, the program will warn if the tests are done using a different
perl version. The value is of the form major.minor.sub. Example:

    $tests = {
	...
	perl => "5.8.0",
	...
    }

=item data_url

An optional field giving the url of the dataset used for this challenge.
See the L<--update|"--update"> option for an explanation of how it gets loaded.
Notice that this is in general supposed to refer to just the dataset, B<NOT>
the full testprogram. Preferred format is L<Storable|Storable>, which you can
generate using the L<--dump|"--dump"> option. If this leads to a big file,
you may optionally decide to L<gzip|gzip(1)> it, but you then implicitely
require people to have L<gunzip|gunzip> installed.

=item tie_digits

Optional field describing the number of significant digits shown for the
tie-breaker. Defaults to 2 and can be overridden from the command line.

=item require

Optional field describing the required version of gentest.pl to be
able to handle a dataset correctly. Example:

    $tests = {
	...
	require => ">= 0.12",
	...
    }

indicates the program version should be at least 0.12. You can check the
version of your program using the L<--version|"--version"> option.

This field is especially important if you need to make changes to the generic
tester code to e.g. handle special output formats. In that case, extend the
C<$VERSION> variable with an ad-hoc identifier, something like:

    my $VERSION = "0.11-tpr28c";

and add a require for that exact version in C<$tests>:

    $tests = {
	...
	require => "== 0.11-tpr28c",
	...
    }

This will avoid this dataset getting loaded into a tester that cannot
handle it.

Please make your ad hoc changes in such a way that you add features, don't
change existing features. E.g. if you won't just be comparing the program
output to a fixed string, don't use the C<out> field as a parameter, but
invent a new field like C<_out>. This way the tester can still be used to
process generic datasets.

=item holes

An array reference with each element being a hash reference describing per
hole data. The per hole hash keys are:

=over 8

=item name

The name of this hole. Should not contain too icky characters
(the program will warn you about bad ones).
Defaults to "hole".

=item program

The default name for the user program that will try to solve this hole.
Should not contain too icky characters (the program will warn you about bad
ones) The user can always override this using L<--prog|"--prog">.

Defaults to the hole name with C<.pl> appended.

=item newline_in

Be giving this key a newline will be added to every L<in|"in"> entry. This is
especially convenient when the input consists of single lines. Example:

	     {name => "filterinc",
	      newline_in => 1,
	      check =>
		  [{in => "foo", out => "bar\n"}]},

The program will see "foo\n" on STDIN and should output "bar\n".

=item newline_out

Normally you want the output of a hole to be properly newline terminated, and
every L<out|"out"> entry in the testset will end on a newline.
By giving this key a true value, the test program will add a newline to every
L<out|"out"> entry, which makes the testset much more readable.
E.g. in the "arginc" example the hole definition becomes:

    ...
    {name => "arginc",
	newline_out => 1,
	check =>
	    [{args =>  4, out =>  5},
	     {args =>  0, out =>  1},
	     {args => -1, out =>  0},
	     {args => -8, out => -7}]},
    ...

This key used to be called C<newline>, but that turned out to be too
confusing.

=item any_out

Normally you want the programs stdout fully specified by the L<out|"out">
entry. Sometimes however a test may have multiple valid outputs. By setting
this option to 1 for a given hole, each L<out|"out"> entry becomes a set of
alternatives if given as a list (instead of being concatenated as in the
usual case). Giving a string instead of an array reference still means
a request for an exact match. For example:

    ...
    {name => "arginc",
	any_out => 1,
	newline_out => 1,
	check =>
	    [{args =>  4, out =>  5},	   # STDOUT must be "5\n"
	     {args =>  0, out =>  [1, 2]}, # STDOUT must be "1\n" or "2\n"
	     {args => -1, out =>  [0]},	   # STDOUT must be "0\n"
	     {args => -8, out => -7}]},
    ...

=item all_out

At times you may want the program to generate all solutions to something, but
don't care about their order. Giving this option will cause STDOUT to be split
into seperate lines and will demand them to be a permutation of the
L<out|"out"> list.

Internally the compare is done by by sorting the expected and actual results
and comparing the combined strings. So if you sort the lines in L<out|"out">
yourself, you can still give out as one long multiline string.

Example:

    {name => "arginc",
	any_out => 1,
	newline_out => 1,
	check =>
	    [{args => 4, out =>	 5},	  # STDOUT must be "5\n"
	     {args => 0, out =>	 [1, 2]}, # STDOUT must be "1\n2\n" or "2\n1\n"
	     {args => 3, out =>	 "1\n2"}, # STDOUT must be "1\n2\n" or "2\n1\n"
	     {args => 2, out =>	 [1, 2, 2]},
	     # STDOUT must be "1\n2\n2\", "2\n1\n2\n" or "2\n2\n1\n".
	     # "1\n2\n" is NOT a valid solution, nor is "1\n2\n2\n2\n".
	     {args => 1, out =>	 [0]},	  # STDOUT must be "0\n"
	     {args => 8, out => -7}]},
    ...


=item order_out

This works exacly like L<all_out|"all_out"> except that it is done on
a word basis instead of a line basis (a word is a sequence of non-space
characters). This allows you to make the order of items on a line
optional. It will demand the items to be separated by single spaces.

Notice you can combine this with L<all_out|"all_out"> to make both the
order on a line as the order of lines irrelevant.

Example:

    {name => "arginc",
	order_out => 1,
	newline_out => 1,
	check =>
	    [{args => 4, out =>	 5},	 # STDOUT must be "5\n"
	     {args => 0, out =>	 "1 2"}, # STDOUT must be "1 2\n" or "2 1\n"
	    ]},
    ...

=item set

The test program can be started with as extra options L<--brief|"--brief"> or
L<--full|"--full">, or with neither of them ("normal").

Every test case itself is in set "brief", "normal" or "full". If the program
is started with --brief, only tests in set "brief" will run. If the program
is started without --brief or --full, tests in set "brief" or "normal" will
run. If the option --full is given, all tests will run, regardless of their
set.

Every test case defaults to "brief". You can override this per test case.
However, this is awkward if you want to change most of them. In that case you
can use the per hole "set" key to change the default to a value of
"brief", "normal" or "full".

Suppose for example that for hole "arginc" you want to only run the zero to 1
case by default, and only run the rest if the user gives --full. In that case
you want all holes with one exception to be in set "full", so its convenient
to make that the default and only mark the exceptions:

    ...
    {name => "arginc",
     set => "full",
     check =>
	 [{args =>  4, out =>  "5\n"},
	  {args =>  0, out =>  "1\n"},
	  {args => -1, out =>  "0\n", set => "brief"},
	  {args => -8, out => "-7\n"}]},
    ...

=item permuted_args

Sometimes it happens that a hole is defined with something like "you may
give the two commandline arguments in any order, as long as the order is
consistent". In these cases the test program must figure out for itself
which order the user has chosen. You do that by giving this key with as value
an array reference telling which arguments may be permuted (starting to count
from zero). So for the example we are talking about arguments 0 and 1, so
the entry becomes:

    ...
    {name => "ambiguous",
     permuted_args => [0, 1],
     ...
    }
    ...

It works by trying all possible permutations on the first test being run,
until it meets one that works. The last one that will be tried is the
unpermuted order, and if that one fails too, the error for B<only> that
one will be reported. If any order B<did> work, that particular permutation
is remembered and applied on all other tests, without any more searching.

Notice that it's up to you to make sure the first test is able to distinguish
between good and bad permutations. Especially when you use the L<set|"set"> key
to classify tests it's up to you to make sure that the first test being run
(which can be different depending on if the user gives L<--brief|"--brief">,
L<--full|"--full"> or none of these) does the right thing.

=item tie

If given, it's the name of the tie breaker for this hole. This will be
a key into a dispatch table mapping names to tie breaker code. This code,
when given program text and a score (length) as arguments, will calculate
a number (normally in the range [0..0.99] so it won't change the integer
part of the total score) that will be divided by the total number of
tiebreakers defined for the course and added to the hole score.

The special case of the empty program (score 0) is assumed to always give
a tie of 0. The tie breaker will never be called in this case, so your code
can ignore that case.

When writing a new tie breaker, give it a name of the property to optimize
for (not the one to avoid). So a tie named "whitespace" should give a low
tie (good) if you have lots of white space, while "non-whitespace" should
return a high tie (bad).

Currently the builtin tie breakers are:

=over 12

=item high_ascii

Prefers code with many characters with an ASCII code high in the [0..126]
range.

=item same_chars

Prefers code any given character appears many times
(not necessarily consecutive)

=item letters_and_digits

Prefers code with many letters and digits (a-z, A-Z, 0-9 and _).

=item modulo_100

Prefers code where the ASCII code of a character modulo 100 is low.
(C<\0>, C<d> and C<È> score best)

=back

=item normal_ratio

Demands a minimum percentage of the code that must consist of normal
characters, defined as characters matching / -~\n\t/. Defaults to 55.

=item regexes

Often the challenge contains regexes that certain pieces of input or output
must match. The following options allow you to specify such regexes that
must be valid for each test. For efficiency and security these regexes are
only tested if you pass the L<--check|"--check"> option to the program.

The regex body must be specified as a string. Don't forget that even in a
single-quoted string C<\\> represents only one C<\>, and that the resulting
string then gets inserted in a regex, where you need two backslashes to match
a C<\>. So you need C<'\\\\'> to match a single backslash. A backslash before
a letter in a single-quoted string does not need to be doubled, so you can
for example check for a newline with the normal C<'\n'>.

For portability and security reasons reqex quotation (qr/regex/) is not
allowed by default, but you can allow it by using the L<--unsafe|"--unsafe">
option. It will however still behave badly under save and load. Avoid it.

Usually it's also good to avoid C<$> in your regexes. Depending on what you
really want, use C<\z> or C<\n\z> (or even C<\n?\z>) instead. (The regexes
run under the default perl settings, so there is no reason to replace C<^>
with C<\A>).

Normally you give only one regex per field, but in all cases you can use an
array reference to regexes if you want to do more than one check. In that
case B<all> regexes must match.

=over 12

=item args_regex

All arguments are joined with a space inbetween and is then matched against
the regex. This is the only case where a space is used, all others concatenate
without any intervening characters (though the concatenated strings themselves
can have newlins appended if you use newline options like
L<newline_in|"newline_in">).

Example:

    ...
    {name => "arginc",
     args_regex => '^\w+( \w+)*\z',	# One or more word arguments
	check =>
	 [{args =>  4, out =>  "5\n"},		# Ok
	  {args =>  "4 5", out =>  "5\n"},	# Also ok
	  {args =>  [4, 5], out =>  "5\n"},	# Again ok
	  {args =>  "4\n", out =>  "5\n"}]},	# Not ok
    ...

=item in_regex

All input lines are concatenated and checked against the regex(es).

Example:

    ...
    {name => "filterinc",
     # Must contain one word character *and* ONE backslash
     # (the single-quoted string is \\, which will be applied as
     #	the regex /\\/, so it checks for only one backslash)
     in_regex => ['\w', '\\\\'],
    ...

=item out_regex

All L<out|"out"> lines are concatenated and checked against the regex(es).
Notice the regex is run against the expected value, not against the value
the program being tested outputs.

=item err_regex

All L<err|"err"> lines are concatenated and checked against the regex(es).
Notice the regex is run against the expected value, not against the value
the program being tested outputs.

=back

=item check

An array reference where the elements describe the actual tests that
can be done for a hole. Each element is a hash reference describing one test
using the following keys:

=over 12

=item args

The command line arguments that will be given to the program. Can be a string
if there is only one argument or an array reference whose elements
correspond to the arguments that will be passed. If not given, assumes
no commandline arguments.

If given as a string, the tester will use

    @args = split " ", $string;

to construct the individual arguments. So use the array reference form
if you want to do special things like including a space in an argument.

=item in

What will be passed to the program on STDIN. Can be a string or an array
reference (elements will be concatenated in that case). If not given, no STDIN
assumptions will be made.

=item out

Can be a string or an array reference (elements will be concatenated in that
case, except when the L<any_out|"any_out"> option is set). After the test has
finished, the program output is compared to this string and the test fails if
they are not equal.

In case the L<any_out|"any_out"> option is set for this hole, each element
in the array reference is an allowed alternative output instead. The program
output must be equal to one of these. (Giving a string or a one-element array
is effectively a pure equality test again).

If this item is not given, no output check will be done, so you almost
certainly want to specify this.

=item err

Can be a string or an array reference (elements will be concatenated in that
case). After the test has finished, the program's STDERR output is compared
to this string and the test fails if they are not equal.

Defaults to the empty string, meaning that nothing should appear on
STDERR. When set to C<undef>, STDERR output will be ignored.

=item exit

By default the return code of the program will be ignored. By defining a value
for this key, you ask for a specific returncode.

Preceding the value by C<!> will demand that the returncode is B<not> that
value.

=item set

The concept is explained under the entry for the perl hole L<set|"set"> key.
This per test key allows you to mark exceptions to the default.

=item taint

The perl interpreter for the test will be called using the -T option.
This will automatically get added if you fetch tests from an untrusted
source and any L<args|"args"> start or end with C<|>.

=item refuse

The program will refuse to run this test. This will automatically get added
if you fetch tests from an untrusted source and any L<args|"args"> start with
C<E<lt>>, C<E<gt>>, C<+E<lt>> or C<+E<gt>>.

=item nr

This entry is supposed to number the tests starting with 1, and only exists
to help people find back particular tests. Except for being there it doesn't
do anything. It's also purely optional, so leave it out if you don't want to
bother.

Notice that any form of loading (unless the L<--nonr|"--nonr"> option is given)
will regenerate these numbers, meaning they will be there on the next save
(so that's an easy way to renumber).

=back

=back

=back

A number of convenience functions is available to clean up the format.

=over 4

=item lines

This function adds a newline to the end of every argument and then
joins them into a big string. So you can also write the "filterinc" hole
like this:

    ...
    {name => "filterinc",
	check =>
	    [{in => lines(4,0,-1,-8), out => lines(5,1,0,-7)},
	     {in => "", out => "" }]},
    ...

notice that you can also use the plain perl EOF construct, for example:

    ...
    {name => "filterinc",
	check =>
	    [{in => <<'EOF', out => <<'EOF'},
 4
 0
 -1
 8
 EOF
 5
 1
 0
 -7
 EOF
	     {in => "", out => "" }]},
    ...

=back

=head1 BUGS

None known.

=head1 AUTHOR

Ton Hospel (gentest@ton.iguana.be)

=cut