resurrect t/op/glob.t on VMS
[p5sagit/p5-mst-13.2.git] / t / TEST
CommitLineData
8d063cd8 1#!./perl
2
8d063cd8 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 6$| = 1;
7
60e23f2f 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
5d9a6404 12# Cheesy version of Getopt::Std. Maybe we should replace it with that.
13if ($#ARGV >= 0) {
14 foreach my $idx (0..$#ARGV) {
485988ae 15 next unless $ARGV[$idx] =~ /^-(\S+)$/;
5a6e071d 16 $core = 1 if $1 eq 'core';
5d9a6404 17 $verbose = 1 if $1 eq 'v';
18 $with_utf= 1 if $1 eq 'utf8';
485988ae 19 if ($1 =~ /^deparse(,.+)?$/) {
20 $deparse = 1;
21 $deparse_opts = $1;
22 }
5d9a6404 23 splice(@ARGV, $idx, 1);
24 }
8d063cd8 25}
26
378cc40b 27chdir 't' if -f 't/TEST';
28
3e6e8be7 29die "You need to run \"make test\" first to set things up.\n"
4633a7c4 30 unless -e 'perl' or -e 'perl.exe';
31
7a315204 32if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
09187cb1 33 unless (-x 'perl.third') {
34 unless (-x '../perl.third') {
35 die "You need to run \"make perl.third first.\n";
36 }
37 else {
38 print "Symlinking ../perl.third as perl.third...\n";
39 die "Failed to symlink: $!\n"
40 unless symlink("../perl.third", "perl.third");
41 die "Symlinked but no executable perl.third: $!\n"
42 unless -x 'perl.third';
43 }
44 }
45}
46
3fb91a5e 47# check leakage for embedders
48$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
49
4633a7c4 50$ENV{EMXSHELL} = 'sh'; # For OS/2
748a9306 51
24c841ba 52# Roll your own File::Find!
53use TestInit;
54use File::Spec;
55my $curdir = File::Spec->curdir;
56my $updir = File::Spec->updir;
57
58sub _find_tests {
59 my($dir) = @_;
60 opendir DIR, $dir || die "Trouble opening $dir: $!";
a1886d87 61 foreach my $f (sort { $a cmp $b } readdir DIR) {
24c841ba 62 next if $f eq $curdir or $f eq $updir;
63
64 my $fullpath = File::Spec->catdir($dir, $f);
65
66 _find_tests($fullpath) if -d $fullpath;
67 push @ARGV, $fullpath if $f =~ /\.t$/;
68 }
69}
70
71unless (@ARGV) {
5a6e071d 72 foreach my $dir (qw(base comp cmd run io op)) {
24c841ba 73 _find_tests($dir);
74 }
5a6e071d 75 _find_tests("lib") unless $core;
7a315204 76 my $mani = File::Spec->catdir($updir, "MANIFEST");
77 if (open(MANI, $mani)) {
80ffb5f9 78 while (<MANI>) { # similar code in t/harness
b695f709 79 if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) {
5a6e071d 80 $t = $1;
81 if (!$core || $t =~ m!^lib/[a-z]!)
82 {
73ddec28 83 $path = File::Spec->catdir($updir, $t);
84 push @ARGV, $path;
85 $name{$path} = $t;
5a6e071d 86 }
7a315204 87 }
88 }
89 } else {
90 warn "$0: cannot open $mani: $!\n";
91 }
b695f709 92 _find_tests('pod');
8d063cd8 93}
94
7a315204 95# Tests known to cause infinite loops for the perlcc tests.
595ae481 96# %infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
24c841ba 97%infinite = ();
6ee623d5 98
485988ae 99if ($deparse) {
100 _testprogs('deparse', @ARGV);
101} else {
102 _testprogs('perl', @ARGV);
103 _testprogs('compile', @ARGV) if (-e "../testcompile");
104}
6ee623d5 105
bb365837 106sub _testprogs {
107 $type = shift @_;
108 @tests = @_;
6ee623d5 109
bb365837 110 print <<'EOT' if ($type eq 'compile');
7a315204 111------------------------------------------------------------------------------
6ee623d5 112TESTING COMPILER
7a315204 113------------------------------------------------------------------------------
bb365837 114EOT
115
485988ae 116 print <<'EOT' if ($type eq 'deparse');
7a315204 117------------------------------------------------------------------------------
485988ae 118TESTING DEPARSER
7a315204 119------------------------------------------------------------------------------
485988ae 120EOT
121
595ae481 122 $ENV{PERLCC_TIMEOUT} = 120
9636a016 123 if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
ef712cf7 124
bb365837 125 $bad = 0;
126 $good = 0;
127 $total = @tests;
128 $files = 0;
129 $totmax = 0;
73ddec28 130
131 foreach (@tests) {
132 $name{$_} = File::Spec->catdir('t',$_) unless exists $name{$_};
133 }
908801fe 134 my $maxlen = 0;
73ddec28 135 foreach (@name{@tests}) {
136 s/\.\w+\z/./;
137 my $len = length ;
138 $maxlen = $len if $len > $maxlen;
088b5126 139 }
908801fe 140 # + 3 : we want three dots between the test name and the "ok"
73ddec28 141 $dotdotdot = $maxlen + 3 ;
bb365837 142 while ($test = shift @tests) {
143
144 if ( $infinite{$test} && $type eq 'compile' ) {
595ae481 145 print STDERR "$test creates infinite loop! Skipping.\n";
bb365837 146 next;
6ee623d5 147 }
bb365837 148 if ($test =~ /^$/) {
149 next;
6ee623d5 150 }
485988ae 151 if ($type eq 'deparse') {
152 if ($test eq "comp/redef.t") {
153 # Redefinition happens at compile time
154 next;
155 }
156 elsif ($test eq "lib/switch.t") {
157 # B::Deparse doesn't support source filtering
158 next;
159 }
160 }
73ddec28 161 $te = $name{$test};
088b5126 162 print "$te" . '.' x ($dotdotdot - length($te));
bb365837 163
7a315204 164 $test = $OVER{$test} if exists $OVER{$test};
165
d638aca2 166 open(SCRIPT,"<$test") or die "Can't run $test.\n";
167 $_ = <SCRIPT>;
485988ae 168 close(SCRIPT) unless ($type eq 'deparse');
d638aca2 169 if (/#!.*perl(.*)$/) {
170 $switch = $1;
171 if ($^O eq 'VMS') {
172 # Must protect uppercase switches with "" on command line
173 $switch =~ s/-([A-Z]\S*)/"-$1"/g;
55497cff 174 }
135863df 175 }
bb365837 176 else {
d638aca2 177 $switch = '';
178 }
6ee623d5 179
485988ae 180 my $file_opts = "";
181 if ($type eq 'deparse') {
182 # Look for #line directives which change the filename
183 while (<SCRIPT>) {
184 $file_opts .= ",-f$3$4"
185 if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
186 }
187 close(SCRIPT);
188 }
7a315204 189
7a315204 190 my $utf = $with_utf ? '-I../lib -Mutf8' : '';
4343e7c3 191 my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
485988ae 192 if ($type eq 'deparse') {
193 my $deparse =
194 "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,".
195 "-l$deparse_opts$file_opts ".
7a315204 196 "$test > $test.dp ".
197 "&& ./perl $testswitch $switch -I../lib $test.dp |";
485988ae 198 open(RESULTS, $deparse)
199 or print "can't deparse '$deparse': $!.\n";
200 }
201 elsif ($type eq 'perl') {
a7da9a42 202 my $perl = $ENV{PERL} || './perl';
203 my $run = "$perl $testswitch $switch $utf $test |";
be24517c 204 open(RESULTS,$run) or print "can't run '$run': $!.\n";
d638aca2 205 }
206 else {
be24517c 207 my $compile =
4343e7c3 208 "./perl $testswitch -I../lib ../utils/perlcc -o ".
7a315204 209 "$test.plc $utf $test ".
210 " && $test.plc |";
be24517c 211 open(RESULTS, $compile)
212 or print "can't compile '$compile': $!.\n";
7a315204 213 unlink "$test.plc";
6ee623d5 214 }
d638aca2 215
bb365837 216 $ok = 0;
217 $next = 0;
218 while (<RESULTS>) {
219 if ($verbose) {
220 print $_;
221 }
222 unless (/^#/) {
809908f7 223 if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
bb365837 224 $max = $1;
809908f7 225 %todo = map { $_ => 1 } split / /, $3 if $3;
bb365837 226 $totmax += $max;
227 $files += 1;
228 $next = 1;
229 $ok = 1;
230 }
231 else {
2fe373ce 232 if (/^(not )?ok (\d+)[^#]*(\s*#.*)?/ &&
595ae481 233 $2 == $next)
37ce32a7 234 {
235 my($not, $num, $extra) = ($1, $2, $3);
236 my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
809908f7 237 $istodo = 1 if $todo{$num};
37ce32a7 238
239 if( $not && !$istodo ) {
240 $ok = 0;
241 $next = $num;
242 last;
243 }
244 else {
245 $next = $next + 1;
246 }
d667a7e6 247 }
248 elsif (/^Bail out!\s*(.*)/i) { # magic words
249 die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
bb365837 250 }
251 else {
252 $ok = 0;
253 }
8d063cd8 254 }
255 }
256 }
bb365837 257 close RESULTS;
485988ae 258 if ($type eq 'deparse') {
259 unlink "./$test.dp";
260 }
211f317f 261 if ($ENV{PERL_3LOG}) {
262 my $tpp = $test;
a7da9a42 263 $tpp =~ s:^../::;
211f317f 264 $tpp =~ s:/:_:g;
265 $tpp =~ s:\.t$::;
a7da9a42 266 rename("perl.3log", "perl.3log.$tpp") ||
267 die "rename: perl3.log to perl.3log.$tpp: $!\n";
211f317f 268 }
bb365837 269 $next = $next - 1;
270 if ($ok && $next == $max) {
271 if ($max) {
272 print "ok\n";
273 $good = $good + 1;
274 }
275 else {
276 print "skipping test on this platform\n";
277 $files -= 1;
278 }
bcce72a7 279 }
bb365837 280 else {
281 $next += 1;
282 print "FAILED at test $next\n";
283 $bad = $bad + 1;
284 $_ = $test;
285 if (/^base/) {
286 die "Failed a basic test--cannot continue.\n";
287 }
8d063cd8 288 }
289 }
8d063cd8 290
bb365837 291 if ($bad == 0) {
292 if ($ok) {
293 print "All tests successful.\n";
294 # XXX add mention of 'perlbug -ok' ?
295 }
296 else {
297 die "FAILED--no tests were run for some reason.\n";
298 }
8d063cd8 299 }
bb365837 300 else {
ba1398cf 301 $pct = $files ? sprintf("%.2f", ($files - $bad) / $files * 100) : "0.00";
bb365837 302 if ($bad == 1) {
e824fb2c 303 warn "Failed 1 test script out of $files, $pct% okay.\n";
bb365837 304 }
305 else {
e824fb2c 306 warn "Failed $bad test scripts out of $files, $pct% okay.\n";
bb365837 307 }
4e4732c1 308 warn <<'SHRDLU_1';
e089c33f 309 ### Since not all tests were successful, you may want to run some of
310 ### them individually and examine any diagnostic messages they produce.
311 ### See the INSTALL document's section on "make test".
4e4732c1 312SHRDLU_1
313 warn <<'SHRDLU_2' if $good / $total > 0.8;
e089c33f 314 ### You have a good chance to get more information by running
595ae481 315 ### ./perl harness
e089c33f 316 ### in the 't' directory since most (>=80%) of the tests succeeded.
4e4732c1 317SHRDLU_2
318 if (eval {require Config; import Config; 1}) {
319 if (my $p = $Config{ldlibpthname}) {
320 warn <<SHRDLU_3;
e089c33f 321 ### You may have to set your dynamic library search path,
b3ec3848 322 ### $p, to point to the build directory:
4e4732c1 323SHRDLU_3
324 if (exists $ENV{$p} && $ENV{$p} ne '') {
325 warn <<SHRDLU_4a;
b3ec3848 326 ### setenv $p `pwd`:\$$p; cd t; ./perl harness
327 ### $p=`pwd`:\$$p; export $p; cd t; ./perl harness
328 ### export $p=`pwd`:\$$p; cd t; ./perl harness
4e4732c1 329SHRDLU_4a
330 } else {
331 warn <<SHRDLU_4b;
b3ec3848 332 ### setenv $p `pwd`; cd t; ./perl harness
333 ### $p=`pwd`; export $p; cd t; ./perl harness
334 ### export $p=`pwd`; cd t; ./perl harness
4e4732c1 335SHRDLU_4b
336 }
337 warn <<SHRDLU_5;
61d44243 338 ### for csh-style shells, like tcsh; or for traditional/modern
339 ### Bourne-style shells, like bash, ksh, and zsh, respectively.
4e4732c1 340SHRDLU_5
341 }
afd33fa9 342 }
bb365837 343 }
344 ($user,$sys,$cuser,$csys) = times;
345 print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n",
346 $user,$sys,$cuser,$csys,$files,$totmax);
6ee623d5 347}
3e6e8be7 348exit ($bad != 0);