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