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