This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make PerlIO::get_layers accept IO references
[perl5.git] / t / TEST
CommitLineData
63217fa2 1#!./perl
8d063cd8 2
8d063cd8 3# This is written in a peculiar style, since we're trying to avoid
1de9afcd 4# most of the constructs we'll be testing for. (This comment is
8bdd21ca 5# probably obsolete on the avoidance side, though still current
1de9afcd 6# on the peculiarity side.)
8d063cd8 7
c537bcda
NC
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
94708f6d
JH
17# Measure the elapsed wallclock time.
18my $t0 = time();
19
2722144b
MH
20# If we're doing deparse tests, ignore failures for these
21my $deparse_failures;
22
23# And skip even running these
24my $deparse_skips;
2adbc9b6 25
10d90405
DM
26my $deparse_skip_file = '../Porting/deparse-skips.txt';
27
2adbc9b6
NC
28# directories with special sets of test switches
29my %dir_to_switch =
30 (base => '',
31 comp => '',
32 run => '',
30b6e591 33 '../ext/File-Glob/t' => '-I.. -MTestInit', # FIXME - tests assume t/
2adbc9b6
NC
34 );
35
cb596ae4 36# "not absolute" is the default, as it saves some fakery within TestInit
8bdd21ca 37# which can perturb tests, and takes CPU. Working with the upstream author of
41239ce7
NC
38# any of these, to figure out how to remove them from this list, considered
39# "a good thing".
40my %abs = (
41239ce7
NC
41 '../cpan/Archive-Tar' => 1,
42 '../cpan/AutoLoader' => 1,
43 '../cpan/CPAN' => 1,
41239ce7 44 '../cpan/Encode' => 1,
41239ce7 45 '../cpan/ExtUtils-Constant' => 1,
d393d7e5 46 '../cpan/ExtUtils-Install' => 1,
41239ce7 47 '../cpan/ExtUtils-MakeMaker' => 1,
854a00d8 48 '../cpan/ExtUtils-Manifest' => 1,
41239ce7
NC
49 '../cpan/File-Fetch' => 1,
50 '../cpan/IPC-Cmd' => 1,
51 '../cpan/IPC-SysV' => 1,
41239ce7
NC
52 '../cpan/Module-Load' => 1,
53 '../cpan/Module-Load-Conditional' => 1,
41239ce7 54 '../cpan/Pod-Simple' => 1,
41239ce7 55 '../cpan/Test-Simple' => 1,
41239ce7 56 '../cpan/podlators' => 1,
2a6dc374 57 '../dist/Cwd' => 1,
7baf245a 58 '../dist/Devel-PPPort' => 1,
cc79184a 59 '../dist/ExtUtils-ParseXS' => 1,
c0504019 60 '../dist/Tie-File' => 1,
41239ce7 61 );
2a6dc374 62
903b1101 63my %temp_no_core = (
d371e02a 64 '../cpan/Compress-Raw-Bzip2' => 1,
c6f84bbd 65 '../cpan/Compress-Raw-Zlib' => 1,
b2861970 66 '../cpan/Devel-PPPort' => 1,
e41cfb92 67 '../cpan/Getopt-Long' => 1,
3fd969f4 68 '../cpan/IO-Compress' => 1,
b7c8007e 69 '../cpan/MIME-Base64' => 1,
a636c943 70 '../cpan/parent' => 1,
490d1888 71 '../cpan/Pod-Simple' => 1,
f4e6b692 72 '../cpan/podlators' => 1,
e0ee75a6 73 '../cpan/Test-Simple' => 1,
325914f9 74 '../cpan/Tie-RefHash' => 1,
a3e5f045 75 '../cpan/Unicode-Collate' => 1,
3baae3fa 76 '../dist/Unicode-Normalize' => 1,
2adbc9b6
NC
77 );
78
2574563e
TB
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)
b6646683 82my @bad_env_vars = qw(
74480d1e 83 PERL5LIB PERLLIB PERL5OPT PERL_UNICODE
b6646683
DG
84 PERL_YAML_BACKEND PERL_JSON_BACKEND
85);
86
87for my $envname (@bad_env_vars) {
2574563e
TB
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}
60e23f2f 97
be075caf
MH
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
75e21add 110
63217fa2 111if ($::do_nothing) {
75e21add
JH
112 return 1;
113}
114
a2d3de13
NC
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
cc6ae9e5
CB
121# remove empty elements due to insertion of empty symbols via "''p1'" syntax
122@ARGV = grep($_,@ARGV) if $^O eq 'VMS';
70a78ba7 123
7fa64c24
FC
124# String eval to avoid loading File::Glob on non-miniperl.
125# (Windows only uses this script for miniperl.)
804352e2 126@ARGV = eval 'map glob, @ARGV' if $^O eq 'MSWin32';
70a78ba7 127
551405c4 128our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0;
cc6ae9e5 129
18869dc6
NC
130# Cheesy version of Getopt::Std. We can't replace it with that, because we
131# can't rely on require working.
80ed0dea
DM
132{
133 my @argv = ();
5d9a6404 134 foreach my $idx (0..$#ARGV) {
b03030b8 135 push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
7019aa11 136 $::benchmark = 1 if $1 eq 'benchmark';
80ed0dea
DM
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';
80ed0dea 142 $::taintwarn = 1 if $1 eq 'taintwarn';
485988ae 143 if ($1 =~ /^deparse(,.+)?$/) {
80ed0dea
DM
144 $::deparse = 1;
145 $::deparse_opts = $1;
2722144b 146 _process_deparse_config();
485988ae 147 }
5d9a6404 148 }
80ed0dea 149 @ARGV = @argv;
8d063cd8
LW
150}
151
378cc40b 152chdir 't' if -f 't/TEST';
ab662740
NC
153if (-f 'TEST' && -f 'harness' && -d '../lib') {
154 @INC = '../lib';
155}
378cc40b 156
3816c65f 157die "You need to run \"make test_prep\" first to set things up.\n"
196918b0 158 unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
4633a7c4 159
3fb91a5e
GS
160# check leakage for embedders
161$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
da6a8325
GG
162# check existence of all symbols
163$ENV{PERL_DL_NONLAZY} = 1 unless exists $ENV{PERL_DL_NONLAZY};
3fb91a5e 164
4633a7c4 165$ENV{EMXSHELL} = 'sh'; # For OS/2
748a9306 166
28ffa55a 167if ($show_elapsed_time) { require Time::HiRes }
b49055e9 168my %timings = (); # testname => [@et] pairs if $show_elapsed_time.
7ebf5c89 169
18869dc6 170# Roll your own File::Find!
81c73c11
TR
171our @found;
172sub _find_tests { @found=(); push @ARGV, _find_files('\.t$', $_[0]) }
c96083ea
JC
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";
c96083ea
JC
181 if (-d $fullpath) {
182 _find_files($patt, $fullpath);
183 } elsif ($f =~ /$patt/) {
184 push @found, $fullpath;
185 }
7ebf5c89 186 }
24c841ba 187 }
c96083ea 188 @found;
24c841ba
MS
189}
190
3fd4b359
MS
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])/) {
79b01a68 204 $switch = "-$1";
3fd4b359
MS
205 } else {
206 if ($::taintwarn) {
207 # not all tests are expected to pass with this option
79b01a68 208 $switch = '-t';
3fd4b359
MS
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>) {
11ea18f2 218 $file_opts = $file_opts . ",-f$3$4"
3fd4b359
MS
219 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
220 }
221 }
222
491c9572 223 close $script;
84650816 224
70a78ba7 225 my $perl = $^O eq 'MSWin32' ? '.\perl' : './perl';
923e061d 226 my $lib = '../lib';
491c9572
VP
227 my $run_dir;
228 my $return_dir;
229
2adbc9b6
NC
230 $test =~ /^(.+)\/[^\/]+/;
231 my $dir = $1;
2adbc9b6 232 my $testswitch = $dir_to_switch{$dir};
5ed59b83 233 if (!defined $testswitch) {
55d965ca 234 if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) {
491c9572 235 $run_dir = $1;
2adbc9b6
NC
236 $return_dir = '../../t';
237 $lib = '../../lib';
1ff5bc37 238 $perl = '../../t/perl';
6d1e6673 239 $testswitch = "-I../.. -MTestInit=U2T";
4b05cdbd 240 if ($2 eq 'cpan' || $2 eq 'dist') {
41239ce7 241 if($abs{$run_dir}) {
55d965ca
NC
242 $testswitch = $testswitch . ',A';
243 }
244 if ($temp_no_core{$run_dir}) {
245 $testswitch = $testswitch . ',NC';
246 }
2adbc9b6 247 }
76cc22ec
NC
248 } elsif ($test =~ m!^\.\./lib!) {
249 $testswitch = '-I.. -MTestInit=U1'; # -T will remove . from @INC
2adbc9b6 250 } else {
30b6e591 251 $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC
2adbc9b6 252 }
5ed59b83 253 }
923e061d 254
9fb03e61 255 my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : '';
84650816 256
9b37184d 257 my %options = (
491c9572
VP
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,
9b37184d
VP
267 );
268
269 return \%options;
491c9572
VP
270}
271
d1fe220a
VP
272sub _cmd {
273 my($options, $type) = @_;
491c9572 274
d1fe220a 275 my $test = $options->{test};
491c9572 276
d1fe220a 277 my $cmd;
84650816 278 if ($type eq 'deparse') {
491c9572
VP
279 my $perl = "$options->{perl} $options->{testswitch}";
280 my $lib = $options->{lib};
d1fe220a
VP
281
282 $cmd = (
491c9572 283 "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,".
84650816
MS
284 "-l$::deparse_opts$options->{file} ".
285 "$test > $test.dp ".
d1fe220a
VP
286 "&& $perl $options->{switch} -I$lib $test.dp"
287 );
84650816
MS
288 }
289 elsif ($type eq 'perl') {
491c9572 290 my $perl = $options->{perl};
84650816
MS
291 my $redir = $^O eq 'VMS' ? '2>&1' : '';
292
293 if ($ENV{PERL_VALGRIND}) {
e07ce2e4 294 my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp";
c7b956bb 295 my $valgrind_exe = $ENV{VALGRIND} // 'valgrind';
be075caf 296 if ($options->{run_dir}) {
7ab0d5f3
MH
297 require Cwd;
298 $Valgrind_Log = Cwd::abs_path("$options->{run_dir}/$Valgrind_Log");
be075caf 299 }
84650816 300 my $vg_opts = $ENV{VG_OPTS}
be075caf 301 // "--log-file=$Valgrind_Log "
c7b956bb
JC
302 . "--suppressions=$perl_supp --leak-check=yes "
303 . "--leak-resolution=high --show-reachable=yes "
be075caf
MH
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 }
c7b956bb 309 $perl = "$valgrind_exe $vg_opts $perl";
84650816
MS
310 }
311
491c9572 312 my $args = "$options->{testswitch} $options->{switch} $options->{utf8}";
d1fe220a 313 $cmd = $perl . _quote_args($args) . " $test $redir";
84650816 314 }
d1fe220a
VP
315 return $cmd;
316}
317
9324df28
VP
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
be075caf
MH
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
9324df28
VP
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
d1fe220a 351sub _run_test {
999051eb 352 my ($test, $type) = @_;
d1fe220a
VP
353
354 my $options = _scan_test($test, $type);
999051eb
VP
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.
d1fe220a 357
9324df28 358 _before_fork($options);
d1fe220a
VP
359
360 my $cmd = _cmd($options, $type);
361
362 open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n";
363
9324df28 364 _after_fork($options);
2adbc9b6 365
84650816
MS
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
cc6ae9e5
CB
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;
11ea18f2 383 $argstring = $argstring . ' ' . $_;
cc6ae9e5
CB
384 }
385 return $argstring;
386}
387
6234cb77 388sub _populate_hash {
a3323f52 389 return unless defined $_[0];
6234cb77
NC
390 return map {$_, 1} split /\s+/, $_[0];
391}
392
a3323f52
NC
393sub _tests_from_manifest {
394 my ($extensions, $known_extensions) = @_;
6234cb77 395 my %skip;
a3323f52
NC
396 my %extensions = _populate_hash($extensions);
397 my %known_extensions = _populate_hash($known_extensions);
64c61100 398 my %printed_skip_warning;
a3323f52
NC
399
400 foreach (keys %known_extensions) {
11ea18f2 401 $skip{$_} = 1 unless $extensions{$_};
6234cb77 402 }
a3323f52
NC
403
404 my @results;
7ebf5c89 405 my $mani = '../MANIFEST';
7a315204 406 if (open(MANI, $mani)) {
18869dc6 407 while (<MANI>) {
a193a2db 408 if (m!^((?:cpan|dist|ext)/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
80ed0dea
DM
409 my $t = $1;
410 my $extension = $2;
2e0cc28b 411
64c61100 412 if ( ord "A" != 65
703512f5
KW
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/
8a0a216e
KW
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/
703512f5 437 )
64c61100
KW
438 !x)
439 {
440 print STDERR "Skipping testing of $extension on EBCDIC\n"
441 unless $printed_skip_warning{$extension}++;
442 next;
443 }
2e0cc28b 444
a3323f52 445 if (!$::core || $t =~ m!^lib/[a-z]!) {
6234cb77 446 if (defined $extension) {
b12cb1ba 447 $extension =~ s!/t(:?/\S+)*$!!;
6234cb77
NC
448 # XXX Do I want to warn that I'm skipping these?
449 next if $skip{$extension};
142f6a0d 450 my $flat_extension = $extension;
6ebb0601
CB
451 $flat_extension =~ s!-!/!g;
452 next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
6234cb77 453 }
7ebf5c89 454 my $path = "../$t";
a3323f52 455 push @results, $path;
80ed0dea 456 $::path_to_name{$path} = $t;
5a6e071d 457 }
7a315204
JH
458 }
459 }
35d88760 460 close MANI;
7a315204 461 } else {
f458b6e8 462 warn "$0: cannot open $mani: $!\n";
7a315204 463 }
a3323f52
NC
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
560a5958 472 foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
a3323f52
NC
473 _find_tests($dir);
474 }
cc306f49
NC
475 unless ($::core) {
476 _find_tests('porting');
9f5bbdb6 477 _find_tests("lib");
cc306f49 478 }
a3323f52
NC
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.
a3815e44 481 # What we want to do is make a list of extensions which we did not build.
a3323f52
NC
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);
80ed0dea 506 unless ($::core) {
80ed0dea 507 _find_tests('japh') if $::torture;
7e71d4a4 508 _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
ff5db609 509 _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
e018f8be 510 }
8d063cd8 511}
60fae40d
YO
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};
8d063cd8 543
80ed0dea 544if ($::deparse) {
f193aa2f
MS
545 _testprogs('deparse', '', @ARGV);
546}
80ed0dea 547elsif ($::with_utf16) {
1de9afcd
RGS
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")) {
90f6ca78 559 print U pack("$f", 0xFEFF) if $b;
1de9afcd
RGS
560 while (<A>) {
561 print U pack("$f*", unpack("C*", $_));
562 }
80ed0dea 563 close(U);
1de9afcd 564 }
80ed0dea 565 close(A);
1de9afcd
RGS
566 }
567 }
568 _testprogs('perl', '', @UARGV);
569 unlink(@UARGV);
570 }
571 }
572}
f193aa2f 573else {
f193aa2f 574 _testprogs('perl', '', @ARGV);
485988ae 575}
6ee623d5 576
bb365837 577sub _testprogs {
80ed0dea 578 my ($type, $args, @tests) = @_;
6ee623d5 579
485988ae 580 print <<'EOT' if ($type eq 'deparse');
7a315204 581------------------------------------------------------------------------------
485988ae 582TESTING DEPARSER
7a315204 583------------------------------------------------------------------------------
485988ae
RH
584EOT
585
80ed0dea 586 $::bad_files = 0;
73ddec28 587
cc6ae9e5 588 foreach my $t (@tests) {
80ed0dea 589 unless (exists $::path_to_name{$t}) {
7ebf5c89 590 my $tname = "t/$t";
f458b6e8 591 $::path_to_name{$t} = $tname;
cc6ae9e5 592 }
73ddec28 593 }
908801fe 594 my $maxlen = 0;
80ed0dea 595 foreach (@::path_to_name{@tests}) {
f7b9b043 596 s/\.\w+\z/ /; # space gives easy doubleclick to select fname
73ddec28
RB
597 my $len = length ;
598 $maxlen = $len if $len > $maxlen;
088b5126 599 }
908801fe 600 # + 3 : we want three dots between the test name and the "ok"
80ed0dea 601 my $dotdotdot = $maxlen + 3 ;
c7b956bb 602 my $grind_ct = 0; # count of non-empty valgrind reports
80ed0dea
DM
603 my $total_files = @tests;
604 my $good_files = 0;
33c0d182 605 my $tested_files = 0;
fb7ba3c8 606 my $totmax = 0;
ade55ef4 607 my %failed_tests;
10d90405 608 my @unexpected_pass; # files where deparse-skips.txt says fail but passed
c96083ea 609 my $toolnm; # valgrind, cachegrind, perf
80ed0dea 610
551405c4 611 while (my $test = shift @tests) {
25a2b27f
JC
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
8bdd21ca 621 # collection scheme (Storable isn't tuned for incremental use)
25a2b27f
JC
622 @starttimes = times;
623 }
bb365837
GS
624 if ($test =~ /^$/) {
625 next;
6ee623d5 626 }
2722144b
MH
627 if ($type eq 'deparse' && $test =~ $deparse_skips) {
628 next;
485988ae 629 }
80ed0dea 630 my $te = $::path_to_name{$test} . '.'
f7b9b043 631 x ($dotdotdot - length($::path_to_name{$test})) .' ';
cc6ae9e5
CB
632
633 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
634 print $te;
635 $te = '';
636 }
bb365837 637
be075caf
MH
638 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
639
999051eb 640 my $results = _run_test($test, $type);
d638aca2 641
33c0d182 642 my $failure;
e1a5ed7a
JH
643 my $next = 0;
644 my $seen_leader = 0;
645 my $seen_ok = 0;
646 my $trailing_leader = 0;
647 my $max;
43fe0836 648 my %todo;
84650816 649 while (<$results>) {
cc6ae9e5 650 next if /^\s*$/; # skip blank lines
615b7a35
JM
651 if (/^1..$/ && ($^O eq 'VMS')) {
652 # VMS pipe bug inserts blank lines.
5403a9a2 653 my $l2 = <$results>;
615b7a35 654 if ($l2 =~ /^\s*$/) {
5403a9a2 655 $l2 = <$results>;
615b7a35
JM
656 }
657 $_ = '1..' . $l2;
658 }
80ed0dea 659 if ($::verbose) {
bb365837
GS
660 print $_;
661 }
21c74f43 662 unless (/^\#/) {
fb7ba3c8
JH
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 }
809908f7 668 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
fb7ba3c8
JH
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";
20f82676
DM
682 last;
683 }
684 }
fb7ba3c8
JH
685 else {
686 $next = 0;
20f82676 687 }
fb7ba3c8 688 $seen_leader = 1;
bb365837
GS
689 }
690 else {
fb7ba3c8
JH
691 if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
692 unless ($seen_leader) {
693 unless ($seen_ok) {
694 $next = 0;
695 }
696 }
697 $seen_ok = 1;
11ea18f2 698 $next = $next + 1;
fb7ba3c8
JH
699 my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
700 $num = $next unless $num;
701
702 if ($num == $next) {
f458b6e8 703
eac7c728
MB
704 # SKIP is essentially the same as TODO for t/TEST
705 # this still conforms to TAP:
464a08e7 706 # http://testanything.org/wiki/index.php/TAP_specification
eac7c728 707 $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
21c74f43
A
708 $istodo = 1 if $todo{$num};
709
710 if( $not && !$istodo ) {
20f82676 711 $failure = "FAILED at test $num";
21c74f43
A
712 last;
713 }
20f82676 714 }
fb7ba3c8
JH
715 else {
716 $failure ="FAILED--expected test $next, saw test $num";
717 last;
718 }
f458b6e8
MS
719 }
720 elsif (/^Bail out!\s*(.*)/i) { # magic words
721 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
bb365837
GS
722 }
723 else {
dbf51d07
YST
724 # module tests are allowed extra output,
725 # because Test::Harness allows it
4d834435 726 next if $test =~ /^\W*(cpan|dist|ext|lib)\b/;
a5890677 727 $failure = "FAILED--unexpected output at test $next";
20f82676 728 last;
bb365837 729 }
8d063cd8
LW
730 }
731 }
732 }
983c6181
KW
733 my @junk = <$results>; # dump remaining output to prevent SIGPIPE
734 # (so far happens only on os390)
84650816 735 close $results;
983c6181 736 undef @junk;
20f82676 737
33c0d182 738 if (not defined $failure) {
fb7ba3c8 739 $failure = 'FAILED--no leader found' unless $seen_leader;
20f82676
DM
740 }
741
be075caf
MH
742 _check_valgrind(\$toolnm, \$grind_ct, \$test);
743
2722144b 744 if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) {
485988ae
RH
745 unlink "./$test.dp";
746 }
33c0d182 747 if (not defined $failure and $next != $max) {
fb7ba3c8 748 $failure="FAILED--expected $max tests, saw $next";
20f82676
DM
749 }
750
33c0d182
JH
751 if( !defined $failure # don't mask a test failure
752 and $? )
753 {
343bc60d
MS
754 $failure = "FAILED--non-zero wait status: $?";
755 }
756
2722144b
MH
757 # Deparse? Should it have passed or failed?
758 if ($type eq 'deparse' && $test =~ $deparse_failures) {
759 if (!$failure) {
dcf4c706 760 # Wait, it didn't fail? Great news!
10d90405 761 push @unexpected_pass, $test;
2722144b
MH
762 } else {
763 # Bah, still failing. Mask it.
764 print "${te}skipped\n";
765 $tested_files = $tested_files - 1;
766 next;
767 }
768 }
769
33c0d182 770 if (defined $failure) {
20f82676 771 print "${te}$failure\n";
11ea18f2 772 $::bad_files = $::bad_files + 1;
25a4a90c
KW
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";
20f82676 778 }
11ea18f2 779 $failed_tests{$test} = 1;
20f82676
DM
780 }
781 else {
fb7ba3c8 782 if ($max) {
b49055e9 783 my ($elapsed, $etms) = ("", 0);
551405c4 784 if ( $show_elapsed_time ) {
b49055e9 785 $etms = (Time::HiRes::time() - $test_start_time) * 1000;
25a2b27f
JC
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;
551405c4
AL
794 }
795 print "${te}ok$elapsed\n";
11ea18f2 796 $good_files = $good_files + 1;
bb365837
GS
797 }
798 else {
6b202754 799 print "${te}skipped\n";
11ea18f2 800 $tested_files = $tested_files - 1;
bb365837 801 }
bcce72a7 802 }
551405c4 803 } # while tests
8d063cd8 804
80ed0dea 805 if ($::bad_files == 0) {
20f82676 806 if ($good_files) {
bb365837
GS
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 }
8d063cd8 813 }
bb365837 814 else {
80ed0dea 815 my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
ade55ef4
AL
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";
bb365837 820 }
10d90405
DM
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
4e4732c1 832 warn <<'SHRDLU_1';
f7d228c6
JH
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".
4e4732c1 836SHRDLU_1
80ed0dea 837 warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
f7d228c6
JH
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.
4e4732c1 841SHRDLU_2
f458b6e8 842 if (eval {require Config; import Config; 1}) {
80ed0dea 843 if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
4e4732c1 844 warn <<SHRDLU_3;
f7d228c6
JH
845### You may have to set your dynamic library search path,
846### $p, to point to the build directory:
4e4732c1 847SHRDLU_3
f458b6e8 848 if (exists $ENV{$p} && $ENV{$p} ne '') {
4e4732c1 849 warn <<SHRDLU_4a;
f7d228c6
JH
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
4e4732c1 853SHRDLU_4a
f458b6e8 854 } else {
4e4732c1 855 warn <<SHRDLU_4b;
f7d228c6
JH
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
4e4732c1 859SHRDLU_4b
f458b6e8 860 }
4e4732c1 861 warn <<SHRDLU_5;
f7d228c6
JH
862### for csh-style shells, like tcsh; or for traditional/modern
863### Bourne-style shells, like bash, ksh, and zsh, respectively.
4e4732c1 864SHRDLU_5
f458b6e8 865 }
afd33fa9 866 }
bb365837 867 }
94708f6d 868 printf "Elapsed: %d sec\n", time() - $t0;
80ed0dea 869 my ($user,$sys,$cuser,$csys) = times;
8e03ad8f
JC
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) {
56e28cb0
JH
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.
8e03ad8f 879 require Storable;
133d407a
JH
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";
56e28cb0 883 Storable::store({ perf => \%timings,
8e03ad8f
JC
884 gather_conf_platform_info(),
885 total => $tot,
886 }, $fn);
887 print "wrote storable file: $fn\n";
888 }
889 }
be075caf
MH
890
891 _cleanup_valgrind(\$toolnm, \$grind_ct);
6ee623d5 892}
80ed0dea 893exit ($::bad_files != 0);
ade55ef4 894
8e03ad8f
JC
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`),
56e28cb0 922 version => '0.03', # bump for conf, platform, or data collection changes
8e03ad8f
JC
923 );
924}
925
be075caf
MH
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') {
e73fd51e 945 # append perfs subcommand, not just stat
be075caf
MH
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 }
0d40ea5e
KW
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 }
be075caf
MH
1007}
1008
2722144b 1009# Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
2722144b
MH
1010
1011sub _process_deparse_config {
1012 my @deparse_failures;
1013 my @deparse_skips;
1014
10d90405 1015 my $f = $deparse_skip_file;
2722144b
MH
1016
1017 my $skips;
1018 if (!open($skips, '<', $f)) {
1019 warn "Failed to find $f: $!\n";
1020 return;
1021 }
1022
94021b25 1023 my $in;
2722144b
MH
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, $_;
94021b25 1039 warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
2722144b
MH
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
ade55ef4 1057# ex: set ts=8 sts=4 sw=4 noet: