#! /usr/bin/perl -w
package Games::GolfTest;

#use warnings;
use strict;

use vars qw($tests);
$tests = {
    version => 1,
    perl  => "5.8.0",
    tie_digits => 3,
    require => "== 0.21-tpr06",
    holes =>
        [
         {name =>"bwt",
          tie  => "same_chars",
          newline_out => 1,
          check => [
                    { in => "1\tBA\n",
                      out => "AB"},
                    { in => "0\tBA\n",
                      out => "BA"},
                    { in => "1\tAA\n",
                      out => "AA"},
                    { in => "5\tOBRSDDB\n",
                      out => "DRDOBBS"},
                    { in => "2\tNNBAAA\n",
                      out => "BANANA"},
                    { in => "1\tCAB\n",
                      out => "ABC"},
                    { in => "2\tBCA\n",
                      out => "ACB"},
                    { in => "0\tBCA\n",
                      out => "BAC"},
                    { in => "2\tCAB\n",
                      out => "BCA"},
                    { in => "0\tCAB\n",
                      out => "CAB"},
                    { in => "1\tBCA\n",
                      out => "CBA"},
                    { in => "1\tBAA\n",
                      out => "AAB"},
                    { in => "2\tBAA\n",
                      out => "ABA"},
                    { in => "0\tBAA\n",
                      out => "BAA"},
                    { in => "0\tAB,\n",
                      out => "A,B"},
                    { in => "0\tABC,,\n",
                      out => "A,B,C"},
                    { in => "0\tABCD,,,\n",
                      out => "A,B,C,D"},
                    { in => "1\tCAAABBCCB\n",
                      out => "AAABBBCCC"},
                    { in => "7\tBAABBCCCA\n",
                      out => "CCCBBBAAA"},
                    { in => "3\tCCCAAABBB\n",
                      out => "ABCABCABC"},
                    { in => "3\tBBBCCCAAA\n",
                      out => "CBACBACBA"},
                    { in => "18\tSSEEAAYEE,HHSSHSRTSSSEELLHOLL,,,E,,,B\n",
                      out => "SHE,SELLS,SEA,SHELLS,BY,THE,SEA,SHORE"},
                    { in => "25\tNAEIOAIOUEAAEIEIOUNTTTTTNBBBBBNNB,BBBU,,,,,,,,,,,A,,,E,,I,OB,BBB,,,,,EEEEEMMMMMBB,BB,,,,,EEEEEBB,BEEEEEB,B\n",
                      out => "B,MET,EEN,A,BA,B,MET,EEN,E,BE,B,MET,EEN,I,BI,BA,BE,BI,B,MET,EEN,O,BO,BA,BE,BI,BO,B,MET,EEN,U,BU,BABEBIBOBU"},
                    { in => "12\tLTS,E,IIDLLAA,ENUSM\n",
                      out => "ALL,ALIENS,MUST,DIE"},
                    { in => "7\tVP,EROUMET\n",
                      out => "MTV,EUROPE"},
                    { in => "9\tEKXWSIHHESSSSCE,P,,,AI\n",
                      out => "SHE,SAW,SIX,SICK,SHEEP"},
                    { in => "5\tNP,EOTHSOL\n",
                      out => "TON,HOSPEL"},
                    { in => "349\tTTHTNDDRDESTTTAKSATSRERTRESTRDSRRRRRAAAEAETYEKOAAESYEAAESKEETSDOEYWKRERRRYEISKKKKSSESKNAAEADDDDTFRRRRRRFFFFRRRRKSYRAKEEAKRARETYOESSEEEEEYTFDTERRAAAEAARRAYEATRAAOSAEAMSSSDNDSKNNESDOWEETTEODRELLL,,,,,,,,,,,LEEEEELELL,,LLLUUUBTUUBUUUSSM,CCCCC,,LLLLL,,LTCCHHCCCCCCC,CHL,,,,,,,,,,II,,,,,,,,,,,,,AAUAEEEEAAAUAIIAIIAAAIIIIIIAAAU,NEEEEEEEEEIILN,,,,TNNHRUHHHWKRHEUHHURRHHHHHUHRHRRVULSSSSSLPPPPKKKKLLLLKLTHHHHSHHHSSHHPPPPKLKPKKKLLLPPPPPPTTTTKHHTPWHTTTTTOLLPPPPLHHIOOOOI,,,,,,,,,,UUUUU,EGWT,TTTTSTTTTSSSTTSSSSSSSSW,,WTTPSSSSSTGGGG,RHPPPPUPPPPUAA,,EEEEMMMPPPPPKKK,,,PPPP,UUUUUUCCCCCCCCCCCCCACCCCC,,CCCC,,,CCCCCCCCCLLLIIIIBBBLLLLLAFUFFKKKKFSLLL,,FIIIIIIIIIIIEEEEEEEAALLLLLLLBBBFFFFKFLL,,AAAIIEIOOAAOOWSDTSSG,,,,,,,,RTTTTHHGHHHRSSSC,,,,,,,,,,PPPIIIIP,,,,O,,,,,,,,RRRRR,,,,EEEEEEE,,,,,,,,,,,EEUUEEEEAEAAAAEEEEEEEEEEEEOOOEOEEEOEAUOUOTHEEEEEOOOILKKAUULKLLKELL,,LA,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,A,,,,,,,PAPHHUAUPAIHRARHEETAIAEEEERAAAAA,,,,,,,,,,,,,,,IIIISA,QQQQQQQQDDDLLLLLOOOOAQQSQSSSSOOOSS,,BBAAEM,,,,TEELLLLLL\n",
                      out => "WE,HAVE,TWO,DUCKS,ONE,BLUE,ONE,BLACK,AND,WHEN,OUR,BLUE,DUCK,GOES,QUACK,QUACK,OUR,BLACK,DUCK,QUICKLY,QUACK,QUACKS,BACK,THE,QUACKS,BLUE,QUACKS,MAKE,HER,QUITE,A,QUACKER,BUT,BLACK,IS,A,QUICKER,QUACKER,BACKER,CAMILLA,CATERPILLAR,KEPT,A,CATERPILLAR,KILLER,CAT,A,CATERPILLAR,KILLER,CATEGORICALLY,SHE,KEPT,BUT,ALAS,THE,CATERPILLAR,KILLER,CAT,ATTACKED,CAMILLA,AS,CAMILLA,CATERPILLAR,CATASTROPHICALLY,SLEPT,A,FLEA,AND,A,FLY,IN,A,FLUE,WERE,CAUGHT,SO,WHAT,COULD,THEY,DO,SAID,THE,FLY,LET,US,FLEE,LET,US,FLY,SAID,THE,FLEA,SO,THEY,FLEW,THROUGH,A,FLAW,IN,THE,FLUE,SHEILA,SHORTER,SOUGHT,A,SUITOR,SHEILA,SOUGHT,A,SUITOR,SHORT,SHEILA,S,SUITOR,S,SURE,TO,SUIT,HER,SHORT,S,THE,SUITOR,SHEILA,SOUGHT,PETER,PIPER,PICKED,A,PECK,OF,PICKLED,PEPPER,A,PECK,OF,PICKLED,PEPPER,PETER,PIPER,PICKED,IF,PETER,PIPER,PICKED,A,PECK,OF,PICKLED,PEPPER,WHERE,S,THE,PECK,OF,PICKLED,PEPPER,PETER,PIPER,PICKED,SHE,SELLS,SEA,SHELLS,ON,THE,SEA,SHORE,THE,SHELLS,THAT,SHE,SELLS,ARE,SEA,SHELLS,I,M,SURE,SO,IF,SHE,SELLS,SEA,SHELLS,ON,THE,SEA,SHORE,IM"},
                    { in => "374\tTTTRRSRYRYYSFFRRRRSAAARRSYYRERRRRFESRRNENFRTTTTDRTLLEENTTTEIREEODTEEARRTRETDORT,,,EMSMMH,,,WHBBBBB,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,NNIAHMDKKHHRHRRSHHTTHHTTTTTHTTTTTTTTTTTTTTTBBBBBBBBOOOIUUUTTSSSTSS,,,TSGGG,A,WW,,H,,,BBB,BBBAALLIIEELL,,,O,,,IAIAASS,,,SHBBBBB,,EEEEEEEEEEEEEEEEEEEEEEEEAOUELAL,I,,,,,,,,,,,RUHHIIUUIIIIUHAITTTTTTTTTTTTTTTTTTTTTT,,,,AUAAUEAOOIUIEEIAUEEEUUEE,TTOOOSBPPBBBBBBBT,,MMMTT\n",
                      out => "SURE,THAT,THE,SHELLS,ARE,SEA,SHORE,SHELLS,BETTY,BOTTER,BOUGHT,SOME,BUTTER,BUT,SHE,SAID,THIS,BUTTER,S,BITTER,IF,I,PUT,IT,IN,MY,BATTER,IT,WILL,MAKE,MY,BATTER,BITTER,BUT,A,BIT,OF,BETTER,BUTTER,WILL,MAKE,MY,BATTER,BETTER,SO,SHE,BOUGHT,A,BIT,OF,BUTTER,BETTER,THAN,HER,BITTER,BUTTER,AND,SHE,PUT,IT,IN,HER,BATTER,AND,IT,MADE,HER,BATTER,BETTER,SO,TWAS,BETTER,BETTY,BOTTER,BOUGHT,A,BIT,OF,BETTER,BUTTER"},
                    { in => "15\tTNETEENRVRKAP,,DDDL,,,LUAEAKTKBA,R,\n",
                      out => "DE,KAT,KRABT,DE,KRULLEN,VAN,DE,TRAP"},
                    { in => "20\tELNEKTFEREL,,USLR,HNI,TWTTHTAI,IEE,UOICFOBLAS,XNNN,,E\n",
                      out => "IF,THEN,ELSE,FOR,WHILE,UNTIL,CONTINUE,BREAK,LAST,NEXT"},
                    { in => "22\tOOTREEESTH,,BHBUTTT,,OTTI,N,OIEAO,,SN,Q\n",
                      out => "TO,BE,OR,NOT,TO,BE,THAT,IS,THE,QUESTION"},
                    { in => "118\tTSSSEDOODGSRTESRSAYEEFEAEOOENSRDRTDRFNE,,RGT,,,,H,,OU,NNNNKHBNHHBSH,GLFHLUHOOFU,NAANTTTTTTW,MSLATT,ABBS,REIOAAEIUII,,ITTTTN,,I,,,FPNRE,RPO,EOEEOTATRAOMGEUIWI,O,NE,SAO,,,,,,ES,M,,,U,ROQSTOO,OB\n",
                      out => "TO,BE,OR,NOT,TO,BE,THAT,IS,THE,QUESTION,WHETHER,TIS,NOBLER,IN,THE,MIND,TO,SUFFER,THE,SLINGS,AND,ARROWS,OF,OUTRAGEOUS,FORTUNE,OR,TO,TAKE,ARMS,AGAINST,A,SEA,OF,TROUBLES,AND,BY,OPPOSING,END,THEM"},
                    { in => "88\tGEENNDSDEDIESOADESAORGODNOOEAODERSWREDYFNOYFAOWEEFGNKOSOIYEDYFFOEEEKDRNERIOWL,NKBETTMSZ,RM,H,,CGPHEYB,O,I,IUIIUI,,ANEEENEON,RAE,N,,OOSCCCLHHHHHCHMKCHLRRNTKBIIRG,EMHTMDHHMCRNN,EEOOOOOOFFF,,NNNENI,,SSTTTS,T,TSCCWG,HKSFLFFHHLLRRRRA,,DNNLAAO,,TDDL,,RCAIOAIIII,OEBPOS,CLEAA,LTRTL,,,OTRIEOIEEAIAAER,,IIIAII,,,,OIIEIIKHKTTKWYTKTWKORR,,,,,,POTPWIPTLFNNNNYF,,,,LSE,P,SAAEOUUETAII,,OOOOOEOUTTEAA,IRIOA,,,AN,IE,PNNX,,,,OCCHR,,,,,SNNN,,,DDOOTOEE,TT,ELLLLAK,O\n",
                      out => "RALLY,STOOD,EXTENDING,A,HAND,IN,NORIKO,S,DIRECTION,INCLINING,HER,HEAD,SLIGHTLY,SHE,LOOKED,TO,THE,OTHER,TWO,WOMEN,PLEASE,ALLOW,ME,TO,INTRODUCE,CHIEF,NORIKO,KOBAYASHI,SHE,IS,RESPONSIBLE,FOR,MAINTAINING,OUR,TOKYO,OFFICE,SHE,THEN,TURNED,BACK,TO,REGARD,NORIKO,DIRECTLY,NORIKO,I,D,LIKE,TO,INTRODUCE,TWO,OF,OUR,NEW,OFFICERS,MANA,ISOZAKI,WHO,HAS,BEEN,APPOINTED,CHIEF,OF,THE,OSAKA,OFFICE,AND,CAPTAIN,ANGELA,ELLIS,FORMERLY,OF,THE,NEW,YORK,POLICE,DEPARTMENT"},
                    { in => "0\tA,\n",
                      out => "A,"},
                    { in => "1\tA,\n",
                      out => ",A"},
                    { in => "0\tA,,\n",
                      out => "A,,"},
                    { in => "1\tA,,\n",
                      out => ",,A"},
                    { in => "2\tA,,\n",
                      out => ",A,"},
                    { in => "1\t,,\n",
                      out => ",,"},
                    ]}
         ],
};

