X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e772598991ca5994af17ccfc75b507c64089f992..859b78b1a8287681e524286f4e989b01816433ba:/t/harness diff --git a/t/harness b/t/harness index 662afb6..58a212f 100644 --- a/t/harness +++ b/t/harness @@ -7,16 +7,24 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; # pick up only this build's lib } -delete $ENV{PERL5LIB}; my $torture; # torture testing? use TAP::Harness 3.13; use strict; +use Config; + +$::do_nothing = $::do_nothing = 1; +require './TEST'; +our $Valgrind_Log; my $Verbose = 0; $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; +# For valgrind summary output +my $htoolnm; +my $hgrind_ct; + if ($ARGV[0] && $ARGV[0] eq '-torture') { shift; $torture = 1; @@ -26,35 +34,11 @@ if ($ARGV[0] && $ARGV[0] eq '-torture') { # which live dual lives on CPAN. $ENV{PERL_CORE} = 1; -#fudge DATA for now. -my %datahandle = qw( - lib/bigint.t 1 - lib/bigintpm.t 1 - lib/bigfloat.t 1 - lib/bigfloatpm.t 1 - op/gv.t 1 - lib/complex.t 1 - lib/ph.t 1 - lib/soundex.t 1 - op/misc.t 1 - op/runlevel.t 1 - op/tie.t 1 - op/lex_assign.t 1 - ); - -foreach (keys %datahandle) { - unlink "$_.t"; -} - -my (@tests, $re); +my (@tests, @re, @anti_re); # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV @ARGV = grep $_ && length( $_ ) => @ARGV; -sub _populate_hash { - return map {$_, 1} split /\s+/, $_[0]; -} - sub _extract_tests; sub _extract_tests { # This can probably be done more tersely with a map, but I doubt that it @@ -77,13 +61,16 @@ sub _extract_tests { @results; } -if ($ARGV[0] && $ARGV[0]=~/^-re/) { - if ($ARGV[0]!~/=/) { - shift; - $re=join "|",@ARGV; - @ARGV=(); +while ($ARGV[0] && $ARGV[0]=~/^-(n?)re/) { + my $ary= $1 ? \@anti_re : \@re; + + if ( $ARGV[0] !~ /=/ ) { + shift @ARGV; + while (@ARGV and $ARGV[0] !~ /^-/) { + push @$ary, shift @ARGV; + } } else { - (undef,$re)=split/=/,shift; + push @$ary, (split/=/,shift @ARGV)[1]; } } @@ -103,40 +90,6 @@ if ($ENV{HARNESS_OPTIONS}) { } } -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{$_}; - } - - my @results; - my $mani = '../MANIFEST'; - if (open(MANI, $mani)) { - while () { # similar code in t/TEST - if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { - my ($test, $extension) = ($1, $2); - 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 - } - push @results, "../$test"; - } - } - close MANI; - } else { - warn "$0: cannot open $mani: $!\n"; - } - return @results; -} - if (@ARGV) { # If you want these run in speed order, just use prove if ($^O eq 'MSWin32') { @@ -145,28 +98,30 @@ if (@ARGV) { else { @tests = @ARGV; } + # This is a hack to force config_heavy.pl to be loaded, before the + # prep work for running a test changes directory. + 1 if $Config{d_fork}; } else { # Ideally we'd get somewhere close to Tux's Oslo rules # my $rules = { # par => [ # { seq => '../ext/DB_File/t/*' }, # { seq => '../ext/IO_Compress_Zlib/t/*' }, - # { seq => '../lib/CPANPLUS/*' }, # { seq => '../lib/ExtUtils/t/*' }, # '*' # ] # }; - # but for now, run all directories in sequence. In particular, it would be - # nice to get the tests in t/op/*.t able to run in parallel. + # but for now, run all directories in sequence. unless (@tests) { my @seq = ; - my @next = qw(comp run cmd io op uni mro lib porting); + my @next = qw(comp run cmd io re opbasic op uni mro lib porting perf); push @next, 'japh' if $torture; push @next, 'win32' if $^O eq 'MSWin32'; push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; + push @next, 'bigmem' if $ENV{PERL_TEST_MEMORY}; # Hopefully TAP::Parser::Scheduler will support this syntax soon. # my $next = { par => '{' . join (',', @next) . '}/*.t' }; my $next = { par => [ @@ -193,12 +148,8 @@ if (@ARGV) { push @seq, $next; my @last; - use Config; - push @last, sort { lc $a cmp lc $b } + push @last, _tests_from_manifest($Config{extensions}, $Config{known_extensions}); - push @last, ; - push @last, ; - my %times; if ($state) { # Where known, collate the elapsed times by test name @@ -209,23 +160,74 @@ if (@ARGV) { my %dir; my %total_time; + my %serials; + my %all_dirs; + # Preprocess the list of tests for (@last) { if ($^O eq 'MSWin32') { s,\\,/,g; # canonicalize path }; - m!(.*[/])! or die "'$_'"; + + # Keep a list of the distinct directory names, and another list of + # those which contain a file whose name begins with a 0 + if ( m! \A \.\. / + ( .*? ) # $1 is the directory path name + / + ( [^/]* \.t ) # $2 is the .t name + \z !x) + { + my $path = $1; + + $all_dirs{$path} = 1; + $serials{$path} = 1 if $2 =~ / \A 0 /x; + } + } + + # We assume that the reason a test file's name begins with a 0 is to + # order its execution among the tests in its directory. Hence, a + # directory containing such files should be tested in serial order. + # + # Add exceptions to the above rule + for (qw(ext/Pod-Html/t cpan/IO-Zlib/t ext/File-Find/t)) { + $serials{$_} = 1; + } + + my @nonexistent_serials = grep { not exists $all_dirs{$_} } keys %serials; + if (@nonexistent_serials) { + die "These directories to be run serially don't exist." + . " Check your spelling:\n" . join "\n", @nonexistent_serials; + } + + # Remove the serial testing directories from the list of all + # directories. The remaining ones are testable in parallel. Make the + # parallel list a scalar with names separated by '|' so that below + # they will be added to a regular expression. + my $non_serials = join "|", grep { not exists $serials{$_} } keys %all_dirs; + undef %all_dirs; + undef %serials; + + for (@last) { + # Treat every file in each non-serial directory as its own + # "directory", so that it can be executed in parallel + m! \A ( \.\. / (?: $non_serials ) + / [^/]+ \.t \z | .* [/] ) !x + or die "'$_'"; push @{$dir{$1}}, $_; + + # This file contributes time to the total needed for the directory + # as a whole $total_time{$1} += $times{$_} || 0; } + #print STDERR __LINE__, join "\n", sort { $total_time{$b} <=> $total_time{$a} } keys %dir, " "; push @tests, @last; # Generate T::H schedule rules that run the contents of each directory # sequentially. - push @seq, { par => [ map { { seq => "$_*" } } sort { + push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort { # Directories, ordered by total time descending then name ascending - $total_time{$b} <=> $total_time{$a} || $a cmp $b + $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b } keys %dir ] }; $rules = { seq => \@seq }; @@ -234,16 +236,87 @@ if (@ARGV) { if ($^O eq 'MSWin32') { s,\\,/,g for @tests; } -@tests=grep /$re/, @tests - if $re; +if (@re or @anti_re) { + my @keepers; + foreach my $test (@tests) { + my $keep = 0; + if (@re) { + foreach my $re (@re) { + $keep = 1 if $test=~/$re/; + } + } else { + $keep = 1; + } + if (@anti_re) { + foreach my $anti_re (@anti_re) { + $keep = 0 if $test=~/$anti_re/; + } + } + if ($keep) { + push @keepers, $test; + } + } + @tests= @keepers; +} + +# Allow eg ./perl t/harness t/op/lc.t +for (@tests) { + if (! -f $_ && !/^\.\./ && -f "../$_") { + $_ = "../$_"; + s{^\.\./t/}{}; + } +} + +my %options; + +my $type = 'perl'; + +# Load TAP::Parser now as otherwise it could be required in the short time span +# in which the harness process chdirs into ext/Dist +require TAP::Parser; my $h = TAP::Harness->new({ rules => $rules, color => $color, jobs => $jobs, verbosity => $Verbose, + timer => $ENV{HARNESS_TIMER}, + exec => sub { + my ($harness, $test) = @_; + + my $options = $options{$test}; + if (!defined $options) { + $options = $options{$test} = _scan_test($test, $type); + } + + (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; + + return [ split ' ', _cmd($options, $type) ]; + }, }); +# Print valgrind output after test completes +if ($ENV{PERL_VALGRIND}) { + $h->callback( + after_test => sub { + my ($job) = @_; + my $test = $job->[0]; + my $vfile = "$test.valgrind-current"; + $vfile =~ s/^.*\///; + + if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) { + print "$test: Valgrind output:\n"; + print "$test: $_" for <$voutput>; + close($voutput); + } + + (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; + + _check_valgrind(\$htoolnm, \$hgrind_ct, \$test); + } + ); +} + if ($state) { $h->callback( after_test => sub { @@ -259,9 +332,22 @@ if ($state) { $h->callback( parser_args => sub { - my ( $args, $test ) = @_; - push @{ $args->{switches} }, '-I../lib'; + my ($args, $job) = @_; + my $test = $job->[0]; + _before_fork($options{$test}); + push @{ $args->{switches} }, "-I../../lib"; } ); -$h->runtests(@tests); -exit(0); + +$h->callback( + made_parser => sub { + my ($parser, $job) = @_; + my $test = $job->[0]; + my $options = delete $options{$test}; + _after_fork($options); + } + ); + +my $agg = $h->runtests(@tests); +_cleanup_valgrind(\$htoolnm, \$hgrind_ct); +exit $agg->has_errors ? 1 : 0;