#! /usr/bin/perl -w
use strict;

$::tests = {
    version => 3,
    course => "mex",
    perl => "5.6.1",
    holes =>
        [{name => "mini4",
          newline => 1,
          check => [
                    {args => "", out => 0 },
                    {args => "3 7 13 15 0 1 0 4 21 5 13 13 13 9 10 12 8 6", 
                     out => 2},
                    {args => 0, out => 1},
                    {args => "0 0 0", out => 1},
                    {args => 1, out => 0},
                    {args => 2, out => 0},
                    {args => 999999, out => 0},
                    {args => "0 1 2", out => 3},
                    {args => "0 1 3", out => 2},
                    {args => "1 2 3", out => 0},
                    {args => "2 1 0", out => 3},
                    {args => "3 1 0", out => 2},
                    {args => "1 2 3 2 1", out => 0},
                    {args => "0 1 2 1 0", out => 3},
                    {args => "0 1 3 1 0", out => 2},
                    {args => "3 2 1", out => 0},
                    {args => "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29", out => 30},
                    {args => "0 1 2 3 4 5 6 7 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30", out => 8},
                    {args => "29 28 27 26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0", out => 30},
                    {args => "0 12 11 8 5 3 6 4", out => 1},
                    ],
          }],
};

# CODE START
# Don't remove this comment block
# You normally shouldn't change anything below this point.

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

# 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 $INVALID = qq([\t\r\n\0=\\\'\"]);	# " (silly emacs)

my ($unsafe, $help, $version, $verbose, $list, $binary, $markers,$force);
my (@files, @missing, $failed, $sum, %props, %programs, $missing, $ties);
my ($norun, $data_file, $full, $brief, $nr_ties, $quiet, $dump, $save, $exit);
my ($single, $driver, $nop, $tie_digits, $pod, $debug, $fetch, $in_open);

my $marker = "|";
my $executor = "/usr/bin/env";

my $generic_name = "gentest.pl";
my $generic = $0 =~ /\b\Q$generic_name\E\z/;
restore(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!"	=> \$version,
               "verbose!"	=> \$verbose,
               "v"		=> \$verbose,
               "markers!"	=> \$markers,
               "m"		=> \$markers,
               "binary!"	=> \$binary,
               "b"		=> \$binary,
               "data_file=s"	=> \$data_file,
               "force!"		=> \$force,
               "tie_digits=i"	=> \$tie_digits,
               "program=s"	=> \%programs,
               "p=s"		=> \%programs,
               "quiet!"		=> \$quiet,
               "full!"		=> \$full,
               "brief!"		=> \$brief,
               "list!"		=> \$list,
               "l"		=> \$list,
               "n"		=> \$norun,
               "no_checks!"	=> \$norun,
               "dump=s"		=> \$dump,
               "save=s"		=> \$save,
               "single=s"	=> \$single,
               "driver=s"	=> \$driver,
               "pod=s"		=> \$pod,
               "fetch=s"	=> \$fetch,
               "nop!"		=> \$nop,
               "debug!"		=> \$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'}";
    if (0) {
        # scanning the file is very slow
        exec("perldoc", "-F", $unsafe ? "-U" : (), $0) || exit 1;
        # make parser happy
        %Config::Config = ();
    } else {
        my $file = $0;
        $file =~ s/\.pl\z//i;
        $file .= ".pod.$$";
        save($file, 4);
        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;

restore($data_file) if !$generic && defined($data_file);
data_check();

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

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

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

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

if (defined($pod)) {
    save($pod, 4);
    $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;
}

if ($fetch) {
    fetch_file($fetch, "$::tests->{base_url}/fun.txt");
    $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 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/$nr_ties;
}

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

# Quick sanity check on $::tests fields
sub data_check {
    $::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} =~ /($INVALID)/;
    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} =~ /($INVALID|\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} =~ /($INVALID|\s)/;
    }
}

