X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2FTEST;h=58f1da5a5a611cfdcaf7cd73f3f70f498e6d653d;hb=a3323f52209391b4b2c45b3e1feb26c6f51fb6fa;hp=776bf01937f9919c3839d41bf50af876dcedada7;hpb=3fd4b35989e5f2055b5e1a7a81e7355f6ba2f846;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/TEST b/t/TEST index 776bf01..58f1da5 100755 --- a/t/TEST +++ b/t/TEST @@ -5,15 +5,15 @@ # 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; # for testing TEST only -#BEGIN { require '../lib/strict.pm'; strict->import() }; -#BEGIN { require '../lib/warnings.pm'; warnings->import() }; +#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; delete $ENV{PERL5LIB}; # remove empty elements due to insertion of empty symbols via "''p1'" syntax @@ -67,7 +67,6 @@ $ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL}; $ENV{EMXSHELL} = 'sh'; # For OS/2 # Roll your own File::Find! -use TestInit; if ($show_elapsed_time) { require Time::HiRes } my %skip = ( @@ -130,6 +129,67 @@ sub _scan_test { 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 = ''; @@ -144,56 +204,28 @@ sub _quote_args { } sub _populate_hash { + return unless defined $_[0]; return map {$_, 1} split /\s+/, $_[0]; } -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'; +sub _tests_from_manifest { + my ($extensions, $known_extensions) = @_; 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 %extensions = _populate_hash($extensions); + my %known_extensions = _populate_hash($known_extensions); + + foreach (keys %known_extensions) { + $skip{$_}++ unless $extensions{$_}; } + + my @results; my $mani = '../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!) { my $t = $1; my $extension = $2; - if (!$::core || $t =~ m!^lib/[a-z]!) - { + if (!$::core || $t =~ m!^lib/[a-z]!) { if (defined $extension) { $extension =~ s!/t$!!; # XXX Do I want to warn that I'm skipping these? @@ -203,7 +235,7 @@ unless (@ARGV) { next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar } my $path = "../$t"; - push @ARGV, $path; + push @results, $path; $::path_to_name{$path} = $t; } } @@ -212,6 +244,45 @@ unless (@ARGV) { } else { warn "$0: cannot open $mani: $!\n"; } + return @results; +} + +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'); @@ -280,7 +351,6 @@ EOT # + 3 : we want three dots between the test name and the "ok" my $dotdotdot = $maxlen + 3 ; my $valgrind = 0; - my $valgrind_log = 'current.valgrind'; my $total_files = @tests; my $good_files = 0; my $tested_files = 0; @@ -311,43 +381,7 @@ EOT $te = ''; } - # XXX DAPM %OVER not defined anywhere - # $test = $OVER{$test} if exists $OVER{$test}; - - my $options = _scan_test($test, $type); - - my $utf8 = $::with_utf8 ? '-I../lib -Mutf8' : ''; - my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC - 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; + my $results = _run_test($test, $type); my $failure; my $next = 0; @@ -356,7 +390,7 @@ EOT my $trailing_leader = 0; my $max; my %todo; - while () { + while (<$results>) { next if /^\s*$/; # skip blank lines if (/^1..$/ && ($^O eq 'VMS')) { # VMS pipe bug inserts blank lines. @@ -440,7 +474,7 @@ EOT } } } - close RESULTS; + close $results; if (not defined $failure) { $failure = 'FAILED--no leader found' unless $seen_leader; @@ -448,16 +482,16 @@ EOT if ($ENV{PERL_VALGRIND}) { my @valgrind; - if (-e $valgrind_log) { - if (open(V, $valgrind_log)) { + if (-e $Valgrind_Log) { + if (open(V, $Valgrind_Log)) { @valgrind = ; close V; } else { - warn "$0: Failed to open '$valgrind_log': $!\n"; + warn "$0: Failed to open '$Valgrind_Log': $!\n"; } } if ($ENV{VG_OPTS} =~ /cachegrind/) { - if (rename $valgrind_log, "$test.valgrind") { + if (rename $Valgrind_Log, "$test.valgrind") { $valgrind++; } else { warn "$0: Failed to create '$test.valgrind': $!\n"; @@ -480,7 +514,7 @@ EOT } } if ($errors or $leaks) { - if (rename $valgrind_log, "$test.valgrind") { + if (rename $Valgrind_Log, "$test.valgrind") { $valgrind++; } else { warn "$0: Failed to create '$test.valgrind': $!\n"; @@ -489,9 +523,9 @@ EOT } else { warn "No valgrind output?\n"; } - if (-e $valgrind_log) { - unlink $valgrind_log - or warn "$0: Failed to unlink '$valgrind_log': $!\n"; + if (-e $Valgrind_Log) { + unlink $Valgrind_Log + or warn "$0: Failed to unlink '$Valgrind_Log': $!\n"; } } if ($type eq 'deparse') {