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