sub restore {
    my $file = shift;
    local (*FILE, $_);
    open(FILE, "< $file") || die "Could not open $file for read: $!";
    defined($_ = <FILE>) || die "$file seems empty\n";
    if (my ($arg) = /^\#! ?\S*perl\S*\s+(\S+)\s*$/) {
        # seems pure perl code
        my $rc = system("./$file", "--nop");
        die "Unexpected returncode $rc from ./$file --nop\n" if $rc;
    } elsif (/^=/) {
        # smells like pod
        # no sane pod checks currently
    } else {
        # Storable dump or Data:Dumper
        defined($_ = <FILE>) || 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;

            require Storable;
            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";
        } else {
            require $file;
        }
    }
}

sub save {
    my ($file, $pretty) = @_;
    my $new = "$file.new.$$";
    local *FILE;
    new_file(local *FILE, $new, 0777);
    binmode FILE;
    eval {
        if ($pretty) {
            unless ($pretty == 4) {
                require Data::Dumper;
                $Data::Dumper::Indent = 1;
                if ($pretty > 1) {
                    print FILE "#! /usr/bin/perl -w\n";
                } else {
                    print FILE "#! $executor $generic_name\n";
                }
                if ($pretty == 3) {
                    print FILE <<'EOF';
use strict;

$::tests = {
    version => 1,
    holes =>
       [
       # hole definitions and tests go here
       ],
};
EOF
    ;
                } else {
                    print FILE <<'EOF';
use strict;

use vars qw($VAR1);
$::tests =
EOF
    ;
                    print FILE Data::Dumper::Dumper($::tests);
                }
            }
            if ($pretty > 1) {
                local (*CODE, $_);
                open(CODE, "< $0") || die "Could not open $0 for read: $!";
                binmode CODE;
                my $magic = $pretty == 4 ? "__END__" : "# CODE START";
                while (<CODE>) {
                    last if /^\Q$magic\E\s*$/;
                }
                die "Could not find magic marker '$magic' in $0\n" unless
                    defined($_);
                if ($pretty == 4) {
                    while(<CODE>) {
                        last if /^=/;
                    }
                    die "Could not find actual pod in $0\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" unless $pretty > 1;
        close FILE;

        restore($new);

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

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

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

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

    my $new = "$file.new.$$";
    new_file(local *FILE, $new);
    eval {
        binmode FILE;
        print FILE $res->content;
        close FILE;

        local $/;
        open(FILE, "< $file") || die "Could not open '$file': $!";
        binmode FILE;
        my $line = <FILE>;
        $line eq $res->content || 
            die "'$file' doesn't contain what just got written. Disk full ?\n";
        
        rename($new, $file) || die "Could not rename $new to $file: $!";
    };
    if ($@) {
        unlink($new);
        die $@;
    }

}

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

sub count {
    my ($hole, $tie) = @_;
    my $file = $props{$hole}{work};
    local (*FILE, $/);
    open(FILE, "< $file") || die "Could not open $file: $!\n";
    binmode FILE if $binary;
    defined(local $_=<FILE>) || return 0;
    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);
        $ties++;
    }
    return $score;
}

sub compare {
    my ($context, $file, $txt, $newline) = @_;
    open(local *FILE, "< $file") || die "Could not open $file: $!";
    my $all = <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";
    }
}

# 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
sub check_single {
    my ($hole_data, $nr, $test) = @_;

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

    my $set = $hole_data->{set};
    if (defined($test->{set})) {
        defined($set = $set_map{lc($test->{set})}) ||
            die "Hole $hole, test $nr: Unknown set type $test->{set}\n";
    }
    return if $set > $do_set;

    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 = $test->{args};
    $args = "" unless defined($args);
    $args = [split " ", $args] if !ref($args);
    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";
        };

        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;

            open(FILE, "< $in_file") || 
                die "Could not open $in_file: $!\n";
            my $all = <FILE>;
            $all = "" if !defined($all);
            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);

        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++;
        # print ERR "$^X, $props{$hole}{work}, @$args\n";
        my $rc = system($^X, $props{$hole}{work}, @$args);
        print ERR "Program $file dumped core\n" if ($rc & 0x80) && !$quiet;
        die "Program $file killed by signal\n" if $rc & 0x7f;
        $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 (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});
        }
    };
    close STDERR;
    close STDOUT;
    unlink($out_file, $err_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;
    }
}

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>;
    return 1;
}

