| 1 | #!./perl |
| 2 | |
| 3 | # We suppose that perl _mostly_ works at this moment, so may use |
| 4 | # sophisticated testing. |
| 5 | |
| 6 | BEGIN { |
| 7 | chdir 't' if -d 't'; |
| 8 | @INC = '../lib'; # pick up only this build's lib |
| 9 | } |
| 10 | |
| 11 | my $torture; # torture testing? |
| 12 | |
| 13 | use TAP::Harness 3.13; |
| 14 | use strict; |
| 15 | use Config; |
| 16 | |
| 17 | $::do_nothing = $::do_nothing = 1; |
| 18 | require './TEST'; |
| 19 | our $Valgrind_Log; |
| 20 | |
| 21 | my $Verbose = 0; |
| 22 | $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; |
| 23 | |
| 24 | # For valgrind summary output |
| 25 | my $htoolnm; |
| 26 | my $hgrind_ct; |
| 27 | |
| 28 | if ($ARGV[0] && $ARGV[0] eq '-torture') { |
| 29 | shift; |
| 30 | $torture = 1; |
| 31 | } |
| 32 | |
| 33 | # Let tests know they're running in the perl core. Useful for modules |
| 34 | # which live dual lives on CPAN. |
| 35 | $ENV{PERL_CORE} = 1; |
| 36 | |
| 37 | my (@tests, @re, @anti_re); |
| 38 | |
| 39 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
| 40 | @ARGV = grep $_ && length( $_ ) => @ARGV; |
| 41 | |
| 42 | sub _extract_tests; |
| 43 | sub _extract_tests { |
| 44 | # This can probably be done more tersely with a map, but I doubt that it |
| 45 | # would be as clear |
| 46 | my @results; |
| 47 | foreach (@_) { |
| 48 | my $ref = ref $_; |
| 49 | if ($ref) { |
| 50 | if ($ref eq 'ARRAY') { |
| 51 | push @results, _extract_tests @$_; |
| 52 | } elsif ($ref eq 'HASH') { |
| 53 | push @results, _extract_tests values %$_; |
| 54 | } else { |
| 55 | die "Unknown reference type $ref"; |
| 56 | } |
| 57 | } else { |
| 58 | push @results, glob $_; |
| 59 | } |
| 60 | } |
| 61 | @results; |
| 62 | } |
| 63 | |
| 64 | while ($ARGV[0] && $ARGV[0]=~/^-(n?)re/) { |
| 65 | my $ary= $1 ? \@anti_re : \@re; |
| 66 | |
| 67 | if ( $ARGV[0] !~ /=/ ) { |
| 68 | shift @ARGV; |
| 69 | while (@ARGV and $ARGV[0] !~ /^-/) { |
| 70 | push @$ary, shift @ARGV; |
| 71 | } |
| 72 | } else { |
| 73 | push @$ary, (split/=/,shift @ARGV)[1]; |
| 74 | } |
| 75 | } |
| 76 | |
| 77 | my $jobs = $ENV{TEST_JOBS}; |
| 78 | my ($rules, $state, $color); |
| 79 | if ($ENV{HARNESS_OPTIONS}) { |
| 80 | for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { |
| 81 | if ( $opt =~ /^j(\d*)$/ ) { |
| 82 | $jobs ||= $1 || 9; |
| 83 | } |
| 84 | elsif ( $opt eq 'c' ) { |
| 85 | $color = 1; |
| 86 | } |
| 87 | else { |
| 88 | die "Unknown HARNESS_OPTIONS item: $opt\n"; |
| 89 | } |
| 90 | } |
| 91 | } |
| 92 | |
| 93 | if (@ARGV) { |
| 94 | # If you want these run in speed order, just use prove |
| 95 | if ($^O eq 'MSWin32') { |
| 96 | @tests = map(glob($_),@ARGV); |
| 97 | } |
| 98 | else { |
| 99 | @tests = @ARGV; |
| 100 | } |
| 101 | # This is a hack to force config_heavy.pl to be loaded, before the |
| 102 | # prep work for running a test changes directory. |
| 103 | 1 if $Config{d_fork}; |
| 104 | } else { |
| 105 | # Ideally we'd get somewhere close to Tux's Oslo rules |
| 106 | # my $rules = { |
| 107 | # par => [ |
| 108 | # { seq => '../ext/DB_File/t/*' }, |
| 109 | # { seq => '../ext/IO_Compress_Zlib/t/*' }, |
| 110 | # { seq => '../lib/ExtUtils/t/*' }, |
| 111 | # '*' |
| 112 | # ] |
| 113 | # }; |
| 114 | |
| 115 | # but for now, run all directories in sequence. |
| 116 | |
| 117 | unless (@tests) { |
| 118 | my @seq = <base/*.t>; |
| 119 | |
| 120 | my @next = qw(comp run cmd io re opbasic op uni mro lib porting perf); |
| 121 | push @next, 'japh' if $torture; |
| 122 | push @next, 'win32' if $^O eq 'MSWin32'; |
| 123 | push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; |
| 124 | push @next, 'bigmem' if $ENV{PERL_TEST_MEMORY}; |
| 125 | # Hopefully TAP::Parser::Scheduler will support this syntax soon. |
| 126 | # my $next = { par => '{' . join (',', @next) . '}/*.t' }; |
| 127 | my $next = { par => [ |
| 128 | map { "$_/*.t" } @next |
| 129 | ] }; |
| 130 | @tests = _extract_tests ($next); |
| 131 | |
| 132 | # This is a bit of a game, because we only want to sort these tests in |
| 133 | # speed order. base/*.t wants to run first, and ext,lib etc last and in |
| 134 | # MANIFEST order |
| 135 | if ($jobs) { |
| 136 | require App::Prove::State; |
| 137 | $state = App::Prove::State->new({ store => 'test_state' }); |
| 138 | $state->apply_switch('slow', 'save'); |
| 139 | # For some reason get_tests returns *all* the tests previously run, |
| 140 | # (in the right order), not simply the selection in @tests |
| 141 | # (in the right order). Not sure if this is a bug or a feature. |
| 142 | # Whatever, *we* are only interested in the ones that are in @tests |
| 143 | my %seen; |
| 144 | @seen{@tests} = (); |
| 145 | @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); |
| 146 | } |
| 147 | @tests = (@seq, @tests); |
| 148 | push @seq, $next; |
| 149 | |
| 150 | my @last; |
| 151 | push @last, |
| 152 | _tests_from_manifest($Config{extensions}, $Config{known_extensions}); |
| 153 | my %times; |
| 154 | if ($state) { |
| 155 | # Where known, collate the elapsed times by test name |
| 156 | foreach ($state->results->tests()) { |
| 157 | $times{$_->name} = $_->elapsed(); |
| 158 | } |
| 159 | } |
| 160 | |
| 161 | my %dir; |
| 162 | my %total_time; |
| 163 | my %serials; |
| 164 | my %all_dirs; |
| 165 | |
| 166 | # Preprocess the list of tests |
| 167 | for (@last) { |
| 168 | if ($^O eq 'MSWin32') { |
| 169 | s,\\,/,g; # canonicalize path |
| 170 | }; |
| 171 | |
| 172 | # Keep a list of the distinct directory names, and another list of |
| 173 | # those which contain a file whose name begins with a 0 |
| 174 | if ( m! \A \.\. / |
| 175 | ( .*? ) # $1 is the directory path name |
| 176 | / |
| 177 | ( [^/]* \.t ) # $2 is the .t name |
| 178 | \z !x) |
| 179 | { |
| 180 | my $path = $1; |
| 181 | |
| 182 | $all_dirs{$path} = 1; |
| 183 | $serials{$path} = 1 if $2 =~ / \A 0 /x; |
| 184 | } |
| 185 | } |
| 186 | |
| 187 | # We assume that the reason a test file's name begins with a 0 is to |
| 188 | # order its execution among the tests in its directory. Hence, a |
| 189 | # directory containing such files should be tested in serial order. |
| 190 | # |
| 191 | # Add exceptions to the above rule |
| 192 | for (qw(ext/Pod-Html/t cpan/IO-Zlib/t ext/File-Find/t)) { |
| 193 | $serials{$_} = 1; |
| 194 | } |
| 195 | |
| 196 | my @nonexistent_serials = grep { not exists $all_dirs{$_} } keys %serials; |
| 197 | if (@nonexistent_serials) { |
| 198 | die "These directories to be run serially don't exist." |
| 199 | . " Check your spelling:\n" . join "\n", @nonexistent_serials; |
| 200 | } |
| 201 | |
| 202 | # Remove the serial testing directories from the list of all |
| 203 | # directories. The remaining ones are testable in parallel. Make the |
| 204 | # parallel list a scalar with names separated by '|' so that below |
| 205 | # they will be added to a regular expression. |
| 206 | my $non_serials = join "|", grep { not exists $serials{$_} } keys %all_dirs; |
| 207 | undef %all_dirs; |
| 208 | undef %serials; |
| 209 | |
| 210 | for (@last) { |
| 211 | # Treat every file in each non-serial directory as its own |
| 212 | # "directory", so that it can be executed in parallel |
| 213 | m! \A ( \.\. / (?: $non_serials ) |
| 214 | / [^/]+ \.t \z | .* [/] ) !x |
| 215 | or die "'$_'"; |
| 216 | push @{$dir{$1}}, $_; |
| 217 | |
| 218 | # This file contributes time to the total needed for the directory |
| 219 | # as a whole |
| 220 | $total_time{$1} += $times{$_} || 0; |
| 221 | } |
| 222 | #print STDERR __LINE__, join "\n", sort { $total_time{$b} <=> $total_time{$a} } keys %dir, " "; |
| 223 | |
| 224 | push @tests, @last; |
| 225 | |
| 226 | # Generate T::H schedule rules that run the contents of each directory |
| 227 | # sequentially. |
| 228 | push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort { |
| 229 | # Directories, ordered by total time descending then name ascending |
| 230 | $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b |
| 231 | } keys %dir ] }; |
| 232 | |
| 233 | $rules = { seq => \@seq }; |
| 234 | } |
| 235 | } |
| 236 | if ($^O eq 'MSWin32') { |
| 237 | s,\\,/,g for @tests; |
| 238 | } |
| 239 | if (@re or @anti_re) { |
| 240 | my @keepers; |
| 241 | foreach my $test (@tests) { |
| 242 | my $keep = 0; |
| 243 | if (@re) { |
| 244 | foreach my $re (@re) { |
| 245 | $keep = 1 if $test=~/$re/; |
| 246 | } |
| 247 | } else { |
| 248 | $keep = 1; |
| 249 | } |
| 250 | if (@anti_re) { |
| 251 | foreach my $anti_re (@anti_re) { |
| 252 | $keep = 0 if $test=~/$anti_re/; |
| 253 | } |
| 254 | } |
| 255 | if ($keep) { |
| 256 | push @keepers, $test; |
| 257 | } |
| 258 | } |
| 259 | @tests= @keepers; |
| 260 | } |
| 261 | |
| 262 | # Allow eg ./perl t/harness t/op/lc.t |
| 263 | for (@tests) { |
| 264 | if (! -f $_ && !/^\.\./ && -f "../$_") { |
| 265 | $_ = "../$_"; |
| 266 | s{^\.\./t/}{}; |
| 267 | } |
| 268 | } |
| 269 | |
| 270 | my %options; |
| 271 | |
| 272 | my $type = 'perl'; |
| 273 | |
| 274 | # Load TAP::Parser now as otherwise it could be required in the short time span |
| 275 | # in which the harness process chdirs into ext/Dist |
| 276 | require TAP::Parser; |
| 277 | |
| 278 | my $h = TAP::Harness->new({ |
| 279 | rules => $rules, |
| 280 | color => $color, |
| 281 | jobs => $jobs, |
| 282 | verbosity => $Verbose, |
| 283 | timer => $ENV{HARNESS_TIMER}, |
| 284 | exec => sub { |
| 285 | my ($harness, $test) = @_; |
| 286 | |
| 287 | my $options = $options{$test}; |
| 288 | if (!defined $options) { |
| 289 | $options = $options{$test} = _scan_test($test, $type); |
| 290 | } |
| 291 | |
| 292 | (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; |
| 293 | |
| 294 | return [ split ' ', _cmd($options, $type) ]; |
| 295 | }, |
| 296 | }); |
| 297 | |
| 298 | # Print valgrind output after test completes |
| 299 | if ($ENV{PERL_VALGRIND}) { |
| 300 | $h->callback( |
| 301 | after_test => sub { |
| 302 | my ($job) = @_; |
| 303 | my $test = $job->[0]; |
| 304 | my $vfile = "$test.valgrind-current"; |
| 305 | $vfile =~ s/^.*\///; |
| 306 | |
| 307 | if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) { |
| 308 | print "$test: Valgrind output:\n"; |
| 309 | print "$test: $_" for <$voutput>; |
| 310 | close($voutput); |
| 311 | } |
| 312 | |
| 313 | (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; |
| 314 | |
| 315 | _check_valgrind(\$htoolnm, \$hgrind_ct, \$test); |
| 316 | } |
| 317 | ); |
| 318 | } |
| 319 | |
| 320 | if ($state) { |
| 321 | $h->callback( |
| 322 | after_test => sub { |
| 323 | $state->observe_test(@_); |
| 324 | } |
| 325 | ); |
| 326 | $h->callback( |
| 327 | after_runtests => sub { |
| 328 | $state->commit(@_); |
| 329 | } |
| 330 | ); |
| 331 | } |
| 332 | |
| 333 | $h->callback( |
| 334 | parser_args => sub { |
| 335 | my ($args, $job) = @_; |
| 336 | my $test = $job->[0]; |
| 337 | _before_fork($options{$test}); |
| 338 | push @{ $args->{switches} }, "-I../../lib"; |
| 339 | } |
| 340 | ); |
| 341 | |
| 342 | $h->callback( |
| 343 | made_parser => sub { |
| 344 | my ($parser, $job) = @_; |
| 345 | my $test = $job->[0]; |
| 346 | my $options = delete $options{$test}; |
| 347 | _after_fork($options); |
| 348 | } |
| 349 | ); |
| 350 | |
| 351 | my $agg = $h->runtests(@tests); |
| 352 | _cleanup_valgrind(\$htoolnm, \$hgrind_ct); |
| 353 | exit $agg->has_errors ? 1 : 0; |