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