(perl #131836) avoid a use-after-free after parsing a "sub" keyword
[perl.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);
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 if ($ARGV[0] && $ARGV[0]=~/^-re/) {
65     if ($ARGV[0]!~/=/) {
66         shift;
67         $re=join "|",@ARGV;
68         @ARGV=();
69     } else {
70         (undef,$re)=split/=/,shift;
71     }
72 }
73
74 my $jobs = $ENV{TEST_JOBS};
75 my ($rules, $state, $color);
76 if ($ENV{HARNESS_OPTIONS}) {
77     for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) {
78         if ( $opt =~ /^j(\d*)$/ ) {
79             $jobs ||= $1 || 9;
80         }
81         elsif ( $opt eq 'c' ) {
82             $color = 1;
83         }
84         else {
85             die "Unknown HARNESS_OPTIONS item: $opt\n";
86         }
87     }
88 }
89
90 if (@ARGV) {
91     # If you want these run in speed order, just use prove
92     if ($^O eq 'MSWin32') {
93         @tests = map(glob($_),@ARGV);
94     }
95     else {
96         @tests = @ARGV;
97     }
98     # This is a hack to force config_heavy.pl to be loaded, before the
99     # prep work for running a test changes directory.
100     1 if $Config{d_fork};
101 } else {
102     # Ideally we'd get somewhere close to Tux's Oslo rules
103     # my $rules = {
104     #     par => [
105     #         { seq => '../ext/DB_File/t/*' },
106     #         { seq => '../ext/IO_Compress_Zlib/t/*' },
107     #         { seq => '../lib/ExtUtils/t/*' },
108     #         '*'
109     #     ]
110     # };
111
112     # but for now, run all directories in sequence.
113
114     unless (@tests) {
115         my @seq = <base/*.t>;
116
117         my @next = qw(comp run cmd io re opbasic op uni mro lib porting perf);
118         push @next, 'japh' if $torture;
119         push @next, 'win32' if $^O eq 'MSWin32';
120         push @next, 'benchmark' if $ENV{PERL_BENCHMARK};
121         push @next, 'bigmem' if $ENV{PERL_TEST_MEMORY};
122         # Hopefully TAP::Parser::Scheduler will support this syntax soon.
123         # my $next = { par => '{' . join (',', @next) . '}/*.t' };
124         my $next = { par => [
125                              map { "$_/*.t" } @next
126                             ] };
127         @tests = _extract_tests ($next);
128
129         # This is a bit of a game, because we only want to sort these tests in
130         # speed order. base/*.t wants to run first, and ext,lib etc last and in
131         # MANIFEST order
132         if ($jobs) {
133             require App::Prove::State;
134             $state = App::Prove::State->new({ store => 'test_state' });
135             $state->apply_switch('slow', 'save');
136             # For some reason get_tests returns *all* the tests previously run,
137             # (in the right order), not simply the selection in @tests
138             # (in the right order). Not sure if this is a bug or a feature.
139             # Whatever, *we* are only interested in the ones that are in @tests
140             my %seen;
141             @seen{@tests} = ();
142             @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests);
143         }
144         @tests = (@seq, @tests);
145         push @seq, $next;
146
147         my @last;
148         push @last,
149             _tests_from_manifest($Config{extensions}, $Config{known_extensions});
150         my %times;
151         if ($state) {
152             # Where known, collate the elapsed times by test name
153             foreach ($state->results->tests()) {
154                 $times{$_->name} = $_->elapsed();
155             }
156         }
157
158         my %dir;
159         my %total_time;
160
161         for (@last) {
162             if ($^O eq 'MSWin32') {
163                 s,\\,/,g; # canonicalize path
164             };
165             # Treat every file matching lib/*.t as a "directory"
166             m! \A ( \.\. / (?: lib | ext/XS-APItest/t )
167                          / [^/]+ \.t \z | .* [/] ) !x
168                 or die "'$_'";
169             push @{$dir{$1}}, $_;
170             $total_time{$1} += $times{$_} || 0;
171         }
172
173         push @tests, @last;
174
175         # Generate T::H schedule rules that run the contents of each directory
176         # sequentially.
177         push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort {
178             # Directories, ordered by total time descending then name ascending
179             $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b
180         } keys %dir ] };
181
182         $rules = { seq => \@seq };
183     }
184 }
185 if ($^O eq 'MSWin32') {
186     s,\\,/,g for @tests;
187 }
188 @tests=grep /$re/, @tests 
189     if $re;
190
191 # Allow eg ./perl t/harness t/op/lc.t
192 for (@tests) {
193     if (! -f $_ && !/^\.\./ && -f "../$_") {
194         $_ = "../$_";
195         s{^\.\./t/}{};
196     }
197 }
198
199 my %options;
200
201 my $type = 'perl';
202
203 # Load TAP::Parser now as otherwise it could be required in the short time span
204 # in which the harness process chdirs into ext/Dist
205 require TAP::Parser;
206
207 my $h = TAP::Harness->new({
208     rules       => $rules,
209     color       => $color,
210     jobs        => $jobs,
211     verbosity   => $Verbose,
212     timer       => $ENV{HARNESS_TIMER},
213     exec        => sub {
214         my ($harness, $test) = @_;
215
216         my $options = $options{$test};
217         if (!defined $options) {
218             $options = $options{$test} = _scan_test($test, $type);
219         }
220
221         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
222
223         return [ split ' ', _cmd($options, $type) ];
224     },
225 });
226
227 # Print valgrind output after test completes
228 if ($ENV{PERL_VALGRIND}) {
229     $h->callback(
230                  after_test => sub {
231                      my ($job) = @_;
232                      my $test = $job->[0];
233                      my $vfile = "$test.valgrind-current";
234                      $vfile =~ s/^.*\///;
235
236                      if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) {
237                         print "$test: Valgrind output:\n";
238                         print "$test: $_" for <$voutput>;
239                         close($voutput);
240                      }
241
242                      (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
243
244                      _check_valgrind(\$htoolnm, \$hgrind_ct, \$test);
245                  }
246                  );
247 }
248
249 if ($state) {
250     $h->callback(
251                  after_test => sub {
252                      $state->observe_test(@_);
253                  }
254                  );
255     $h->callback(
256                  after_runtests => sub {
257                      $state->commit(@_);
258                  }
259                  );
260 }
261
262 $h->callback(
263              parser_args => sub {
264                  my ($args, $job) = @_;
265                  my $test = $job->[0];
266                  _before_fork($options{$test});
267                  push @{ $args->{switches} }, "-I../../lib";
268              }
269              );
270
271 $h->callback(
272              made_parser => sub {
273                  my ($parser, $job) = @_;
274                  my $test = $job->[0];
275                  my $options = delete $options{$test};
276                  _after_fork($options);
277              }
278              );
279
280 my $agg = $h->runtests(@tests);
281 _cleanup_valgrind(\$htoolnm, \$hgrind_ct);
282 exit $agg->has_errors ? 1 : 0;