This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
6b3504002f6f46f7f0f6c0416f66da178fab1295
[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                 require Cwd;
319                 $Valgrind_Log = Cwd::abs_path("$options->{run_dir}/$Valgrind_Log");
320             }
321             my $vg_opts = $ENV{VG_OPTS}
322                //   "--log-file=$Valgrind_Log "
323                   . "--suppressions=$perl_supp --leak-check=yes "
324                   . "--leak-resolution=high --show-reachable=yes "
325                   . "--num-callers=50 --track-origins=yes";
326             # Force logging if not asked for (so cachegrind reporting works below)
327             if ($vg_opts !~ /--log-file/) {
328                 $vg_opts = "--log-file=$Valgrind_Log $vg_opts";
329             }
330             $perl = "$valgrind_exe $vg_opts $perl";
331         }
332
333         my $args = "$options->{testswitch} $options->{switch} $options->{utf8}";
334         $cmd = $perl . _quote_args($args) . " $test $redir";
335     }
336     return $cmd;
337 }
338
339 sub _before_fork {
340     my ($options) = @_;
341
342     if ($options->{run_dir}) {
343         my $run_dir = $options->{run_dir};
344         chdir $run_dir or die "Can't chdir to '$run_dir': $!";
345     }
346
347     # Remove previous valgrind output otherwise it will interfere
348     my $test = $options->{test};
349
350     (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
351
352     if ($ENV{PERL_VALGRIND} && -e $Valgrind_Log) {
353         unlink $Valgrind_Log
354             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
355     }
356
357     return;
358 }
359
360 sub _after_fork {
361     my ($options) = @_;
362
363     if ($options->{return_dir}) {
364         my $return_dir = $options->{return_dir};
365         chdir $return_dir
366            or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!";
367     }
368
369     return;
370 }
371
372 sub _run_test {
373     my ($test, $type) = @_;
374
375     my $options = _scan_test($test, $type);
376     # $test might have changed if we're in ext/Foo, so don't use it anymore
377     # from now on. Use $options->{test} instead.
378
379     _before_fork($options);
380
381     my $cmd = _cmd($options, $type);
382
383     open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n";
384
385     _after_fork($options);
386
387     # Our environment may force us to use UTF-8, but we can't be sure that
388     # anything we're reading from will be generating (well formed) UTF-8
389     # This may not be the best way - possibly we should unset ${^OPEN} up
390     # top?
391     binmode $results;
392
393     return $results;
394 }
395
396 sub _quote_args {
397     my ($args) = @_;
398     my $argstring = '';
399
400     foreach (split(/\s+/,$args)) {
401        # In VMS protect with doublequotes because otherwise
402        # DCL will lowercase -- unless already doublequoted.
403        $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
404        $argstring = $argstring . ' ' . $_;
405     }
406     return $argstring;
407 }
408
409 sub _populate_hash {
410     return unless defined $_[0];
411     return map {$_, 1} split /\s+/, $_[0];
412 }
413
414 sub _tests_from_manifest {
415     my ($extensions, $known_extensions) = @_;
416     my %skip;
417     my %extensions = _populate_hash($extensions);
418     my %known_extensions = _populate_hash($known_extensions);
419
420     foreach (keys %known_extensions) {
421         $skip{$_} = 1 unless $extensions{$_};
422     }
423
424     my @results;
425     my $mani = '../MANIFEST';
426     if (open(MANI, $mani)) {
427         while (<MANI>) {
428             if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
429                 my $t = $1;
430                 my $extension = $2;
431
432                 # XXX Generates way too many error lines currently.  Skip for
433                 # v5.22
434                 next if $t =~ /^cpan/ && ord("A") != 65;
435
436                 if (!$::core || $t =~ m!^lib/[a-z]!) {
437                     if (defined $extension) {
438                         $extension =~ s!/t(:?/\S+)*$!!;
439                         # XXX Do I want to warn that I'm skipping these?
440                         next if $skip{$extension};
441                         my $flat_extension = $extension;
442                         $flat_extension =~ s!-!/!g;
443                         next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
444                     }
445                     my $path = "../$t";
446                     push @results, $path;
447                     $::path_to_name{$path} = $t;
448                 }
449             }
450         }
451         close MANI;
452     } else {
453         warn "$0: cannot open $mani: $!\n";
454     }
455     return @results;
456 }
457
458 unless (@ARGV) {
459     # base first, as TEST bails out if that can't run
460     # then comp, to validate that require works
461     # then run, to validate that -M works
462     # then we know we can -MTestInit for everything else, making life simpler
463     foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
464         _find_tests($dir);
465     }
466     unless ($::core) {
467         _find_tests('porting');
468         _find_tests("lib"); 
469     }
470     # Config.pm may be broken for make minitest. And this is only a refinement
471     # for skipping tests on non-default builds, so it is allowed to fail.
472     # What we want to to is make a list of extensions which we did not build.
473     my $configsh = '../config.sh';
474     my ($extensions, $known_extensions);
475     if (-f $configsh) {
476         open FH, $configsh or die "Can't open $configsh: $!";
477         while (<FH>) {
478             if (/^extensions=['"](.*)['"]$/) {
479                 $extensions = $1;
480             }
481             elsif (/^known_extensions=['"](.*)['"]$/) {
482                 $known_extensions = $1;
483             }
484         }
485         if (!defined $known_extensions) {
486             warn "No known_extensions line found in $configsh";
487         }
488         if (!defined $extensions) {
489             warn "No extensions line found in $configsh";
490         }
491     }
492     # The "complex" constructions of list return from a subroutine, and push of
493     # a list, might fail if perl is really hosed, but they aren't needed for
494     # make minitest, and the building of extensions will likely also fail if
495     # something is that badly wrong.
496     push @ARGV, _tests_from_manifest($extensions, $known_extensions);
497     unless ($::core) {
498         _find_tests('japh') if $::torture;
499         _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
500         _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
501     }
502 }
503 @ARGV= do {
504     my @order= (
505         "base",
506         "comp",
507         "run",
508         "cmd",
509         "io",
510         "re",
511         "opbasic",
512         "op",
513         "uni",
514         "mro",
515         "lib",
516         "ext",
517         "dist",
518         "cpan",
519         "perf",
520         "porting",
521     );
522     my %order= map { $order[$_] => 1+$_ } 0..$#order;
523     my $idx= 0;
524     map {
525         $_->[0]
526     } sort {
527             $a->[3] <=> $b->[3] ||
528             $a->[1] <=> $b->[1]
529     } map {
530         my $root= /(\w+)/ ? $1 : "";
531         [ $_, $idx++, $root, $order{$root}||=0 ]
532     } @ARGV;
533 };
534
535 if ($::deparse) {
536     _testprogs('deparse', '',   @ARGV);
537 }
538 elsif ($::with_utf16) {
539     for my $e (0, 1) {
540         for my $b (0, 1) {
541             print STDERR "# ENDIAN $e BOM $b\n";
542             my @UARGV;
543             for my $a (@ARGV) {
544                 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
545                 my $f = $e ? "v" : "n";
546                 push @UARGV, $u;
547                 unlink($u);
548                 if (open(A, $a)) {
549                     if (open(U, ">$u")) {
550                         print U pack("$f", 0xFEFF) if $b;
551                         while (<A>) {
552                             print U pack("$f*", unpack("C*", $_));
553                         }
554                         close(U);
555                     }
556                     close(A);
557                 }
558             }
559             _testprogs('perl', '', @UARGV);
560             unlink(@UARGV);
561         }
562     }
563 }
564 else {
565     _testprogs('perl',    '',   @ARGV);
566 }
567
568 sub _testprogs {
569     my ($type, $args, @tests) = @_;
570
571     print <<'EOT' if ($type eq 'deparse');
572 ------------------------------------------------------------------------------
573 TESTING DEPARSER
574 ------------------------------------------------------------------------------
575 EOT
576
577     $::bad_files = 0;
578
579     foreach my $t (@tests) {
580       unless (exists $::path_to_name{$t}) {
581         my $tname = "t/$t";
582         $::path_to_name{$t} = $tname;
583       }
584     }
585     my $maxlen = 0;
586     foreach (@::path_to_name{@tests}) {
587         s/\.\w+\z/ /; # space gives easy doubleclick to select fname
588         my $len = length ;
589         $maxlen = $len if $len > $maxlen;
590     }
591     # + 3 : we want three dots between the test name and the "ok"
592     my $dotdotdot = $maxlen + 3 ;
593     my $grind_ct = 0;           # count of non-empty valgrind reports
594     my $total_files = @tests;
595     my $good_files = 0;
596     my $tested_files  = 0;
597     my $totmax = 0;
598     my %failed_tests;
599     my @unexpected_pass; # files where deparse-skips.txt says fail but passed
600     my $toolnm;         # valgrind, cachegrind, perf
601
602     while (my $test = shift @tests) {
603         my ($test_start_time, @starttimes) = 0;
604         if ($show_elapsed_time) {
605             $test_start_time = Time::HiRes::time();
606             # times() reports usage by TEST, but we want usage of each
607             # testprog it calls, so record accumulated times now,
608             # subtract them out afterwards.  Ideally, we'd take times
609             # in BEGIN/END blocks (giving better visibility of self vs
610             # children of each testprog), but that would require some
611             # IPC to send results back here, or a completely different
612             # collection scheme (Storable isn't tuned for incremental use)
613             @starttimes = times;
614         }
615         if ($test =~ /^$/) {
616             next;
617         }
618         if ($type eq 'deparse' && $test =~ $deparse_skips) {
619             next;
620         }
621         my $te = $::path_to_name{$test} . '.'
622                     x ($dotdotdot - length($::path_to_name{$test})) .' ';
623
624         if ($^O ne 'VMS') {  # defer printing on VMS due to piping bug
625             print $te;
626             $te = '';
627         }
628
629         (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
630
631         my $results = _run_test($test, $type);
632
633         my $failure;
634         my $next = 0;
635         my $seen_leader = 0;
636         my $seen_ok = 0;
637         my $trailing_leader = 0;
638         my $max;
639         my %todo;
640         while (<$results>) {
641             next if /^\s*$/; # skip blank lines
642             if (/^1..$/ && ($^O eq 'VMS')) {
643                 # VMS pipe bug inserts blank lines.
644                 my $l2 = <$results>;
645                 if ($l2 =~ /^\s*$/) {
646                     $l2 = <$results>;
647                 }
648                 $_ = '1..' . $l2;
649             }
650             if ($::verbose) {
651                 print $_;
652             }
653             unless (/^\#/) {
654                 if ($trailing_leader) {
655                     # shouldn't be anything following a postfix 1..n
656                     $failure = 'FAILED--extra output after trailing 1..n';
657                     last;
658                 }
659                 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
660                     if ($seen_leader) {
661                         $failure = 'FAILED--seen duplicate leader';
662                         last;
663                     }
664                     $max = $1;
665                     %todo = map { $_ => 1 } split / /, $3 if $3;
666                     $totmax = $totmax + $max;
667                     $tested_files = $tested_files + 1;
668                     if ($seen_ok) {
669                         # 1..n appears at end of file
670                         $trailing_leader = 1;
671                         if ($next != $max) {
672                             $failure = "FAILED--expected $max tests, saw $next";
673                             last;
674                         }
675                     }
676                     else {
677                         $next = 0;
678                     }
679                     $seen_leader = 1;
680                 }
681                 else {
682                     if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
683                         unless ($seen_leader) {
684                             unless ($seen_ok) {
685                                 $next = 0;
686                             }
687                         }
688                         $seen_ok = 1;
689                         $next = $next + 1;
690                         my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
691                         $num = $next unless $num;
692
693                         if ($num == $next) {
694
695                             # SKIP is essentially the same as TODO for t/TEST
696                             # this still conforms to TAP:
697                             # http://testanything.org/wiki/index.php/TAP_specification
698                             $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
699                             $istodo = 1 if $todo{$num};
700
701                             if( $not && !$istodo ) {
702                                 $failure = "FAILED at test $num";
703                                 last;
704                             }
705                         }
706                         else {
707                             $failure ="FAILED--expected test $next, saw test $num";
708                             last;
709                         }
710                     }
711                     elsif (/^Bail out!\s*(.*)/i) { # magic words
712                         die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
713                     }
714                     else {
715                         # module tests are allowed extra output,
716                         # because Test::Harness allows it
717                         next if $test =~ /^\W*(cpan|dist|ext|lib)\b/;
718                         $failure = "FAILED--unexpected output at test $next";
719                         last;
720                     }
721                 }
722             }
723         }
724         my  @junk = <$results>;  # dump remaining output to prevent SIGPIPE
725                                  # (so far happens only on os390)
726         close $results;
727         undef @junk;
728
729         if (not defined $failure) {
730             $failure = 'FAILED--no leader found' unless $seen_leader;
731         }
732
733         _check_valgrind(\$toolnm, \$grind_ct, \$test);
734
735         if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) {
736             unlink "./$test.dp";
737         }
738         if (not defined $failure and $next != $max) {
739             $failure="FAILED--expected $max tests, saw $next";
740         }
741
742         if( !defined $failure  # don't mask a test failure
743             and $? )
744         {
745             $failure = "FAILED--non-zero wait status: $?";
746         }
747
748         # Deparse? Should it have passed or failed?
749         if ($type eq 'deparse' && $test =~ $deparse_failures) {
750             if (!$failure) {
751                 # Wait, it didn't fail? Great news!
752                 push @unexpected_pass, $test;
753             } else {
754                 # Bah, still failing. Mask it.
755                 print "${te}skipped\n";
756                 $tested_files = $tested_files - 1;
757                 next;
758             }
759         }
760
761         if (defined $failure) {
762             print "${te}$failure\n";
763             $::bad_files = $::bad_files + 1;
764             if ($test =~ /^base/ && ! defined &DynaLoader::boot_DynaLoader) {
765                 # Die if running under minitest (no DynaLoader).  Otherwise
766                 # keep going, as  we know that Perl basically works, or we
767                 # would not have been able to actually compile it all the way.
768                 die "Failed a basic test ($test) under minitest -- cannot continue.\n";
769             }
770             $failed_tests{$test} = 1;
771         }
772         else {
773             if ($max) {
774                 my ($elapsed, $etms) = ("", 0);
775                 if ( $show_elapsed_time ) {
776                     $etms = (Time::HiRes::time() - $test_start_time) * 1000;
777                     $elapsed = sprintf(" %8.0f ms", $etms);
778
779                     my (@endtimes) = times;
780                     $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes;
781                     splice @endtimes, 0, 2;    # drop self/harness times
782                     $_ *= 1000 for @endtimes;  # and scale to ms
783                     $timings{$test} = [$etms,@endtimes];
784                     $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes;
785                 }
786                 print "${te}ok$elapsed\n";
787                 $good_files = $good_files + 1;
788             }
789             else {
790                 print "${te}skipped\n";
791                 $tested_files = $tested_files - 1;
792             }
793         }
794     } # while tests
795
796     if ($::bad_files == 0) {
797         if ($good_files) {
798             print "All tests successful.\n";
799             # XXX add mention of 'perlbug -ok' ?
800         }
801         else {
802             die "FAILED--no tests were run for some reason.\n";
803         }
804     }
805     else {
806         my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
807         my $s = $::bad_files == 1 ? "" : "s";
808         warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
809         for my $test ( sort keys %failed_tests ) {
810             print "\t$test\n";
811         }
812
813         if (@unexpected_pass) {
814             print <<EOF;
815
816 The following scripts were expected to fail under -deparse (at least
817 according to $deparse_skip_file), but unexpectedly succeeded:
818 EOF
819             print "\t$_\n" for sort @unexpected_pass;
820             print "\n";
821         }
822
823         warn <<'SHRDLU_1';
824 ### Since not all tests were successful, you may want to run some of
825 ### them individually and examine any diagnostic messages they produce.
826 ### See the INSTALL document's section on "make test".
827 SHRDLU_1
828         warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
829 ### You have a good chance to get more information by running
830 ###   ./perl harness
831 ### in the 't' directory since most (>=80%) of the tests succeeded.
832 SHRDLU_2
833         if (eval {require Config; import Config; 1}) {
834             if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
835                 warn <<SHRDLU_3;
836 ### You may have to set your dynamic library search path,
837 ### $p, to point to the build directory:
838 SHRDLU_3
839                 if (exists $ENV{$p} && $ENV{$p} ne '') {
840                     warn <<SHRDLU_4a;
841 ###   setenv $p `pwd`:\$$p; cd t; ./perl harness
842 ###   $p=`pwd`:\$$p; export $p; cd t; ./perl harness
843 ###   export $p=`pwd`:\$$p; cd t; ./perl harness
844 SHRDLU_4a
845                 } else {
846                     warn <<SHRDLU_4b;
847 ###   setenv $p `pwd`; cd t; ./perl harness
848 ###   $p=`pwd`; export $p; cd t; ./perl harness
849 ###   export $p=`pwd`; cd t; ./perl harness
850 SHRDLU_4b
851                 }
852                 warn <<SHRDLU_5;
853 ### for csh-style shells, like tcsh; or for traditional/modern
854 ### Bourne-style shells, like bash, ksh, and zsh, respectively.
855 SHRDLU_5
856             }
857         }
858     }
859     printf "Elapsed: %d sec\n", time() - $t0;
860     my ($user,$sys,$cuser,$csys) = times;
861     my $tot = sprintf("u=%.2f  s=%.2f  cu=%.2f  cs=%.2f  scripts=%d  tests=%d",
862                       $user,$sys,$cuser,$csys,$tested_files,$totmax);
863     print "$tot\n";
864     if ($good_files) {
865         if (-d $show_elapsed_time) {
866             # HARNESS_TIMER = <a-directory>.  Save timings etc to
867             # storable file there.  NB: the test cds to ./t/, so
868             # relative path must account for that, ie ../../perf
869             # points to dir next to source tree.
870             require Storable;
871             my @dt = localtime;
872             $dt[5] += 1900; $dt[4] += 1; # fix year, month
873             my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes";
874             Storable::store({ perf => \%timings,
875                               gather_conf_platform_info(),
876                               total => $tot,
877                             }, $fn);
878             print "wrote storable file: $fn\n";
879         }
880     }
881
882     _cleanup_valgrind(\$toolnm, \$grind_ct);
883 }
884 exit ($::bad_files != 0);
885
886 # Collect platform, config data that should allow comparing
887 # performance data between different machines.  With enough data,
888 # and/or clever statistical analysis, it should be possible to
889 # determine the effect of config choices, more memory, etc
890
891 sub gather_conf_platform_info {
892     # currently rather quick & dirty, and subject to change
893     # for both content and format.
894     require Config;
895     my (%conf, @platform) = ();
896     $conf{$_} = $Config::Config{$_} for
897         grep /cc|git|config_arg\d+/, keys %Config::Config;
898     if (-f '/proc/cpuinfo') {
899         open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
900         @platform = grep /name|cpu/, <$fh>;
901         chomp $_ for @platform;
902     }
903     unshift @platform, $^O;
904
905     return (
906         conf => \%conf,
907         platform => {cpu => \@platform,
908                      mem => [ grep s/\s+/ /,
909                               grep chomp, `free` ],
910                      load => [ grep chomp, `uptime` ],
911         },
912         host => (grep chomp, `hostname -f`),
913         version => '0.03', # bump for conf, platform, or data collection changes
914         );
915 }
916
917 sub _check_valgrind {
918     return unless $ENV{PERL_VALGRIND};
919
920     my ($toolnm, $grind_ct, $test) = @_;
921
922     $$toolnm = $ENV{VALGRIND};
923     $$toolnm =~ s|.*/||;  # keep basename
924     my @valgrind;       # gets content of file
925     if (-e $Valgrind_Log) {
926         if (open(V, $Valgrind_Log)) {
927             @valgrind = <V>;
928             close V;
929         } else {
930             warn "$0: Failed to open '$Valgrind_Log': $!\n";
931         }
932     }
933     if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) {
934         $$toolnm = $1;
935         if ($$toolnm eq 'perf') {
936             # append perfs subcommand, not just stat
937             my ($sub) = split /\s/, $ENV{VG_OPTS};
938             $$toolnm .= "-$sub";
939         }
940         if (rename $Valgrind_Log, "$$test.$$toolnm") {
941             $$grind_ct++;
942         } else {
943             warn "$0: Failed to create '$$test.$$toolnm': $!\n";
944         }
945     }
946     elsif (@valgrind) {
947         my $leaks = 0;
948         my $errors = 0;
949         for my $i (0..$#valgrind) {
950             local $_ = $valgrind[$i];
951             if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
952                 $errors = $errors + $1;   # there may be multiple error summaries
953             } elsif (/^==\d+== LEAK SUMMARY:/) {
954                 for my $off (1 .. 4) {
955                     if ($valgrind[$i+$off] =~
956                         /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
957                             $leaks = $leaks + $1;
958                     }
959                 }
960             }
961         }
962         if ($errors or $leaks) {
963             if (rename $Valgrind_Log, "$$test.valgrind") {
964                 $$grind_ct = $$grind_ct + 1;
965             } else {
966                 warn "$0: Failed to create '$$test.valgrind': $!\n";
967             }
968         }
969     } else {
970         # Quiet wasn't asked for? Something may be amiss
971         if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) {
972             warn "No valgrind output?\n";
973         }
974     }
975     if (-e $Valgrind_Log) {
976         unlink $Valgrind_Log
977             or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
978     }
979 }
980
981 sub _cleanup_valgrind {
982     return unless $ENV{PERL_VALGRIND};
983
984     my ($toolnm, $grind_ct) = @_;
985     my $s = $$grind_ct == 1 ? '' : 's';
986     print "$$grind_ct valgrind report$s created.\n", ;
987     if ($$toolnm eq 'cachegrind') {
988         # cachegrind leaves a lot of cachegrind.out.$pid litter
989         # around the tree, find and delete them
990         unlink _find_files('cachegrind.out.\d+$',
991                      qw ( ../t ../cpan ../ext ../dist/ ));
992     }
993 }
994
995 # Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
996
997 sub _process_deparse_config {
998     my @deparse_failures;
999     my @deparse_skips;
1000
1001     my $f = $deparse_skip_file;
1002
1003     my $skips;
1004     if (!open($skips, '<', $f)) {
1005         warn "Failed to find $f: $!\n";
1006         return;
1007     }
1008
1009     my $in;
1010     while(<$skips>) {
1011         if (/__DEPARSE_FAILURES__/) {
1012             $in = \@deparse_failures; next;
1013         } elsif (/__DEPARSE_SKIPS__/) {
1014             $in = \@deparse_skips; next;
1015         } elsif (!$in) {
1016             next;
1017         }
1018
1019         s/#.*$//; # Kill comments
1020         s/\s+$//; # And trailing whitespace
1021
1022         next unless $_;
1023
1024         push @$in, $_;
1025         warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
1026     }
1027
1028     for my $f (@deparse_failures, @deparse_skips) {
1029         if ($f =~ m|/$|) { # Dir? Skip everything below it
1030             $f = qr/\Q$f\E.*/;
1031         } else {
1032             $f = qr/\Q$f\E/;
1033         }
1034     }
1035
1036     $deparse_failures = join('|', @deparse_failures);
1037     $deparse_failures = qr/^(?:$deparse_failures)$/;
1038
1039     $deparse_skips = join('|', @deparse_skips);
1040     $deparse_skips = qr/^(?:$deparse_skips)$/;
1041 }
1042
1043 # ex: set ts=8 sts=4 sw=4 noet: