This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typo in perldelta entry for bareword_filehandles removal
[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
96     # Note: we use glob even on *nix and not just on Windows
97     # because arguments might be passed in via the TEST_ARGS
98     # env var where they wont be expanded by the shell.
99     @tests = map(glob($_),@ARGV);
100     # This is a hack to force config_heavy.pl to be loaded, before the
101     # prep work for running a test changes directory.
102     1 if $Config{d_fork};
103 } else {
104     # Ideally we'd get somewhere close to Tux's Oslo rules
105     # my $rules = {
106     #     par => [
107     #         { seq => '../ext/DB_File/t/*' },
108     #         { seq => '../ext/IO_Compress_Zlib/t/*' },
109     #         { seq => '../lib/ExtUtils/t/*' },
110     #         '*'
111     #     ]
112     # };
113
114     # but for now, run all directories in sequence.
115
116     unless (@tests) {
117         my @seq = <base/*.t>;
118
119         my @last;
120         my @next = qw(comp run cmd);
121
122         # The remaining core tests are either intermixed with the non-core for
123         # more parallelism (if PERL_TEST_HARNESS_ASAP is set non-zero) or done
124         # after the above basic sanity tests, before any non-core ones.
125         my $which = $ENV{PERL_TEST_HARNESS_ASAP} ? \@last : \@next;
126
127         push @$which, qw(io re opbasic op uni mro lib porting perf);
128         push @$which, 'japh' if $torture;
129         push @$which, 'win32' if $^O eq 'MSWin32';
130         push @$which, 'benchmark' if $ENV{PERL_BENCHMARK};
131         push @$which, 'bigmem' if $ENV{PERL_TEST_MEMORY};
132
133         # Hopefully TAP::Parser::Scheduler will support this syntax soon.
134         # my $next = { par => '{' . join (',', @next) . '}/*.t' };
135         my $next = { par => [
136                              map { "$_/*.t" } @next
137                             ] };
138         @tests = _extract_tests ($next);
139
140         my $last = { par => '{' . join (',', @last) . '}/*.t' };
141         @last = _extract_tests ($last);
142
143         # This is a bit of a game, because we only want to sort these tests in
144         # speed order. base/*.t wants to run first, and ext,lib etc last and in
145         # MANIFEST order
146         if ($jobs) {
147             require App::Prove::State;
148             $state = App::Prove::State->new({ store => 'test_state' });
149             $state->apply_switch('slow', 'save');
150             # For some reason get_tests returns *all* the tests previously run,
151             # (in the right order), not simply the selection in @tests
152             # (in the right order). Not sure if this is a bug or a feature.
153             # Whatever, *we* are only interested in the ones that are in @tests
154             my %seen;
155             @seen{@tests} = ();
156             @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests);
157         }
158         @tests = (@seq, @tests);
159         push @seq, $next;
160
161         push @last,
162             _tests_from_manifest($Config{extensions}, $Config{known_extensions});
163         my %times;
164         if ($state) {
165             # Where known, collate the elapsed times by test name
166             foreach ($state->results->tests()) {
167                 $times{$_->name} = $_->elapsed();
168             }
169         }
170
171         my %dir;
172         my %total_time;
173         my %serials;
174         my %all_dirs;
175
176         # Preprocess the list of tests
177         for (@last) {
178             if ($^O eq 'MSWin32') {
179                 s,\\,/,g; # canonicalize path
180             };
181
182             # Keep a list of the distinct directory names, and another list of
183             # those which contain a file whose name begins with a 0
184             if ( m! \A (?: \.\. / )?
185                                 ( .*? )         # $1 is the directory path name
186                             /
187                                 ( [^/]* \.t )   # $2 is the .t name
188                     \z !x)
189             {
190                 my $path = $1;
191
192                 $all_dirs{$path} = 1;
193                 $serials{$path} = 1 if $2 =~ / \A 0 /x;
194             }
195         }
196
197         # We assume that the reason a test file's name begins with a 0 is to
198         # order its execution among the tests in its directory.  Hence, a
199         # directory containing such files should be tested in serial order.
200         #
201         # Add exceptions to the above rule
202         for (qw(cpan/IO-Zlib/t ext/File-Find/t)) {
203             $serials{$_} = 1;
204         }
205
206         my @nonexistent_serials = grep { not exists $all_dirs{$_} } keys %serials;
207         if (@nonexistent_serials) {
208             die "These directories to be run serially don't exist."
209               . "  Check your spelling:\n" . join "\n", @nonexistent_serials;
210         }
211
212         # Remove the serial testing directories from the list of all
213         # directories.  The remaining ones are testable in parallel.  Make the
214         # parallel list a scalar with names separated by '|' so that below
215         # they will be added to a regular expression.
216         my $non_serials = join "|", grep { not exists $serials{$_} } keys %all_dirs;
217         undef %all_dirs;
218         undef %serials;
219
220         for (@last) {
221             # Treat every file in each non-serial directory as its own
222             # "directory", so that it can be executed in parallel
223             m! \A ( (?: \.\. / )? (?: $non_serials )
224                          / [^/]+ \.t \z | .* [/] ) !x
225                 or die "'$_'";
226             push @{$dir{$1}}, $_;
227
228             # This file contributes time to the total needed for the directory
229             # as a whole
230             $total_time{$1} += $times{$_} || 0;
231         }
232         #print STDERR __LINE__, join "\n", sort { $total_time{$b} <=> $total_time{$a} } keys %dir, "  ";
233
234         push @tests, @last;
235
236         # Generate T::H schedule rules that run the contents of each directory
237         # sequentially.
238         push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort {
239             # Directories, ordered by total time descending then name ascending
240             $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b
241         } keys %dir ] };
242
243         $rules = { seq => \@seq };
244     }
245 }
246 if ($^O eq 'MSWin32') {
247     s,\\,/,g for @tests;
248 }
249 if (@re or @anti_re) {
250     my @keepers;
251     foreach my $test (@tests) {
252         my $keep = 0;
253         if (@re) {
254             foreach my $re (@re) {
255                 $keep = 1 if $test=~/$re/;
256             }
257         } else {
258             $keep = 1;
259         }
260         if (@anti_re) {
261             foreach my $anti_re (@anti_re) {
262                 $keep = 0 if $test=~/$anti_re/;
263             }
264         }
265         if ($keep) {
266             push @keepers, $test;
267         }
268     }
269     @tests= @keepers;
270 }
271
272 # Allow eg ./perl t/harness t/op/lc.t
273 for (@tests) {
274     if (! -f $_ && !/^\.\./ && -f "../$_") {
275         $_ = "../$_";
276         s{^\.\./t/}{};
277     }
278 }
279
280 my %options;
281
282 my $type = 'perl';
283
284 # Load TAP::Parser now as otherwise it could be required in the short time span
285 # in which the harness process chdirs into ext/Dist
286 require TAP::Parser;
287
288 my $h = TAP::Harness->new({
289     rules       => $rules,
290     color       => $color,
291     jobs        => $jobs,
292     verbosity   => $Verbose,
293     timer       => $ENV{HARNESS_TIMER},
294     exec        => sub {
295         my ($harness, $test) = @_;
296
297         my $options = $options{$test};
298         if (!defined $options) {
299             $options = $options{$test} = _scan_test($test, $type);
300         }
301
302         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
303
304         return [ split ' ', _cmd($options, $type) ];
305     },
306 });
307
308 # Print valgrind output after test completes
309 if ($ENV{PERL_VALGRIND}) {
310     $h->callback(
311                  after_test => sub {
312                      my ($job) = @_;
313                      my $test = $job->[0];
314                      my $vfile = "$test.valgrind-current";
315                      $vfile =~ s/^.*\///;
316
317                      if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) {
318                         print "$test: Valgrind output:\n";
319                         print "$test: $_" for <$voutput>;
320                         close($voutput);
321                      }
322
323                      (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
324
325                      _check_valgrind(\$htoolnm, \$hgrind_ct, \$test);
326                  }
327                  );
328 }
329
330 if ($state) {
331     $h->callback(
332                  after_test => sub {
333                      $state->observe_test(@_);
334                  }
335                  );
336     $h->callback(
337                  after_runtests => sub {
338                      $state->commit(@_);
339                  }
340                  );
341 }
342
343 $h->callback(
344              parser_args => sub {
345                  my ($args, $job) = @_;
346                  my $test = $job->[0];
347                  _before_fork($options{$test});
348                  push @{ $args->{switches} }, "-I../../lib";
349              }
350              );
351
352 $h->callback(
353              made_parser => sub {
354                  my ($parser, $job) = @_;
355                  my $test = $job->[0];
356                  my $options = delete $options{$test};
357                  _after_fork($options);
358              }
359              );
360
361 my $agg = $h->runtests(@tests);
362 _cleanup_valgrind(\$htoolnm, \$hgrind_ct);
363 exit $agg->has_errors ? 1 : 0;