This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d5649732afb5230eae0ef5d90ee465cede1d7b72
[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! Tell someone!
751                 $failure = "FAILED--all tests passed but test should have failed";
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: