vms/test.com

   1 $!  Test.Com - DCL driver for perl5 regression tests
   2 $!
   3 $!  Version 1.0  30-Sep-1994
   4 $!  Charles Bailey  bailey@genetics.upenn.edu
   5 $
   6 $!  A little basic setup
   7 $   On Error Then Goto wrapup
   8 $   Set Default [.t]
   9 $
  10 $!  Pick up a copy of perl to use for the tests
  11 $   Delete/Log/NoConfirm Perl.;*
  12 $   Copy/Log/NoConfirm [-]Perl.Exe []Perl.
  13 $
  14 $!  Make the environment look a little friendlier to tests which assume Unix
  15 $   cat = "Type"
  16 $   Macro/NoDebug/Object=Echo.Obj Sys$Input
  17                 .title echo
  18                 .psect data,wrt,noexe
  19         dsc:
  20                 .word 0
  21                 .byte 14 ; DSC$K_DTYPE_T
  22                 .byte 2  ; DSC$K_CLASS_D
  23                 .long 0
  24                 .psect code,nowrt,exe
  25                 .entry  echo,^m<r2,r3>
  26                 movab   dsc,r2
  27                 pushab  (r2)
  28                 calls   #1,G^LIB$GET_FOREIGN
  29                 movl    4(r2),r3
  30                 movzwl  (r2),r0
  31                 addl2   4(r2),r0
  32                 cmpl    r3,r0
  33                 bgtru   sym.3
  34                 nop
  35         sym.1:
  36                 movb    (r3),r0
  37                 cmpb    r0,#65
  38                 blss    sym.2
  39                 cmpb    r0,#90
  40                 bgtr    sym.2
  41                 cvtbl   r0,r0
  42                 addl2   #32,r0
  43                 cvtlb   r0,(r3)
  44         sym.2:
  45                 incl    r3
  46                 movzwl  (r2),r0
  47                 addl2   4(r2),r0
  48                 cmpl    r3,r0
  49                 blequ   sym.1
  50         sym.3:
  51                 pushab  (r2)
  52                 calls   #1,G^LIB$PUT_OUTPUT
  53                 movl    #1,r0
  54                 ret
  55                 .end echo
  56 $   Link/NoTrace Echo.Obj;
  57 $   Delete/Log/NoConfirm Echo.Obj;*
  58 $   echo = "$" + F$Parse("Echo.Exe")
  59 $
  60 $!  And do it
  61 $   MCR Sys$Disk:[]Perl.
  62 $   Deck/Dollar=$$END-OF-TEST$$
  63 # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
  64 # Modified for VMS 30-Sep-1994  Charles Bailey  bailey@genetics.upenn.edu
  65 #
  66 # This is written in a peculiar style, since we're trying to avoid
  67 # most of the constructs we'll be testing for.
  68
  69 # skip those tests we know will fail entirely or cause perl to hang bacause
  70 # of Unixisms
  71 @compexcl=('cpp.t','script.t');
  72 @ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t');
  73 @libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t',
  74           'gdbm.t','ndbm.t','odbm.t','sdbm.t','posix.t','soundex.t');
  75 @opexcl=('exec.t','fork.t','glob.t','magic.t','misc.t','stat.t');
  76 @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
  77 foreach $file (@exclist) { $skip{$file}++; }
  78
  79 $| = 1;
  80
  81 #if ($ARGV[0] eq '-v') {
  82     $verbose = 1;
  83 #    shift;
  84 #}
  85
  86 chdir 't' if -f 't/TEST';
  87
  88 if ($ARGV[0] eq '') {
  89     @files = split(/[ \n]/, `\$ dir/col=1/nohead/notrail [...]*.t;`);
  90     foreach (@files) {
  91       $fname = $_;
  92       $fname =~ s/.*\]([\w\$\-]+\.T);.*/$1/;
  93       if ($skip{"\L$fname"}) { push(@skipped,$_); }
  94       else { push(@ARGV,$_); }
  95     }
  96 }
  97
  98 if (@skipped) {
  99   print "The following tests were skipped because they rely extensively on\n";
 100   print " Unixisms not compatible with the current version of perl for VMS:\n";
 101   print "\t",join("\n\t",@skipped);
 102 }
 103
 104 $bad = 0;
 105 $good = 0;
 106 $total = @ARGV;
 107 while ($test = shift) {
 108     if ($test =~ /^$/) {
 109         next;
 110     }
 111     $te = $test;
 112     chop($te);
 113     print "$te" . '.' x (15 - length($te)) . "\n";
 114         open(script,"$test") || die "Can't run $test.\n";
 115         $_ = <script>;
 116         close(script);
 117         if (/#!..perl(.*)/) {
 118             $switch = $1;
 119         } else {
 120             $switch = '';
 121         }
 122         open(results,"\$ MCR Sys\$Disk:[]Perl. $switch $test |") || (print "can't run.\n");
 123     $ok = 0;
 124     $next = 0;
 125     while (<results>) {
 126         if ($verbose) {
 127             print $_;
 128         }
 129         unless (/^#/) {
 130             if (/^1\.\.([0-9]+)/) {
 131                 $max = $1;
 132                 $totmax += $max;
 133                 $files += 1;
 134                 $next = 1;
 135                 $ok = 1;
 136             } else {
 137                 $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
 138                 next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix'
 139                 if (/^ok (.*)/ && $1 == $next) {
 140                     $next = $next + 1;
 141                 } else {
 142                     $ok = 0;
 143                 }
 144             }
 145         }
 146     }
 147     $next = $next - 1;
 148     if ($ok && $next == $max) {
 149         print "ok\n";
 150         $good = $good + 1;
 151     } else {
 152         $next += 1;
 153         print "FAILED on test $next\n";
 154         $bad = $bad + 1;
 155         $_ = $test;
 156         if (/^base/) {
 157             die "Failed a basic test--cannot continue.\n";
 158         }
 159     }
 160 }
 161
 162 if ($bad == 0) {
 163     if ($ok) {
 164         print "All tests successful.\n";
 165     } else {
 166         die "FAILED--no tests were run for some reason.\n";
 167     }
 168 } else {
 169     $pct = sprintf("%.2f", $good / $total * 100);
 170     if ($bad == 1) {
 171         warn "Failed 1 test, $pct% okay.\n";
 172     } else {
 173         warn "Failed $bad/$total tests, $pct% okay.\n";
 174     }
 175 }
 176 ($user,$sys,$cuser,$csys) = times;
 177 print sprintf("u=%g  s=%g  cu=%g  cs=%g  files=%d  tests=%d\n",
 178     $user,$sys,$cuser,$csys,$files,$totmax);
 179 $$END-OF-TEST$$
 180 $ wrapup:
 181 $   If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
 182 $   Set Default [-]
 183 $   Exit