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