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