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