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