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

my $VERSION = "0.04";

my @tests =
    ("maxi2.pl" =>
     [
      [[], <<EOF],
AAAAAAAAAA
ABBDDAAAAA
ABBDDHAAAA
ACCDDHAAAA
ACCDDHAAAA
AAAAAHAAAA
AEEFFHAAAA
AEEFFHAAAA
AGGFFAIAAA
AAAAAAAAAA
EOF
      [[], <<EOF],
AAAAAAAAAA
AAAAAAAAAA
AJJJKKLLLA
AJEEEFFFLA
AJEEBBFFLA
AGGCBBDIIA
AGGCCDDIIA
AGGGHHIIIA
AAAAAAAAAA
AAAAAAAAAA
EOF
      [[], <<EOF],
AAAAAAAAAA
AAANNNNAAA
AJJJKKLLLA
AJEEEFFFLA
AJEEBBFFLA
AGGCBBDIIA
AGGCCDDIIA
AGGGHHIIIA
AAAMMMMAAA
AAAAAAAAAA
EOF
      [[], <<EOF],
AAAAAQQQQQ
ANNNNNNNNQ
JJJJKKLLLL
JJEEEFFFLL
JJEEBBFFLL
OGGCBBDIIP
OGGCCDDIIP
OGGGHHIIIP
OMMMMMMMMP
OOOOOPPPPP
EOF
      [[], <<EOF],
SBCDEFGHIJ
SBCDEFGHIJ
KKLLMMNNOJ
KKLLMMNNOJ
PPPQQQRRRJ
PPPQQQRRRJ
TTTTUUUUVJ
TTTTUUUUVJ
WWWWWXXXXJ
WWAWWXYZZJ
EOF
      [[], <<EOF],
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
BBBBBBBBBB
EOF
      [[], <<EOF],
ZZYXXXXXXX
ZYYRXMMMMX
RRRRXMMMMX
RRRRXMMMMX
VVVVVVVVVX
UUUUUUUXXX
WWWWWWWWWX
TTTTXSSSSX
TTTTXSSSSX
TTTTXXXXXX
EOF
      [[], <<EOF],
AAAAAAGGGG
BBBBBAHHHG
CCCCBAIIHG
DDDCBAJIHG
EEDCBAJHHG
FEDCBAJGGG
FDDCBAKKKK
FCCCBALLLK
FBBBBAMLLK
FAAAAAKKKK
EOF
      [[], <<EOF],
ZBCDEFGHIJ
KKKLLLMMMM
NNNNNNNNNN
OPQRSTUVVV
WWWXXXYYYV
AAAAAAAAAA
AAAAAAAAAA
AAAAAAAAAA
AAAAAAAAAA
AAAAAAAAAA
EOF
      [[], <<EOF],
AAAAAAAAAA
AIIIIIIIIA
AIJJJKKKIA
ADJQQQQKFA
BDJQRSQKFC
BGJQQQQKFC
BGOONNPPHC
BGOLLMMPHC
BGGGEEHHHC
BBBBBCCCCC
EOF
     ]
    );

use Getopt::Long;
Getopt::Long::config("bundling", "require_order");

my ($unsafe, $help, $version, $verbose, $binary, $markers,$force);
my (@files, $sum, %props);
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,
               "force!"		=> \$force,
               );
if ($version) {
    print<<"EOF";
generic perl golf tester $VERSION
EOF
    exit 0;
}

if ($help) {
    require Config;
    $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
    $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
    exec("perldoc", "-F", $unsafe ? "-U" : (), $0) || exit 1;
    # make parser happy
    %Config::Config = ();
}
my $marker = "|";

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

sub count {
    my $file = $props{+shift}{work};
    local (*FILE, $/);
    open(FILE, "< $file") || die "Could not open $file: $!\n";
    binmode FILE if $binary;
    defined(local $_=<FILE>) || return 0;
    s/\#! ?\S+\s?// if /^\#!/;
    s/\s*\z//;
    return length;
}

