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