sub check_hole {
    my $hole_data = shift;
    my $hole = $hole_data->{name};
    my $test = $hole_data->{check};

    print ERR "Checking hole '$hole'", $quiet ? "..." : "\n" unless $norun;
    die "Already tested $hole\n" if exists $props{$hole};
    if (copy($hole_data)) {
        push(@files, $hole);
        $sum += $props{$hole}{count} = count($hole, $hole_data->{tie});
        unless ($norun) {
            eval {
                close STDOUT;
                close STDERR;
                check_single($hole_data, $_, $test->[$_-1]) for 1..@$test;
            };
            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: $!";
            open(STDERR, ">&ERR") || die "Could not restore STDERR: $!";

            die $@ if $@;
        }
    } 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;
}

{
    my %abbrev;

    sub build_abbrevs {
        for (@{$::tests->{holes}}) {
            my $hole = lc($_->{name});
            do {
                push(@{$abbrev{$hole}}, $_->{name});
                chop $hole;
            } while $hole ne "";
        }
        return \%abbrev;
    }

    sub lookup_abbrev {
        my $name = shift;
        defined(my $targets = $abbrev{lc $name}) ||
            die "Never heard of hole '$name'\n";
        die("Multiple matches for '$name': ", join(", ", @$targets), "\n") if
            @$targets > 1;
        return $targets->[0];
    }
}

sub show_holes {
    my (%work_programs, %holes);
    my $abbrev = build_abbrevs;

    $work_programs{lookup_abbrev($_)} = $programs{$_} for keys %programs;
    %programs = %work_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;
    if (@_) {
        @to_test = map {$holes{lookup_abbrev($_)} ||
                            die "Never heard of hole $_\n"} @_;
    } else {
        @to_test = @{$::tests->{holes}};
    }
    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) = $] =~ /^(\d+)\.(\d{1,3})(\d*)$/ or
            die "Could not parse running perl version $]\n";
        $Main+=0;
        $Sub +=0;
        $Rel = $Rel ? $Rel+0 : 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 (!$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";
        }
    }
}

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 {
    show_holes(@ARGV);
};
if ($@) {
    print ERR $@;
    exit 1;
}

__END__

=head1 NAME

gentest.pl - Generic perl golf tester

=head1 SYNOPSIS

 gentest.pl
 gentest.pl [-b] [-m] [--tie_digits=num] {-phole=file} [--force] [--full | --brief] [-n] {hole}
 gentest.pl -l
 gentest.pl --data_file data_file
 gentest.pl [-U] [-h]
 gentest.pl --version
 gentest.pl [--dump file] [--save file] [--single file] [--driver file] [--pod file]
 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.

In all places where you enter hole names, it's enough to specify enough
of the start letters to uniquely identify the hole.

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

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 -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 --tie_digits=num

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

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

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.

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

=item --version

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

=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

=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|newline> 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
C<\n> or C<=>.

=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 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 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 [\s='"\0]. Defaults to "hole".

=item program

The default name for the user program that will try to solve this hole.
Should not contain [\s='"\0]. The user can always override this 
using L<--prog|--prog>.

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

=item newline

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 => 1,
        check =>
            [{args =>  4, out =>  5}
             {args =>  0, out =>  1}
             {args => -1, out =>  0}
             {args => -8, out => -7}]},
    ...

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

=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