# 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.21-tpr06";

# 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, $exit);
my (@files, @missing, $failed, $sum, %props, %programs, $missing, $ties);
my ($in_open, $show, $data_file);

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

my $GENERIC_NAME = "gentest.pl";
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,
               "b"		=> \$binary,
               "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,
               "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,
               "nop!"		=> \my $nop,
               "debug!"		=> \my $debug,
               );
if ($version) {
    print<<"EOF";
test data set version $tests->{version}
generic perl golf tester version $VERSION
EOF
    $exit = 1;
}

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);
    $exit = 1;
}

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

die "Can't specifiy both --full and --brief\n" if $brief && $full;
my $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");
    $exit = 1;
}

if ($update) {
    update();
    $exit = 1;
}

if (defined($dump)) {
    save($dump, $STORABLE);
    $exit = 1;
}

if (defined($save)) {
    save($save, $DUMPER);
    $exit = 1;
}

if (defined($single)) {
    save($single, $COMBO);
    $exit = 1;
}

if (defined($driver)) {
    save($driver, $DRIVER);
    $exit = 1;
}

if (defined($pod)) {
    save($pod, $POD);
    $exit = 1;
}

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};
    }
    $exit = 1;
}

exit 0 if $exit || $nop;

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 $^W = 0;	# Avoid perlio bitching
        open(FILE, "< $file") || die "Could not open $file: $!";
    }
    binmode FILE if $binary;
    my $all = <FILE>;
    close FILE;		# Avoid perlio assimilating low filedescriptors
    return $all;
}

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

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||1)/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) = @_;
    return 0 if $score == 0;
    my $sum;
    for (0..255) {
        $_ = chr;
        my $count = $code =~ s/\Q$_//g;
        $sum += $count * $count;
    }
    return(1-sqrt($sum)/$score)**2;
}

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

