This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldelta - move split change to other perlfunc changes and add issue link
[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";
181
182 if (-d $fullpath) {
183 _find_files($patt, $fullpath);
184 } elsif ($f =~ /$patt/) {
185 push @found, $fullpath;
186 }
7ebf5c89 187 }
24c841ba 188 }
c96083ea 189 @found;
24c841ba
MS
190}
191
3fd4b359
MS
192
193# Scan the text of the test program to find switches and special options
194# we might need to apply.
195sub _scan_test {
196 my($test, $type) = @_;
197
198 open(my $script, "<", $test) or die "Can't read $test.\n";
199 my $first_line = <$script>;
200
201 $first_line =~ tr/\0//d if $::with_utf16;
202
203 my $switch = "";
204 if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) {
79b01a68 205 $switch = "-$1";
3fd4b359
MS
206 } else {
207 if ($::taintwarn) {
208 # not all tests are expected to pass with this option
79b01a68 209 $switch = '-t';
3fd4b359
MS
210 } else {
211 $switch = '';
212 }
213 }
214
215 my $file_opts = "";
216 if ($type eq 'deparse') {
217 # Look for #line directives which change the filename
218 while (<$script>) {
11ea18f2 219 $file_opts = $file_opts . ",-f$3$4"
3fd4b359
MS
220 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
221 }
222 }
223
491c9572 224 close $script;
84650816 225
70a78ba7 226 my $perl = $^O eq 'MSWin32' ? '.\perl' : './perl';
923e061d 227 my $lib = '../lib';
491c9572
VP
228 my $run_dir;
229 my $return_dir;
230
2adbc9b6
NC
231 $test =~ /^(.+)\/[^\/]+/;
232 my $dir = $1;
2adbc9b6 233 my $testswitch = $dir_to_switch{$dir};
5ed59b83 234 if (!defined $testswitch) {
55d965ca 235 if ($test =~ s!^(\.\./(cpan|dist|ext)/[^/]+)/t!t!) {
491c9572 236 $run_dir = $1;
2adbc9b6
NC
237 $return_dir = '../../t';
238 $lib = '../../lib';
1ff5bc37 239 $perl = '../../t/perl';
6d1e6673 240 $testswitch = "-I../.. -MTestInit=U2T";
4b05cdbd 241 if ($2 eq 'cpan' || $2 eq 'dist') {
41239ce7 242 if($abs{$run_dir}) {
55d965ca
NC
243 $testswitch = $testswitch . ',A';
244 }
245 if ($temp_no_core{$run_dir}) {
246 $testswitch = $testswitch . ',NC';
247 }
2adbc9b6 248 }
76cc22ec
NC
249 } elsif ($test =~ m!^\.\./lib!) {
250 $testswitch = '-I.. -MTestInit=U1'; # -T will remove . from @INC
2adbc9b6 251 } else {
30b6e591 252 $testswitch = '-I.. -MTestInit'; # -T will remove . from @INC
2adbc9b6 253 }
5ed59b83 254 }
923e061d 255
9fb03e61 256 my $utf8 = ($::with_utf8 || $::with_utf16) ? "-I$lib -Mutf8" : '';
84650816 257
9b37184d 258 my %options = (
491c9572
VP
259 perl => $perl,
260 lib => $lib,
261 test => $test,
262 run_dir => $run_dir,
263 return_dir => $return_dir,
264 testswitch => $testswitch,
265 utf8 => $utf8,
266 file => $file_opts,
267 switch => $switch,
9b37184d
VP
268 );
269
270 return \%options;
491c9572
VP
271}
272
d1fe220a
VP
273sub _cmd {
274 my($options, $type) = @_;
491c9572 275
d1fe220a 276 my $test = $options->{test};
491c9572 277
d1fe220a 278 my $cmd;
84650816 279 if ($type eq 'deparse') {
491c9572
VP
280 my $perl = "$options->{perl} $options->{testswitch}";
281 my $lib = $options->{lib};
d1fe220a
VP
282
283 $cmd = (
491c9572 284 "$perl $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,".
84650816
MS
285 "-l$::deparse_opts$options->{file} ".
286 "$test > $test.dp ".
d1fe220a
VP
287 "&& $perl $options->{switch} -I$lib $test.dp"
288 );
84650816
MS
289 }
290 elsif ($type eq 'perl') {
491c9572 291 my $perl = $options->{perl};
84650816
MS
292 my $redir = $^O eq 'VMS' ? '2>&1' : '';
293
294 if ($ENV{PERL_VALGRIND}) {
e07ce2e4 295 my $perl_supp = $options->{return_dir} ? "$options->{return_dir}/perl.supp" : "perl.supp";
c7b956bb 296 my $valgrind_exe = $ENV{VALGRIND} // 'valgrind';
be075caf 297 if ($options->{run_dir}) {
7ab0d5f3
MH
298 require Cwd;
299 $Valgrind_Log = Cwd::abs_path("$options->{run_dir}/$Valgrind_Log");
be075caf 300 }
84650816 301 my $vg_opts = $ENV{VG_OPTS}
be075caf 302 // "--log-file=$Valgrind_Log "
c7b956bb
JC
303 . "--suppressions=$perl_supp --leak-check=yes "
304 . "--leak-resolution=high --show-reachable=yes "
be075caf
MH
305 . "--num-callers=50 --track-origins=yes";
306 # Force logging if not asked for (so cachegrind reporting works below)
307 if ($vg_opts !~ /--log-file/) {
308 $vg_opts = "--log-file=$Valgrind_Log $vg_opts";
309 }
c7b956bb 310 $perl = "$valgrind_exe $vg_opts $perl";
84650816
MS
311 }
312
491c9572 313 my $args = "$options->{testswitch} $options->{switch} $options->{utf8}";
d1fe220a 314 $cmd = $perl . _quote_args($args) . " $test $redir";
84650816 315 }
d1fe220a
VP
316 return $cmd;
317}
318
9324df28
VP
319sub _before_fork {
320 my ($options) = @_;
321
322 if ($options->{run_dir}) {
323 my $run_dir = $options->{run_dir};
324 chdir $run_dir or die "Can't chdir to '$run_dir': $!";
325 }
326
be075caf
MH
327 # Remove previous valgrind output otherwise it will interfere
328 my $test = $options->{test};
329
330 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
331
332 if ($ENV{PERL_VALGRIND} && -e $Valgrind_Log) {
333 unlink $Valgrind_Log
334 or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
335 }
336
9324df28
VP
337 return;
338}
339
340sub _after_fork {
341 my ($options) = @_;
342
343 if ($options->{return_dir}) {
344 my $return_dir = $options->{return_dir};
345 chdir $return_dir
346 or die "Can't chdir from '$options->{run_dir}' to '$return_dir': $!";
347 }
348
349 return;
350}
351
d1fe220a 352sub _run_test {
999051eb 353 my ($test, $type) = @_;
d1fe220a
VP
354
355 my $options = _scan_test($test, $type);
999051eb
VP
356 # $test might have changed if we're in ext/Foo, so don't use it anymore
357 # from now on. Use $options->{test} instead.
d1fe220a 358
9324df28 359 _before_fork($options);
d1fe220a
VP
360
361 my $cmd = _cmd($options, $type);
362
363 open(my $results, "$cmd |") or print "can't run '$cmd': $!.\n";
364
9324df28 365 _after_fork($options);
2adbc9b6 366
84650816
MS
367 # Our environment may force us to use UTF-8, but we can't be sure that
368 # anything we're reading from will be generating (well formed) UTF-8
369 # This may not be the best way - possibly we should unset ${^OPEN} up
370 # top?
371 binmode $results;
372
373 return $results;
374}
375
cc6ae9e5
CB
376sub _quote_args {
377 my ($args) = @_;
378 my $argstring = '';
379
380 foreach (split(/\s+/,$args)) {
381 # In VMS protect with doublequotes because otherwise
382 # DCL will lowercase -- unless already doublequoted.
383 $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
11ea18f2 384 $argstring = $argstring . ' ' . $_;
cc6ae9e5
CB
385 }
386 return $argstring;
387}
388
6234cb77 389sub _populate_hash {
a3323f52 390 return unless defined $_[0];
6234cb77
NC
391 return map {$_, 1} split /\s+/, $_[0];
392}
393
a3323f52
NC
394sub _tests_from_manifest {
395 my ($extensions, $known_extensions) = @_;
6234cb77 396 my %skip;
a3323f52
NC
397 my %extensions = _populate_hash($extensions);
398 my %known_extensions = _populate_hash($known_extensions);
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
703512f5
KW
412 next 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/
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
KW
437 )
438 !x;
2e0cc28b 439
a3323f52 440 if (!$::core || $t =~ m!^lib/[a-z]!) {
6234cb77 441 if (defined $extension) {
b12cb1ba 442 $extension =~ s!/t(:?/\S+)*$!!;
6234cb77
NC
443 # XXX Do I want to warn that I'm skipping these?
444 next if $skip{$extension};
142f6a0d 445 my $flat_extension = $extension;
6ebb0601
CB
446 $flat_extension =~ s!-!/!g;
447 next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
6234cb77 448 }
7ebf5c89 449 my $path = "../$t";
a3323f52 450 push @results, $path;
80ed0dea 451 $::path_to_name{$path} = $t;
5a6e071d 452 }
7a315204
JH
453 }
454 }
35d88760 455 close MANI;
7a315204 456 } else {
f458b6e8 457 warn "$0: cannot open $mani: $!\n";
7a315204 458 }
a3323f52
NC
459 return @results;
460}
461
462unless (@ARGV) {
463 # base first, as TEST bails out if that can't run
464 # then comp, to validate that require works
465 # then run, to validate that -M works
466 # then we know we can -MTestInit for everything else, making life simpler
560a5958 467 foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
a3323f52
NC
468 _find_tests($dir);
469 }
cc306f49
NC
470 unless ($::core) {
471 _find_tests('porting');
472 _find_tests("lib");
473 }
a3323f52
NC
474 # Config.pm may be broken for make minitest. And this is only a refinement
475 # for skipping tests on non-default builds, so it is allowed to fail.
a3815e44 476 # What we want to do is make a list of extensions which we did not build.
a3323f52
NC
477 my $configsh = '../config.sh';
478 my ($extensions, $known_extensions);
479 if (-f $configsh) {
480 open FH, $configsh or die "Can't open $configsh: $!";
481 while (<FH>) {
482 if (/^extensions=['"](.*)['"]$/) {
483 $extensions = $1;
484 }
485 elsif (/^known_extensions=['"](.*)['"]$/) {
486 $known_extensions = $1;
487 }
488 }
489 if (!defined $known_extensions) {
490 warn "No known_extensions line found in $configsh";
491 }
492 if (!defined $extensions) {
493 warn "No extensions line found in $configsh";
494 }
495 }
496 # The "complex" constructions of list return from a subroutine, and push of
497 # a list, might fail if perl is really hosed, but they aren't needed for
498 # make minitest, and the building of extensions will likely also fail if
499 # something is that badly wrong.
500 push @ARGV, _tests_from_manifest($extensions, $known_extensions);
80ed0dea 501 unless ($::core) {
80ed0dea 502 _find_tests('japh') if $::torture;
7e71d4a4 503 _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
ff5db609 504 _find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
e018f8be 505 }
8d063cd8 506}
60fae40d
YO
507@ARGV= do {
508 my @order= (
509 "base",
510 "comp",
511 "run",
512 "cmd",
513 "io",
514 "re",
515 "opbasic",
516 "op",
517 "uni",
518 "mro",
519 "lib",
520 "ext",
521 "dist",
522 "cpan",
523 "perf",
524 "porting",
525 );
526 my %order= map { $order[$_] => 1+$_ } 0..$#order;
527 my $idx= 0;
528 map {
529 $_->[0]
530 } sort {
531 $a->[3] <=> $b->[3] ||
532 $a->[1] <=> $b->[1]
533 } map {
534 my $root= /(\w+)/ ? $1 : "";
535 [ $_, $idx++, $root, $order{$root}||=0 ]
536 } @ARGV;
537};
8d063cd8 538
80ed0dea 539if ($::deparse) {
f193aa2f
MS
540 _testprogs('deparse', '', @ARGV);
541}
80ed0dea 542elsif ($::with_utf16) {
1de9afcd
RGS
543 for my $e (0, 1) {
544 for my $b (0, 1) {
545 print STDERR "# ENDIAN $e BOM $b\n";
546 my @UARGV;
547 for my $a (@ARGV) {
548 my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
549 my $f = $e ? "v" : "n";
550 push @UARGV, $u;
551 unlink($u);
552 if (open(A, $a)) {
553 if (open(U, ">$u")) {
90f6ca78 554 print U pack("$f", 0xFEFF) if $b;
1de9afcd
RGS
555 while (<A>) {
556 print U pack("$f*", unpack("C*", $_));
557 }
80ed0dea 558 close(U);
1de9afcd 559 }
80ed0dea 560 close(A);
1de9afcd
RGS
561 }
562 }
563 _testprogs('perl', '', @UARGV);
564 unlink(@UARGV);
565 }
566 }
567}
f193aa2f 568else {
f193aa2f 569 _testprogs('perl', '', @ARGV);
485988ae 570}
6ee623d5 571
bb365837 572sub _testprogs {
80ed0dea 573 my ($type, $args, @tests) = @_;
6ee623d5 574
485988ae 575 print <<'EOT' if ($type eq 'deparse');
7a315204 576------------------------------------------------------------------------------
485988ae 577TESTING DEPARSER
7a315204 578------------------------------------------------------------------------------
485988ae
RH
579EOT
580
80ed0dea 581 $::bad_files = 0;
73ddec28 582
cc6ae9e5 583 foreach my $t (@tests) {
80ed0dea 584 unless (exists $::path_to_name{$t}) {
7ebf5c89 585 my $tname = "t/$t";
f458b6e8 586 $::path_to_name{$t} = $tname;
cc6ae9e5 587 }
73ddec28 588 }
908801fe 589 my $maxlen = 0;
80ed0dea 590 foreach (@::path_to_name{@tests}) {
f7b9b043 591 s/\.\w+\z/ /; # space gives easy doubleclick to select fname
73ddec28
RB
592 my $len = length ;
593 $maxlen = $len if $len > $maxlen;
088b5126 594 }
908801fe 595 # + 3 : we want three dots between the test name and the "ok"
80ed0dea 596 my $dotdotdot = $maxlen + 3 ;
c7b956bb 597 my $grind_ct = 0; # count of non-empty valgrind reports
80ed0dea
DM
598 my $total_files = @tests;
599 my $good_files = 0;
33c0d182 600 my $tested_files = 0;
fb7ba3c8 601 my $totmax = 0;
ade55ef4 602 my %failed_tests;
10d90405 603 my @unexpected_pass; # files where deparse-skips.txt says fail but passed
c96083ea 604 my $toolnm; # valgrind, cachegrind, perf
80ed0dea 605
551405c4 606 while (my $test = shift @tests) {
25a2b27f
JC
607 my ($test_start_time, @starttimes) = 0;
608 if ($show_elapsed_time) {
609 $test_start_time = Time::HiRes::time();
610 # times() reports usage by TEST, but we want usage of each
611 # testprog it calls, so record accumulated times now,
612 # subtract them out afterwards. Ideally, we'd take times
613 # in BEGIN/END blocks (giving better visibility of self vs
614 # children of each testprog), but that would require some
615 # IPC to send results back here, or a completely different
8bdd21ca 616 # collection scheme (Storable isn't tuned for incremental use)
25a2b27f
JC
617 @starttimes = times;
618 }
bb365837
GS
619 if ($test =~ /^$/) {
620 next;
6ee623d5 621 }
2722144b
MH
622 if ($type eq 'deparse' && $test =~ $deparse_skips) {
623 next;
485988ae 624 }
80ed0dea 625 my $te = $::path_to_name{$test} . '.'
f7b9b043 626 x ($dotdotdot - length($::path_to_name{$test})) .' ';
cc6ae9e5
CB
627
628 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
629 print $te;
630 $te = '';
631 }
bb365837 632
be075caf
MH
633 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///;
634
999051eb 635 my $results = _run_test($test, $type);
d638aca2 636
33c0d182 637 my $failure;
e1a5ed7a
JH
638 my $next = 0;
639 my $seen_leader = 0;
640 my $seen_ok = 0;
641 my $trailing_leader = 0;
642 my $max;
43fe0836 643 my %todo;
84650816 644 while (<$results>) {
cc6ae9e5 645 next if /^\s*$/; # skip blank lines
615b7a35
JM
646 if (/^1..$/ && ($^O eq 'VMS')) {
647 # VMS pipe bug inserts blank lines.
5403a9a2 648 my $l2 = <$results>;
615b7a35 649 if ($l2 =~ /^\s*$/) {
5403a9a2 650 $l2 = <$results>;
615b7a35
JM
651 }
652 $_ = '1..' . $l2;
653 }
80ed0dea 654 if ($::verbose) {
bb365837
GS
655 print $_;
656 }
21c74f43 657 unless (/^\#/) {
fb7ba3c8
JH
658 if ($trailing_leader) {
659 # shouldn't be anything following a postfix 1..n
660 $failure = 'FAILED--extra output after trailing 1..n';
661 last;
662 }
809908f7 663 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
fb7ba3c8
JH
664 if ($seen_leader) {
665 $failure = 'FAILED--seen duplicate leader';
666 last;
667 }
668 $max = $1;
669 %todo = map { $_ => 1 } split / /, $3 if $3;
670 $totmax = $totmax + $max;
671 $tested_files = $tested_files + 1;
672 if ($seen_ok) {
673 # 1..n appears at end of file
674 $trailing_leader = 1;
675 if ($next != $max) {
676 $failure = "FAILED--expected $max tests, saw $next";
20f82676
DM
677 last;
678 }
679 }
fb7ba3c8
JH
680 else {
681 $next = 0;
20f82676 682 }
fb7ba3c8 683 $seen_leader = 1;
bb365837
GS
684 }
685 else {
fb7ba3c8
JH
686 if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
687 unless ($seen_leader) {
688 unless ($seen_ok) {
689 $next = 0;
690 }
691 }
692 $seen_ok = 1;
11ea18f2 693 $next = $next + 1;
fb7ba3c8
JH
694 my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
695 $num = $next unless $num;
696
697 if ($num == $next) {
f458b6e8 698
eac7c728
MB
699 # SKIP is essentially the same as TODO for t/TEST
700 # this still conforms to TAP:
464a08e7 701 # http://testanything.org/wiki/index.php/TAP_specification
eac7c728 702 $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
21c74f43
A
703 $istodo = 1 if $todo{$num};
704
705 if( $not && !$istodo ) {
20f82676 706 $failure = "FAILED at test $num";
21c74f43
A
707 last;
708 }
20f82676 709 }
fb7ba3c8
JH
710 else {
711 $failure ="FAILED--expected test $next, saw test $num";
712 last;
713 }
f458b6e8
MS
714 }
715 elsif (/^Bail out!\s*(.*)/i) { # magic words
716 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
bb365837
GS
717 }
718 else {
dbf51d07
YST
719 # module tests are allowed extra output,
720 # because Test::Harness allows it
4d834435 721 next if $test =~ /^\W*(cpan|dist|ext|lib)\b/;
a5890677 722 $failure = "FAILED--unexpected output at test $next";
20f82676 723 last;
bb365837 724 }
8d063cd8
LW
725 }
726 }
727 }
983c6181
KW
728 my @junk = <$results>; # dump remaining output to prevent SIGPIPE
729 # (so far happens only on os390)
84650816 730 close $results;
983c6181 731 undef @junk;
20f82676 732
33c0d182 733 if (not defined $failure) {
fb7ba3c8 734 $failure = 'FAILED--no leader found' unless $seen_leader;
20f82676
DM
735 }
736
be075caf
MH
737 _check_valgrind(\$toolnm, \$grind_ct, \$test);
738
2722144b 739 if ($type eq 'deparse' && !$ENV{KEEP_DEPARSE_FILES}) {
485988ae
RH
740 unlink "./$test.dp";
741 }
33c0d182 742 if (not defined $failure and $next != $max) {
fb7ba3c8 743 $failure="FAILED--expected $max tests, saw $next";
20f82676
DM
744 }
745
33c0d182
JH
746 if( !defined $failure # don't mask a test failure
747 and $? )
748 {
343bc60d
MS
749 $failure = "FAILED--non-zero wait status: $?";
750 }
751
2722144b
MH
752 # Deparse? Should it have passed or failed?
753 if ($type eq 'deparse' && $test =~ $deparse_failures) {
754 if (!$failure) {
dcf4c706 755 # Wait, it didn't fail? Great news!
10d90405 756 push @unexpected_pass, $test;
2722144b
MH
757 } else {
758 # Bah, still failing. Mask it.
759 print "${te}skipped\n";
760 $tested_files = $tested_files - 1;
761 next;
762 }
763 }
764
33c0d182 765 if (defined $failure) {
20f82676 766 print "${te}$failure\n";
11ea18f2 767 $::bad_files = $::bad_files + 1;
25a4a90c
KW
768 if ($test =~ /^base/ && ! defined &DynaLoader::boot_DynaLoader) {
769 # Die if running under minitest (no DynaLoader). Otherwise
770 # keep going, as we know that Perl basically works, or we
771 # would not have been able to actually compile it all the way.
772 die "Failed a basic test ($test) under minitest -- cannot continue.\n";
20f82676 773 }
11ea18f2 774 $failed_tests{$test} = 1;
20f82676
DM
775 }
776 else {
fb7ba3c8 777 if ($max) {
b49055e9 778 my ($elapsed, $etms) = ("", 0);
551405c4 779 if ( $show_elapsed_time ) {
b49055e9 780 $etms = (Time::HiRes::time() - $test_start_time) * 1000;
25a2b27f
JC
781 $elapsed = sprintf(" %8.0f ms", $etms);
782
783 my (@endtimes) = times;
784 $endtimes[$_] -= $starttimes[$_] for 0..$#endtimes;
785 splice @endtimes, 0, 2; # drop self/harness times
786 $_ *= 1000 for @endtimes; # and scale to ms
787 $timings{$test} = [$etms,@endtimes];
788 $elapsed .= sprintf(" %5.0f ms", $_) for @endtimes;
551405c4
AL
789 }
790 print "${te}ok$elapsed\n";
11ea18f2 791 $good_files = $good_files + 1;
bb365837
GS
792 }
793 else {
6b202754 794 print "${te}skipped\n";
11ea18f2 795 $tested_files = $tested_files - 1;
bb365837 796 }
bcce72a7 797 }
551405c4 798 } # while tests
8d063cd8 799
80ed0dea 800 if ($::bad_files == 0) {
20f82676 801 if ($good_files) {
bb365837
GS
802 print "All tests successful.\n";
803 # XXX add mention of 'perlbug -ok' ?
804 }
805 else {
806 die "FAILED--no tests were run for some reason.\n";
807 }
8d063cd8 808 }
bb365837 809 else {
80ed0dea 810 my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
ade55ef4
AL
811 my $s = $::bad_files == 1 ? "" : "s";
812 warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
813 for my $test ( sort keys %failed_tests ) {
814 print "\t$test\n";
bb365837 815 }
10d90405
DM
816
817 if (@unexpected_pass) {
818 print <<EOF;
819
820The following scripts were expected to fail under -deparse (at least
821according to $deparse_skip_file), but unexpectedly succeeded:
822EOF
823 print "\t$_\n" for sort @unexpected_pass;
824 print "\n";
825 }
826
4e4732c1 827 warn <<'SHRDLU_1';
f7d228c6
JH
828### Since not all tests were successful, you may want to run some of
829### them individually and examine any diagnostic messages they produce.
830### See the INSTALL document's section on "make test".
4e4732c1 831SHRDLU_1
80ed0dea 832 warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
f7d228c6
JH
833### You have a good chance to get more information by running
834### ./perl harness
835### in the 't' directory since most (>=80%) of the tests succeeded.
4e4732c1 836SHRDLU_2
f458b6e8 837 if (eval {require Config; import Config; 1}) {
80ed0dea 838 if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
4e4732c1 839 warn <<SHRDLU_3;
f7d228c6
JH
840### You may have to set your dynamic library search path,
841### $p, to point to the build directory:
4e4732c1 842SHRDLU_3
f458b6e8 843 if (exists $ENV{$p} && $ENV{$p} ne '') {
4e4732c1 844 warn <<SHRDLU_4a;
f7d228c6
JH
845### setenv $p `pwd`:\$$p; cd t; ./perl harness
846### $p=`pwd`:\$$p; export $p; cd t; ./perl harness
847### export $p=`pwd`:\$$p; cd t; ./perl harness
4e4732c1 848SHRDLU_4a
f458b6e8 849 } else {
4e4732c1 850 warn <<SHRDLU_4b;
f7d228c6
JH
851### setenv $p `pwd`; cd t; ./perl harness
852### $p=`pwd`; export $p; cd t; ./perl harness
853### export $p=`pwd`; cd t; ./perl harness
4e4732c1 854SHRDLU_4b
f458b6e8 855 }
4e4732c1 856 warn <<SHRDLU_5;
f7d228c6
JH
857### for csh-style shells, like tcsh; or for traditional/modern
858### Bourne-style shells, like bash, ksh, and zsh, respectively.
4e4732c1 859SHRDLU_5
f458b6e8 860 }
afd33fa9 861 }
bb365837 862 }
94708f6d 863 printf "Elapsed: %d sec\n", time() - $t0;
80ed0dea 864 my ($user,$sys,$cuser,$csys) = times;
8e03ad8f
JC
865 my $tot = sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d",
866 $user,$sys,$cuser,$csys,$tested_files,$totmax);
867 print "$tot\n";
868 if ($good_files) {
869 if (-d $show_elapsed_time) {
56e28cb0
JH
870 # HARNESS_TIMER = <a-directory>. Save timings etc to
871 # storable file there. NB: the test cds to ./t/, so
872 # relative path must account for that, ie ../../perf
873 # points to dir next to source tree.
8e03ad8f 874 require Storable;
133d407a
JH
875 my @dt = localtime;
876 $dt[5] += 1900; $dt[4] += 1; # fix year, month
877 my $fn = "$show_elapsed_time/".join('-', @dt[5,4,3,2,1]).".ttimes";
56e28cb0 878 Storable::store({ perf => \%timings,
8e03ad8f
JC
879 gather_conf_platform_info(),
880 total => $tot,
881 }, $fn);
882 print "wrote storable file: $fn\n";
883 }
884 }
be075caf
MH
885
886 _cleanup_valgrind(\$toolnm, \$grind_ct);
6ee623d5 887}
80ed0dea 888exit ($::bad_files != 0);
ade55ef4 889
8e03ad8f
JC
890# Collect platform, config data that should allow comparing
891# performance data between different machines. With enough data,
892# and/or clever statistical analysis, it should be possible to
893# determine the effect of config choices, more memory, etc
894
895sub gather_conf_platform_info {
896 # currently rather quick & dirty, and subject to change
897 # for both content and format.
898 require Config;
899 my (%conf, @platform) = ();
900 $conf{$_} = $Config::Config{$_} for
901 grep /cc|git|config_arg\d+/, keys %Config::Config;
902 if (-f '/proc/cpuinfo') {
903 open my $fh, '/proc/cpuinfo' or warn "$!: /proc/cpuinfo\n";
904 @platform = grep /name|cpu/, <$fh>;
905 chomp $_ for @platform;
906 }
907 unshift @platform, $^O;
908
909 return (
910 conf => \%conf,
911 platform => {cpu => \@platform,
912 mem => [ grep s/\s+/ /,
913 grep chomp, `free` ],
914 load => [ grep chomp, `uptime` ],
915 },
916 host => (grep chomp, `hostname -f`),
56e28cb0 917 version => '0.03', # bump for conf, platform, or data collection changes
8e03ad8f
JC
918 );
919}
920
be075caf
MH
921sub _check_valgrind {
922 return unless $ENV{PERL_VALGRIND};
923
924 my ($toolnm, $grind_ct, $test) = @_;
925
926 $$toolnm = $ENV{VALGRIND};
927 $$toolnm =~ s|.*/||; # keep basename
928 my @valgrind; # gets content of file
929 if (-e $Valgrind_Log) {
930 if (open(V, $Valgrind_Log)) {
931 @valgrind = <V>;
932 close V;
933 } else {
934 warn "$0: Failed to open '$Valgrind_Log': $!\n";
935 }
936 }
937 if ($ENV{VG_OPTS} =~ /(cachegrind)/ or $$toolnm =~ /(perf)/) {
938 $$toolnm = $1;
939 if ($$toolnm eq 'perf') {
e73fd51e 940 # append perfs subcommand, not just stat
be075caf
MH
941 my ($sub) = split /\s/, $ENV{VG_OPTS};
942 $$toolnm .= "-$sub";
943 }
944 if (rename $Valgrind_Log, "$$test.$$toolnm") {
945 $$grind_ct++;
946 } else {
947 warn "$0: Failed to create '$$test.$$toolnm': $!\n";
948 }
949 }
950 elsif (@valgrind) {
951 my $leaks = 0;
952 my $errors = 0;
953 for my $i (0..$#valgrind) {
954 local $_ = $valgrind[$i];
955 if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
956 $errors = $errors + $1; # there may be multiple error summaries
957 } elsif (/^==\d+== LEAK SUMMARY:/) {
958 for my $off (1 .. 4) {
959 if ($valgrind[$i+$off] =~
960 /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
961 $leaks = $leaks + $1;
962 }
963 }
964 }
965 }
966 if ($errors or $leaks) {
967 if (rename $Valgrind_Log, "$$test.valgrind") {
968 $$grind_ct = $$grind_ct + 1;
969 } else {
970 warn "$0: Failed to create '$$test.valgrind': $!\n";
971 }
972 }
973 } else {
974 # Quiet wasn't asked for? Something may be amiss
975 if ($ENV{VG_OPTS} && $ENV{VG_OPTS} !~ /(^|\s)(-q|--quiet)(\s|$)/) {
976 warn "No valgrind output?\n";
977 }
978 }
979 if (-e $Valgrind_Log) {
980 unlink $Valgrind_Log
981 or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
982 }
983}
984
985sub _cleanup_valgrind {
986 return unless $ENV{PERL_VALGRIND};
987
988 my ($toolnm, $grind_ct) = @_;
989 my $s = $$grind_ct == 1 ? '' : 's';
990 print "$$grind_ct valgrind report$s created.\n", ;
991 if ($$toolnm eq 'cachegrind') {
992 # cachegrind leaves a lot of cachegrind.out.$pid litter
993 # around the tree, find and delete them
994 unlink _find_files('cachegrind.out.\d+$',
995 qw ( ../t ../cpan ../ext ../dist/ ));
996 }
0d40ea5e
KW
997 elsif ($$toolnm eq 'valgrind') {
998 # Remove empty, hence non-error, output files
999 unlink grep { -z } _find_files('valgrind-current',
1000 qw ( ../t ../cpan ../ext ../dist/ ));
1001 }
be075caf
MH
1002}
1003
2722144b 1004# Generate regexps of known bad filenames / skips from Porting/deparse-skips.txt
2722144b
MH
1005
1006sub _process_deparse_config {
1007 my @deparse_failures;
1008 my @deparse_skips;
1009
10d90405 1010 my $f = $deparse_skip_file;
2722144b
MH
1011
1012 my $skips;
1013 if (!open($skips, '<', $f)) {
1014 warn "Failed to find $f: $!\n";
1015 return;
1016 }
1017
94021b25 1018 my $in;
2722144b
MH
1019 while(<$skips>) {
1020 if (/__DEPARSE_FAILURES__/) {
1021 $in = \@deparse_failures; next;
1022 } elsif (/__DEPARSE_SKIPS__/) {
1023 $in = \@deparse_skips; next;
1024 } elsif (!$in) {
1025 next;
1026 }
1027
1028 s/#.*$//; # Kill comments
1029 s/\s+$//; # And trailing whitespace
1030
1031 next unless $_;
1032
1033 push @$in, $_;
94021b25 1034 warn "WARNING: $f:$.: excluded file doesn't exist: $_\n" unless -f $_;
2722144b
MH
1035 }
1036
1037 for my $f (@deparse_failures, @deparse_skips) {
1038 if ($f =~ m|/$|) { # Dir? Skip everything below it
1039 $f = qr/\Q$f\E.*/;
1040 } else {
1041 $f = qr/\Q$f\E/;
1042 }
1043 }
1044
1045 $deparse_failures = join('|', @deparse_failures);
1046 $deparse_failures = qr/^(?:$deparse_failures)$/;
1047
1048 $deparse_skips = join('|', @deparse_skips);
1049 $deparse_skips = qr/^(?:$deparse_skips)$/;
1050}
1051
ade55ef4 1052# ex: set ts=8 sts=4 sw=4 noet: