This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a test.taintwarn makefile target,
[perl5.git] / t / TEST
CommitLineData
8d063cd8
LW
1#!./perl
2
8d063cd8
LW
3# This is written in a peculiar style, since we're trying to avoid
4# most of the constructs we'll be testing for.
5
a687059c
LW
6$| = 1;
7
60e23f2f
MS
8# Let tests know they're running in the perl core. Useful for modules
9# which live dual lives on CPAN.
10$ENV{PERL_CORE} = 1;
11
cc6ae9e5
CB
12# remove empty elements due to insertion of empty symbols via "''p1'" syntax
13@ARGV = grep($_,@ARGV) if $^O eq 'VMS';
14
5d9a6404 15# Cheesy version of Getopt::Std. Maybe we should replace it with that.
b326da91 16@argv = ();
5d9a6404
MS
17if ($#ARGV >= 0) {
18 foreach my $idx (0..$#ARGV) {
b326da91 19 push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
5a6e071d 20 $core = 1 if $1 eq 'core';
5d9a6404 21 $verbose = 1 if $1 eq 'v';
e018f8be 22 $torture = 1 if $1 eq 'torture';
5d9a6404 23 $with_utf= 1 if $1 eq 'utf8';
b26492ee
RGS
24 $bytecompile = 1 if $1 eq 'bytecompile';
25 $compile = 1 if $1 eq 'compile';
26 $taintwarn = 1 if $1 eq 'taintwarn';
485988ae
RH
27 if ($1 =~ /^deparse(,.+)?$/) {
28 $deparse = 1;
29 $deparse_opts = $1;
30 }
5d9a6404 31 }
8d063cd8 32}
b326da91 33@ARGV = @argv;
8d063cd8 34
378cc40b
LW
35chdir 't' if -f 't/TEST';
36
3e6e8be7 37die "You need to run \"make test\" first to set things up.\n"
196918b0 38 unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
4633a7c4 39
7a315204 40if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
09187cb1
JH
41 unless (-x 'perl.third') {
42 unless (-x '../perl.third') {
43 die "You need to run \"make perl.third first.\n";
44 }
45 else {
46 print "Symlinking ../perl.third as perl.third...\n";
47 die "Failed to symlink: $!\n"
48 unless symlink("../perl.third", "perl.third");
49 die "Symlinked but no executable perl.third: $!\n"
50 unless -x 'perl.third';
51 }
52 }
53}
54
3fb91a5e
GS
55# check leakage for embedders
56$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
57
4633a7c4 58$ENV{EMXSHELL} = 'sh'; # For OS/2
748a9306 59
24c841ba
MS
60# Roll your own File::Find!
61use TestInit;
62use File::Spec;
63my $curdir = File::Spec->curdir;
64my $updir = File::Spec->updir;
65
66sub _find_tests {
67 my($dir) = @_;
93e325a7 68 opendir DIR, $dir or die "Trouble opening $dir: $!";
a1886d87 69 foreach my $f (sort { $a cmp $b } readdir DIR) {
24c841ba
MS
70 next if $f eq $curdir or $f eq $updir;
71
cc6ae9e5 72 my $fullpath = File::Spec->catfile($dir, $f);
24c841ba
MS
73
74 _find_tests($fullpath) if -d $fullpath;
cc6ae9e5 75 $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS';
24c841ba
MS
76 push @ARGV, $fullpath if $f =~ /\.t$/;
77 }
78}
79
cc6ae9e5
CB
80sub _quote_args {
81 my ($args) = @_;
82 my $argstring = '';
83
84 foreach (split(/\s+/,$args)) {
85 # In VMS protect with doublequotes because otherwise
86 # DCL will lowercase -- unless already doublequoted.
87 $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
88 $argstring .= ' ' . $_;
89 }
90 return $argstring;
91}
92
24c841ba 93unless (@ARGV) {
9f3d340b 94 foreach my $dir (qw(base comp cmd run io op uni)) {
24c841ba
MS
95 _find_tests($dir);
96 }
5a6e071d 97 _find_tests("lib") unless $core;
cc6ae9e5 98 my $mani = File::Spec->catfile($updir, "MANIFEST");
7a315204 99 if (open(MANI, $mani)) {
80ffb5f9 100 while (<MANI>) { # similar code in t/harness
9c9537e6 101 if (m!^(ext/\S+/?(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
5a6e071d
PJ
102 $t = $1;
103 if (!$core || $t =~ m!^lib/[a-z]!)
104 {
cc6ae9e5 105 $path = File::Spec->catfile($updir, $t);
73ddec28
RB
106 push @ARGV, $path;
107 $name{$path} = $t;
5a6e071d 108 }
7a315204
JH
109 }
110 }
35d88760 111 close MANI;
7a315204
JH
112 } else {
113 warn "$0: cannot open $mani: $!\n";
114 }
e018f8be 115 unless ($core) {
d44161bf 116 _find_tests('pod');
e018f8be
JH
117 _find_tests('x2p');
118 _find_tests('japh') if $torture;
119 }
8d063cd8
LW
120}
121
7a315204 122# Tests known to cause infinite loops for the perlcc tests.
595ae481 123# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
24c841ba 124%infinite = ();
6ee623d5 125
485988ae 126if ($deparse) {
f193aa2f
MS
127 _testprogs('deparse', '', @ARGV);
128}
1df34986
AE
129elsif( $compile ) {
130 _testprogs('compile', '', @ARGV);
131}
132elsif( $bytecompile ) {
133 _testprogs('bytecompile', '', @ARGV);
f193aa2f
MS
134}
135else {
136 _testprogs('compile', '', @ARGV) if -e "../testcompile";
137 _testprogs('perl', '', @ARGV);
485988ae 138}
6ee623d5 139
bb365837
GS
140sub _testprogs {
141 $type = shift @_;
f193aa2f 142 $args = shift;
bb365837 143 @tests = @_;
6ee623d5 144
bb365837 145 print <<'EOT' if ($type eq 'compile');
7a315204 146------------------------------------------------------------------------------
6ee623d5 147TESTING COMPILER
7a315204 148------------------------------------------------------------------------------
bb365837
GS
149EOT
150
485988ae 151 print <<'EOT' if ($type eq 'deparse');
7a315204 152------------------------------------------------------------------------------
485988ae 153TESTING DEPARSER
7a315204 154------------------------------------------------------------------------------
485988ae
RH
155EOT
156
566ece03 157 print <<EOT if ($type eq 'bytecompile');
1df34986
AE
158------------------------------------------------------------------------------
159TESTING BYTECODE COMPILER
160------------------------------------------------------------------------------
161EOT
162
595ae481 163 $ENV{PERLCC_TIMEOUT} = 120
9636a016 164 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
ef712cf7 165
bb365837
GS
166 $bad = 0;
167 $good = 0;
168 $total = @tests;
169 $files = 0;
170 $totmax = 0;
73ddec28 171
cc6ae9e5
CB
172 foreach my $t (@tests) {
173 unless (exists $name{$t}) {
174 my $tname = File::Spec->catfile('t',$t);
175 $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS';
176 $name{$t} = $tname;
177 }
73ddec28 178 }
908801fe 179 my $maxlen = 0;
73ddec28
RB
180 foreach (@name{@tests}) {
181 s/\.\w+\z/./;
182 my $len = length ;
183 $maxlen = $len if $len > $maxlen;
088b5126 184 }
908801fe 185 # + 3 : we want three dots between the test name and the "ok"
73ddec28 186 $dotdotdot = $maxlen + 3 ;
7a834142 187 my $valgrind = 0;
da51b73c 188 my $valgrind_log = 'current.valgrind';
bb365837
GS
189 while ($test = shift @tests) {
190
191 if ( $infinite{$test} && $type eq 'compile' ) {
595ae481 192 print STDERR "$test creates infinite loop! Skipping.\n";
bb365837 193 next;
6ee623d5 194 }
bb365837
GS
195 if ($test =~ /^$/) {
196 next;
6ee623d5 197 }
485988ae
RH
198 if ($type eq 'deparse') {
199 if ($test eq "comp/redef.t") {
200 # Redefinition happens at compile time
201 next;
202 }
7a834142 203 elsif ($test =~ m{lib/Switch/t/}) {
485988ae
RH
204 # B::Deparse doesn't support source filtering
205 next;
206 }
207 }
cc6ae9e5
CB
208 $te = $name{$test} . '.' x ($dotdotdot - length($name{$test}));
209
210 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
211 print $te;
212 $te = '';
213 }
bb365837 214
7a315204
JH
215 $test = $OVER{$test} if exists $OVER{$test};
216
2f6bec1d
MS
217 open(SCRIPT,"<$test") or die "Can't run $test.\n";
218 $_ = <SCRIPT>;
219 close(SCRIPT) unless ($type eq 'deparse');
5dc83c40 220 if (/#!.*\bperl.*\s-\w*([tT])/) {
6537fe72 221 $switch = qq{"-$1"};
2f6bec1d
MS
222 }
223 else {
b26492ee
RGS
224 if ($taintwarn) {
225 # not all tests are expected to pass with this option
226 $switch = '"-t"';
227 }
228 else {
229 $switch = '';
230 }
2f6bec1d 231 }
6ee623d5 232
b326da91 233 my $test_executable; # for 'compile' tests
485988ae
RH
234 my $file_opts = "";
235 if ($type eq 'deparse') {
236 # Look for #line directives which change the filename
237 while (<SCRIPT>) {
238 $file_opts .= ",-f$3$4"
239 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
240 }
241 close(SCRIPT);
242 }
7a315204 243
7a315204 244 my $utf = $with_utf ? '-I../lib -Mutf8' : '';
4343e7c3 245 my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
485988ae
RH
246 if ($type eq 'deparse') {
247 my $deparse =
127212b2 248 "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,".
485988ae 249 "-l$deparse_opts$file_opts ".
7a315204
JH
250 "$test > $test.dp ".
251 "&& ./perl $testswitch $switch -I../lib $test.dp |";
485988ae
RH
252 open(RESULTS, $deparse)
253 or print "can't deparse '$deparse': $!.\n";
254 }
1df34986 255 elsif ($type eq 'bytecompile') {
c7e45529
AE
256 my ($pwd, $null);
257 if( $^O eq 'MSWin32') {
258 $pwd = `cd`;
259 $null = 'nul';
260 } else {
261 $pwd = `pwd`;
262 $null = '/dev/null';
263 }
264 chomp $pwd;
265 my $perl = $ENV{PERL} || "$pwd/perl";
266 my $bswitch = "-MO=Bytecode,-H,-TI,-s$pwd/$test,";
566ece03 267 $bswitch .= "-TF$test.plc,"
1df34986
AE
268 if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB);
269 $bswitch .= "-k,"
270 if $test =~ m(deparse|terse|ext/Storable/t/code);
1df34986
AE
271 $bswitch .= "-b,"
272 if $test =~ m(op/getpid);
273 my $bytecompile =
274 "$perl $testswitch $switch -I../lib $bswitch".
c7e45529
AE
275 "-o$test.plc $test 2>$null &&".
276 "$perl $testswitch $switch -I../lib $utf $test.plc |";
1df34986
AE
277 open(RESULTS,$bytecompile)
278 or print "can't byte-compile '$bytecompile': $!.\n";
279 }
485988ae 280 elsif ($type eq 'perl') {
a7da9a42 281 my $perl = $ENV{PERL} || './perl';
da51b73c 282 my $redir = $^O eq 'VMS' ? '2>&1' : '';
7a834142 283 if ($ENV{PERL_VALGRIND}) {
d44161bf
MHM
284 $perl = "valgrind --suppressions=perl.supp --leak-check=yes "
285 . "--leak-resolution=high --show-reachable=yes "
da51b73c
MHM
286 . "--num-callers=50 --logfile-fd=3 $perl";
287 $redir = "3>$valgrind_log";
7a834142 288 }
cc6ae9e5 289 my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|";
be24517c 290 open(RESULTS,$run) or print "can't run '$run': $!.\n";
d638aca2
GS
291 }
292 else {
b326da91
MB
293 my $compile;
294 my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " .
9d2bbe64
MB
295 # -O9 for good measure, -fcog is broken ATM
296 "$switch -Wb=-O9,-fno-cog -L .. " .
b326da91
MB
297 "-I \".. ../lib/CORE\" $args $utf $test -o ";
298
299 if( $^O eq 'MSWin32' ) {
300 $test_executable = "$test.exe";
301 # hopefully unused name...
302 open HACK, "> xweghyz.pl";
303 print HACK <<EOT;
304#!./perl
305
306open HACK, '.\\perl $pl2c $test_executable |';
307# cl.exe prints the name of the .c file on stdout (\%^\$^#)
6d73d07f 308while(<HACK>) {m/^\\w+\\.[cC]\$/ && next;print}
b326da91
MB
309open HACK, '$test_executable |';
310while(<HACK>) {print}
311EOT
312 close HACK;
313 $compile = 'xweghyz.pl |';
314 }
315 else {
316 $test_executable = "$test.plc";
317 $compile = "./perl $pl2c $test_executable && $test_executable |";
318 }
319 unlink $test_executable if -f $test_executable;
be24517c
JH
320 open(RESULTS, $compile)
321 or print "can't compile '$compile': $!.\n";
6ee623d5 322 }
d638aca2 323
b326da91
MB
324 $ok = 0;
325 $next = 0;
21c74f43
A
326 my $seen_leader = 0;
327 my $seen_ok = 0;
bb365837 328 while (<RESULTS>) {
cc6ae9e5 329 next if /^\s*$/; # skip blank lines
bb365837
GS
330 if ($verbose) {
331 print $_;
332 }
21c74f43 333 unless (/^\#/) {
809908f7 334 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
bb365837 335 $max = $1;
809908f7 336 %todo = map { $_ => 1 } split / /, $3 if $3;
bb365837
GS
337 $totmax += $max;
338 $files += 1;
21c74f43
A
339 unless ($seen_ok) {
340 $next = 1;
341 $ok = 1;
342 }
343 $seen_leader = 1;
bb365837
GS
344 }
345 else {
21c74f43
A
346 if (/^(not )?ok (\d+)[^\#]*(\s*\#.*)?/) {
347 unless ($seen_leader) {
348 unless ($seen_ok) {
349 $next = 1;
350 $ok = 1;
351 }
37ce32a7 352 }
21c74f43
A
353 $seen_ok = 1;
354 if ($2 == $next) {
355 my($not, $num, $extra) = ($1, $2, $3);
356 my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
357 $istodo = 1 if $todo{$num};
358
359 if( $not && !$istodo ) {
360 $ok = 0;
361 $next = $num;
362 last;
363 }
364 else {
365 $next = $next + 1;
366 }
37ce32a7 367 }
d667a7e6
A
368 }
369 elsif (/^Bail out!\s*(.*)/i) { # magic words
370 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
bb365837
GS
371 }
372 else {
373 $ok = 0;
374 }
8d063cd8
LW
375 }
376 }
377 }
bb365837 378 close RESULTS;
7a834142 379 if ($ENV{PERL_VALGRIND}) {
da51b73c
MHM
380 my @valgrind;
381 if (-e $valgrind_log) {
382 if (open(V, $valgrind_log)) {
383 @valgrind = <V>;
384 close V;
385 } else {
386 warn "$0: Failed to open '$valgrind_log': $!\n";
387 }
388 }
7a834142 389 if (@valgrind) {
d44161bf
MHM
390 my $leaks = 0;
391 my $errors = 0;
7a834142
JH
392 for my $i (0..$#valgrind) {
393 local $_ = $valgrind[$i];
d44161bf
MHM
394 if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
395 $errors += $1; # there may be multiple error summaries
396 } elsif (/^==\d+== LEAK SUMMARY:/) {
397 for my $off (1 .. 4) {
398 if ($valgrind[$i+$off] =~
399 /(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
400 $leaks += $1;
401 }
402 }
7a834142
JH
403 }
404 }
d44161bf 405 if ($errors or $leaks) {
da51b73c 406 if (rename $valgrind_log, "$test.valgrind") {
d44161bf
MHM
407 $valgrind++;
408 } else {
409 warn "$0: Failed to create '$test.valgrind': $!\n";
7a834142
JH
410 }
411 }
412 } else {
413 warn "No valgrind output?\n";
414 }
da51b73c
MHM
415 if (-e $valgrind_log) {
416 unlink $valgrind_log
417 or warn "$0: Failed to unlink '$valgrind_log': $!\n";
418 }
7a834142 419 }
485988ae
RH
420 if ($type eq 'deparse') {
421 unlink "./$test.dp";
422 }
211f317f
JH
423 if ($ENV{PERL_3LOG}) {
424 my $tpp = $test;
3716a21d 425 $tpp =~ s:^\.\./::;
9c54ecba 426 $tpp =~ s:/:_:g;
3716a21d
JH
427 $tpp =~ s:\.t$:.3log:;
428 rename("perl.3log", $tpp) ||
429 die "rename: perl3.log to $tpp: $!\n";
211f317f 430 }
bb365837 431 $next = $next - 1;
b326da91
MB
432 # test if the compiler compiled something
433 if( $type eq 'compile' && !-e "$test_executable" ) {
434 $ok = 0;
435 print "Test did not compile\n";
436 }
437 if ($ok && $next == $max ) {
bb365837 438 if ($max) {
cc6ae9e5 439 print "${te}ok\n";
bb365837
GS
440 $good = $good + 1;
441 }
442 else {
cc6ae9e5 443 print "${te}skipping test on this platform\n";
bb365837
GS
444 $files -= 1;
445 }
bcce72a7 446 }
bb365837
GS
447 else {
448 $next += 1;
cc6ae9e5 449 print "${te}FAILED at test $next\n";
bb365837
GS
450 $bad = $bad + 1;
451 $_ = $test;
452 if (/^base/) {
453 die "Failed a basic test--cannot continue.\n";
454 }
8d063cd8
LW
455 }
456 }
8d063cd8 457
bb365837
GS
458 if ($bad == 0) {
459 if ($ok) {
460 print "All tests successful.\n";
461 # XXX add mention of 'perlbug -ok' ?
462 }
463 else {
464 die "FAILED--no tests were run for some reason.\n";
465 }
8d063cd8 466 }
bb365837 467 else {
ba1398cf 468 $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00";
bb365837 469 if ($bad == 1) {
e824fb2c 470 warn "Failed 1 test script out of $files, $pct% okay.\n";
bb365837
GS
471 }
472 else {
e824fb2c 473 warn "Failed $bad test scripts out of $files, $pct% okay.\n";
bb365837 474 }
4e4732c1 475 warn <<'SHRDLU_1';
f7d228c6
JH
476### Since not all tests were successful, you may want to run some of
477### them individually and examine any diagnostic messages they produce.
478### See the INSTALL document's section on "make test".
4e4732c1
NC
479SHRDLU_1
480 warn <<'SHRDLU_2' if $good / $total > 0.8;
f7d228c6
JH
481### You have a good chance to get more information by running
482### ./perl harness
483### in the 't' directory since most (>=80%) of the tests succeeded.
4e4732c1
NC
484SHRDLU_2
485 if (eval {require Config; import Config; 1}) {
e6af294e 486 if ($Config{usedl} && (my $p = $Config{ldlibpthname})) {
4e4732c1 487 warn <<SHRDLU_3;
f7d228c6
JH
488### You may have to set your dynamic library search path,
489### $p, to point to the build directory:
4e4732c1
NC
490SHRDLU_3
491 if (exists $ENV{$p} && $ENV{$p} ne '') {
492 warn <<SHRDLU_4a;
f7d228c6
JH
493### setenv $p `pwd`:\$$p; cd t; ./perl harness
494### $p=`pwd`:\$$p; export $p; cd t; ./perl harness
495### export $p=`pwd`:\$$p; cd t; ./perl harness
4e4732c1
NC
496SHRDLU_4a
497 } else {
498 warn <<SHRDLU_4b;
f7d228c6
JH
499### setenv $p `pwd`; cd t; ./perl harness
500### $p=`pwd`; export $p; cd t; ./perl harness
501### export $p=`pwd`; cd t; ./perl harness
4e4732c1
NC
502SHRDLU_4b
503 }
504 warn <<SHRDLU_5;
f7d228c6
JH
505### for csh-style shells, like tcsh; or for traditional/modern
506### Bourne-style shells, like bash, ksh, and zsh, respectively.
4e4732c1
NC
507SHRDLU_5
508 }
afd33fa9 509 }
bb365837
GS
510 }
511 ($user,$sys,$cuser,$csys) = times;
512 print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n",
513 $user,$sys,$cuser,$csys,$files,$totmax);
7a834142
JH
514 if ($ENV{PERL_VALGRIND}) {
515 my $s = $valgrind == 1 ? '' : 's';
516 print "$valgrind valgrind report$s created.\n", ;
517 }
6ee623d5 518}
3e6e8be7 519exit ($bad != 0);