-$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'"
-$ Deck/Dollar=$$END-OF-TEST$$
-# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
-# Modified for VMS 30-Sep-1994 Charles Bailey bailey@newman.upenn.edu
-#
-# This is written in a peculiar style, since we're trying to avoid
-# most of the constructs we'll be testing for.
-
-# skip those tests we know will fail entirely or cause perl to hang bacause
-# of Unixisms in the tests. (The Perl operators being tested may work fine,
-# but the tests may use other operators which don't.)
-use Config;
-use File::Spec;
-
-@compexcl=('cpp.t');
-@ioexcl=('argv.t','dup.t','pipe.t');
-@libexcl=('db-btree.t','db-hash.t','db-recno.t',
- 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
- 'io_sock.t', 'io_unix.t',
- 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t');
-
-# Note: POSIX is not part of basic build, but can be built
-# separately if you're using DECC
-# io_xs.t tests the new_tmpfile routine, which doesn't work with the
-# VAXCRTL, since the file can't be stat()d, an Perl's do_open()
-# insists on stat()ing a file descriptor before it'll use it.
-push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc';
-
-@opexcl=('die_exit.t','exec.t','fork.t','glob.t','groups.t','magic.t','stat.t');
-@exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
-foreach $file (@exclist) { $skip{$file}++; }
-
-$| = 1;
-
-@ARGV = grep($_,@ARGV); # remove empty elements due to "''p1'" syntax
-
-if (lc($ARGV[0]) eq '-v') {
- $verbose = 1;
- shift;
-}
-
-chdir 't' if -f 't/TEST';
-
-if ($ARGV[0] eq '') {
- foreach (<[-.ext...]*.t>, <[-.lib...]*.t>, <[.*]*.t>) {
- $_ = File::Spec->abs2rel($_);
- s/\[([a-z]+)/[.$1/; # hmm, abs2rel doesn't do subdirs of the cwd
- ($fname = $_) =~ s/.*\]//;
- if ($skip{"\L$fname"}) { push(@skipped,$_); }
- else { push(@ARGV,$_); }
- }
-}
-
-if (@skipped) {
- print "The following tests were skipped because they rely extensively on\n";
- print " Unixisms not compatible with the current version of perl for VMS:\n";
- print "\t",join("\n\t",@skipped),"\n\n";
-}
-
-$bad = 0;
-$good = 0;
-$total = @ARGV;
-while ($test = shift) {
- if ($test =~ /^$/) {
- next;
- }
- $te = $test;
- chop($te);
- $te .= '.' x (40 - length($te));
- open(script,"$test") || die "Can't run $test.\n";
- $_ = <script>;
- close(script);
- if (/#!..perl(.*)/) {
- $switch = $1;
- # Add "" to protect uppercase switches on command line
- $switch =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
- } else {
- $switch = '';
- }
- open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test 2>&1|") || (print "can't run.\n");
- $ok = 0;
- $next = 0;
- $pending_not = 0;
- while (<results>) {
- if ($verbose) {
- print "$te$_";
- $te = '';
- }
- unless (/^#/) {
- if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
- $max = $1;
- %todo = map { $_ => 1 } split / /, $3 if $3;
- $totmax += $max;
- $files += 1;
- $next = 1;
- $ok = 1;
- } else {
- # our 'echo' substitute produces one more \n than Unix'
- next if /^\s*$/;
-
-
- if (/^(not )?ok (\d+)[^#]*(\s*#.*)?/ &&
- $2 == $next)
- {
- my($not, $num, $extra) = ($1, $2, $3);
- my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
- $istodo = 1 if $todo{$num};
-
- if( $not && !$istodo ) {
- $ok = 0;
- $next = $num;
- last;
- }
- elsif( $pending_not ) {
- $next = $num;
- $ok = 0;
- }
- else {
- $next = $next + 1;
- }
- }
- elsif(/^not $/) {
- # VMS has this problem. It sometimes adds newlines
- # between prints. This sometimes means you get
- # "not \nok 42"
- $pending_not = 1;
- }
- elsif (/^Bail out!\s*(.*)/i) { # magic words
- die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
- }
- else {
- $ok = 0;
- }
-
- }
- }
- }
- $next = $next - 1;
- if ($ok && $next == $max) {
- if ($max) {
- print "${te}ok\n";
- $good = $good + 1;
- } else {
- print "${te}skipping test on this platform\n";
- $files -= 1;
- }
- } else {
- $next += 1;
- print "${te}FAILED on test $next\n";
- $bad = $bad + 1;
- $_ = $test;
- if (/^base/) {
- die "Failed a basic test--cannot continue.\n";
- }
- }
-}
-
-if ($bad == 0) {
- if ($ok) {
- print "All tests successful.\n";
- } else {
- die "FAILED--no tests were run for some reason.\n";
- }
-} else {
- $pct = sprintf("%.2f", $good / $total * 100);
- if ($bad == 1) {
- warn "Failed 1 test, $pct% okay.\n";
- } else {
- warn "Failed $bad/$total tests, $pct% okay.\n";
- }
-}
-($user,$sys,$cuser,$csys) = times;
-print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n",
- $user,$sys,$cuser,$csys,$files,$totmax);
-$$END-OF-TEST$$