X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2FTEST;h=38afe6f6910fe05d6d30fcd9b184b8a9e7c54076;hb=784fea9c399df2b90bca112fecf00acbb3989212;hp=9ac287a7f4a5794a668313d103eca43f45c87476;hpb=5dc83c4054cb6624685a80f58caabe5e173a543f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/TEST b/t/TEST index 9ac287a..38afe6f 100755 --- a/t/TEST +++ b/t/TEST @@ -1,7 +1,9 @@ #!./perl # This is written in a peculiar style, since we're trying to avoid -# most of the constructs we'll be testing for. +# most of the constructs we'll be testing for. (This comment is +# probably obsolete on the avoidance side, though still currrent +# on the peculiarity side.) $| = 1; @@ -20,9 +22,12 @@ if ($#ARGV >= 0) { $core = 1 if $1 eq 'core'; $verbose = 1 if $1 eq 'v'; $torture = 1 if $1 eq 'torture'; - $with_utf= 1 if $1 eq 'utf8'; - $byte_compile = 1 if $1 eq 'bytecompile'; - $compile = 1 if $1 eq 'compile'; + $with_utf8 = 1 if $1 eq 'utf8'; + $with_utf16 = 1 if $1 eq 'utf16'; + $bytecompile = 1 if $1 eq 'bytecompile'; + $compile = 1 if $1 eq 'compile'; + $taintwarn = 1 if $1 eq 'taintwarn'; + $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; if ($1 =~ /^deparse(,.+)?$/) { $deparse = 1; $deparse_opts = $1; @@ -64,9 +69,10 @@ my $updir = File::Spec->updir; sub _find_tests { my($dir) = @_; - opendir DIR, $dir || die "Trouble opening $dir: $!"; + opendir DIR, $dir or die "Trouble opening $dir: $!"; foreach my $f (sort { $a cmp $b } readdir DIR) { - next if $f eq $curdir or $f eq $updir; + next if $f eq $curdir or $f eq $updir or + $f =~ /^(?:CVS|RCS|SCCS|\.svn)$/; my $fullpath = File::Spec->catfile($dir, $f); @@ -89,18 +95,58 @@ sub _quote_args { return $argstring; } +sub _populate_hash { + return map {$_, 1} split /\s+/, $_[0]; +} + unless (@ARGV) { foreach my $dir (qw(base comp cmd run io op uni)) { _find_tests($dir); } _find_tests("lib") unless $core; + # Config.pm may be broken for make minitest. And this is only a refinement + # for skipping tests on non-default builds, so it is allowed to fail. + # What we want to to is make a list of extensions which we did not build. + my $configsh = File::Spec->catfile($updir, "config.sh"); + my %skip; + if (-f $configsh) { + my (%extensions, %known_extensions); + open FH, $configsh or die "Can't open $configsh: $!"; + while () { + if (/^extensions=['"](.*)['"]$/) { + # Deliberate string interpolation to avoid triggering possible + # $1 resetting bugs. + %extensions = _populate_hash ("$1"); + } + elsif (/^known_extensions=['"](.*)['"]$/) { + %known_extensions = _populate_hash ($1); + } + } + if (%extensions) { + if (%known_extensions) { + foreach (keys %known_extensions) { + $skip{$_}++ unless $extensions{$_}; + } + } else { + warn "No known_extensions line found in $configsh"; + } + } else { + warn "No extensions line found in $configsh"; + } + } my $mani = File::Spec->catfile($updir, "MANIFEST"); if (open(MANI, $mani)) { while () { # similar code in t/harness - if (m!^(ext/\S+/?([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { + if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { $t = $1; + $extension = $2; if (!$core || $t =~ m!^lib/[a-z]!) { + if (defined $extension) { + $extension =~ s!/t$!!; + # XXX Do I want to warn that I'm skipping these? + next if $skip{$extension}; + } $path = File::Spec->catfile($updir, $t); push @ARGV, $path; $name{$path} = $t; @@ -112,7 +158,7 @@ unless (@ARGV) { warn "$0: cannot open $mani: $!\n"; } unless ($core) { - _find_tests('pod'); + _find_tests('pod'); _find_tests('x2p'); _find_tests('japh') if $torture; } @@ -125,9 +171,37 @@ unless (@ARGV) { if ($deparse) { _testprogs('deparse', '', @ARGV); } -elsif( $compile || $byte_compile ) { - _testprogs('compile', '', @ARGV) if $compile; - _testprogs('compile', '-B', @ARGV) if $byte_compile; +elsif( $compile ) { + _testprogs('compile', '', @ARGV); +} +elsif( $bytecompile ) { + _testprogs('bytecompile', '', @ARGV); +} +elsif ($with_utf16) { + for my $e (0, 1) { + for my $b (0, 1) { + print STDERR "# ENDIAN $e BOM $b\n"; + my @UARGV; + for my $a (@ARGV) { + my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : ""); + my $f = $e ? "v" : "n"; + push @UARGV, $u; + unlink($u); + if (open(A, $a)) { + if (open(U, ">$u")) { + print U pack("$f", 0xFEFF) if $b; + while () { + print U pack("$f*", unpack("C*", $_)); + } + close(A); + } + close(B); + } + } + _testprogs('perl', '', @UARGV); + unlink(@UARGV); + } + } } else { _testprogs('compile', '', @ARGV) if -e "../testcompile"; @@ -151,6 +225,12 @@ TESTING DEPARSER ------------------------------------------------------------------------------ EOT + print <; close(SCRIPT) unless ($type eq 'deparse'); + if ($with_utf16) { + $_ =~ tr/\0//d; + } if (/#!.*\bperl.*\s-\w*([tT])/) { $switch = qq{"-$1"}; } else { - $switch = ''; + if ($taintwarn) { + # not all tests are expected to pass with this option + $switch = '"-t"'; + } + else { + $switch = ''; + } } my $test_executable; # for 'compile' tests @@ -224,21 +315,52 @@ EOT close(SCRIPT); } - my $utf = $with_utf ? '-I../lib -Mutf8' : ''; + my $utf8 = $with_utf8 ? '-I../lib -Mutf8' : ''; my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC if ($type eq 'deparse') { my $deparse = - "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,". + "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,". "-l$deparse_opts$file_opts ". "$test > $test.dp ". "&& ./perl $testswitch $switch -I../lib $test.dp |"; open(RESULTS, $deparse) or print "can't deparse '$deparse': $!.\n"; } + elsif ($type eq 'bytecompile') { + my ($pwd, $null); + if( $^O eq 'MSWin32') { + $pwd = `cd`; + $null = 'nul'; + } else { + $pwd = `pwd`; + $null = '/dev/null'; + } + chomp $pwd; + my $perl = $ENV{PERL} || "$pwd/perl"; + my $bswitch = "-MO=Bytecode,-H,-TI,-s$pwd/$test,"; + $bswitch .= "-TF$test.plc," + if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB); + $bswitch .= "-k," + if $test =~ m(deparse|terse|ext/Storable/t/code); + $bswitch .= "-b," + if $test =~ m(op/getpid); + my $bytecompile = + "$perl $testswitch $switch -I../lib $bswitch". + "-o$test.plc $test 2>$null &&". + "$perl $testswitch $switch -I../lib $utf8 $test.plc |"; + open(RESULTS,$bytecompile) + or print "can't byte-compile '$bytecompile': $!.\n"; + } elsif ($type eq 'perl') { my $perl = $ENV{PERL} || './perl'; - my $redir = ($^O eq 'VMS' ? '2>&1' : ''); - my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|"; + my $redir = $^O eq 'VMS' ? '2>&1' : ''; + if ($ENV{PERL_VALGRIND}) { + $perl = "valgrind --suppressions=perl.supp --leak-check=yes " + . "--leak-resolution=high --show-reachable=yes " + . "--num-callers=50 --logfile-fd=3 $perl"; + $redir = "3>$valgrind_log"; + } + my $run = "$perl" . _quote_args("$testswitch $switch $utf8") . " $test $redir|"; open(RESULTS,$run) or print "can't run '$run': $!.\n"; } else { @@ -246,7 +368,7 @@ EOT my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " . # -O9 for good measure, -fcog is broken ATM "$switch -Wb=-O9,-fno-cog -L .. " . - "-I \".. ../lib/CORE\" $args $utf $test -o "; + "-I \".. ../lib/CORE\" $args $utf8 $test -o "; if( $^O eq 'MSWin32' ) { $test_executable = "$test.exe"; @@ -275,35 +397,47 @@ EOT $ok = 0; $next = 0; + my $seen_leader = 0; + my $seen_ok = 0; while () { next if /^\s*$/; # skip blank lines if ($verbose) { print $_; } - unless (/^#/) { + unless (/^\#/) { if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { $max = $1; %todo = map { $_ => 1 } split / /, $3 if $3; $totmax += $max; $files += 1; - $next = 1; - $ok = 1; + unless ($seen_ok) { + $next = 1; + $ok = 1; + } + $seen_leader = 1; } else { - if (/^(not )?ok (\d+)[^#]*(\s*#.*)?/ && - $2 == $next) - { - my($not, $num, $extra) = ($1, $2, $3); - my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra; - $istodo = 1 if $todo{$num}; - - if( $not && !$istodo ) { - $ok = 0; - $next = $num; - last; + if (/^(not )?ok (\d+)[^\#]*(\s*\#.*)?/) { + unless ($seen_leader) { + unless ($seen_ok) { + $next = 1; + $ok = 1; + } } - else { - $next = $next + 1; + $seen_ok = 1; + if ($2 == $next) { + my($not, $num, $extra) = ($1, $2, $3); + my($istodo) = $extra =~ /#\s*TODO/ if $extra; + $istodo = 1 if $todo{$num}; + + if( $not && !$istodo ) { + $ok = 0; + $next = $num; + last; + } + else { + $next = $next + 1; + } } } elsif (/^Bail out!\s*(.*)/i) { # magic words @@ -316,16 +450,57 @@ EOT } } close RESULTS; + if ($ENV{PERL_VALGRIND}) { + my @valgrind; + if (-e $valgrind_log) { + if (open(V, $valgrind_log)) { + @valgrind = ; + close V; + } else { + warn "$0: Failed to open '$valgrind_log': $!\n"; + } + } + if (@valgrind) { + my $leaks = 0; + my $errors = 0; + for my $i (0..$#valgrind) { + local $_ = $valgrind[$i]; + if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) { + $errors += $1; # there may be multiple error summaries + } elsif (/^==\d+== LEAK SUMMARY:/) { + for my $off (1 .. 4) { + if ($valgrind[$i+$off] =~ + /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) { + $leaks += $1; + } + } + } + } + if ($errors or $leaks) { + if (rename $valgrind_log, "$test.valgrind") { + $valgrind++; + } else { + warn "$0: Failed to create '$test.valgrind': $!\n"; + } + } + } else { + warn "No valgrind output?\n"; + } + if (-e $valgrind_log) { + unlink $valgrind_log + or warn "$0: Failed to unlink '$valgrind_log': $!\n"; + } + } if ($type eq 'deparse') { unlink "./$test.dp"; } if ($ENV{PERL_3LOG}) { my $tpp = $test; - $tpp =~ s:^../::; + $tpp =~ s:^\.\./::; $tpp =~ s:/:_:g; - $tpp =~ s:\.t$::; - rename("perl.3log", "perl.3log.$tpp") || - die "rename: perl3.log to perl.3log.$tpp: $!\n"; + $tpp =~ s:\.t$:.3log:; + rename("perl.3log", $tpp) || + die "rename: perl3.log to $tpp: $!\n"; } $next = $next - 1; # test if the compiler compiled something @@ -345,7 +520,12 @@ EOT } else { $next += 1; - print "${te}FAILED at test $next\n"; + if ($next > $max) { + print "${te}FAILED at test $next\tpossibly due to extra output\n"; + } + else { + print "${te}FAILED at test $next\n"; + } $bad = $bad + 1; $_ = $test; if (/^base/) { @@ -410,5 +590,9 @@ SHRDLU_5 ($user,$sys,$cuser,$csys) = times; print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", $user,$sys,$cuser,$csys,$files,$totmax); + if ($ENV{PERL_VALGRIND}) { + my $s = $valgrind == 1 ? '' : 's'; + print "$valgrind valgrind report$s created.\n", ; + } } exit ($bad != 0);