home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / vms / test.com < prev    next >
Text File  |  2000-03-05  |  6KB  |  248 lines
  1. $!  Test.Com - DCL driver for perl5 regression tests
  2. $!
  3. $!  Version 1.1   4-Dec-1995
  4. $!  Charles Bailey  bailey@newman.upenn.edu
  5. $
  6. $!  A little basic setup
  7. $   On Error Then Goto wrapup
  8. $   olddef = F$Environment("Default")
  9. $   oldmsg = F$Environment("Message")
  10. $   If F$Search("t.dir").nes.""
  11. $   Then
  12. $       Set Default [.t]
  13. $   Else
  14. $       If F$TrnLNm("Perl_Root").nes.""
  15. $       Then 
  16. $           Set Default Perl_Root:[t]
  17. $       Else
  18. $           Write Sys$Error "Can't find test directory"
  19. $           Exit 44
  20. $       EndIf
  21. $   EndIf
  22. $   Set Message /Facility/Severity/Identification/Text
  23. $
  24. $   exe = ".Exe"
  25. $   If p1.nes."" Then exe = p1
  26. $   If F$Extract(0,1,exe) .nes. "."
  27. $   Then
  28. $     Write Sys$Error ""
  29. $     Write Sys$Error "The first parameter passed to Test.Com must be the file type used for the"
  30. $     Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited"
  31. $     Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line."
  32. $     Write Sys$Error ""
  33. $     Exit 44
  34. $   EndIf
  35. $!
  36. $!  "debug" perl if second parameter is nonblank
  37. $!
  38. $   dbg = ""
  39. $   ndbg = ""
  40. $   if p2.nes."" then dbg  = "dbg"
  41. $   if p2.nes."" then ndbg = "ndbg"
  42. $!
  43. $!  Pick up a copy of perl to use for the tests
  44. $   Delete/Log/NoConfirm Perl.;*
  45. $   Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl.
  46. $
  47. $!  Make the environment look a little friendlier to tests which assume Unix
  48. $   cat == "Type"
  49. $   Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
  50.         .title echo
  51.         .psect data,wrt,noexe
  52.     dsc:
  53.         .word 0
  54.         .byte 14 ; DSC$K_DTYPE_T
  55.         .byte 2  ; DSC$K_CLASS_D
  56.         .long 0
  57.         .psect code,nowrt,exe
  58.         .entry    echo,^m<r2,r3>
  59.         movab    dsc,r2
  60.         pushab    (r2)
  61.         calls    #1,G^LIB$GET_FOREIGN
  62.         movl    4(r2),r3
  63.         movzwl    (r2),r0
  64.         addl2    4(r2),r0
  65.         cmpl    r3,r0
  66.         bgtru    sym.3
  67.         nop    
  68.     sym.1:
  69.         movb    (r3),r0
  70.         cmpb    r0,#65
  71.         blss    sym.2
  72.         cmpb    r0,#90
  73.         bgtr    sym.2
  74.         cvtbl    r0,r0
  75.         addl2    #32,r0
  76.         cvtlb    r0,(r3)
  77.     sym.2:
  78.         incl    r3
  79.         movzwl    (r2),r0
  80.         addl2    4(r2),r0
  81.         cmpl    r3,r0
  82.         blequ    sym.1
  83.     sym.3:
  84.         pushab    (r2)
  85.         calls    #1,G^LIB$PUT_OUTPUT
  86.         movl    #1,r0
  87.         ret    
  88.         .end echo
  89. $   Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj;
  90. $   Delete/Log/NoConfirm Echo.Obj;*
  91. $   echo == "$" + F$Parse("Echo.Exe")
  92. $
  93. $!  And do it
  94. $   Show Process/Accounting
  95. $   testdir = "Directory/NoHead/NoTrail/Column=1"
  96. $   Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe'
  97. $   MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'"
  98. $   Deck/Dollar=$$END-OF-TEST$$
  99. # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
  100. # Modified for VMS 30-Sep-1994  Charles Bailey  bailey@newman.upenn.edu
  101. #
  102. # This is written in a peculiar style, since we're trying to avoid
  103. # most of the constructs we'll be testing for.
  104.  
  105. # skip those tests we know will fail entirely or cause perl to hang bacause
  106. # of Unixisms in the tests.  (The Perl operators being tested may work fine,
  107. # but the tests may use other operators which don't.)
  108. use Config;
  109.  
  110. @compexcl=('cpp.t');
  111. @ioexcl=('argv.t','dup.t','fs.t','pipe.t','openpid.t');
  112. @libexcl=('db-btree.t','db-hash.t','db-recno.t',
  113.           'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
  114.           'io_sock.t', 'io_unix.t',
  115.           'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t', 'dprof.t');
  116.  
  117. # Note: POSIX is not part of basic build, but can be built
  118. # separately if you're using DECC
  119. # io_xs.t tests the new_tmpfile routine, which doesn't work with the
  120. # VAXCRTL, since the file can't be stat()d, an Perl's do_open()
  121. # insists on stat()ing a file descriptor before it'll use it.
  122. push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc';
  123.  
  124. @opexcl=('die_exit.t','exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t');
  125. @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
  126. foreach $file (@exclist) { $skip{$file}++; }
  127.  
  128. $| = 1;
  129.  
  130. @ARGV = grep($_,@ARGV);  # remove empty elements due to "''p1'" syntax
  131.  
  132. if (lc($ARGV[0]) eq '-v') {
  133.     $verbose = 1;
  134.     shift;
  135. }
  136.  
  137. chdir 't' if -f 't/TEST';
  138.  
  139. if ($ARGV[0] eq '') {
  140.     foreach (<[.*]*.t>) {
  141.       s/.*[\[.]t./[./;
  142.       ($fname = $_) =~ s/.*\]//;
  143.       if ($skip{"\L$fname"}) { push(@skipped,$_); }
  144.       else { push(@ARGV,$_); }
  145.     }
  146. }
  147.  
  148. if (@skipped) {
  149.   print "The following tests were skipped because they rely extensively on\n";
  150.   print " Unixisms not compatible with the current version of perl for VMS:\n";
  151.   print "\t",join("\n\t",@skipped),"\n\n";
  152. }
  153.  
  154. $bad = 0;
  155. $good = 0;
  156. $total = @ARGV;
  157. while ($test = shift) {
  158.     if ($test =~ /^$/) {
  159.     next;
  160.     }
  161.     $te = $test;
  162.     chop($te);
  163.     $te .= '.' x (24 - length($te));
  164.     open(script,"$test") || die "Can't run $test.\n";
  165.     $_ = <script>;
  166.     close(script);
  167.     if (/#!..perl(.*)/) {
  168.         $switch = $1;
  169.         # Add "" to protect uppercase switches on command line
  170.         $switch =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
  171.     } else {
  172.         $switch = '';
  173.     }
  174.     open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test |") || (print "can't run.\n");
  175.     $ok = 0;
  176.     $next = 0;
  177.     $pending_not = 0;
  178.     while (<results>) {
  179.     if ($verbose) {
  180.         print "$te$_";
  181.         $te = '';
  182.     }
  183.     unless (/^#/) {
  184.         if (/^1\.\.([0-9]+)/) {
  185.         $max = $1;
  186.         $totmax += $max;
  187.         $files += 1;
  188.         $next = 1;
  189.         $ok = 1;
  190.         } else {
  191.         $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
  192.         next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix'
  193.         if (/^ok (.*)/ && $1 == $next) {
  194.             $next = $1, $ok=0, last if $pending_not;
  195.             $next = $next + 1;
  196.         } elsif (/^not/) {
  197.             $pending_not = 1;
  198.         } else {
  199.             $ok = 0;
  200.         }
  201.         }
  202.     }
  203.     }
  204.     $next = $next - 1;
  205.     if ($ok && $next == $max) {
  206.     if ($max) {
  207.         print "${te}ok\n";
  208.         $good = $good + 1;
  209.     } else {
  210.         print "${te}skipping test on this platform\n";
  211.         $files -= 1;
  212.     }
  213.     } else {
  214.     $next += 1;
  215.     print "${te}FAILED on test $next\n";
  216.     $bad = $bad + 1;
  217.     $_ = $test;
  218.     if (/^base/) {
  219.         die "Failed a basic test--cannot continue.\n";
  220.     }
  221.     }
  222. }
  223.  
  224. if ($bad == 0) {
  225.     if ($ok) {
  226.     print "All tests successful.\n";
  227.     } else {
  228.     die "FAILED--no tests were run for some reason.\n";
  229.     }
  230. } else {
  231.     $pct = sprintf("%.2f", $good / $total * 100);
  232.     if ($bad == 1) {
  233.     warn "Failed 1 test, $pct% okay.\n";
  234.     } else {
  235.     warn "Failed $bad/$total tests, $pct% okay.\n";
  236.     }
  237. }
  238. ($user,$sys,$cuser,$csys) = times;
  239. print sprintf("u=%g  s=%g  cu=%g  cs=%g  files=%d  tests=%d\n",
  240.     $user,$sys,$cuser,$csys,$files,$totmax);
  241. $$END-OF-TEST$$
  242. $ wrapup:
  243. $   Show Process/Accounting
  244. $   If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
  245. $   Set Default &olddef
  246. $   Set Message 'oldmsg'
  247. $   Exit
  248.