X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2FTEST;h=58f1da5a5a611cfdcaf7cd73f3f70f498e6d653d;hb=a3323f52209391b4b2c45b3e1feb26c6f51fb6fa;hp=7be22f1dc0c8bd8bf90b6c00a95cf111e0dc0f1a;hpb=6990bd8313a66cf767ee8399392cba03106747f2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/TEST b/t/TEST index 7be22f1..58f1da5 100755 --- a/t/TEST +++ b/t/TEST @@ -1,31 +1,45 @@ #!./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.) + +# Location to put the Valgrind log. +my $Valgrind_Log = 'current.valgrind'; $| = 1; -# Let tests know they're running in the perl core. Useful for modules -# which live dual lives on CPAN. -$ENV{PERL_CORE} = 1; +# for testing TEST only +#BEGIN { require '../lib/strict.pm'; "strict"->import() }; +#BEGIN { require '../lib/warnings.pm'; "warnings"->import() }; + +delete $ENV{PERL5LIB}; + +# 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'; - $with_utf= 1 if $1 eq 'utf8'; - $byte_compile = 1 if $1 eq 'bytecompile'; - $compile = 1 if $1 eq 'compile'; + $::benchmark = 1 if $1 eq 'benchmark'; + $::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'; @@ -53,76 +67,266 @@ $ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; $ENV{EMXSHELL} = 'sh'; # For OS/2 # Roll your own File::Find! -use TestInit; -use File::Spec; -my $curdir = File::Spec->curdir; -my $updir = File::Spec->updir; +if ($show_elapsed_time) { require Time::HiRes } + +my %skip = ( + '.' => 1, + '..' => 1, + 'CVS' => 1, + 'RCS' => 1, + 'SCCS' => 1, + '.svn' => 1, + ); 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 $skip{$f}; - my $fullpath = File::Spec->catdir($dir, $f); + my $fullpath = "$dir/$f"; - _find_tests($fullpath) if -d $fullpath; - push @ARGV, $fullpath if $f =~ /\.t$/; + if (-d $fullpath) { + _find_tests($fullpath); + } elsif ($f =~ /\.t$/) { + push @ARGV, $fullpath; + } } } -unless (@ARGV) { - foreach my $dir (qw(base comp cmd run io op uni)) { - _find_tests($dir); + +# Scan the text of the test program to find switches and special options +# we might need to apply. +sub _scan_test { + my($test, $type) = @_; + + open(my $script, "<", $test) or die "Can't read $test.\n"; + my $first_line = <$script>; + + $first_line =~ tr/\0//d if $::with_utf16; + + my $switch = ""; + if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) { + $switch = qq{"-$1"}; + } else { + if ($::taintwarn) { + # not all tests are expected to pass with this option + $switch = '"-t"'; + } else { + $switch = ''; + } + } + + my $file_opts = ""; + if ($type eq 'deparse') { + # Look for #line directives which change the filename + while (<$script>) { + $file_opts .= ",-f$3$4" + if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/; + } + } + + return { file => $file_opts, switch => $switch }; +} + +# directories with special sets of test switches +my %dir_to_switch = + (base => '', + comp => '', + run => '', + ); + +sub _run_test { + my($test, $type) = @_; + + my $options = _scan_test($test, $type); + + my $perl = './perl'; + my $lib = '../lib'; + $test =~ /^([^\/]+)/; + + my $testswitch = $dir_to_switch{$1}; + if (!defined $testswitch) { + $testswitch = '-I. -MTestInit'; # -T will remove . from @INC + } + + my $utf8 = $::with_utf8 ? '-I$lib -Mutf8' : ''; + + my $results; + if ($type eq 'deparse') { + my $deparse_cmd = + "$perl $testswitch $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,". + "-l$::deparse_opts$options->{file} ". + "$test > $test.dp ". + "&& $perl $testswitch $options->{switch} -I$lib $test.dp |"; + open($results, $deparse_cmd) + or print "can't deparse '$deparse_cmd': $!.\n"; + } + elsif ($type eq 'perl') { + my $perl = $ENV{PERL} || $perl; + my $redir = $^O eq 'VMS' ? '2>&1' : ''; + + if ($ENV{PERL_VALGRIND}) { + my $valgrind = $ENV{VALGRIND} // 'valgrind'; + my $vg_opts = $ENV{VG_OPTS} + // "--suppressions=perl.supp --leak-check=yes " + . "--leak-resolution=high --show-reachable=yes " + . "--num-callers=50"; + $perl = "$valgrind --log-fd=3 $vg_opts $perl"; + $redir = "3>$Valgrind_Log"; + } + + my $run = $perl . _quote_args("$testswitch $options->{switch} $utf8") + . " $test $redir|"; + open($results, $run) or print "can't run '$run': $!.\n"; + } + + # Our environment may force us to use UTF-8, but we can't be sure that + # anything we're reading from will be generating (well formed) UTF-8 + # This may not be the best way - possibly we should unset ${^OPEN} up + # top? + binmode $results; + + return $results; +} + +sub _quote_args { + my ($args) = @_; + my $argstring = ''; + + foreach (split(/\s+/,$args)) { + # In VMS protect with doublequotes because otherwise + # DCL will lowercase -- unless already doublequoted. + $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0; + $argstring .= ' ' . $_; + } + return $argstring; +} + +sub _populate_hash { + return unless defined $_[0]; + return map {$_, 1} split /\s+/, $_[0]; +} + +sub _tests_from_manifest { + my ($extensions, $known_extensions) = @_; + my %skip; + my %extensions = _populate_hash($extensions); + my %known_extensions = _populate_hash($known_extensions); + + foreach (keys %known_extensions) { + $skip{$_}++ unless $extensions{$_}; } - _find_tests("lib") unless $core; - my $mani = File::Spec->catdir($updir, "MANIFEST"); + + my @results; + my $mani = '../MANIFEST'; if (open(MANI, $mani)) { - while () { # similar code in t/harness - if (m!^(ext/\S+/?([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { - $t = $1; - if (!$core || $t =~ m!^lib/[a-z]!) - { - $path = File::Spec->catdir($updir, $t); - push @ARGV, $path; - $name{$path} = $t; + while () { # similar code in t/harness + if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { + my $t = $1; + my $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}; + my $flat_extension = $extension; + $flat_extension =~ s!-!/!g; + next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar + } + my $path = "../$t"; + push @results, $path; + $::path_to_name{$path} = $t; } } } + close MANI; } else { - warn "$0: cannot open $mani: $!\n"; + warn "$0: cannot open $mani: $!\n"; } - _find_tests('pod') unless $core; - _find_tests('x2p') unless $core; - _find_tests('japh') unless $core; + return @results; } -# Tests known to cause infinite loops for the perlcc tests. -# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); -%infinite = (); +unless (@ARGV) { + # base first, as TEST bails out if that can't run + # then comp, to validate that require works + # then run, to validate that -M works + # then we know we can -MTestInit for everything else, making life simpler + foreach my $dir (qw(base comp run cmd io op uni mro)) { + _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 = '../config.sh'; + my ($extensions, $known_extensions); + if (-f $configsh) { + open FH, $configsh or die "Can't open $configsh: $!"; + while () { + if (/^extensions=['"](.*)['"]$/) { + $extensions = $1; + } + elsif (/^known_extensions=['"](.*)['"]$/) { + $known_extensions = $1; + } + } + if (!defined $known_extensions) { + warn "No known_extensions line found in $configsh"; + } + if (!defined $extensions) { + warn "No extensions line found in $configsh"; + } + } + # The "complex" constructions of list return from a subroutine, and push of + # a list, might fail if perl is really hosed, but they aren't needed for + # make minitest, and the building of extensions will likely also fail if + # something is that badly wrong. + push @ARGV, _tests_from_manifest($extensions, $known_extensions); + unless ($::core) { + _find_tests('pod'); + _find_tests('x2p'); + _find_tests('porting'); + _find_tests('japh') if $::torture; + _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK}; + } +} -if ($deparse) { +if ($::deparse) { _testprogs('deparse', '', @ARGV); } -elsif( $compile || $byte_compile ) { - _testprogs('compile', '', @ARGV) if $compile; - _testprogs('compile', '-B', @ARGV) if $byte_compile; +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'); ------------------------------------------------------------------------------ @@ -130,32 +334,32 @@ TESTING DEPARSER ------------------------------------------------------------------------------ EOT - $ENV{PERLCC_TIMEOUT} = 120 - if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT}); + $::bad_files = 0; - $bad = 0; - $good = 0; - $total = @tests; - $files = 0; - $totmax = 0; - - foreach (@tests) { - $name{$_} = File::Spec->catdir('t',$_) unless exists $name{$_}; + foreach my $t (@tests) { + unless (exists $::path_to_name{$t}) { + my $tname = "t/$t"; + $::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 ; - while ($test = shift @tests) { + my $dotdotdot = $maxlen + 3 ; + my $valgrind = 0; + 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; } @@ -164,167 +368,216 @@ EOT # Redefinition happens at compile time next; } - elsif ($test eq "lib/switch.t") { + elsif ($test =~ m{lib/Switch/t/}) { # B::Deparse doesn't support source filtering next; } } - $te = $name{$test}; - print "$te" . '.' x ($dotdotdot - length($te)); - - $test = $OVER{$test} if exists $OVER{$test}; - - open(SCRIPT,"<$test") or die "Can't run $test.\n"; - $_ =