# 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)/;
    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)/;
        $hole_data->{program} = "$hole_data->{name}.pl" unless
            defined($hole_data->{program});
        die sprintf("Hole program '%s' contains invalid characters like ".
                    "'%s'(0x%02x)\n", $hole_data->{program}, $1, ord($1)) if
                        $hole_data->{program} =~ /([^$VALID]|\s)/;
    }
}

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

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

sub compare {
    my ($context, $file, $txt, $newline) = @_;
    my $all = slurp($file);
    $all = "" unless defined($all);
    $txt = join("", @$txt) if ref($txt);
    $txt .= "\n" if $newline;
    if ($txt ne $all) {
        $all =~ s/(?=\n)/$marker/g if $markers;
        $all =~ s/\n?\z//;
        $txt =~ s/(?=\n)/$marker/g if $markers;
        $txt =~ s/\n?\z//;
        die "Unexpected $context: Expected:\n$txt\nbut got:\n$all\n";
    }
}

# 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 string_line {
    my ($prefix, $str, $newline) = @_;
    $str = join("", @$str) if ref($str);
    $str .= "\n" if $newline || $str !~ /\n\z/;
    $str =~ s/(?=\n)/$marker/g if $markers;
    return "$prefix", $str =~ tr/\n// == 1 ? "" : "\n", $str;
}

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

