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