xref: /openbsd/gnu/usr.bin/perl/t/TEST (revision 3bef86f7) 
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.
18my $t0 = time();
19
20# If we're doing deparse tests, ignore failures for these
21my $deparse_failures;
22
23# And skip even running these
24my $deparse_skips;
25
26my $deparse_skip_file = '../Porting/deparse-skips.txt';
27
28# directories with special sets of test switches
29my %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".
40my %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
63my %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)
82my @bad_env_vars = qw(
83    PERL5LIB PERLLIB PERL5OPT PERL_UNICODE
84    PERL_YAML_BACKEND PERL_JSON_BACKEND
85);
86
87for 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.
99our $Valgrind_Log;
100
101my %skip = (
102	    '.' => 1,
103	    '..' => 1,
104	    'CVS' => 1,
105	    'RCS' => 1,
106	    'SCCS' => 1,
107	    '.svn' => 1,
108	   );
109
110
111if ($::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
128our $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
152chdir 't' if -f 't/TEST';
153if (-f 'TEST' && -f 'harness' && -d '../lib') {
154    @INC = '../lib';
155}
156
157die "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
167if ($show_elapsed_time) { require Time::HiRes }
168my %timings = (); # testname => [@et] pairs if $show_elapsed_time.
169
170# Roll your own File::Find!
171our @found;
172sub _find_tests { @found=(); push @ARGV, _find_files('\.t$', $_[0]) }
173sub _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.
194sub _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
272sub _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
318sub _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
339sub _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
351sub _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
375sub _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
388sub _populate_hash {
389    return unless defined $_[0];
390    return map {$_, 1} split /\s+/, $_[0];
391}
392
393sub _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
467unless (@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
544if ($::deparse) {
545    _testprogs('deparse', '',   @ARGV);
546}
547elsif ($::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}
573else {
574    _testprogs('perl',    '',   @ARGV);
575}
576
577sub _testprogs {
578    my ($type, $args, @tests) = @_;
579
580    print <<'EOT' if ($type eq 'deparse');
581------------------------------------------------------------------------------
582TESTING DEPARSER
583------------------------------------------------------------------------------
584EOT
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
825The following scripts were expected to fail under -deparse (at least
826according to $deparse_skip_file), but unexpectedly succeeded:
827EOF
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".
836SHRDLU_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.
841SHRDLU_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:
847SHRDLU_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
853SHRDLU_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
859SHRDLU_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.
864SHRDLU_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}
893exit ($::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
900sub 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
926sub _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
990sub _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
1011sub _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:
1058