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