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