sub checker {
    my ($in, $out) = @_;
    my (%color, $i, @in, @out, %nei);
    die "wtf, input doesn't match regex!\n"
	if $in !~ /^([A-Z]{10}\n){10}\z/;
    die "output doesn't match regex!\n"
	if $out !~ /^([0-3]{10}\n){10}\z/;
    @in = $in =~ /./g;
    @out = $out =~ /./g;
    for ('A' .. 'Z') {
        $in =~ $_ or next;
	$color{$_} = substr $out, $-[0], 1;
    }
    for (0 .. $#in) {
	die "inconsistent output: $in[$_] colored to $out[$_] instead of early $color{$in[$_]}\n!"
	    if $out[$_] ne $color{$in[$_]};
        $_%10 > 0 and $nei{$in[$_]} .= $in[$_ -  1];
        $_ > 9    and $nei{$in[$_]} .= $in[$_ - 10];
        $_%10 < 9 and $nei{$in[$_]} .= $in[$_ +  1];
        $_ < 90   and $nei{$in[$_]} .= $in[$_ + 10];
    }
    for $i ('A' .. 'Z') {
        next if !exists $nei{$i};
	for ($nei{$i} =~ /./g) {
	    die "neighbours $_ and $i has the same color $color{$_}!\n"
		if $i ne $_ and $color{$i} eq $color{$_};
        }
    }
}

sub check_one {
    my ($file, $nr, $test) = @_;
    my ($args, $in, $out, $err, $exit, $name) = @$test;
    $err = "" if @$test <= 3;
    local(*FILE);
    my $in_file = "$file.in.$$";
    my $out_file = "$file.out.$$";
    my $err_file = "$file.err.$$";

    $args = "@$args" if ref($args);
    $in = join("", @$in) if ref($in);
    eval {
        $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub {
            die "Argh. Killed by signal";
        } if $^O !~ /Win/;
        open(FILE, "> $in_file") || die "Could not create $in_file: $!\n";
        print FILE $in;
        close FILE;
        local $/;
        open(FILE, "< $in_file") || die "Could not open $in_file: $!\n";
        my $all = <FILE>;
        if (!defined($all)) {
            die "unexpected short read from $in_file. Disk full ?\n" if
                $in ne "";
            $all = "";
        }
        $name = $_ unless defined($name) && $name ne "";
        printf STDERR "%s: Running test %2s ... ", $file, $name;
        my $rc = system("$^X $props{$file}{work} $args < $in_file >$out_file" . ($^O!~/Win/ && " 2>$err_file"));
        print STDERR "Program $file dumped core\n" if $rc & 0x80;
        print STDERR "Program $file killed by signal\n" if $rc & 0x7f;
        $rc = $rc >> 8;
        die "Program $file should finish with exitcode $exit, not $rc\n" if
            defined($exit) && $exit != $rc;

        if ($^O !~ /Win/ && defined($err)) {
            open(FILE, "< $err_file");
            $all = <FILE>;
            if (defined($all) && $all ne "") {
                if ($err eq "") {
                    $all =~ s/\n?\z/\n/;
                    die "Unexpected output on STDERR:\n$all";
                } elsif ($err ne $all) {
                    $all =~ s/\n?\z/\n/;
                    die "Expected '$err' on STDERR, but got:\n$all";
                }
            } elsif ($err ne "") {
                die "Expected '$err' on STDERR, but got nothing\n";
            }
        }

        open(FILE, "< $out_file") || die "Could not open $out_file: $!\n";
        my $any = <FILE>;
        $any = "" if !defined($any);
	checker ($in, $any);
    };
    unlink($in_file, $out_file, $err_file);
    if ($@) {
        die $@ unless $force;
        print STDERR $@;
    } else {
        print STDERR "Ok\n";
    }
}

sub copy {
    my $file = shift;
    $props{$file}{work} = my $new = "$file.$$";
    local (*IN, *OUT);
    open(IN, "< $file") || die "Could not open $file: $!";
    binmode(IN);
    open(OUT, "> $new") || die "Could not create $new: $!";
    binmode(OUT);
    print OUT while <IN>;
}

sub check_all {
    my ($file, $test) = @_;
    die "Already tested $file\n" if exists $props{$file};
    push(@files, $file);
    copy($file);
    $sum += $props{$file}{count} = count($file);
    check_one($file, $_, $test->[$_-1]) for 1..@$test;
}

sub check_data {
    @tests % 2 && die "Odd number of values in \@test\n";
    eval {
        check_all(shift @tests, shift @tests) while @tests;
    };
    unlink($props{$_}{work}) for @files;
    die $@ if $@;
    my $count_length = length($sum);
    my $name_length = 1e9;
    for my $file (@files) {
        $name_length = length($file) if length($file) < $name_length;
    }
    for my $file (@files) {
        printf("%*d: %-*s\n",
                $count_length, $props{$file}{count},
                $name_length, $file);
    }
    if (@files > 1) {
        printf("%s\n%*d\n", "-" x $count_length,
               $count_length, $sum);
    }
}

#check_data($_) for @ARGV;
check_data();

__END__

=head1 NAME

gentest.pl - Generic perl golf tester

=head1 OPTIONS

=over 4

=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 the
difference will not matter. 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 --force

Keep running even after errors.

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

=back