This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldelta - move split change to other perlfunc changes and add issue link
[perl5.git] / t / TEST
1 #!./perl
2
3 # This is written in a peculiar style, since we're trying to avoid
4 # most of the constructs we'll be testing for.  (This comment is
5 # probably obsolete on the avoidance side, though still current
6 # on the peculiarity side.)
7
8 # t/TEST and t/harness need to share code. The logical way to do this would be
9 # to have the common code in a file both require or use. However, t/TEST needs
10 # to still work, to generate test results, even if require isn't working, so
11 # we cannot do that. t/harness has no such restriction, so it is quite
12 # acceptable to have it require t/TEST.
13
14 # In which case, we need to stop t/TEST actually running tests, as all
15 # t/harness needs are its subroutines.
16
17 # Measure the elapsed wallclock time.
18 my $t0 = time();
19
20 # If we're doing deparse tests, ignore failures for these
21 my $deparse_failures;
22
23 # And skip even running these
24 my $deparse_skips;
25
26 my $deparse_skip_file = '../Porting/deparse-skips.txt';
27
28 # directories with special sets of test switches
29 my %dir_to_switch =
30     (base => '',
31      comp => '',
32      run => '',
33      '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/
34      );
35
36 # "not absolute" is the default, as it saves some fakery within TestInit
37 # which can perturb tests, and takes CPU. Working with the upstream author of
38 # any of these, to figure out how to remove them from this list, considered
39 # "a good thing".
40 my %abs = (
41            '../cpan/Archive-Tar' => 1,
42            '../cpan/AutoLoader' => 1,
43            '../cpan/CPAN' => 1,
44            '../cpan/Encode' => 1,
45            '../cpan/ExtUtils-Constant' => 1,
46            '../cpan/ExtUtils-Install' => 1,
47            '../cpan/ExtUtils-MakeMaker' => 1,
48            '../cpan/ExtUtils-Manifest' => 1,
49            '../cpan/File-Fetch' => 1,
50            '../cpan/IPC-Cmd' => 1,
51            '../cpan/IPC-SysV' => 1,
52            '../cpan/Module-Load' => 1,
53            '../cpan/Module-Load-Conditional' => 1,
54            '../cpan/Pod-Simple' => 1,
55            '../cpan/Test-Simple' => 1,
56            '../cpan/podlators' => 1,
57            '../dist/Cwd' => 1,
58            '../dist/Devel-PPPort' => 1,
59            '../dist/ExtUtils-ParseXS' => 1,
60            '../dist/Tie-File' => 1,
61           );
62
63 my %temp_no_core = (
64      '../cpan/Compress-Raw-Bzip2' => 1,
65      '../cpan/Compress-Raw-Zlib' => 1,
66      '../cpan/Devel-PPPort' => 1,
67      '../cpan/Getopt-Long' => 1,
68      '../cpan/IO-Compress' => 1,
69      '../cpan/MIME-Base64' => 1,
70      '../cpan/parent' => 1,
71      '../cpan/Pod-Simple' => 1,
72      '../cpan/podlators' => 1,
73      '../cpan/Test-Simple' => 1,
74      '../cpan/Tie-RefHash' => 1,
75      '../cpan/Unicode-Collate' => 1,
76      '../dist/Unicode-Normalize' => 1,
77     );
78
79 # delete env vars that may influence the results
80 # but allow override via *_TEST env var if wanted
81 # (e.g. PERL5OPT_TEST=-d:NYTProf)
82 my @bad_env_vars = qw(
83     PERL5LIB PERLLIB PERL5OPT PERL_UNICODE
84     PERL_YAML_BACKEND PERL_JSON_BACKEND
85 );
86
87 for my $envname (@bad_env_vars) {
88     my $override = $ENV{"${envname}_TEST"};
89     if (defined $override) {
90         warn "$0: $envname=$override\n";
91         $ENV{$envname} = $override;
92     }
93     else {
94         delete $ENV{$envname};
95     }
96 }
97
98 # Location to put the Valgrind log.
99 our $Valgrind_Log;
100
101 my %skip = (
102             '.' => 1,
103             '..' => 1,
104             'CVS' => 1,
105             'RCS' => 1,
106             'SCCS' => 1,
107             '.svn' => 1,
108            );
109
110
111 if ($::do_nothing) {
112     return 1;
113 }
114
115 $| = 1;
116
117 # for testing TEST only
118 #BEGIN { require '../lib/strict.pm'; "strict"->import() };
119 #BEGIN { require '../lib/warnings.pm'; "warnings"->import() };
120
121 # remove empty elements due to insertion of empty symbols via "''p1'" syntax
122 @ARGV = grep($_,@ARGV) if $^O eq 'VMS';
123
124 # String eval to avoid loading File::Glob on non-miniperl.
125 # (Windows only uses this script for miniperl.)
126 @ARGV = eval 'map glob, @ARGV' if $^O eq 'MSWin32';
127
128 our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0;
129
130 # Cheesy version of Getopt::Std.  We can't replace it with that, because we
131 # can't rely on require working.
132 {
133     my @argv = ();
134     foreach my $idx (0..$#ARGV) {
135         push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
136         $::benchmark = 1 if $1 eq 'benchmark';
137         $::core    = 1 if $1 eq 'core';
138         $::verbose = 1 if $1 eq 'v';
139         $::torture = 1 if $1 eq 'torture';
140         $::with_utf8 = 1 if $1 eq 'utf8';
141         $::with_utf16 = 1 if $1 eq 'utf16';
142         $::taintwarn = 1 if $1 eq 'taintwarn';
143         if ($1 =~ /^deparse(,.+)?$/) {
144             $::deparse = 1;
145             $::deparse_opts = $1;
146             _process_deparse_config();
147         }
148     }
149     @ARGV = @argv;
150 }
151
152 chdir 't' if -f 't/TEST';
153 if (-f 'TEST' && -f 'harness' && -d '../lib') {
154     @INC = '../lib';
155 }
156
157 die "You need to run \"make test_prep\" first to set things up.\n"
158   unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
159
160 # check leakage for embedders
161 $ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
162 # check existence of all symbols
163 $ENV{PERL_DL_NONLAZY} = 1 unless exists $ENV{PERL_DL_NONLAZY};
164
165 $ENV{EMXSHELL} = 'sh';        # For OS/2
166
167 if ($show_elapsed_time) { require Time::HiRes }
168 my %timings = (); # testname => [@et] pairs if $show_elapsed_time.
169
170 # Roll your own File::Find!
171 our @found;
172 sub _find_tests { @found=(); push @ARGV, _find_files('\.t$', $_[0]) }
173 sub _find_files {
174     my($patt, @dirs) = @_;
175     for my $dir (@dirs) {
176         opendir DIR, $dir or die "Trouble opening $dir: $!";
177         foreach my $f (sort { $a cmp $b } readdir DIR) {
178             next if $skip{$f};
179
180             my $fullpath = "$dir/$f";
181             
182             if (-d $fullpath) {
183                 _find_files($patt, $fullpath);
184             } elsif ($f =~ /$patt/) {
185                 push @found, $fullpath;
186             }
187         }
188     }
189     @found;
190 }
191
192
193 # Scan the text of the test program to find switches and special options
194 # we might need to apply.
195 sub _scan_test {
196     my($test, $type) = @_;
197
198     open(my $script, "<", $test) or die "Can't read $test.\n";
199     my $first_line = <$script>;
200
201     $first_line =~ tr/\0//d if $::with_utf16;
202
203     my $switch = "";
204     if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) {
205         $switch = "-$1";
206     } else {
207         if ($::taintwarn) {
208             # not all tests are expected to pass with this option
209             $switch = '-t';
210         } else {
211             $switch = '';
212         }
213     }
214
215     my $file_opts = "";
216     if ($type eq 'deparse') {
217         # Look for #line directives which change the filename
218         while (<$script>) {
219             $file_opts = $file_opts . ",-f$3$4"
220               if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
221         }
222     }
223
224     close $script;
225
226     my $perl = $^O eq 'MSWin32' ? '.\perl' : './perl';
227     my $lib  = '../lib';
228     my $run_dir;
229     my $return_dir;
230
231     $test =~ /^(.+)\/[^\/]+/;
232     my $dir = $1;
233     my $testswitch = $dir_to_switch{$dir};
234     if (!defined $testswitch) {
235         if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) {
236             $run_dir = $1;
237             $return_dir = '../../t';
238             $lib = '../../lib';
239             $perl = '../../t/perl';
240             $testswitch = "-I../.. -MTestInit=U2T";
241             if ($2 eq 'cpan' || $2 eq 'dist') {
242                 if($abs{$run_dir}) {
243                     $testswitch = $testswitch . ',A';
244                 }
245                 if ($temp_no_core{$run_dir}) {
246                     $testswitch = $testswitch . ',NC';
247                 }
248             }
249         } elsif ($test =~ m!^\.\./lib!) {
250             $testswitch = '-I.. -MTestInit=U1'; # -T will remove . from @INC
251         } else {
252             $testswitch = '-I.. -MTestInit';  # -T will remove . from @INC
253         }
254     }
255
256     my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : '';
257
258     my %options = (
259         perl => $perl,
260         lib => $lib,
261         test => $test,
262         run_dir => $run_dir,
263         return_dir => $return_dir,
264         testswitch => $testswitch,
265         utf8 => $utf8,
266         file => $file_opts,
267         switch => $switch,
268     );
269
270     return \%options;
271 }
272
273 sub _cmd {
274     my($options, $type) = @_;
275
276     my $test = $options->{test};
277
278     my $cmd;
279     if ($type eq 'deparse') {
280         my $perl = "$options->{perl} $options->{testswitch}";
281         my $lib = $options->{lib};
282
283         $cmd = (
284           "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,".
285           "-l$::deparse_opts$options->{file} ".
286           "$test > $test.dp ".
287           "&& $perl $options->{switch} -I$lib $test.dp"
288         );
289     }
290     elsif ($type eq 'perl') {
291         my $perl = $options->{perl};
292         my $redir = $^O eq 'VMS' ? '2>&1' : '';
293
294         if ($ENV{PERL_VALGRIND}) {
295             my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp";
296             my $valgrind_exe = $ENV{VALGRIND} // 'valgrind';
297             if ($options->{run_dir}) {
298                 require Cwd;
299                 $Valgrind_Log = Cwd::abs_path("$options->{run_dir}/$Valgrind_Log");
300             }
301             my $vg_opts = $ENV{VG_OPTS}
302                //   "--log-file=$Valgrind_Log "
303                   . "--suppressions=$perl_supp --leak-check=yes "
304                   . "--leak-resolution=high --show-reachable=yes "
305                   . "--num-callers=50 --track-origins=yes";
306             # Force logging if not asked for (so cachegrind reporting works below)
307             if ($vg_opts !~ /--log-file/) {
308                 $vg_opts = "--log-file=$Valgrind_Log $vg_opts";
309             }
310             $perl = "$valgrind_exe $vg_opts $perl";
311         }
312
313         my $args = "$options->{testswitch} $options->{switch} $options->{utf8}";
314         $cmd = $perl . _quote_args($args) . " $test $redir";
315     }
316     return $cmd;
317 }
318
319 sub _before_fork {
320     my ($options) = @_;
321
322     if ($options->{run_dir}) {
323         my $run_dir = $options->{run_dir};
324         chdir $run_dir or die "Can't chdir to '$run_dir': $!";
325     }
326
327     # Remove previous valgrind output otherwise it will interfere
328     my $test = $options->{test};
329
330     (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
331
332     if ($ENV{PERL_VALGRIND} && -e $Valgrind_Log) {
333         unlink $Valgrind_Log
334             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
335     }
336
337     return;
338 }
339
340 sub _after_fork {
341     my ($options) = @_;
342
343     if ($options->{return_dir}) {
344         my $return_dir = $options->{return_dir};
345         chdir $return_dir
346            or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!";
347     }
348
349     return;
350 }
351
352 sub _run_test {
353     my ($test, $type) = @_;
354
355     my $options = _scan_test($test, $type);
356     # $test might have changed if we're in ext/Foo, so don't use it anymore
357     # from now on. Use $options->{test} instead.
358
359     _before_fork($options);
360
361     my $cmd = _cmd($options, $type);
362
363     open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n";
364
365     _after_fork($options);
366
367     # Our environment may force us to use UTF-8, but we can't be sure that
368     # anything we're reading from will be generating (well formed) UTF-8
369     # This may not be the best way - possibly we should unset ${^OPEN} up
370     # top?
371     binmode $results;
372
373     return $results;
374 }
375
376 sub _quote_args {
377     my ($args) = @_;
378     my $argstring = '';
379
380     foreach (split(/\s+/,$args)) {
381        # In VMS protect with doublequotes because otherwise
382        # DCL will lowercase -- unless already doublequoted.
383        $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
384        $argstring = $argstring . ' ' . $_;
385     }
386     return $argstring;
387 }
388
389 sub _populate_hash {
390     return unless defined $_[0];
391     return map {$_, 1} split /\s+/, $_[0];
392 }
393
394 sub _tests_from_manifest {
395     my ($extensions, $known_extensions) = @_;
396     my %skip;
397     my %extensions = _populate_hash($extensions);
398     my %known_extensions = _populate_hash($known_extensions);
399
400     foreach (keys %known_extensions) {
401         $skip{$_} = 1 unless $extensions{$_};
402     }
403
404     my @results;
405     my $mani = '../MANIFEST';
406     if (open(MANI, $mani)) {
407         while (<MANI>) {
408             if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
409                 my $t = $1;
410                 my $extension = $2;
411
412                 next if ord "A" != 65
413                      && defined $extension
414                      && $extension =~ m! \b (?:
415                                                 Archive-Tar/
416                                               | Config-Perl-V/
417                                               | CPAN-Meta/
418                                               | CPAN-Meta-YAML/
419                                               | Digest-SHA/
420                                               | ExtUtils-MakeMaker/
421                                               | HTTP-Tiny/
422                                               | IO-Compress/
423                                               | JSON-PP/
424                                               | libnet/
425                                               | MIME-Base64/
426                                               | podlators/
427                                               | Pod-Simple/
428                                               | Pod-Checker/
429                                               | Digest-MD5/
430                                               | Test-Harness/
431                                               | IPC-Cmd/
432                                               | Encode/
433                                               | Socket/
434                                               | ExtUtils-Manifest/
435                                               | Module-Metadata/
436                                               | PerlIO-via-QuotedPrint/
437                                             )
438                                        !x;
439
440                 if (!$::core || $t =~ m!^lib/[a-z]!) {
441                     if (defined $extension) {
442                         $extension =~ s!/t(:?/\S+)*$!!;
443                         # XXX Do I want to warn that I'm skipping these?
444                         next if $skip{$extension};
445                         my $flat_extension = $extension;
446                         $flat_extension =~ s!-!/!g;
447                         next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
448                     }
449                     my $path = "../$t";
450                     push @results, $path;
451                     $::path_to_name{$path} = $t;
452                 }
453             }
454         }
455         close MANI;
456     } else {
457         warn "$0: cannot open $mani: $!\n";
458     }
459     return @results;
460 }
461
462 unless (@ARGV) {
463     # base first, as TEST bails out if that can't run
464     # then comp, to validate that require works
465     # then run, to validate that -M works
466     # then we know we can -MTestInit for everything else, making life simpler
467     foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
468         _find_tests($dir);
469     }
470     unless ($::core) {
471         _find_tests('porting');
472         _find_tests("lib"); 
473     }
474     # Config.pm may be broken for make minitest. And this is only a refinement
475     # for skipping tests on non-default builds, so it is allowed to fail.
476     # What we want to do is make a list of extensions which we did not build.
477     my $configsh = '../config.sh';
478     my ($extensions, $known_extensions);
479     if (-f $configsh) {
480         open FH, $configsh or die "Can't open $configsh: $!";
481         while (<FH>) {
482             if (/^extensions=['"](.*)['"]$/) {
483                 $extensions = $1;
484             }
485             elsif (/^known_extensions=['"](.*)['"]$/) {
486                 $known_extensions = $1;
487             }
488         }
489         if (!defined $known_extensions) {
490             warn "No known_extensions line found in $configsh";
491         }
492         if (!defined $extensions) {
493             warn "No extensions line found in $configsh";
494         }
495     }
496     # The "complex" constructions of list return from a subroutine, and push of
497     # a list, might fail if perl is really hosed, but they aren't needed for
498     # make minitest, and the building of extensions will likely also fail if
499     # something is that badly wrong.
500     push @ARGV, _tests_from_manifest($extensions, $known_extensions);
501     unless ($::core) {
502         _find_tests('japh') if $::torture;
503         _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
504         _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
505     }
506 }
507 @ARGV= do {
508     my @order= (
509         "base",
510         "comp",
511         "run",
512         "cmd",
513         "io",
514         "re",
515         "opbasic",
516         "op",
517         "uni",
518         "mro",
519         "lib",
520         "ext",
521         "dist",
522         "cpan",
523         "perf",
524         "porting",
525     );
526     my %order= map { $order[$_] => 1+$_ } 0..$#order;
527     my $idx= 0;
528     map {
529         $_->[0]
530     } sort {
531             $a->[3] <=> $b->[3] ||
532             $a->[1] <=> $b->[1]
533     } map {
534         my $root= /(\w+)/ ? $1 : "";
535         [ $_, $idx++, $root, $order{$root}||=0 ]
536     } @ARGV;
537 };
538
539 if ($::deparse) {
540     _testprogs('deparse', '',   @ARGV);
541 }
542 elsif ($::with_utf16) {
543     for my $e (0, 1) {
544         for my $b (0, 1) {
545             print STDERR "# ENDIAN $e BOM $b\n";
546             my @UARGV;
547             for my $a (@ARGV) {
548                 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
549                 my $f = $e ? "v" : "n";
550                 push @UARGV, $u;
551                 unlink($u);
552                 if (open(A, $a)) {
553                     if (open(U, ">$u")) {
554                         print U pack("$f", 0xFEFF) if $b;
555                         while (<A>) {
556                             print U pack("$f*", unpack("C*", $_));
557                         }
558                         close(U);
559                     }
560                     close(A);
561                 }
562             }
563             _testprogs('perl', '', @UARGV);
564             unlink(@UARGV);
565         }
566     }
567 }
568 else {
569     _testprogs('perl',    '',   @ARGV);
570 }
571
572 sub _testprogs {
573     my ($type, $args, @tests) = @_;
574
575     print <<'EOT' if ($type eq 'deparse');
576 ------------------------------------------------------------------------------
577 TESTING DEPARSER
578 ------------------------------------------------------------------------------
579 EOT
580
581     $::bad_files = 0;
582
583     foreach my $t (@tests) {
584       unless (exists $::path_to_name{$t}) {
585         my $tname = "t/$t";
586         $::path_to_name{$t} = $tname;
587       }
588     }
589     my $maxlen = 0;
590     foreach (@::path_to_name{@tests}) {
591         s/\.\w+\z/ /; # space gives easy doubleclick to select fname
592         my $len = length ;
593         $maxlen = $len if $len > $maxlen;
594     }
595     # + 3 : we want three dots between the test name and the "ok"
596     my $dotdotdot = $maxlen + 3 ;
597     my $grind_ct = 0;           # count of non-empty valgrind reports
598     my $total_files = @tests;
599     my $good_files = 0;
600     my $tested_files  = 0;
601     my $totmax = 0;
602     my %failed_tests;
603     my @unexpected_pass; # files where deparse-skips.txt says fail but passed
604     my $toolnm;         # valgrind, cachegrind, perf
605
606     while (my $test = shift @tests) {
607         my ($test_start_time, @starttimes) = 0;
608         if ($show_elapsed_time) {
609             $test_start_time = Time::HiRes::time();
610             # times() reports usage by TEST, but we want usage of each
611             # testprog it calls, so record accumulated times now,
612             # subtract them out afterwards.  Ideally, we'd take times
613             # in BEGIN/END blocks (giving better visibility of self vs
614             # children of each testprog), but that would require some
615             # IPC to send results back here, or a completely different
616             # collection scheme (Storable isn't tuned for incremental use)
617             @starttimes = times;
618         }
619         if ($test =~ /^$/) {
620             next;
621         }
622         if ($type eq 'deparse' && $test =~ $deparse_skips) {
623             next;
624         }
625         my $te = $::path_to_name{$test} . '.'
626                     x ($dotdotdot - length($::path_to_name{$test})) .' ';
627
628         if ($^O ne 'VMS') {  # defer printing on VMS due to piping bug
629             print $te;
630             $te = '';
631         }
632
633         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
634
635         my $results = _run_test($test, $type);
636
637         my $failure;
638         my $next = 0;
639         my $seen_leader = 0;
640         my $seen_ok = 0;
641         my $trailing_leader = 0;
642         my $max;
643         my %todo;
644         while (<$results>) {
645             next if /^\s*$/; # skip blank lines
646             if (/^1..$/ && ($^O eq 'VMS')) {
647                 # VMS pipe bug inserts blank lines.
648                 my $l2 = <$results>;
649                 if ($l2 =~ /^\s*$/) {
650                     $l2 = <$results>;
651                 }
652                 $_ = '1..' . $l2;
653             }
654             if ($::verbose) {
655                 print $_;
656             }
657             unless (/^\#/) {
658                 if ($trailing_leader) {
659                     # shouldn't be anything following a postfix 1..n
660                     $failure = 'FAILED--extra output after trailing 1..n';
661                     last;
662                 }
663                 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
664                     if ($seen_leader) {
665                         $failure = 'FAILED--seen duplicate leader';
666                         last;
667                     }
668                     $max = $1;
669                     %todo = map { $_ => 1 } split / /, $3 if $3;
670                     $totmax = $totmax + $max;
671                     $tested_files = $tested_files + 1;
672                     if ($seen_ok) {
673                         # 1..n appears at end of file
674                         $trailing_leader = 1;
675                         if ($next != $max) {
676                             $failure = "FAILED--expected $max tests, saw $next";
677                             last;
678                         }
679                     }
680                     else {
681                         $next = 0;
682                     }
683                     $seen_leader = 1;
684                 }
685                 else {
686                     if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
687                         unless ($seen_leader) {
688                             unless ($seen_ok) {
689                                 $next = 0;
690                             }
691                         }
692                         $seen_ok = 1;
693                         $next = $next + 1;
694                         my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
695                         $num = $next unless $num;
696
697                         if ($num == $next) {
698
699                             # SKIP is essentially the same as TODO for t/TEST
700                             # this still conforms to TAP:
701                             # http://testanything.org/wiki/index.php/TAP_specification
702                             $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
703                             $istodo = 1 if $todo{$num};
704
705                             if( $not && !$istodo ) {
706                                 $failure = "FAILED at test $num";
707                                 last;
708                             }
709                         }
710                         else {
711                             $failure ="FAILED--expected test $next, saw test $num";
712                             last;
713                         }
714                     }
715                     elsif (/^Bail out!\s*(.*)/i) { # magic words
716                         die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
717                     }
718                     else {
719                         # module tests are allowed extra output,
720                         # because Test::Harness allows it
721                         next if $test =~ /^\W*(cpan|dist|ext|lib)\b/;
722                         $failure = "FAILED--unexpected output at test $next";
723                         last;
724                     }
725                 }
726             }
727         }
728         my  @junk = <$results>;  # dump remaining output to prevent SIGPIPE
729                                  # (so far happens only on os390)
730         close $results;
731         undef @junk;
732
733         if (not defined $failure) {
734             $failure = 'FAILED--no leader found' unless $seen_leader;
735         }
736
737         _check_valgrind(\$toolnm, \$grind_ct, \$test);
738
739         if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) {
740             unlink "./$test.dp";
741         }
742         if (not defined $failure and $next != $max) {
743             $failure="FAILED--expected $max tests, saw $next";
744         }
745
746         if( !defined $failure  # don't mask a test failure
747             and $? )
748         {
749             $failure = "FAILED--non-zero wait status: $?";
750         }
751
752         # Deparse? Should it have passed or failed?
753         if ($type eq 'deparse' && $test =~ $deparse_failures) {
754             if (!$failure) {
755                 # Wait, it didn't fail? Great news!
756                 push @unexpected_pass, $test;
757             } else {
758                 # Bah, still failing. Mask it.
759                 print "${te}skipped\n";
760                 $tested_files = $tested_files - 1;
761                 next;
762             }
763         }
764
765         if (defined $failure) {
766             print "${te}$failure\n";
767             $::bad_files = $::bad_files + 1;
768             if ($test =~ /^base/ && ! defined &DynaLoader::boot_DynaLoader) {
769                 # Die if running under minitest (no DynaLoader).  Otherwise
770                 # keep going, as  we know that Perl basically works, or we
771                 # would not have been able to actually compile it all the way.
772                 die "Failed a basic test ($test) under minitest -- cannot continue.\n";
773             }
774             $failed_tests{$test} = 1;
775         }
776         else {
777             if ($max) {
778                 my ($elapsed, $etms) = ("", 0);
779                 if ( $show_elapsed_time ) {
780                     $etms = (Time::HiRes::time() - $test_start_time) * 1000;
781                     $elapsed = sprintf(" %8.0f ms", $etms);
782
783                     my (@endtimes) = times;
784                     $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes;
785                     splice @endtimes, 0, 2;    # drop self/harness times
786                     $_ *= 1000 for @endtimes;  # and scale to ms
787                     $timings{$test} = [$etms,@endtimes];
788                     $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes;
789                 }
790                 print "${te}ok$elapsed\n";
791                 $good_files = $good_files + 1;
792             }
793             else {
794                 print "${te}skipped\n";
795                 $tested_files = $tested_files - 1;
796             }
797         }
798     } # while tests
799
800     if ($::bad_files == 0) {
801         if ($good_files) {
802             print "All tests successful.\n";
803             # XXX add mention of 'perlbug -ok' ?
804         }
805         else {
806             die "FAILED--no tests were run for some reason.\n";
807         }
808     }
809     else {
810         my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
811         my $s = $::bad_files == 1 ? "" : "s";
812         warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
813         for my $test ( sort keys %failed_tests ) {
814             print "\t$test\n";
815         }
816
817         if (@unexpected_pass) {
818             print <<EOF;
819
820 The following scripts were expected to fail under -deparse (at least
821 according to $deparse_skip_file), but unexpectedly succeeded:
822 EOF
823             print "\t$_\n" for sort @unexpected_pass;
824             print "\n";
825         }
826
827         warn <<'SHRDLU_1';
828 ### Since not all tests were successful, you may want to run some of
829 ### them individually and examine any diagnostic messages they produce.
830 ### See the INSTALL document's section on "make test".
831 SHRDLU_1
832         warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
833 ### You have a good chance to get more information by running
834 ###   ./perl harness
835 ### in the 't' directory since most (>=80%) of the tests succeeded.
836 SHRDLU_2
837         if (eval {require Config; import Config; 1}) {
838             if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
839                 warn <<SHRDLU_3;
840 ### You may have to set your dynamic library search path,
841 ### $p, to point to the build directory:
842 SHRDLU_3
843                 if (exists $ENV{$p} && $ENV{$p} ne '') {
844                     warn <<SHRDLU_4a;
845 ###   setenv $p `pwd`:\$$p; cd t; ./perl harness
846 ###   $p=`pwd`:\$$p; export $p; cd t; ./perl harness
847 ###   export $p=`pwd`:\$$p; cd t; ./perl harness
848 SHRDLU_4a
849                 } else {
850                     warn <<SHRDLU_4b;
851 ###   setenv $p `pwd`; cd t; ./perl harness
852 ###   $p=`pwd`; export $p; cd t; ./perl harness
853 ###   export $p=`pwd`; cd t; ./perl harness
854 SHRDLU_4b
855                 }
856                 warn <<SHRDLU_5;
857 ### for csh-style shells, like tcsh; or for traditional/modern
858 ### Bourne-style shells, like bash, ksh, and zsh, respectively.
859 SHRDLU_5
860             }
861         }
862     }
863     printf "Elapsed: %d sec\n", time() - $t0;
864     my ($user,$sys,$cuser,$csys) = times;
865     my $tot = sprintf("u=%.2f  s=%.2f  cu=%.2f  cs=%.2f  scripts=%d  tests=%d",
866                       $user,$sys,$cuser,$csys,$tested_files,$totmax);
867     print "$tot\n";
868     if ($good_files) {
869         if (-d $show_elapsed_time) {
870             # HARNESS_TIMER = <a-directory>.  Save timings etc to
871             # storable file there.  NB: the test cds to ./t/, so
872             # relative path must account for that, ie ../../perf
873             # points to dir next to source tree.
874             require Storable;
875             my @dt = localtime;
876             $dt[5] += 1900; $dt[4] += 1; # fix year, month
877             my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes";
878             Storable::store({ perf => \%timings,
879                               gather_conf_platform_info(),
880                               total => $tot,
881                             }, $fn);
882             print "wrote storable file: $fn\n";
883         }
884     }
885
886     _cleanup_valgrind(\$toolnm, \$grind_ct);
887 }
888 exit ($::bad_files != 0);
889
890 # Collect platform, config data that should allow comparing
891 # performance data between different machines.  With enough data,
892 # and/or clever statistical analysis, it should be possible to
893 # determine the effect of config choices, more memory, etc
894
895 sub gather_conf_platform_info {
896     # currently rather quick & dirty, and subject to change
897     # for both content and format.
898     require Config;
899     my (%conf, @platform) = ();
900     $conf{$_} = $Config::Config{$_} for
901         grep /cc|git|config_arg\d+/, keys %Config::Config;
902     if (-f '/proc/cpuinfo') {
903         open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
904         @platform = grep /name|cpu/, <$fh>;
905         chomp $_ for @platform;
906     }
907     unshift @platform, $^O;
908
909     return (
910         conf => \%conf,
911         platform => {cpu => \@platform,
912                      mem => [ grep s/\s+/ /,
913                               grep chomp, `free` ],
914                      load => [ grep chomp, `uptime` ],
915         },
916         host => (grep chomp, `hostname -f`),
917         version => '0.03', # bump for conf, platform, or data collection changes
918         );
919 }
920
921 sub _check_valgrind {
922     return unless $ENV{PERL_VALGRIND};
923
924     my ($toolnm, $grind_ct, $test) = @_;
925
926     $$toolnm = $ENV{VALGRIND};
927     $$toolnm =~ s|.*/||;  # keep basename
928     my @valgrind;       # gets content of file
929     if (-e $Valgrind_Log) {
930         if (open(V, $Valgrind_Log)) {
931             @valgrind = <V>;
932             close V;
933         } else {
934             warn "$0: Failed to open '$Valgrind_Log': $!\n";
935         }
936     }
937     if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) {
938         $$toolnm = $1;
939         if ($$toolnm eq 'perf') {
940             # append perfs subcommand, not just stat
941             my ($sub) = split /\s/, $ENV{VG_OPTS};
942             $$toolnm .= "-$sub";
943         }
944         if (rename $Valgrind_Log, "$$test.$$toolnm") {
945             $$grind_ct++;
946         } else {
947             warn "$0: Failed to create '$$test.$$toolnm': $!\n";
948         }
949     }
950     elsif (@valgrind) {
951         my $leaks = 0;
952         my $errors = 0;
953         for my $i (0..$#valgrind) {
954             local $_ = $valgrind[$i];
955             if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
956                 $errors = $errors + $1;   # there may be multiple error summaries
957             } elsif (/^==\d+== LEAK SUMMARY:/) {
958                 for my $off (1 .. 4) {
959                     if ($valgrind[$i+$off] =~
960                         /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
961                             $leaks = $leaks + $1;
962                     }
963                 }
964             }
965         }
966         if ($errors or $leaks) {
967             if (rename $Valgrind_Log, "$$test.valgrind") {
968                 $$grind_ct = $$grind_ct + 1;
969             } else {
970                 warn "$0: Failed to create '$$test.valgrind': $!\n";
971             }
972         }
973     } else {
974         # Quiet wasn't asked for? Something may be amiss
975         if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) {
976             warn "No valgrind output?\n";
977         }
978     }
979     if (-e $Valgrind_Log) {
980         unlink $Valgrind_Log
981             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
982     }
983 }
984
985 sub _cleanup_valgrind {
986     return unless $ENV{PERL_VALGRIND};
987
988     my ($toolnm, $grind_ct) = @_;
989     my $s = $$grind_ct == 1 ? '' : 's';
990     print "$$grind_ct valgrind report$s created.\n", ;
991     if ($$toolnm eq 'cachegrind') {
992         # cachegrind leaves a lot of cachegrind.out.$pid litter
993         # around the tree, find and delete them
994         unlink _find_files('cachegrind.out.\d+$',
995                      qw ( ../t ../cpan ../ext ../dist/ ));
996     }
997     elsif ($$toolnm eq 'valgrind') {
998         # Remove empty, hence non-error, output files
999         unlink grep { -z } _find_files('valgrind-current',
1000                      qw ( ../t ../cpan ../ext ../dist/ ));
1001     }
1002 }
1003
1004 # Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
1005
1006 sub _process_deparse_config {
1007     my @deparse_failures;
1008     my @deparse_skips;
1009
1010     my $f = $deparse_skip_file;
1011
1012     my $skips;
1013     if (!open($skips, '<', $f)) {
1014         warn "Failed to find $f: $!\n";
1015         return;
1016     }
1017
1018     my $in;
1019     while(<$skips>) {
1020         if (/__DEPARSE_FAILURES__/) {
1021             $in = \@deparse_failures; next;
1022         } elsif (/__DEPARSE_SKIPS__/) {
1023             $in = \@deparse_skips; next;
1024         } elsif (!$in) {
1025             next;
1026         }
1027
1028         s/#.*$//; # Kill comments
1029         s/\s+$//; # And trailing whitespace
1030
1031         next unless $_;
1032
1033         push @$in, $_;
1034         warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
1035     }
1036
1037     for my $f (@deparse_failures, @deparse_skips) {
1038         if ($f =~ m|/$|) { # Dir? Skip everything below it
1039             $f = qr/\Q$f\E.*/;
1040         } else {
1041             $f = qr/\Q$f\E/;
1042         }
1043     }
1044
1045     $deparse_failures = join('|', @deparse_failures);
1046     $deparse_failures = qr/^(?:$deparse_failures)$/;
1047
1048     $deparse_skips = join('|', @deparse_skips);
1049     $deparse_skips = qr/^(?:$deparse_skips)$/;
1050 }
1051
1052 # ex: set ts=8 sts=4 sw=4 noet: