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