X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b26492eee9e9f6169aa5698b42a13506468cb846..233e16ceab6589cdfcfeefabef027f39026bb05f:/t/TEST diff --git a/t/TEST b/t/TEST index 08787e2..c601e45 100755 --- a/t/TEST +++ b/t/TEST @@ -1,36 +1,43 @@ #!./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; +# for testing TEST only +#BEGIN { require '../lib/strict.pm'; strict->import() }; +#BEGIN { require '../lib/warnings.pm'; warnings->import() }; + # Let tests know they're running in the perl core. Useful for modules # which live dual lives on CPAN. $ENV{PERL_CORE} = 1; # remove empty elements due to insertion of empty symbols via "''p1'" syntax @ARGV = grep($_,@ARGV) if $^O eq 'VMS'; +our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; # Cheesy version of Getopt::Std. Maybe we should replace it with that. -@argv = (); -if ($#ARGV >= 0) { +{ + my @argv = (); foreach my $idx (0..$#ARGV) { push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/; - $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'; - $bytecompile = 1 if $1 eq 'bytecompile'; - $compile = 1 if $1 eq 'compile'; - $taintwarn = 1 if $1 eq 'taintwarn'; + $::core = 1 if $1 eq 'core'; + $::verbose = 1 if $1 eq 'v'; + $::torture = 1 if $1 eq 'torture'; + $::with_utf8 = 1 if $1 eq 'utf8'; + $::with_utf16 = 1 if $1 eq 'utf16'; + $::taintwarn = 1 if $1 eq 'taintwarn'; + $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; if ($1 =~ /^deparse(,.+)?$/) { - $deparse = 1; - $deparse_opts = $1; + $::deparse = 1; + $::deparse_opts = $1; } } + @ARGV = @argv; } -@ARGV = @argv; chdir 't' if -f 't/TEST'; @@ -60,6 +67,7 @@ $ENV{EMXSHELL} = 'sh'; # For OS/2 # Roll your own File::Find! use TestInit; use File::Spec; +if ($show_elapsed_time) { require Time::HiRes } my $curdir = File::Spec->curdir; my $updir = File::Spec->updir; @@ -67,13 +75,14 @@ sub _find_tests { my($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); + my $fullpath = File::Spec->catfile($dir, $f); - _find_tests($fullpath) if -d $fullpath; - $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS'; - push @ARGV, $fullpath if $f =~ /\.t$/; + _find_tests($fullpath) if -d $fullpath; + $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS'; + push @ARGV, $fullpath if $f =~ /\.t$/; } } @@ -90,63 +99,111 @@ 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($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"; + } } - _find_tests("lib") unless $core; my $mani = File::Spec->catfile($updir, "MANIFEST"); if (open(MANI, $mani)) { - while () { # similar code in t/harness - if (m!^(ext/\S+/?(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { - $t = $1; - if (!$core || $t =~ m!^lib/[a-z]!) + my $ext_pat = $^O eq 'MSWin32' ? '(?:win32/)?ext' : 'ext'; + while () { # similar code in t/harness + if (m!^($ext_pat/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { + my $t = $1; + my $extension = $2; + if (!$::core || $t =~ m!^lib/[a-z]!) { - $path = File::Spec->catfile($updir, $t); + if (defined $extension) { + $extension =~ s!/t$!!; + # XXX Do I want to warn that I'm skipping these? + next if $skip{$extension}; + } + my $path = File::Spec->catfile($updir, $t); push @ARGV, $path; - $name{$path} = $t; + $::path_to_name{$path} = $t; } } } close MANI; } else { - warn "$0: cannot open $mani: $!\n"; + warn "$0: cannot open $mani: $!\n"; } - unless ($core) { + unless ($::core) { _find_tests('pod'); _find_tests('x2p'); - _find_tests('japh') if $torture; + _find_tests('japh') if $::torture; } } -# Tests known to cause infinite loops for the perlcc tests. -# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); -%infinite = (); - -if ($deparse) { +if ($::deparse) { _testprogs('deparse', '', @ARGV); } -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(U); + } + close(A); + } + } + _testprogs('perl', '', @UARGV); + unlink(@UARGV); + } + } } else { - _testprogs('compile', '', @ARGV) if -e "../testcompile"; _testprogs('perl', '', @ARGV); } sub _testprogs { - $type = shift @_; - $args = shift; - @tests = @_; - - print <<'EOT' if ($type eq 'compile'); ------------------------------------------------------------------------------- -TESTING COMPILER ------------------------------------------------------------------------------- -EOT + my ($type, $args, @tests) = @_; print <<'EOT' if ($type eq 'deparse'); ------------------------------------------------------------------------------ @@ -154,44 +211,34 @@ TESTING DEPARSER ------------------------------------------------------------------------------ EOT - print <catfile('t',$t); - $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; - $name{$t} = $tname; + unless (exists $::path_to_name{$t}) { + my $tname = File::Spec->catfile('t',$t); + $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS'; + $::path_to_name{$t} = $tname; } } my $maxlen = 0; - foreach (@name{@tests}) { + foreach (@::path_to_name{@tests}) { s/\.\w+\z/./; my $len = length ; $maxlen = $len if $len > $maxlen; } # + 3 : we want three dots between the test name and the "ok" - $dotdotdot = $maxlen + 3 ; + my $dotdotdot = $maxlen + 3 ; my $valgrind = 0; my $valgrind_log = 'current.valgrind'; - while ($test = shift @tests) { + my $total_files = @tests; + my $good_files = 0; + my $tested_files = 0; + my $totmax = 0; + my %failed_tests; + + while (my $test = shift @tests) { + my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0; - if ( $infinite{$test} && $type eq 'compile' ) { - print STDERR "$test creates infinite loop! Skipping.\n"; - next; - } if ($test =~ /^$/) { next; } @@ -205,32 +252,37 @@ EOT next; } } - $te = $name{$test} . '.' x ($dotdotdot - length($name{$test})); + my $te = $::path_to_name{$test} . '.' + x ($dotdotdot - length($::path_to_name{$test})); if ($^O ne 'VMS') { # defer printing on VMS due to piping bug print $te; $te = ''; } - $test = $OVER{$test} if exists $OVER{$test}; + # XXX DAPM %OVER not defined anywhere + # $test = $OVER{$test} if exists $OVER{$test}; - open(SCRIPT,"<$test") or die "Can't run $test.\n"; - $_ =