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

my @tests =
    ("mini3.pl" =>
     [
      [[], lines(5,3,1,3),lines(1,1,3,3,4)],
      [[], lines(5),lines(1,1,1,1,1),""],
      [[], lines(5,4,5,4,5,4,5,4,5,4,5),lines(6,11,11,11,11)],
      [[], lines(1,3,9,7,8,1,2,3),lines(1,2,3,3,3,3,5,6,8)],
      [[], lines(1),lines(1)],
      [[], lines(1,1),lines(2)],
      [[], lines(2),lines(1,1)],
      [[], "1\n"x1000,lines(1000)],
      [[], ["1\n"x334,"2\n"x333],lines(333,667)],
      ],
     );

my $VERSION = "0.01";

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 = shift;
    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 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);
    open(FILE, "> $in_file") || die "Could not create $in_file: $!\n";
    eval {
        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 "";
        print STDERR "$file: Running test $name ... ";
        my $rc = system("$^X $file $args < $in_file >$out_file 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 (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";
        $all = <FILE>;
        $all = "" if !defined($all);
        $out = join("", @$out) if ref($out);
        if ($all ne $out) {
            $all =~ s/(?=\n)/$marker/g if $markers;
            $all =~ s/\n?\z//;
            $out =~ s/(?=\n)/$marker/g if $markers;
            $out =~ s/\n?\z//;
            die "Wrong output. Expected:\n$out\nbut got:\n$all\n";
        }
    };
    unlink($in_file, $out_file, $err_file);
    if ($@) {
        die $@ unless $force;
        print STDERR $@;
    } else {
        print STDERR "Ok\n";
    }
}

sub check_all {
    my ($file, $test) = @_;
    die "Already tested $file\n" if exists $props{$file};
    push(@files, $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";
    check_all(shift @tests, shift @tests) while @tests;
    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