1#!./perl 2 3# We suppose that perl _mostly_ works at this moment, so may use 4# sophisticated testing. 5 6BEGIN { 7 chdir 't' if -d 't'; 8 @INC = '../lib'; # pick up only this build's lib 9} 10 11############################################################################## 12# Test files which cannot be executed at the same time. 13# 14# List all files which might fail when executed at the same time as another 15# test file from the same test directory. Being listed here does not mean 16# the test will be run by itself, it just means it won't be run at the same 17# time as any other file in the same test directory, it might be run at the 18# same time as a file from a different test directory. 19# 20# Ideally this is always empty. 21# 22# Example: ../cpan/IO-Zlib/t/basic.t 23# 24my @_must_be_executed_serially = ( 25 # These two both create temporary subdirectories which they delete 26 # at the end. If one deletes while the other is running a recursive 27 # find in that subdir, bad things can happen. This was showing as 28 # random crashes in find.t and taint.t in smokes, with errors like: 29 # "Can't cd to .. from ./FF_find_t_RKdkBE/for_find/fb: Stale file handle" 30 '../ext/File-Find/t/taint.t', 31 '../ext/File-Find/t/find.t', 32); 33 34my %must_be_executed_serially = map { $_ => 1 } @_must_be_executed_serially; 35############################################################################## 36 37############################################################################## 38# Test files which must be executed alone. 39# 40# List files which cannot be run at the same time as any other test. Typically 41# this is used to handle tests which are sensitive to load and which might 42# fail if they were run at the same time as something load intensive. 43# 44# Example: ../dist/threads-shared/t/waithires.t 45# 46my @_must_be_executed_alone = qw(); 47my %must_be_executed_alone = map { $_ => 1 } @_must_be_executed_alone; 48 49my $OS = $ENV{FAKE_OS} || $^O; 50my $is_linux = $OS eq "linux"; 51my $is_win32 = $OS eq "MSWin32"; 52 53if (!$is_linux) { 54 $must_be_executed_alone{"../dist/threads-shared/t/waithires.t"} = 1; 55} 56############################################################################## 57 58my $torture; # torture testing? 59 60use TAP::Harness 3.13; 61use strict; 62use Config; 63 64$::do_nothing = $::do_nothing = 1; 65require './TEST'; 66our $Valgrind_Log; 67 68my $Verbose = 0; 69$Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; 70 71# For valgrind summary output 72my $htoolnm; 73my $hgrind_ct; 74 75my $dump_tests = 0; 76if ($ARGV[0] && $ARGV[0] =~ /^-?-dumptests$/) { 77 shift; 78 $dump_tests = 1; 79} 80 81if ($ARGV[0] && $ARGV[0] =~ /^-?-torture$/) { 82 shift; 83 $torture = 1; 84} 85 86# Let tests know they're running in the perl core. Useful for modules 87# which live dual lives on CPAN. 88$ENV{PERL_CORE} = 1; 89 90my (@tests, @re, @anti_re); 91 92# [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV 93@ARGV = grep $_ && length( $_ ) => @ARGV; 94 95while ($ARGV[0] && $ARGV[0]=~/^-?-(n?)re/) { 96 my $ary= $1 ? \@anti_re : \@re; 97 98 if ( $ARGV[0] !~ /=/ ) { 99 shift @ARGV; 100 while (@ARGV and $ARGV[0] !~ /^-/) { 101 push @$ary, shift @ARGV; 102 } 103 } else { 104 push @$ary, (split/=/,shift @ARGV)[1]; 105 } 106} 107 108my $jobs = $ENV{TEST_JOBS}; 109my ($rules, $state, $color); 110 111if ($ENV{HARNESS_OPTIONS}) { 112 for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { 113 if ( $opt =~ /^j(\d*)$/ ) { 114 $jobs ||= $1 || 9; 115 } 116 elsif ( $opt eq 'c' ) { 117 $color = 1; 118 } 119 else { 120 die "Unknown HARNESS_OPTIONS item: $opt\n"; 121 } 122 } 123} 124 125$jobs ||= 1; 126 127my %total_time; 128sub _compute_tests_and_ordering($) { 129 my @tests = $_[0]->@*; 130 131 my %dir; 132 my %all_dirs; 133 my %map_file_to_dir; 134 135 if (!$dump_tests) { 136 require App::Prove::State; 137 if (!$state) { 138 # silence unhelpful warnings from App::Prove::State about not having 139 # a save state, unless we actually set the PERL_TEST_STATE we don't care 140 # and we don't need to know if its fresh or not. 141 local $SIG{__WARN__} = $ENV{PERL_TEST_STATE} ? $SIG{__WARN__} : sub { 142 return if $_[0] and $_[0]=~/No saved state/; 143 warn $_[0]; 144 }; 145 my $state_file = $ENV{PERL_TEST_STATE_FILE} // 'test_state'; 146 if ($state_file) { # set PERL_TEST_STATE_FILE to 0 to skip this 147 $state = App::Prove::State->new({ store => $state_file }); 148 $state->apply_switch('save'); 149 $state->apply_switch('slow') if $jobs > 1; 150 } 151 } 152 # For some reason get_tests returns *all* the tests previously run, 153 # (in the right order), not simply the selection in @tests 154 # (in the right order). Not sure if this is a bug or a feature. 155 # Whatever, *we* are only interested in the ones that are in @tests 156 my %seen; 157 @seen{@tests} = (); 158 @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); 159 } 160 161 my %times; 162 if ($state) { 163 # Where known, collate the elapsed times by test name 164 foreach ($state->results->tests()) { 165 $times{$_->name} = $_->elapsed(); 166 } 167 } 168 169 my %partial_serials; 170 # Preprocess the list of tests 171 for my $file (@tests) { 172 if ($is_win32) { 173 $file =~ s,\\,/,g; # canonicalize path 174 }; 175 176 # Keep a list of the distinct directory names, and another list of 177 if ($file =~ m! \A ( (?: \.\. / )? 178 .*? 179 ) # $1 is the directory path name 180 / 181 ( [^/]* \. (?: t | pl ) ) # $2 is the test name 182 \z !x) 183 { 184 my $path = $1; 185 my $name = $2; 186 187 $all_dirs{$path} = 1; 188 $map_file_to_dir{$file} = $path; 189 # is this a file that requires we do special processing 190 # on the directory as a whole? 191 if ($must_be_executed_serially{$file}) { 192 $partial_serials{$path} = 1; 193 } 194 } 195 } 196 197 my %split_partial_serials; 198 199 my @alone_files; 200 # Ready to figure out the timings. 201 for my $file (@tests) { 202 my $file_dir = $map_file_to_dir{$file}; 203 204 # if this is a file which must be processed alone 205 if ($must_be_executed_alone{$file}) { 206 push @alone_files, $file; 207 next; 208 } 209 210 # Special handling is needed for a directory that has some test files 211 # to execute serially, and some to execute in parallel. This loop 212 # gathers information that a later loop will process. 213 if (defined $partial_serials{$file_dir}) { 214 if ($must_be_executed_serially{$file}) { 215 # This is a file to execute serially. Its time contributes 216 # directly to the total time for this directory. 217 $total_time{$file_dir} += $times{$file} || 0; 218 219 # Save the sequence number with the file for now; below we 220 # will come back to it. 221 push $split_partial_serials{$file_dir}{seq}->@*, [ $1, $file ]; 222 } 223 else { 224 # This is a file to execute in parallel after all the 225 # sequential ones are done. Save its time in the hash to 226 # later calculate its time contribution. 227 push $split_partial_serials{$file_dir}{par}->@*, $file; 228 $total_time{$file} = $times{$file} || 0; 229 } 230 } 231 else { 232 # Treat every file in each non-serial directory as its own 233 # "directory", so that it can be executed in parallel 234 $dir{$file} = { seq => $file }; 235 $total_time{$file} = $times{$file} || 0; 236 } 237 } 238 239 undef %all_dirs; 240 241 # Here, everything is complete except for the directories that have both 242 # serial components and parallel components. The loop just above gathered 243 # the information required to finish setting those up, which we now do. 244 for my $partial_serial_dir (keys %split_partial_serials) { 245 246 # Look at just the serial portion for now. 247 my @seq_list = $split_partial_serials{$partial_serial_dir}{seq}->@*; 248 249 # The 0th element contains the sequence number; the 1th element the 250 # file name. Get the name, sorted first by the number, then by the 251 # name. Doing it this way allows sequence numbers to be varying 252 # length, and still get a numeric sort 253 my @sorted_seq_list = map { $_->[1] } 254 sort { $a->[0] <=> $b->[0] 255 or lc $a->[1] cmp lc $b->[1] } @seq_list; 256 257 # Now look at the tests to run in parallel. Sort in descending order 258 # of execution time. 259 my @par_list = sort sort_by_execution_order 260 $split_partial_serials{$partial_serial_dir}{par}->@*; 261 262 # The total time to execute this directory is the serial time (already 263 # calculated in the previous loop) plus the parallel time. To 264 # calculate an approximate parallel time, note that the minimum 265 # parallel time is the maximum of each of the test files run in 266 # parallel. If the number of parallel jobs J is more than the number 267 # of such files, N, it could be that all N get executed in parallel, 268 # so that maximum is the actual value. But if N > J, a second, or 269 # third, ... round will be required. The code below just takes the 270 # longest-running time for each round and adds that to the previous 271 # total. It is an imperfect estimate, but not unreasonable. 272 my $par_time = 0; 273 for (my $i = 0; $i < @par_list; $i += $jobs) { 274 $par_time += $times{$par_list[$i]} || 0; 275 } 276 $total_time{$partial_serial_dir} += $par_time; 277 278 # Now construct the rules. Each of the parallel tests is made into a 279 # single element 'seq' structure, like is done for all the other 280 # parallel tests. 281 @par_list = map { { seq => $_ } } @par_list; 282 283 # Then the directory is ordered to have the sequential tests executed 284 # first (serially), then the parallel tests (in parallel) 285 286 $dir{$partial_serial_dir} = 287 { 'seq' => [ { seq => \@sorted_seq_list }, 288 { par => \@par_list }, 289 ], 290 }; 291 } 292 293 #print STDERR __LINE__, join "\n", sort sort_by_execution_order keys %dir 294 295 # Generate T::H schedule rules that run the contents of each directory 296 # sequentially. 297 my @seq = { par => [ map { $dir{$_} } sort sort_by_execution_order 298 keys %dir 299 ] 300 }; 301 302 # and lastly add in the files which must be run by themselves without 303 # any other tests /at all/ running at the same time. 304 push @seq, map { +{ seq => $_ } } sort @alone_files if @alone_files; 305 306 return \@seq; 307} 308 309sub sort_by_execution_order { 310 # Directories, ordered by total time descending then name ascending 311 return $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b; 312} 313 314if (@ARGV) { 315 # If you want these run in speed order, just use prove 316 317 # Note: we use glob even on *nix and not just on Windows 318 # because arguments might be passed in via the TEST_ARGS 319 # env var where they wont be expanded by the shell. 320 @tests = map(glob($_),@ARGV); 321 # This is a hack to force config_heavy.pl to be loaded, before the 322 # prep work for running a test changes directory. 323 1 if $Config{d_fork}; 324} else { 325 # Ideally we'd get somewhere close to Tux's Oslo rules 326 # my $rules = { 327 # par => [ 328 # { seq => '../ext/DB_File/t/*' }, 329 # { seq => '../ext/IO_Compress_Zlib/t/*' }, 330 # { seq => '../lib/ExtUtils/t/*' }, 331 # '*' 332 # ] 333 # }; 334 335 # but for now, run all directories in sequence. 336 337 unless (@tests) { 338 my @seq = <base/*.t>; 339 push @tests, @seq; 340 341 my (@next, @last); 342 343 # The remaining core tests are either intermixed with the non-core for 344 # more parallelism (if PERL_TEST_HARNESS_ASAP is set non-zero) or done 345 # after the above basic sanity tests, before any non-core ones. 346 my $which = $ENV{PERL_TEST_HARNESS_ASAP} ? \@last : \@next; 347 348 push @$which, qw(comp run cmd); 349 push @$which, qw(io re opbasic op op/hook uni mro lib class porting perf test_pl); 350 push @$which, 'japh' if $torture or $ENV{PERL_TORTURE_TEST}; 351 push @$which, 'win32' if $is_win32; 352 push @$which, 'benchmark' if $ENV{PERL_BENCHMARK}; 353 push @$which, 'bigmem' if $ENV{PERL_TEST_MEMORY}; 354 355 if (@next) { 356 @next = map { glob ("$_/*.t") } @next; 357 push @tests, @next; 358 push @seq, _compute_tests_and_ordering(\@next)->@*; 359 } 360 361 @last = map { glob ("$_/*.t") } @last; 362 363 my ($non_ext, @ext_from_manifest)= 364 _tests_from_manifest($Config{extensions}, $Config{known_extensions}, "all"); 365 push @last, @ext_from_manifest; 366 367 push @seq, _compute_tests_and_ordering(\@last)->@*; 368 push @tests, @last; 369 370 $rules = { seq => \@seq }; 371 372 foreach my $test (@tests) { 373 delete $non_ext->{$test}; 374 } 375 376 my @in_manifest_but_not_found = sort keys %$non_ext; 377 if (@in_manifest_but_not_found) { 378 die "There are test files which are in MANIFEST but are not found by the t/harness\n", 379 "directory scanning rules. You should update t/harness line 339 or so.\n", 380 "Files:\n", map { " $_\n" } @in_manifest_but_not_found; 381 } 382 } 383} 384if ($is_win32) { 385 s,\\,/,g for @tests; 386} 387if (@re or @anti_re) { 388 my @keepers; 389 foreach my $test (@tests) { 390 my $keep = 0; 391 if (@re) { 392 foreach my $re (@re) { 393 $keep = 1 if $test=~/$re/; 394 } 395 } else { 396 $keep = 1; 397 } 398 if (@anti_re) { 399 foreach my $anti_re (@anti_re) { 400 $keep = 0 if $test=~/$anti_re/; 401 } 402 } 403 if ($keep) { 404 push @keepers, $test; 405 } 406 } 407 @tests= @keepers; 408} 409 410# Allow e.g., ./perl t/harness t/op/lc.t 411for (@tests) { 412 if (! -f $_ && !/^\.\./ && -f "../$_") { 413 $_ = "../$_"; 414 s{^\.\./t/}{}; 415 } 416} 417 418dump_tests(\@tests) if $dump_tests; 419 420filter_taint_tests(\@tests); 421 422my %options; 423 424my $type = 'perl'; 425 426# Load TAP::Parser now as otherwise it could be required in the short time span 427# in which the harness process chdirs into ext/Dist 428require TAP::Parser; 429 430my $h = TAP::Harness->new({ 431 rules => $rules, 432 color => $color, 433 jobs => $jobs, 434 verbosity => $Verbose, 435 timer => $ENV{HARNESS_TIMER}, 436 exec => sub { 437 my ($harness, $test) = @_; 438 439 my $options = $options{$test}; 440 if (!defined $options) { 441 $options = $options{$test} = _scan_test($test, $type); 442 } 443 444 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; 445 446 return [ split ' ', _cmd($options, $type) ]; 447 }, 448}); 449 450# Print valgrind output after test completes 451if ($ENV{PERL_VALGRIND}) { 452 $h->callback( 453 after_test => sub { 454 my ($job) = @_; 455 my $test = $job->[0]; 456 my $vfile = "$test.valgrind-current"; 457 $vfile =~ s/^.*\///; 458 459 if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) { 460 print "$test: Valgrind output:\n"; 461 print "$test: $_" for <$voutput>; 462 close($voutput); 463 } 464 465 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; 466 467 _check_valgrind(\$htoolnm, \$hgrind_ct, \$test); 468 } 469 ); 470} 471 472if ($state) { 473 $h->callback( 474 after_test => sub { 475 $state->observe_test(@_); 476 } 477 ); 478 $h->callback( 479 after_runtests => sub { 480 $state->commit(@_); 481 } 482 ); 483} 484 485$h->callback( 486 parser_args => sub { 487 my ($args, $job) = @_; 488 my $test = $job->[0]; 489 _before_fork($options{$test}); 490 push @{ $args->{switches} }, "-I../../lib"; 491 } 492 ); 493 494$h->callback( 495 made_parser => sub { 496 my ($parser, $job) = @_; 497 my $test = $job->[0]; 498 my $options = delete $options{$test}; 499 _after_fork($options); 500 } 501 ); 502 503my $agg = $h->runtests(@tests); 504_cleanup_valgrind(\$htoolnm, \$hgrind_ct); 505printf "Finished test run at %s.\n", scalar(localtime); 506exit($agg->has_errors ? 1 : 0); 507