X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2FTEST;h=19f8fb1e6d31ac951639de376fd085439d5d6bde;hb=9b7091183a0e6b41a658e590f90e543efae3b2e4;hp=a0a004ee8f32b671a8a9b4d52b1eff11e55dd0f7;hpb=c81476ca1f24a733b0d141d88811c2fb5b47d395;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/TEST b/t/TEST index a0a004e..19f8fb1 100755 --- a/t/TEST +++ b/t/TEST @@ -23,18 +23,31 @@ my %dir_to_switch = '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/ ); +# I think in the end I'd like "not absolute" to be the default", as it saves +# some fakery within TestInit which can peturb tests, and takes CPU. +my %no_abs = + ('../ext/Pod-Parser' => 1, + ); + my %temp_no_core = - ('../ext/Attribute-Handlers' => 1, - '../ext/B-Debug' => 1, + ('../ext/B-Debug' => 1, '../ext/Compress-Raw-Bzip2' => 1, '../ext/Compress-Raw-Zlib' => 1, - '../ext/Devel-PPPort' => 1, - '../ext/Encode' => 1, - '../ext/I18N-Langinfo' => 'fixme', + '../cpan/Devel-PPPort' => 1, + '../cpan/Getopt-Long' => 1, '../ext/IO-Compress' => 1, - '../ext/IPC-SysV' => 1, + '../ext/Math-BigInt' => 1, + '../ext/Math-BigRat' => 1, '../ext/MIME-Base64' => 1, + '../cpan/NEXT' => 1, + '../ext/parent' => 1, + '../cpan/Parse-CPAN-Meta' => 1, + '../ext/Pod-Simple' => 1, + '../cpan/podlators' => 1, + '../ext/Test-Simple' => 1, + '../cpan/Tie-RefHash' => 1, '../ext/Time-HiRes' => 1, + '../ext/Unicode-Collate' => 1, '../ext/Unicode-Normalize' => 1, ); @@ -82,6 +95,9 @@ our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; } chdir 't' if -f 't/TEST'; +if (-f 'TEST' && -f 'harness' && -d '../lib') { + @INC = '../lib'; +} die "You need to run \"make test\" first to set things up.\n" unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm'; @@ -147,11 +163,11 @@ sub _scan_test { my $switch = ""; if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) { - $switch = qq{"-$1"}; + $switch = "-$1"; } else { if ($::taintwarn) { # not all tests are expected to pass with this option - $switch = '"-t"'; + $switch = '-t'; } else { $switch = ''; } @@ -166,55 +182,70 @@ sub _scan_test { } } - return { file => $file_opts, switch => $switch }; -} - -sub _run_test { - my($harness, $test, $type) = @_; - if (!defined $type) { - # To conform to the interface expected by exec in TAP::Harness - $type = 'perl'; - } - - my $options = _scan_test($test, $type); - my $return_dir; + close $script; my $perl = './perl'; my $lib = '../lib'; + my $run_dir; + my $return_dir; + $test =~ /^(.+)\/[^\/]+/; my $dir = $1; - my $ext_dir; - my $testswitch = $dir_to_switch{$dir}; if (!defined $testswitch) { - if ($test =~ s!^(\.\./ext/[^/]+)/t!t!) { - $ext_dir = $1; + if ($test =~ s!^(\.\./(?:cpan|dist|ext)/[^/]+)/t!t!) { + $run_dir = $1; $return_dir = '../../t'; $lib = '../../lib'; $perl = '../../t/perl'; - $testswitch = "-I../.. -MTestInit=U2T,A"; - if ($temp_no_core{$ext_dir}) { + $testswitch = "-I../.. -MTestInit=U2T"; + if (!$no_abs{$run_dir}) { + $testswitch = $testswitch . ',A'; + } + if ($temp_no_core{$run_dir}) { $testswitch = $testswitch . ',NC'; } - chdir $ext_dir or die "Can't chdir to '$ext_dir': $!"; } else { $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC } } - my $utf8 = $::with_utf8 ? '-I$lib -Mutf8' : ''; + my $utf8 = $::with_utf8 ? "-I$lib -Mutf8" : ''; + + my %options = ( + perl => $perl, + lib => $lib, + test => $test, + run_dir => $run_dir, + return_dir => $return_dir, + testswitch => $testswitch, + utf8 => $utf8, + file => $file_opts, + switch => $switch, + ); - my $results; + return \%options; +} + +sub _cmd { + my($options, $type) = @_; + + my $test = $options->{test}; + + my $cmd; if ($type eq 'deparse') { - my $deparse_cmd = - "$perl $testswitch $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,". + my $perl = "$options->{perl} $options->{testswitch}"; + my $lib = $options->{lib}; + + $cmd = ( + "$perl $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"; + "&& $perl $options->{switch} -I$lib $test.dp" + ); } elsif ($type eq 'perl') { + my $perl = $options->{perl}; my $redir = $^O eq 'VMS' ? '2>&1' : ''; if ($ENV{PERL_VALGRIND}) { @@ -222,21 +253,56 @@ sub _run_test { my $vg_opts = $ENV{VG_OPTS} // "--suppressions=perl.supp --leak-check=yes " . "--leak-resolution=high --show-reachable=yes " - . "--num-callers=50"; + . "--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"; + my $args = "$options->{testswitch} $options->{switch} $options->{utf8}"; + $cmd = $perl . _quote_args($args) . " $test $redir"; } - if ($return_dir) { + return $cmd; +} + +sub _before_fork { + my ($options) = @_; + + if ($options->{run_dir}) { + my $run_dir = $options->{run_dir}; + chdir $run_dir or die "Can't chdir to '$run_dir': $!"; + } + + return; +} + +sub _after_fork { + my ($options) = @_; + + if ($options->{return_dir}) { + my $return_dir = $options->{return_dir}; chdir $return_dir - or die "Can't chdir from '$ext_dir' to '$return_dir': $!"; + or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!"; } + return; +} + +sub _run_test { + my ($test, $type) = @_; + + my $options = _scan_test($test, $type); + # $test might have changed if we're in ext/Foo, so don't use it anymore + # from now on. Use $options->{test} instead. + + _before_fork($options); + + my $cmd = _cmd($options, $type); + + open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n"; + + _after_fork($options); + # 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 @@ -278,7 +344,7 @@ sub _tests_from_manifest { my $mani = '../MANIFEST'; if (open(MANI, $mani)) { while () { - if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { + if (m!^((?:cpan|dist|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]!) { @@ -308,7 +374,7 @@ unless (@ARGV) { # 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)) { + foreach my $dir (qw(base comp run cmd io re op uni mro)) { _find_tests($dir); } _find_tests("lib") unless $::core; @@ -437,7 +503,7 @@ EOT $te = ''; } - my $results = _run_test(undef, $test, $type); + my $results = _run_test($test, $type); my $failure; my $next = 0; @@ -503,7 +569,7 @@ EOT # SKIP is essentially the same as TODO for t/TEST # this still conforms to TAP: - # http://search.cpan.org/dist/TAP/TAP.pod + # http://search.cpan.org/dist/TAP/TAP.pm $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/; $istodo = 1 if $todo{$num}; @@ -523,7 +589,7 @@ EOT else { # module tests are allowed extra output, # because Test::Harness allows it - next if $test =~ /^\W*(ext|lib)\b/; + next if $test =~ /^\W*(cpan|dist|ext|lib)\b/; $failure = "FAILED--unexpected output at test $next"; last; }