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 | |
e018f8be JH |
11 | my $torture; # torture testing? |
12 | ||
abd39864 | 13 | use TAP::Harness 3.13; |
9a4933c3 | 14 | use strict; |
68bb50b0 | 15 | use Config; |
a5f75d66 | 16 | |
c537bcda NC |
17 | $::do_nothing = $::do_nothing = 1; |
18 | require './TEST'; | |
be075caf | 19 | our $Valgrind_Log; |
c537bcda | 20 | |
abd39864 MS |
21 | my $Verbose = 0; |
22 | $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; | |
a5f75d66 | 23 | |
be075caf MH |
24 | # For valgrind summary output |
25 | my $htoolnm; | |
26 | my $hgrind_ct; | |
27 | ||
12558422 | 28 | if ($ARGV[0] && $ARGV[0] eq '-torture') { |
e018f8be JH |
29 | shift; |
30 | $torture = 1; | |
31 | } | |
32 | ||
60e23f2f MS |
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 | ||
7c82d9f4 | 37 | my (@tests, @re, @anti_re); |
122a0375 | 38 | |
40996b78 AT |
39 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
40 | @ARGV = grep $_ && length( $_ ) => @ARGV; | |
41 | ||
9ae5a6c3 NC |
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 { | |
0ae187c2 | 58 | push @results, glob $_; |
9ae5a6c3 NC |
59 | } |
60 | } | |
61 | @results; | |
62 | } | |
63 | ||
7c82d9f4 YO |
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 | } | |
8a76aa1f | 72 | } else { |
7c82d9f4 | 73 | push @$ary, (split/=/,shift @ARGV)[1]; |
8a76aa1f YO |
74 | } |
75 | } | |
76 | ||
0279961e | 77 | my $jobs = $ENV{TEST_JOBS}; |
abd39864 | 78 | my ($rules, $state, $color); |
cd1b270f B |
79 | if ($ENV{HARNESS_OPTIONS}) { |
80 | for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { | |
81 | if ( $opt =~ /^j(\d*)$/ ) { | |
82 | $jobs ||= $1 || 9; | |
83 | } | |
cd1b270f | 84 | elsif ( $opt eq 'c' ) { |
abd39864 | 85 | $color = 1; |
cd1b270f B |
86 | } |
87 | else { | |
88 | die "Unknown HARNESS_OPTIONS item: $opt\n"; | |
89 | } | |
90 | } | |
91 | } | |
0279961e | 92 | |
7a315204 | 93 | if (@ARGV) { |
0279961e | 94 | # If you want these run in speed order, just use prove |
4efb34a6 NIS |
95 | if ($^O eq 'MSWin32') { |
96 | @tests = map(glob($_),@ARGV); | |
97 | } | |
98 | else { | |
99 | @tests = @ARGV; | |
100 | } | |
68bb50b0 NC |
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}; | |
7a315204 | 104 | } else { |
9ae5a6c3 NC |
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/*' }, | |
9ae5a6c3 NC |
110 | # { seq => '../lib/ExtUtils/t/*' }, |
111 | # '*' | |
112 | # ] | |
113 | # }; | |
114 | ||
ee901278 | 115 | # but for now, run all directories in sequence. |
9ae5a6c3 | 116 | |
b695f709 | 117 | unless (@tests) { |
0279961e | 118 | my @seq = <base/*.t>; |
9ae5a6c3 | 119 | |
9cbb5ac7 KW |
120 | my @last; |
121 | my @next = qw(comp run cmd); | |
122 | ||
123 | # The remaining core tests are either intermixed with the non-core for | |
124 | # more parallelism (if PERL_TEST_HARNESS_ASAP is set non-zero) or done | |
125 | # after the above basic sanity tests, before any non-core ones. | |
126 | my $which = $ENV{PERL_TEST_HARNESS_ASAP} ? \@last : \@next; | |
127 | ||
128 | push @$which, qw(io re opbasic op uni mro lib porting perf); | |
129 | push @$which, 'japh' if $torture; | |
130 | push @$which, 'win32' if $^O eq 'MSWin32'; | |
131 | push @$which, 'benchmark' if $ENV{PERL_BENCHMARK}; | |
132 | push @$which, 'bigmem' if $ENV{PERL_TEST_MEMORY}; | |
133 | ||
0279961e NC |
134 | # Hopefully TAP::Parser::Scheduler will support this syntax soon. |
135 | # my $next = { par => '{' . join (',', @next) . '}/*.t' }; | |
136 | my $next = { par => [ | |
2f4cffa7 | 137 | map { "$_/*.t" } @next |
e6867818 | 138 | ] }; |
0279961e NC |
139 | @tests = _extract_tests ($next); |
140 | ||
9cbb5ac7 KW |
141 | my $last = { par => '{' . join (',', @last) . '}/*.t' }; |
142 | @last = _extract_tests ($last); | |
143 | ||
0279961e NC |
144 | # This is a bit of a game, because we only want to sort these tests in |
145 | # speed order. base/*.t wants to run first, and ext,lib etc last and in | |
146 | # MANIFEST order | |
147 | if ($jobs) { | |
148 | require App::Prove::State; | |
149 | $state = App::Prove::State->new({ store => 'test_state' }); | |
150 | $state->apply_switch('slow', 'save'); | |
151 | # For some reason get_tests returns *all* the tests previously run, | |
152 | # (in the right order), not simply the selection in @tests | |
153 | # (in the right order). Not sure if this is a bug or a feature. | |
154 | # Whatever, *we* are only interested in the ones that are in @tests | |
155 | my %seen; | |
156 | @seen{@tests} = (); | |
157 | @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); | |
158 | } | |
159 | @tests = (@seq, @tests); | |
160 | push @seq, $next; | |
9ae5a6c3 | 161 | |
704b574d | 162 | push @last, |
a3323f52 | 163 | _tests_from_manifest($Config{extensions}, $Config{known_extensions}); |
226de479 NC |
164 | my %times; |
165 | if ($state) { | |
166 | # Where known, collate the elapsed times by test name | |
167 | foreach ($state->results->tests()) { | |
168 | $times{$_->name} = $_->elapsed(); | |
169 | } | |
170 | } | |
171 | ||
172 | my %dir; | |
173 | my %total_time; | |
9b0adf19 KW |
174 | my %serials; |
175 | my %all_dirs; | |
226de479 | 176 | |
9b0adf19 | 177 | # Preprocess the list of tests |
226de479 | 178 | for (@last) { |
133fac12 MM |
179 | if ($^O eq 'MSWin32') { |
180 | s,\\,/,g; # canonicalize path | |
181 | }; | |
9b0adf19 KW |
182 | |
183 | # Keep a list of the distinct directory names, and another list of | |
184 | # those which contain a file whose name begins with a 0 | |
9cbb5ac7 | 185 | if ( m! \A (?: \.\. / )? |
9b0adf19 KW |
186 | ( .*? ) # $1 is the directory path name |
187 | / | |
188 | ( [^/]* \.t ) # $2 is the .t name | |
189 | \z !x) | |
190 | { | |
191 | my $path = $1; | |
192 | ||
193 | $all_dirs{$path} = 1; | |
194 | $serials{$path} = 1 if $2 =~ / \A 0 /x; | |
195 | } | |
196 | } | |
197 | ||
198 | # We assume that the reason a test file's name begins with a 0 is to | |
199 | # order its execution among the tests in its directory. Hence, a | |
200 | # directory containing such files should be tested in serial order. | |
201 | # | |
202 | # Add exceptions to the above rule | |
8433f829 | 203 | for (qw(cpan/IO-Zlib/t ext/File-Find/t)) { |
9b0adf19 KW |
204 | $serials{$_} = 1; |
205 | } | |
206 | ||
2f58fd73 KW |
207 | my @nonexistent_serials = grep { not exists $all_dirs{$_} } keys %serials; |
208 | if (@nonexistent_serials) { | |
21815b50 KW |
209 | die "These directories to be run serially don't exist." |
210 | . " Check your spelling:\n" . join "\n", @nonexistent_serials; | |
2f58fd73 KW |
211 | } |
212 | ||
9b0adf19 KW |
213 | # Remove the serial testing directories from the list of all |
214 | # directories. The remaining ones are testable in parallel. Make the | |
215 | # parallel list a scalar with names separated by '|' so that below | |
216 | # they will be added to a regular expression. | |
217 | my $non_serials = join "|", grep { not exists $serials{$_} } keys %all_dirs; | |
218 | undef %all_dirs; | |
219 | undef %serials; | |
220 | ||
221 | for (@last) { | |
222 | # Treat every file in each non-serial directory as its own | |
223 | # "directory", so that it can be executed in parallel | |
9cbb5ac7 | 224 | m! \A ( (?: \.\. / )? (?: $non_serials ) |
7d24ce13 KW |
225 | / [^/]+ \.t \z | .* [/] ) !x |
226 | or die "'$_'"; | |
226de479 | 227 | push @{$dir{$1}}, $_; |
9b0adf19 KW |
228 | |
229 | # This file contributes time to the total needed for the directory | |
230 | # as a whole | |
226de479 NC |
231 | $total_time{$1} += $times{$_} || 0; |
232 | } | |
9b0adf19 | 233 | #print STDERR __LINE__, join "\n", sort { $total_time{$b} <=> $total_time{$a} } keys %dir, " "; |
226de479 | 234 | |
0279961e | 235 | push @tests, @last; |
9ae5a6c3 | 236 | |
fc279e46 NC |
237 | # Generate T::H schedule rules that run the contents of each directory |
238 | # sequentially. | |
8f776eae | 239 | push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort { |
226de479 | 240 | # Directories, ordered by total time descending then name ascending |
704b574d | 241 | $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b |
226de479 | 242 | } keys %dir ] }; |
9ae5a6c3 NC |
243 | |
244 | $rules = { seq => \@seq }; | |
7a315204 JH |
245 | } |
246 | } | |
22a65f1e GS |
247 | if ($^O eq 'MSWin32') { |
248 | s,\\,/,g for @tests; | |
249 | } | |
7c82d9f4 YO |
250 | if (@re or @anti_re) { |
251 | my @keepers; | |
252 | foreach my $test (@tests) { | |
253 | my $keep = 0; | |
254 | if (@re) { | |
255 | foreach my $re (@re) { | |
256 | $keep = 1 if $test=~/$re/; | |
257 | } | |
258 | } else { | |
259 | $keep = 1; | |
260 | } | |
261 | if (@anti_re) { | |
262 | foreach my $anti_re (@anti_re) { | |
263 | $keep = 0 if $test=~/$anti_re/; | |
264 | } | |
265 | } | |
266 | if ($keep) { | |
267 | push @keepers, $test; | |
268 | } | |
269 | } | |
270 | @tests= @keepers; | |
271 | } | |
9ae5a6c3 | 272 | |
cfa56252 JH |
273 | # Allow eg ./perl t/harness t/op/lc.t |
274 | for (@tests) { | |
683433bd | 275 | if (! -f $_ && !/^\.\./ && -f "../$_") { |
cfa56252 JH |
276 | $_ = "../$_"; |
277 | s{^\.\./t/}{}; | |
278 | } | |
279 | } | |
280 | ||
4013a0e1 VP |
281 | my %options; |
282 | ||
283 | my $type = 'perl'; | |
284 | ||
285 | # Load TAP::Parser now as otherwise it could be required in the short time span | |
286 | # in which the harness process chdirs into ext/Dist | |
287 | require TAP::Parser; | |
288 | ||
abd39864 MS |
289 | my $h = TAP::Harness->new({ |
290 | rules => $rules, | |
291 | color => $color, | |
292 | jobs => $jobs, | |
293 | verbosity => $Verbose, | |
640eedb9 | 294 | timer => $ENV{HARNESS_TIMER}, |
4013a0e1 VP |
295 | exec => sub { |
296 | my ($harness, $test) = @_; | |
297 | ||
298 | my $options = $options{$test}; | |
299 | if (!defined $options) { | |
300 | $options = $options{$test} = _scan_test($test, $type); | |
301 | } | |
302 | ||
be075caf MH |
303 | (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; |
304 | ||
4013a0e1 VP |
305 | return [ split ' ', _cmd($options, $type) ]; |
306 | }, | |
abd39864 | 307 | }); |
a0f20b65 | 308 | |
be075caf MH |
309 | # Print valgrind output after test completes |
310 | if ($ENV{PERL_VALGRIND}) { | |
311 | $h->callback( | |
312 | after_test => sub { | |
313 | my ($job) = @_; | |
314 | my $test = $job->[0]; | |
315 | my $vfile = "$test.valgrind-current"; | |
316 | $vfile =~ s/^.*\///; | |
317 | ||
318 | if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) { | |
319 | print "$test: Valgrind output:\n"; | |
320 | print "$test: $_" for <$voutput>; | |
321 | close($voutput); | |
322 | } | |
323 | ||
324 | (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; | |
325 | ||
326 | _check_valgrind(\$htoolnm, \$hgrind_ct, \$test); | |
327 | } | |
328 | ); | |
329 | } | |
330 | ||
a0f20b65 | 331 | if ($state) { |
e8fb11d7 | 332 | $h->callback( |
a0f20b65 NC |
333 | after_test => sub { |
334 | $state->observe_test(@_); | |
e8fb11d7 | 335 | } |
a0f20b65 NC |
336 | ); |
337 | $h->callback( | |
338 | after_runtests => sub { | |
339 | $state->commit(@_); | |
340 | } | |
341 | ); | |
9ae5a6c3 | 342 | } |
a0f20b65 NC |
343 | |
344 | $h->callback( | |
345 | parser_args => sub { | |
4013a0e1 VP |
346 | my ($args, $job) = @_; |
347 | my $test = $job->[0]; | |
348 | _before_fork($options{$test}); | |
349 | push @{ $args->{switches} }, "-I../../lib"; | |
a0f20b65 NC |
350 | } |
351 | ); | |
4013a0e1 VP |
352 | |
353 | $h->callback( | |
354 | made_parser => sub { | |
355 | my ($parser, $job) = @_; | |
356 | my $test = $job->[0]; | |
357 | my $options = delete $options{$test}; | |
358 | _after_fork($options); | |
359 | } | |
360 | ); | |
361 | ||
f483babb | 362 | my $agg = $h->runtests(@tests); |
be075caf | 363 | _cleanup_valgrind(\$htoolnm, \$hgrind_ct); |
f483babb | 364 | exit $agg->has_errors ? 1 : 0; |