# 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});
    show_string("    STDOUT: ", $test->{out}, $hole_data->{newline_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;
    }

    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(my $in = $test->{in})) {
            $in = join("", @$in) if ref($in);

            if ($in_open) {
                close STDIN;
                $in_open = 0;
            }

            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;
            close FILE;

            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";
        my $rc = system($wrapper, $test->{taint} ? "-T" : (), "--",
                        $props{$hole}{work}, @$args);
        if ($rc & 0x80) {
            print ERR "Program $file dumped core\n" unless $quiet;
            $rc &= ~0x80;
        }
        if ($rc & 0x7f) {
            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 (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, $hole_data->{newline_out});
        }
    };

    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" if $quiet;
            die $@;
        }
        print ERR $@ unless $quiet;
    } else {
        print ERR "Ok\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->{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);
    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 ($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} = count($hole, $hole_data->{tie});
    } 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];
                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->{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";
            $_->{set} = $set;
        } else {
            $_->{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;
    unlink($props{$_}{work}) for @files;
    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\n",
                        $name_length+1, "$props{$hole}{file}:",
                        $count_length,
                        sprintf("%.*f", $tie_digits, $props{$hole}{count}),
                        $norun ? "" : $props{$hole}{failed} ? "(fail)" : "(ok)"
                        );
        }
        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\n";
        } else {
            print OUT "Congratulations ! All tests passed for all holes\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.6.1",
    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";
    }
}

main();

1;

__END__

=head1 NAME

gentest.pl - Generic perl golf tester

=head1 SYNOPSIS

 gentest.pl
 gentest.pl [-b] [-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 [--dump file] [--save file] [--single file] [--driver file] [--pod file]
 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.

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, --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).

=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 --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 =>
            [
             {hole => "arginc",
              check =>
                  [{args =>  4, out =>  "5\n"}
                   {args =>  0, out =>  "1\n"}
                   {args => -1, out =>  "0\n"}
                   {args => -8, out => "-7\n"}]},
             {hole => "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.6.1",
        ...
    }

=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_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:

    ...
    {hole => "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 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:

    ...
    {hole => "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:

    ...
    {hole => "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.

Currently the builtin tie breakers are:

=over 12

=item high_ascii

=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). After the test has finished, the program output is compared to this
string and the test fails if they are not equal.

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>>.

=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:

    ...
    {hole => "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:

    ...
    {hole => "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