This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5337delta: note that stadtx was removed
[perl5.git] / t / harness
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 @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
134         # Hopefully TAP::Parser::Scheduler will support this syntax soon.
135         # my $next = { par => '{' . join (',', @next) . '}/*.t' };
136         my $next = { par => [
137                              map { "$_/*.t" } @next
138                             ] };
139         @tests = _extract_tests ($next);
140
141         my $last = { par => '{' . join (',', @last) . '}/*.t' };
142         @last = _extract_tests ($last);
143
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;
161
162         push @last,
163             _tests_from_manifest($Config{extensions}, $Config{known_extensions});
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;
174         my %serials;
175         my %all_dirs;
176
177         # Preprocess the list of tests
178         for (@last) {
179             if ($^O eq 'MSWin32') {
180                 s,\\,/,g; # canonicalize path
181             };
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
185             if ( m! \A (?: \.\. / )?
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
203         for (qw(ext/Pod-Html/t cpan/IO-Zlib/t ext/File-Find/t)) {
204             $serials{$_} = 1;
205         }
206
207         my @nonexistent_serials = grep { not exists $all_dirs{$_} } keys %serials;
208         if (@nonexistent_serials) {
209             die "These directories to be run serially don't exist."
210               . "  Check your spelling:\n" . join "\n", @nonexistent_serials;
211         }
212
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
224             m! \A ( (?: \.\. / )? (?: $non_serials )
225                          / [^/]+ \.t \z | .* [/] ) !x
226                 or die "'$_'";
227             push @{$dir{$1}}, $_;
228
229             # This file contributes time to the total needed for the directory
230             # as a whole
231             $total_time{$1} += $times{$_} || 0;
232         }
233         #print STDERR __LINE__, join "\n", sort { $total_time{$b} <=> $total_time{$a} } keys %dir, "  ";
234
235         push @tests, @last;
236
237         # Generate T::H schedule rules that run the contents of each directory
238         # sequentially.
239         push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort {
240             # Directories, ordered by total time descending then name ascending
241             $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b
242         } keys %dir ] };
243
244         $rules = { seq => \@seq };
245     }
246 }
247 if ($^O eq 'MSWin32') {
248     s,\\,/,g for @tests;
249 }
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 }
272
273 # Allow eg ./perl t/harness t/op/lc.t
274 for (@tests) {
275     if (! -f $_ && !/^\.\./ && -f "../$_") {
276         $_ = "../$_";
277         s{^\.\./t/}{};
278     }
279 }
280
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
289 my $h = TAP::Harness->new({
290     rules       => $rules,
291     color       => $color,
292     jobs        => $jobs,
293     verbosity   => $Verbose,
294     timer       => $ENV{HARNESS_TIMER},
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
303         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
304
305         return [ split ' ', _cmd($options, $type) ];
306     },
307 });
308
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
331 if ($state) {
332     $h->callback(
333                  after_test => sub {
334                      $state->observe_test(@_);
335                  }
336                  );
337     $h->callback(
338                  after_runtests => sub {
339                      $state->commit(@_);
340                  }
341                  );
342 }
343
344 $h->callback(
345              parser_args => sub {
346                  my ($args, $job) = @_;
347                  my $test = $job->[0];
348                  _before_fork($options{$test});
349                  push @{ $args->{switches} }, "-I../../lib";
350              }
351              );
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
362 my $agg = $h->runtests(@tests);
363 _cleanup_valgrind(\$htoolnm, \$hgrind_ct);
364 exit $agg->has_errors ? 1 : 0;