This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[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
MS
21 $verbose = 1 if $1 eq 'v';
22 $with_utf= 1 if $1 eq 'utf8';
f193aa2f
MS
23 $byte_compile = 1 if $1 eq 'bytecompile';
24 $compile = 1 if $1 eq 'compile';
485988ae
RH
25 if ($1 =~ /^deparse(,.+)?$/) {
26 $deparse = 1;
27 $deparse_opts = $1;
28 }
5d9a6404 29 }
8d063cd8 30}
b326da91 31@ARGV = @argv;
8d063cd8 32
378cc40b
LW
33chdir 't' if -f 't/TEST';
34
3e6e8be7 35die "You need to run \"make test\" first to set things up.\n"
196918b0 36 unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
4633a7c4 37
7a315204 38if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
09187cb1
JH
39 unless (-x 'perl.third') {
40 unless (-x '../perl.third') {
41 die "You need to run \"make perl.third first.\n";
42 }
43 else {
44 print "Symlinking ../perl.third as perl.third...\n";
45 die "Failed to symlink: $!\n"
46 unless symlink("../perl.third", "perl.third");
47 die "Symlinked but no executable perl.third: $!\n"
48 unless -x 'perl.third';
49 }
50 }
51}
52
3fb91a5e
GS
53# check leakage for embedders
54$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
55
4633a7c4 56$ENV{EMXSHELL} = 'sh'; # For OS/2
748a9306 57
24c841ba
MS
58# Roll your own File::Find!
59use TestInit;
60use File::Spec;
61my $curdir = File::Spec->curdir;
62my $updir = File::Spec->updir;
63
64sub _find_tests {
65 my($dir) = @_;
66 opendir DIR, $dir || die "Trouble opening $dir: $!";
a1886d87 67 foreach my $f (sort { $a cmp $b } readdir DIR) {
24c841ba
MS
68 next if $f eq $curdir or $f eq $updir;
69
cc6ae9e5 70 my $fullpath = File::Spec->catfile($dir, $f);
24c841ba
MS
71
72 _find_tests($fullpath) if -d $fullpath;
cc6ae9e5 73 $fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS';
24c841ba
MS
74 push @ARGV, $fullpath if $f =~ /\.t$/;
75 }
76}
77
cc6ae9e5
CB
78sub _quote_args {
79 my ($args) = @_;
80 my $argstring = '';
81
82 foreach (split(/\s+/,$args)) {
83 # In VMS protect with doublequotes because otherwise
84 # DCL will lowercase -- unless already doublequoted.
85 $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
86 $argstring .= ' ' . $_;
87 }
88 return $argstring;
89}
90
24c841ba 91unless (@ARGV) {
9f3d340b 92 foreach my $dir (qw(base comp cmd run io op uni)) {
24c841ba
MS
93 _find_tests($dir);
94 }
5a6e071d 95 _find_tests("lib") unless $core;
cc6ae9e5 96 my $mani = File::Spec->catfile($updir, "MANIFEST");
7a315204 97 if (open(MANI, $mani)) {
80ffb5f9 98 while (<MANI>) { # similar code in t/harness
5157cb1b 99 if (m!^(ext/\S+/?([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) {
5a6e071d
PJ
100 $t = $1;
101 if (!$core || $t =~ m!^lib/[a-z]!)
102 {
cc6ae9e5 103 $path = File::Spec->catfile($updir, $t);
73ddec28
RB
104 push @ARGV, $path;
105 $name{$path} = $t;
5a6e071d 106 }
7a315204
JH
107 }
108 }
35d88760 109 close MANI;
7a315204
JH
110 } else {
111 warn "$0: cannot open $mani: $!\n";
112 }
6990bd83
A
113 _find_tests('pod') unless $core;
114 _find_tests('x2p') unless $core;
115 _find_tests('japh') unless $core;
8d063cd8
LW
116}
117
7a315204 118# Tests known to cause infinite loops for the perlcc tests.
595ae481 119# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
24c841ba 120%infinite = ();
6ee623d5 121
485988ae 122if ($deparse) {
f193aa2f
MS
123 _testprogs('deparse', '', @ARGV);
124}
125elsif( $compile || $byte_compile ) {
126 _testprogs('compile', '', @ARGV) if $compile;
127 _testprogs('compile', '-B', @ARGV) if $byte_compile;
128}
129else {
130 _testprogs('compile', '', @ARGV) if -e "../testcompile";
131 _testprogs('perl', '', @ARGV);
485988ae 132}
6ee623d5 133
bb365837
GS
134sub _testprogs {
135 $type = shift @_;
f193aa2f 136 $args = shift;
bb365837 137 @tests = @_;
6ee623d5 138
bb365837 139 print <<'EOT' if ($type eq 'compile');
7a315204 140------------------------------------------------------------------------------
6ee623d5 141TESTING COMPILER
7a315204 142------------------------------------------------------------------------------
bb365837
GS
143EOT
144
485988ae 145 print <<'EOT' if ($type eq 'deparse');
7a315204 146------------------------------------------------------------------------------
485988ae 147TESTING DEPARSER
7a315204 148------------------------------------------------------------------------------
485988ae
RH
149EOT
150
595ae481 151 $ENV{PERLCC_TIMEOUT} = 120
9636a016 152 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
ef712cf7 153
bb365837
GS
154 $bad = 0;
155 $good = 0;
156 $total = @tests;
157 $files = 0;
158 $totmax = 0;
73ddec28 159
cc6ae9e5
CB
160 foreach my $t (@tests) {
161 unless (exists $name{$t}) {
162 my $tname = File::Spec->catfile('t',$t);
163 $tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS';
164 $name{$t} = $tname;
165 }
73ddec28 166 }
908801fe 167 my $maxlen = 0;
73ddec28
RB
168 foreach (@name{@tests}) {
169 s/\.\w+\z/./;
170 my $len = length ;
171 $maxlen = $len if $len > $maxlen;
088b5126 172 }
908801fe 173 # + 3 : we want three dots between the test name and the "ok"
73ddec28 174 $dotdotdot = $maxlen + 3 ;
bb365837
GS
175 while ($test = shift @tests) {
176
177 if ( $infinite{$test} && $type eq 'compile' ) {
595ae481 178 print STDERR "$test creates infinite loop! Skipping.\n";
bb365837 179 next;
6ee623d5 180 }
bb365837
GS
181 if ($test =~ /^$/) {
182 next;
6ee623d5 183 }
485988ae
RH
184 if ($type eq 'deparse') {
185 if ($test eq "comp/redef.t") {
186 # Redefinition happens at compile time
187 next;
188 }
189 elsif ($test eq "lib/switch.t") {
190 # B::Deparse doesn't support source filtering
191 next;
192 }
193 }
cc6ae9e5
CB
194 $te = $name{$test} . '.' x ($dotdotdot - length($name{$test}));
195
196 if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
197 print $te;
198 $te = '';
199 }
bb365837 200
7a315204
JH
201 $test = $OVER{$test} if exists $OVER{$test};
202
2f6bec1d
MS
203 open(SCRIPT,"<$test") or die "Can't run $test.\n";
204 $_ = <SCRIPT>;
205 close(SCRIPT) unless ($type eq 'deparse');
6537fe72
MS
206 if (/#!.*\bperl.*-\w*([tT])/) {
207 $switch = qq{"-$1"};
2f6bec1d
MS
208 }
209 else {
210 $switch = '';
211 }
6ee623d5 212
b326da91 213 my $test_executable; # for 'compile' tests
485988ae
RH
214 my $file_opts = "";
215 if ($type eq 'deparse') {
216 # Look for #line directives which change the filename
217 while (<SCRIPT>) {
218 $file_opts .= ",-f$3$4"
219 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
220 }
221 close(SCRIPT);
222 }
7a315204 223
7a315204 224 my $utf = $with_utf ? '-I../lib -Mutf8' : '';
4343e7c3 225 my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
485988ae
RH
226 if ($type eq 'deparse') {
227 my $deparse =
228 "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,".
229 "-l$deparse_opts$file_opts ".
7a315204
JH
230 "$test > $test.dp ".
231 "&& ./perl $testswitch $switch -I../lib $test.dp |";
485988ae
RH
232 open(RESULTS, $deparse)
233 or print "can't deparse '$deparse': $!.\n";
234 }
235 elsif ($type eq 'perl') {
a7da9a42 236 my $perl = $ENV{PERL} || './perl';
cc6ae9e5
CB
237 my $redir = ($^O eq 'VMS' ? '2>&1' : '');
238 my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|";
be24517c 239 open(RESULTS,$run) or print "can't run '$run': $!.\n";
d638aca2
GS
240 }
241 else {
b326da91
MB
242 my $compile;
243 my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " .
9d2bbe64
MB
244 # -O9 for good measure, -fcog is broken ATM
245 "$switch -Wb=-O9,-fno-cog -L .. " .
b326da91
MB
246 "-I \".. ../lib/CORE\" $args $utf $test -o ";
247
248 if( $^O eq 'MSWin32' ) {
249 $test_executable = "$test.exe";
250 # hopefully unused name...
251 open HACK, "> xweghyz.pl";
252 print HACK <<EOT;
253#!./perl
254
255open HACK, '.\\perl $pl2c $test_executable |';
256# cl.exe prints the name of the .c file on stdout (\%^\$^#)
257while(<HACK>) {m/^\w+\.[cC]\$/ && next;print}
258open HACK, '$test_executable |';
259while(<HACK>) {print}
260EOT
261 close HACK;
262 $compile = 'xweghyz.pl |';
263 }
264 else {
265 $test_executable = "$test.plc";
266 $compile = "./perl $pl2c $test_executable && $test_executable |";
267 }
268 unlink $test_executable if -f $test_executable;
be24517c
JH
269 open(RESULTS, $compile)
270 or print "can't compile '$compile': $!.\n";
6ee623d5 271 }
d638aca2 272
b326da91
MB
273 $ok = 0;
274 $next = 0;
bb365837 275 while (<RESULTS>) {
cc6ae9e5 276 next if /^\s*$/; # skip blank lines
bb365837
GS
277 if ($verbose) {
278 print $_;
279 }
280 unless (/^#/) {
809908f7 281 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
bb365837 282 $max = $1;
809908f7 283 %todo = map { $_ => 1 } split / /, $3 if $3;
bb365837
GS
284 $totmax += $max;
285 $files += 1;
286 $next = 1;
287 $ok = 1;
288 }
289 else {
2fe373ce 290 if (/^(not )?ok (\d+)[^#]*(\s*#.*)?/ &&
595ae481 291 $2 == $next)
37ce32a7
MS
292 {
293 my($not, $num, $extra) = ($1, $2, $3);
294 my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
809908f7 295 $istodo = 1 if $todo{$num};
37ce32a7
MS
296
297 if( $not && !$istodo ) {
298 $ok = 0;
299 $next = $num;
300 last;
301 }
302 else {
303 $next = $next + 1;
304 }
d667a7e6
A
305 }
306 elsif (/^Bail out!\s*(.*)/i) { # magic words
307 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
bb365837
GS
308 }
309 else {
310 $ok = 0;
311 }
8d063cd8
LW
312 }
313 }
314 }
bb365837 315 close RESULTS;
485988ae
RH
316 if ($type eq 'deparse') {
317 unlink "./$test.dp";
318 }
211f317f
JH
319 if ($ENV{PERL_3LOG}) {
320 my $tpp = $test;
a7da9a42 321 $tpp =~ s:^../::;
211f317f
JH
322 $tpp =~ s:/:_:g;
323 $tpp =~ s:\.t$::;
a7da9a42
JH
324 rename("perl.3log", "perl.3log.$tpp") ||
325 die "rename: perl3.log to perl.3log.$tpp: $!\n";
211f317f 326 }
bb365837 327 $next = $next - 1;
b326da91
MB
328 # test if the compiler compiled something
329 if( $type eq 'compile' && !-e "$test_executable" ) {
330 $ok = 0;
331 print "Test did not compile\n";
332 }
333 if ($ok && $next == $max ) {
bb365837 334 if ($max) {
cc6ae9e5 335 print "${te}ok\n";
bb365837
GS
336 $good = $good + 1;
337 }
338 else {
cc6ae9e5 339 print "${te}skipping test on this platform\n";
bb365837
GS
340 $files -= 1;
341 }
bcce72a7 342 }
bb365837
GS
343 else {
344 $next += 1;
cc6ae9e5 345 print "${te}FAILED at test $next\n";
bb365837
GS
346 $bad = $bad + 1;
347 $_ = $test;
348 if (/^base/) {
349 die "Failed a basic test--cannot continue.\n";
350 }
8d063cd8
LW
351 }
352 }
8d063cd8 353
bb365837
GS
354 if ($bad == 0) {
355 if ($ok) {
356 print "All tests successful.\n";
357 # XXX add mention of 'perlbug -ok' ?
358 }
359 else {
360 die "FAILED--no tests were run for some reason.\n";
361 }
8d063cd8 362 }
bb365837 363 else {
ba1398cf 364 $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00";
bb365837 365 if ($bad == 1) {
e824fb2c 366 warn "Failed 1 test script out of $files, $pct% okay.\n";
bb365837
GS
367 }
368 else {
e824fb2c 369 warn "Failed $bad test scripts out of $files, $pct% okay.\n";
bb365837 370 }
4e4732c1 371 warn <<'SHRDLU_1';
f7d228c6
JH
372### Since not all tests were successful, you may want to run some of
373### them individually and examine any diagnostic messages they produce.
374### See the INSTALL document's section on "make test".
4e4732c1
NC
375SHRDLU_1
376 warn <<'SHRDLU_2' if $good / $total > 0.8;
f7d228c6
JH
377### You have a good chance to get more information by running
378### ./perl harness
379### in the 't' directory since most (>=80%) of the tests succeeded.
4e4732c1
NC
380SHRDLU_2
381 if (eval {require Config; import Config; 1}) {
e6af294e 382 if ($Config{usedl} && (my $p = $Config{ldlibpthname})) {
4e4732c1 383 warn <<SHRDLU_3;
f7d228c6
JH
384### You may have to set your dynamic library search path,
385### $p, to point to the build directory:
4e4732c1
NC
386SHRDLU_3
387 if (exists $ENV{$p} && $ENV{$p} ne '') {
388 warn <<SHRDLU_4a;
f7d228c6
JH
389### setenv $p `pwd`:\$$p; cd t; ./perl harness
390### $p=`pwd`:\$$p; export $p; cd t; ./perl harness
391### export $p=`pwd`:\$$p; cd t; ./perl harness
4e4732c1
NC
392SHRDLU_4a
393 } else {
394 warn <<SHRDLU_4b;
f7d228c6
JH
395### setenv $p `pwd`; cd t; ./perl harness
396### $p=`pwd`; export $p; cd t; ./perl harness
397### export $p=`pwd`; cd t; ./perl harness
4e4732c1
NC
398SHRDLU_4b
399 }
400 warn <<SHRDLU_5;
f7d228c6
JH
401### for csh-style shells, like tcsh; or for traditional/modern
402### Bourne-style shells, like bash, ksh, and zsh, respectively.
4e4732c1
NC
403SHRDLU_5
404 }
afd33fa9 405 }
bb365837
GS
406 }
407 ($user,$sys,$cuser,$csys) = times;
408 print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n",
409 $user,$sys,$cuser,$csys,$files,$totmax);
6ee623d5 410}
3e6e8be7 411exit ($bad != 0);