Commit | Line | Data |
---|---|---|
a5f75d66 AD |
1 | #!./perl |
2 | ||
3 | # We suppose that perl _mostly_ works at this moment, so may use | |
4 | # sophisticated testing. | |
5 | ||
aa689395 | 6 | BEGIN { |
7 | chdir 't' if -d 't'; | |
122a0375 | 8 | @INC = '../lib'; # pick up only this build's lib |
aa689395 | 9 | } |
c537bcda | 10 | |
2165aa6a YO |
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 | # | |
24 | my @_must_be_executed_serially = qw( | |
25 | ); | |
26 | my %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 | |
dcfb8208 | 33 | # this is used to handle tests which are sensitive to load and which might |
2165aa6a YO |
34 | # fail if they were run at the same time as something load intensive. |
35 | # | |
36 | # Example: ../dist/threads-shared/t/waithires.t | |
37 | # | |
38 | my @_must_be_executed_alone = qw(); | |
39 | my %must_be_executed_alone = map { $_ => 1 } @_must_be_executed_alone; | |
ca54131a YO |
40 | |
41 | my $OS = $ENV{FAKE_OS} || $^O; | |
42 | my $is_linux = $OS eq "linux"; | |
43 | my $is_win32 = $OS eq "MSWin32"; | |
44 | ||
45 | if (!$is_linux) { | |
2165aa6a YO |
46 | $must_be_executed_alone{"../dist/threads-shared/t/waithires.t"} = 1; |
47 | } | |
48 | ############################################################################## | |
cd5cd5f6 | 49 | |
e018f8be JH |
50 | my $torture; # torture testing? |
51 | ||
abd39864 | 52 | use TAP::Harness 3.13; |
9a4933c3 | 53 | use strict; |
68bb50b0 | 54 | use Config; |
a5f75d66 | 55 | |
c537bcda NC |
56 | $::do_nothing = $::do_nothing = 1; |
57 | require './TEST'; | |
be075caf | 58 | our $Valgrind_Log; |
c537bcda | 59 | |
abd39864 MS |
60 | my $Verbose = 0; |
61 | $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; | |
a5f75d66 | 62 | |
be075caf MH |
63 | # For valgrind summary output |
64 | my $htoolnm; | |
65 | my $hgrind_ct; | |
66 | ||
ca54131a YO |
67 | my $dump_tests = 0; |
68 | if ($ARGV[0] && $ARGV[0] =~ /^-?-dumptests$/) { | |
69 | shift; | |
70 | $dump_tests = 1; | |
71 | } | |
72 | ||
73 | if ($ARGV[0] && $ARGV[0] =~ /^-?-torture$/) { | |
e018f8be JH |
74 | shift; |
75 | $torture = 1; | |
76 | } | |
77 | ||
60e23f2f MS |
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 | ||
7c82d9f4 | 82 | my (@tests, @re, @anti_re); |
122a0375 | 83 | |
40996b78 AT |
84 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
85 | @ARGV = grep $_ && length( $_ ) => @ARGV; | |
86 | ||
ca54131a | 87 | while ($ARGV[0] && $ARGV[0]=~/^-?-(n?)re/) { |
7c82d9f4 YO |
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 | } | |
8a76aa1f | 95 | } else { |
7c82d9f4 | 96 | push @$ary, (split/=/,shift @ARGV)[1]; |
8a76aa1f YO |
97 | } |
98 | } | |
99 | ||
b79e05fa | 100 | my $jobs = $ENV{TEST_JOBS}; |
abd39864 | 101 | my ($rules, $state, $color); |
52d8e37f | 102 | |
cd1b270f B |
103 | if ($ENV{HARNESS_OPTIONS}) { |
104 | for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { | |
105 | if ( $opt =~ /^j(\d*)$/ ) { | |
106 | $jobs ||= $1 || 9; | |
107 | } | |
cd1b270f | 108 | elsif ( $opt eq 'c' ) { |
abd39864 | 109 | $color = 1; |
cd1b270f B |
110 | } |
111 | else { | |
112 | die "Unknown HARNESS_OPTIONS item: $opt\n"; | |
113 | } | |
114 | } | |
115 | } | |
0279961e | 116 | |
b79e05fa MM |
117 | $jobs ||= 1; |
118 | ||
9de1881b | 119 | my %total_time; |
543d5bd2 KW |
120 | sub _compute_tests_and_ordering($) { |
121 | my @tests = $_[0]->@*; | |
122 | ||
123 | my %dir; | |
543d5bd2 KW |
124 | my %all_dirs; |
125 | my %map_file_to_dir; | |
126 | ||
da545c2e | 127 | if (!$dump_tests) { |
543d5bd2 | 128 | require App::Prove::State; |
da545c2e YO |
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 | } | |
543d5bd2 KW |
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 | ||
2165aa6a | 161 | my %partial_serials; |
543d5bd2 KW |
162 | # Preprocess the list of tests |
163 | for my $file (@tests) { | |
ca54131a | 164 | if ($is_win32) { |
543d5bd2 KW |
165 | $file =~ s,\\,/,g; # canonicalize path |
166 | }; | |
167 | ||
168 | # Keep a list of the distinct directory names, and another list of | |
543d5bd2 KW |
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 | ||
2165aa6a | 179 | $all_dirs{$path} = 1; |
543d5bd2 | 180 | $map_file_to_dir{$file} = $path; |
2165aa6a YO |
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; | |
fd51efa1 | 185 | } |
543d5bd2 KW |
186 | } |
187 | } | |
188 | ||
fd51efa1 YO |
189 | my %split_partial_serials; |
190 | ||
2165aa6a | 191 | my @alone_files; |
fd51efa1 | 192 | # Ready to figure out the timings. |
543d5bd2 KW |
193 | for my $file (@tests) { |
194 | my $file_dir = $map_file_to_dir{$file}; | |
195 | ||
2165aa6a YO |
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 | ||
fd51efa1 YO |
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}) { | |
2165aa6a | 206 | if ($must_be_executed_serially{$file}) { |
fd51efa1 YO |
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 | } | |
2165aa6a | 223 | else { |
fd51efa1 YO |
224 | # Treat every file in each non-serial directory as its own |
225 | # "directory", so that it can be executed in parallel | |
543d5bd2 KW |
226 | $dir{$file} = { seq => $file }; |
227 | $total_time{$file} = $times{$file} || 0; | |
228 | } | |
543d5bd2 KW |
229 | } |
230 | ||
231 | undef %all_dirs; | |
fd51efa1 YO |
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) | |
2165aa6a | 277 | |
fd51efa1 | 278 | $dir{$partial_serial_dir} = |
2165aa6a YO |
279 | { 'seq' => [ { seq => \@sorted_seq_list }, |
280 | { par => \@par_list }, | |
fd51efa1 YO |
281 | ], |
282 | }; | |
283 | } | |
284 | ||
543d5bd2 KW |
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 | ||
2165aa6a YO |
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; | |
dcfb8208 | 297 | |
543d5bd2 KW |
298 | return \@seq; |
299 | } | |
300 | ||
9de1881b KW |
301 | sub 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 | ||
7a315204 | 306 | if (@ARGV) { |
0279961e | 307 | # If you want these run in speed order, just use prove |
aa2a6ac2 | 308 | |
c2556348 | 309 | # Note: we use glob even on *nix and not just on Windows |
aa2a6ac2 YO |
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); | |
68bb50b0 NC |
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}; | |
7a315204 | 316 | } else { |
9ae5a6c3 NC |
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/*' }, | |
9ae5a6c3 NC |
322 | # { seq => '../lib/ExtUtils/t/*' }, |
323 | # '*' | |
324 | # ] | |
325 | # }; | |
326 | ||
ee901278 | 327 | # but for now, run all directories in sequence. |
9ae5a6c3 | 328 | |
b695f709 | 329 | unless (@tests) { |
ffee07c8 | 330 | my @seq = <base/*.t>; |
6f959d89 | 331 | push @tests, @seq; |
9ae5a6c3 | 332 | |
6f959d89 | 333 | my (@next, @last); |
9cbb5ac7 KW |
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 | ||
6f959d89 | 340 | push @$which, qw(comp run cmd); |
93f6f965 | 341 | push @$which, qw(io re opbasic op op/hook uni mro lib class porting perf test_pl); |
ca54131a YO |
342 | push @$which, 'japh' if $torture or $ENV{PERL_TORTURE_TEST}; |
343 | push @$which, 'win32' if $is_win32; | |
ffee07c8 KW |
344 | push @$which, 'benchmark' if $ENV{PERL_BENCHMARK}; |
345 | push @$which, 'bigmem' if $ENV{PERL_TEST_MEMORY}; | |
346 | ||
6f959d89 | 347 | if (@next) { |
ce8b32d4 | 348 | @next = map { glob ("$_/*.t") } @next; |
6f959d89 KW |
349 | push @tests, @next; |
350 | push @seq, _compute_tests_and_ordering(\@next)->@*; | |
351 | } | |
ffee07c8 | 352 | |
ce8b32d4 | 353 | @last = map { glob ("$_/*.t") } @last; |
9ae5a6c3 | 354 | |
508a94b6 YO |
355 | my ($non_ext, @ext_from_manifest)= |
356 | _tests_from_manifest($Config{extensions}, $Config{known_extensions}, "all"); | |
357 | push @last, @ext_from_manifest; | |
358 | ||
543d5bd2 | 359 | push @seq, _compute_tests_and_ordering(\@last)->@*; |
508a94b6 | 360 | push @tests, @last; |
9ae5a6c3 | 361 | |
ffee07c8 | 362 | $rules = { seq => \@seq }; |
508a94b6 YO |
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 | } | |
7a315204 JH |
374 | } |
375 | } | |
ca54131a | 376 | if ($is_win32) { |
22a65f1e GS |
377 | s,\\,/,g for @tests; |
378 | } | |
7c82d9f4 YO |
379 | if (@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 | } | |
9ae5a6c3 | 401 | |
63cbdd60 | 402 | # Allow e.g., ./perl t/harness t/op/lc.t |
cfa56252 | 403 | for (@tests) { |
683433bd | 404 | if (! -f $_ && !/^\.\./ && -f "../$_") { |
cfa56252 JH |
405 | $_ = "../$_"; |
406 | s{^\.\./t/}{}; | |
407 | } | |
408 | } | |
409 | ||
ca54131a YO |
410 | dump_tests(\@tests) if $dump_tests; |
411 | ||
66fb7f3c YO |
412 | filter_taint_tests(\@tests); |
413 | ||
4013a0e1 VP |
414 | my %options; |
415 | ||
416 | my $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 | |
420 | require TAP::Parser; | |
421 | ||
abd39864 MS |
422 | my $h = TAP::Harness->new({ |
423 | rules => $rules, | |
424 | color => $color, | |
425 | jobs => $jobs, | |
426 | verbosity => $Verbose, | |
640eedb9 | 427 | timer => $ENV{HARNESS_TIMER}, |
4013a0e1 | 428 | exec => sub { |
ffee07c8 | 429 | my ($harness, $test) = @_; |
4013a0e1 | 430 | |
ffee07c8 KW |
431 | my $options = $options{$test}; |
432 | if (!defined $options) { | |
433 | $options = $options{$test} = _scan_test($test, $type); | |
434 | } | |
4013a0e1 | 435 | |
ffee07c8 | 436 | (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; |
be075caf | 437 | |
ffee07c8 | 438 | return [ split ' ', _cmd($options, $type) ]; |
4013a0e1 | 439 | }, |
abd39864 | 440 | }); |
a0f20b65 | 441 | |
be075caf MH |
442 | # Print valgrind output after test completes |
443 | if ($ENV{PERL_VALGRIND}) { | |
444 | $h->callback( | |
ffee07c8 KW |
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 | ); | |
be075caf MH |
462 | } |
463 | ||
a0f20b65 | 464 | if ($state) { |
e8fb11d7 | 465 | $h->callback( |
ffee07c8 KW |
466 | after_test => sub { |
467 | $state->observe_test(@_); | |
468 | } | |
469 | ); | |
a0f20b65 | 470 | $h->callback( |
ffee07c8 KW |
471 | after_runtests => sub { |
472 | $state->commit(@_); | |
473 | } | |
474 | ); | |
9ae5a6c3 | 475 | } |
a0f20b65 NC |
476 | |
477 | $h->callback( | |
ffee07c8 KW |
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 | ); | |
4013a0e1 VP |
485 | |
486 | $h->callback( | |
ffee07c8 KW |
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 | ); | |
4013a0e1 | 494 | |
f483babb | 495 | my $agg = $h->runtests(@tests); |
be075caf | 496 | _cleanup_valgrind(\$htoolnm, \$hgrind_ct); |
5d022c09 | 497 | printf "Finished test run at %s.\n", scalar(localtime); |
a862c9af | 498 | exit($agg->has_errors ? 1 : 0); |