1#!./perl
2
3# We suppose that perl _mostly_ works at this moment, so may use
4# sophisticated testing.
5
6BEGIN {
7    chdir 't' if -d 't';
8    @INC = '../lib';              # pick up only this build's lib
9}
10
11##############################################################################
12# Test files which cannot be executed at the same time.
13#
14# List all files which might fail when executed at the same time as another
15# test file from the same test directory. Being listed here does not mean
16# the test will be run by itself, it just means it won't be run at the same
17# time as any other file in the same test directory, it might be run at the
18# same time as a file from a different test directory.
19#
20# Ideally this is always empty.
21#
22# Example: ../cpan/IO-Zlib/t/basic.t
23#
24my @_must_be_executed_serially = qw(
25);
26my %must_be_executed_serially = map { $_ => 1 } @_must_be_executed_serially;
27##############################################################################
28
29##############################################################################
30# Test files which must be executed alone.
31#
32# List files which cannot be run at the same time as any other test. Typically
33# this is used to handle tests which are sensitive to load and which might
34# fail if they were run at the same time as something load intensive.
35#
36# Example: ../dist/threads-shared/t/waithires.t
37#
38my @_must_be_executed_alone = qw();
39my %must_be_executed_alone = map { $_ => 1 } @_must_be_executed_alone;
40
41my $OS = $ENV{FAKE_OS} || $^O;
42my $is_linux = $OS eq "linux";
43my $is_win32 = $OS eq "MSWin32";
44
45if (!$is_linux) {
46    $must_be_executed_alone{"../dist/threads-shared/t/waithires.t"} = 1;
47}
48##############################################################################
49
50my $torture; # torture testing?
51
52use TAP::Harness 3.13;
53use strict;
54use Config;
55
56$::do_nothing = $::do_nothing = 1;
57require './TEST';
58our $Valgrind_Log;
59
60my $Verbose = 0;
61$Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift;
62
63# For valgrind summary output
64my $htoolnm;
65my $hgrind_ct;
66
67my $dump_tests = 0;
68if ($ARGV[0] && $ARGV[0] =~ /^-?-dumptests$/) {
69    shift;
70    $dump_tests = 1;
71}
72
73if ($ARGV[0] && $ARGV[0] =~ /^-?-torture$/) {
74    shift;
75    $torture = 1;
76}
77
78# Let tests know they're running in the perl core.  Useful for modules
79# which live dual lives on CPAN.
80$ENV{PERL_CORE} = 1;
81
82my (@tests, @re, @anti_re);
83
84# [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV
85@ARGV = grep $_ && length( $_ ) => @ARGV;
86
87while ($ARGV[0] && $ARGV[0]=~/^-?-(n?)re/) {
88    my $ary= $1 ? \@anti_re : \@re;
89
90    if ( $ARGV[0] !~ /=/ ) {
91        shift @ARGV;
92        while (@ARGV and $ARGV[0] !~ /^-/) {
93            push @$ary, shift @ARGV;
94        }
95    } else {
96        push @$ary, (split/=/,shift @ARGV)[1];
97    }
98}
99
100my $jobs = $ENV{TEST_JOBS};
101my ($rules, $state, $color);
102
103if ($ENV{HARNESS_OPTIONS}) {
104    for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) {
105        if ( $opt =~ /^j(\d*)$/ ) {
106            $jobs ||= $1 || 9;
107        }
108        elsif ( $opt eq 'c' ) {
109            $color = 1;
110        }
111        else {
112            die "Unknown HARNESS_OPTIONS item: $opt\n";
113        }
114    }
115}
116
117$jobs ||= 1;
118
119my %total_time;
120sub _compute_tests_and_ordering($) {
121    my @tests = $_[0]->@*;
122
123    my %dir;
124    my %all_dirs;
125    my %map_file_to_dir;
126
127    if (!$dump_tests) {
128        require App::Prove::State;
129        if (!$state) {
130            # silence unhelpful warnings from App::Prove::State about not having
131            # a save state, unless we actually set the PERL_TEST_STATE we don't care
132            # and we don't need to know if its fresh or not.
133            local $SIG{__WARN__} = $ENV{PERL_TEST_STATE} ? $SIG{__WARN__} : sub {
134                return if $_[0] and $_[0]=~/No saved state/;
135                warn $_[0];
136            };
137            my $state_file = $ENV{PERL_TEST_STATE_FILE} // 'test_state';
138            if ($state_file) { # set PERL_TEST_STATE_FILE to 0 to skip this
139                $state = App::Prove::State->new({ store => $state_file });
140                $state->apply_switch('save');
141                $state->apply_switch('slow') if $jobs > 1;
142            }
143        }
144        # For some reason get_tests returns *all* the tests previously run,
145        # (in the right order), not simply the selection in @tests
146        # (in the right order). Not sure if this is a bug or a feature.
147        # Whatever, *we* are only interested in the ones that are in @tests
148        my %seen;
149        @seen{@tests} = ();
150        @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests);
151    }
152
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 %partial_serials;
162    # Preprocess the list of tests
163    for my $file (@tests) {
164        if ($is_win32) {
165            $file =~ s,\\,/,g; # canonicalize path
166        };
167
168        # Keep a list of the distinct directory names, and another list of
169        if ($file =~ m! \A ( (?: \.\. / )?
170                                .*?
171                            )             # $1 is the directory path name
172                            /
173                            ( [^/]* \. (?: t | pl ) ) # $2 is the test name
174                        \z !x)
175        {
176            my $path = $1;
177            my $name = $2;
178
179            $all_dirs{$path} = 1;
180            $map_file_to_dir{$file} = $path;
181            # is this is a file that requires we do special processing
182            # on the directory as a whole?
183            if ($must_be_executed_serially{$file}) {
184                $partial_serials{$path} = 1;
185            }
186        }
187    }
188
189    my %split_partial_serials;
190
191    my @alone_files;
192    # Ready to figure out the timings.
193    for my $file (@tests) {
194        my $file_dir = $map_file_to_dir{$file};
195
196        # if this is a file which must be processed alone
197        if ($must_be_executed_alone{$file}) {
198            push @alone_files, $file;
199            next;
200        }
201
202        # Special handling is needed for a directory that has some test files
203        # to execute serially, and some to execute in parallel.  This loop
204        # gathers information that a later loop will process.
205        if (defined $partial_serials{$file_dir}) {
206            if ($must_be_executed_serially{$file}) {
207                # This is a file to execute serially.  Its time contributes
208                # directly to the total time for this directory.
209                $total_time{$file_dir} += $times{$file} || 0;
210
211                # Save the sequence number with the file for now; below we
212                # will come back to it.
213                push $split_partial_serials{$file_dir}{seq}->@*, [ $1, $file ];
214            }
215            else {
216                # This is a file to execute in parallel after all the
217                # sequential ones are done.  Save its time in the hash to
218                # later calculate its time contribution.
219                push $split_partial_serials{$file_dir}{par}->@*, $file;
220                $total_time{$file} = $times{$file} || 0;
221            }
222        }
223        else {
224            # Treat every file in each non-serial directory as its own
225            # "directory", so that it can be executed in parallel
226            $dir{$file} = { seq => $file };
227            $total_time{$file} = $times{$file} || 0;
228        }
229    }
230
231    undef %all_dirs;
232
233    # Here, everything is complete except for the directories that have both
234    # serial components and parallel components.  The loop just above gathered
235    # the information required to finish setting those up, which we now do.
236    for my $partial_serial_dir (keys %split_partial_serials) {
237
238        # Look at just the serial portion for now.
239        my @seq_list = $split_partial_serials{$partial_serial_dir}{seq}->@*;
240
241        # The 0th element contains the sequence number; the 1th element the
242        # file name.  Get the name, sorted first by the number, then by the
243        # name.  Doing it this way allows sequence numbers to be varying
244        # length, and still get a numeric sort
245        my @sorted_seq_list = map { $_->[1] }
246                                sort {    $a->[0] <=>    $b->[0]
247                                    or lc $a->[1] cmp lc $b->[1] } @seq_list;
248
249        # Now look at the tests to run in parallel.  Sort in descending order
250        # of execution time.
251        my @par_list = sort sort_by_execution_order
252                        $split_partial_serials{$partial_serial_dir}{par}->@*;
253
254        # The total time to execute this directory is the serial time (already
255        # calculated in the previous loop) plus the parallel time.  To
256        # calculate an approximate parallel time, note that the minimum
257        # parallel time is the maximum of each of the test files run in
258        # parallel.  If the number of parallel jobs J is more than the number
259        # of such files, N, it could be that all N get executed in parallel,
260        # so that maximum is the actual value.  But if N > J, a second, or
261        # third, ...  round will be required.  The code below just takes the
262        # longest-running time for each round and adds that to the previous
263        # total.  It is an imperfect estimate, but not unreasonable.
264        my $par_time = 0;
265        for (my $i = 0; $i < @par_list; $i += $jobs) {
266            $par_time += $times{$par_list[$i]} || 0;
267        }
268        $total_time{$partial_serial_dir} += $par_time;
269
270        # Now construct the rules.  Each of the parallel tests is made into a
271        # single element 'seq' structure, like is done for all the other
272        # parallel tests.
273        @par_list = map { { seq => $_ } } @par_list;
274
275        # Then the directory is ordered to have the sequential tests executed
276        # first (serially), then the parallel tests (in parallel)
277
278        $dir{$partial_serial_dir} =
279                                { 'seq' => [ { seq => \@sorted_seq_list },
280                                             { par => \@par_list        },
281                                           ],
282                                };
283    }
284
285    #print STDERR __LINE__, join "\n", sort sort_by_execution_order keys %dir
286
287    # Generate T::H schedule rules that run the contents of each directory
288    # sequentially.
289    my @seq = { par => [ map { $dir{$_} } sort sort_by_execution_order
290                                                                    keys %dir
291                        ]
292               };
293
294    # and lastly add in the files which must be run by themselves without
295    # any other tests /at all/ running at the same time.
296    push @seq, map { +{ seq => $_ } } sort @alone_files if @alone_files;
297
298    return \@seq;
299}
300
301sub sort_by_execution_order {
302    # Directories, ordered by total time descending then name ascending
303    return $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b;
304}
305
306if (@ARGV) {
307    # If you want these run in speed order, just use prove
308
309    # Note: we use glob even on *nix and not just on Windows
310    # because arguments might be passed in via the TEST_ARGS
311    # env var where they wont be expanded by the shell.
312    @tests = map(glob($_),@ARGV);
313    # This is a hack to force config_heavy.pl to be loaded, before the
314    # prep work for running a test changes directory.
315    1 if $Config{d_fork};
316} else {
317    # Ideally we'd get somewhere close to Tux's Oslo rules
318    # my $rules = {
319    #     par => [
320    #         { seq => '../ext/DB_File/t/*' },
321    #         { seq => '../ext/IO_Compress_Zlib/t/*' },
322    #         { seq => '../lib/ExtUtils/t/*' },
323    #         '*'
324    #     ]
325    # };
326
327    # but for now, run all directories in sequence.
328
329    unless (@tests) {
330        my @seq = <base/*.t>;
331        push @tests, @seq;
332
333        my (@next, @last);
334
335        # The remaining core tests are either intermixed with the non-core for
336        # more parallelism (if PERL_TEST_HARNESS_ASAP is set non-zero) or done
337        # after the above basic sanity tests, before any non-core ones.
338        my $which = $ENV{PERL_TEST_HARNESS_ASAP} ? \@last : \@next;
339
340        push @$which, qw(comp run cmd);
341        push @$which, qw(io re opbasic op op/hook uni mro lib class porting perf test_pl);
342        push @$which, 'japh' if $torture or $ENV{PERL_TORTURE_TEST};
343        push @$which, 'win32' if $is_win32;
344        push @$which, 'benchmark' if $ENV{PERL_BENCHMARK};
345        push @$which, 'bigmem' if $ENV{PERL_TEST_MEMORY};
346
347        if (@next) {
348            @next = map { glob ("$_/*.t") } @next;
349            push @tests, @next;
350            push @seq, _compute_tests_and_ordering(\@next)->@*;
351        }
352
353        @last = map { glob ("$_/*.t") } @last;
354
355        my ($non_ext, @ext_from_manifest)=
356            _tests_from_manifest($Config{extensions}, $Config{known_extensions}, "all");
357        push @last, @ext_from_manifest;
358
359        push @seq, _compute_tests_and_ordering(\@last)->@*;
360        push @tests, @last;
361
362        $rules = { seq => \@seq };
363
364        foreach my $test (@tests) {
365            delete $non_ext->{$test};
366        }
367
368        my @in_manifest_but_not_found = sort keys %$non_ext;
369        if (@in_manifest_but_not_found) {
370            die "There are test files which are in MANIFEST but are not found by the t/harness\n",
371                 "directory scanning rules. You should update t/harness line 339 or so.\n",
372                 "Files:\n", map { "    $_\n" } @in_manifest_but_not_found;
373        }
374    }
375}
376if ($is_win32) {
377    s,\\,/,g for @tests;
378}
379if (@re or @anti_re) {
380    my @keepers;
381    foreach my $test (@tests) {
382        my $keep = 0;
383        if (@re) {
384            foreach my $re (@re) {
385                $keep = 1 if $test=~/$re/;
386            }
387        } else {
388            $keep = 1;
389        }
390        if (@anti_re) {
391            foreach my $anti_re (@anti_re) {
392                $keep = 0 if $test=~/$anti_re/;
393            }
394        }
395        if ($keep) {
396            push @keepers, $test;
397        }
398    }
399    @tests= @keepers;
400}
401
402# Allow e.g., ./perl t/harness t/op/lc.t
403for (@tests) {
404    if (! -f $_ && !/^\.\./ && -f "../$_") {
405        $_ = "../$_";
406        s{^\.\./t/}{};
407    }
408}
409
410dump_tests(\@tests) if $dump_tests;
411
412filter_taint_tests(\@tests);
413
414my %options;
415
416my $type = 'perl';
417
418# Load TAP::Parser now as otherwise it could be required in the short time span
419# in which the harness process chdirs into ext/Dist
420require TAP::Parser;
421
422my $h = TAP::Harness->new({
423    rules       => $rules,
424    color       => $color,
425    jobs        => $jobs,
426    verbosity   => $Verbose,
427    timer       => $ENV{HARNESS_TIMER},
428    exec        => sub {
429        my ($harness, $test) = @_;
430
431        my $options = $options{$test};
432        if (!defined $options) {
433            $options = $options{$test} = _scan_test($test, $type);
434        }
435
436        (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
437
438        return [ split ' ', _cmd($options, $type) ];
439    },
440});
441
442# Print valgrind output after test completes
443if ($ENV{PERL_VALGRIND}) {
444    $h->callback(
445                 after_test => sub {
446                     my ($job) = @_;
447                     my $test = $job->[0];
448                     my $vfile = "$test.valgrind-current";
449                     $vfile =~ s/^.*\///;
450
451                     if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) {
452                        print "$test: Valgrind output:\n";
453                        print "$test: $_" for <$voutput>;
454                        close($voutput);
455                     }
456
457                     (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
458
459                     _check_valgrind(\$htoolnm, \$hgrind_ct, \$test);
460                 }
461                 );
462}
463
464if ($state) {
465    $h->callback(
466                 after_test => sub {
467                     $state->observe_test(@_);
468                 }
469                 );
470    $h->callback(
471                 after_runtests => sub {
472                     $state->commit(@_);
473                 }
474                 );
475}
476
477$h->callback(
478             parser_args => sub {
479                 my ($args, $job) = @_;
480                 my $test = $job->[0];
481                 _before_fork($options{$test});
482                 push @{ $args->{switches} }, "-I../../lib";
483             }
484             );
485
486$h->callback(
487             made_parser => sub {
488                 my ($parser, $job) = @_;
489                 my $test = $job->[0];
490                 my $options = delete $options{$test};
491                 _after_fork($options);
492             }
493             );
494
495my $agg = $h->runtests(@tests);
496_cleanup_valgrind(\$htoolnm, \$hgrind_ct);
497printf "Finished test run at %s.\n", scalar(localtime);
498exit $agg->has_errors ? 1 : 0;
499