use strict;
use IO::File;
use IPC::Open3;
use Data::Dumper;
use Test;
my $CC = 'cc';
my @CFLAGS = qw( -Wall -g );
my $TEST = './ma_test';
END {
$ENV{MEMALLOC_TEST_NO_CLEANUP} or cleanup();
}
sub test {
my %opt = (
PLAN => 0,
CFLAGS => [],
TESTS => [
{
ENV => {},
},
{
ENV => {
MEMALLOC_TEST_DEBUG => 1,
},
},
{
ENV => {
MEMALLOC_TEST_ASSERT => 1,
},
},
{
ENV => {
MEMALLOC_TEST_ASSERT => 1,
MEMALLOC_TEST_DEBUG => 1,
},
},
{
ENV => {
MEMALLOC_CHECK_FREED => 1,
},
},
{
ENV => {
MEMALLOC_CHECK_FREED => 1,
MEMALLOC_TEST_DEBUG => 1,
},
},
{
ENV => {
MEMALLOC_CHECK_FREED => 1,
MEMALLOC_TEST_ASSERT => 1,
},
},
{
ENV => {
MEMALLOC_CHECK_FREED => 1,
MEMALLOC_TEST_ASSERT => 1,
MEMALLOC_TEST_DEBUG => 1,
},
},
],
@_
);
plan( tests => $opt{PLAN} );
my @tests = @{$opt{TESTS}};
push @tests, map { { %$_, FILE => 'test.out' } } @tests;
cleanup();
ok(1);
build( %opt, SOURCE => 'memalloc.c', OUTPUT => $TEST )
or die "couldn't build test\n";
ok(1);
for my $t ( @tests ) {
my %env = %{$t->{ENV}};
if (exists $t->{FILE}) {
$env{MEMALLOC_TEST_DEBUG_FILE} = $t->{FILE};
}
$env{MEMALLOC_SOFT_ASSERT} = 1;
comment(Dumper(\%env));
my $rv = run( \%env, $TEST );
comment(Dumper($rv));
$rv->{didnotrun} and die "couldn't run test\n";
ok($rv->{status}, 0);
ok(not exists $rv->{core});
ok(not exists $rv->{signal});
ok(scalar @{$rv->{stdout}}, 0, "output on stdout");
-f 'test.ref' or die "no reference file\n";
ok(1);
my @ref = slurp('test.ref');
my @out;
if (exists $t->{FILE}) {
ok(scalar @{$rv->{stderr}}, 0, "output on stderr");
ok(-f $t->{FILE});
@out = slurp($t->{FILE});
}
else {
@out = @{$rv->{stderr}};
}
ok(scalar @out, scalar @ref, "differing number of lines in output/reference");
comment( "[Output]\n", @out, "[/Output]\n" );
comment( "[Reference]\n", @ref, "[/Reference]\n" );
chomp @ref;
chomp @out;
for my $i ( 0 .. $#ref ) {
print qq(# "$out[$i]" - "$ref[$i]"\n);
ok($out[$i], $ref[$i]);
}
rm( qw( test.out test.ref ) );
}
}
sub slurp {
my $file = new IO::File $_[0] or die "$_[0]: $!\n";
<$file>;
}
sub cleanup { rm( qw( test.out test.ref ), $TEST ) }
sub rm { -f and unlink || warn "$_: $!" for @_ }
sub build {
my %opt = (
CC => $CC,
CFLAGS => [],
@_
);
my @cflags = (@CFLAGS, @{$opt{CFLAGS}});
my $target;
if (exists $opt{OBJECT}) {
push @cflags, '-c';
$target = $opt{OBJECT};
}
elsif (exists $opt{OUTPUT}) {
$target = $opt{OUTPUT};
}
else {
return 0;
}
unless (exists $opt{SOURCE}) {
return 0;
}
my $source = ref $opt{SOURCE} ? $opt{SOURCE} : [$opt{SOURCE}];
for my $s (@$source) {
unless (-f $s) {
return 0;
}
}
my $rv = run( $opt{CC}, @cflags, '-o', $target, @$source );
comment(Dumper($rv));
@{$rv->{stderr}} and print STDERR "compiler output on stderr\n";
@{$rv->{stdout}} and print STDERR "compiler output on stdout\n";
if ($rv->{didnotrun} || $rv->{status}) {
return 0;
}
return $target;
}
sub comment
{
my @d = @_;
s/^/# /gm for @d;
print @d;
}
sub run
{
my $env = ref $_[0] ? shift : {};
my $prog = shift;
my @args = @_;
local(*W, *S, *E);
for my $e ( keys %$env ) {
$ENV{$e} = $env->{$e};
}
my $pid = open3(\*W, \*S, \*E, $prog, @args);
my @sout = <S>;
my @serr = <E>;
waitpid($pid, 0);
for my $e ( keys %$env ) {
delete $ENV{$e};
}
my %rval = (
status => $? >> 8,
stdout => \@sout,
stderr => \@serr,
);
$rval{didnotrun} = 0;
if( @serr && $serr[0] =~ /^Can't exec "\Q$prog\E":/ ) {
$rval{didnotrun} = 1;
}
if( $^O eq 'MSWin32' && $rval{status} == 1 ) {
$rval{didnotrun} = 1;
}
$? & 128 and $rval{core} = 1;
$? & 127 and $rval{signal} = $? & 127;
\%rval;
}