X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/925fd5a3f200998584b0c9f5f508f038863055cb..69de8d7df79f71970f96742185284b67d38d76c6:/vms/test.com diff --git a/vms/test.com b/vms/test.com index 5bb999d..63573f2 100644 --- a/vms/test.com +++ b/vms/test.com @@ -1,26 +1,25 @@ -$! Test.Com - DCL driver for perl5 regression tests +$! Test.Com - DCL wrapper for perl5 regression test driver +$! +$! Version 2.0 25-April-2002 Craig Berry craigberry@mac.com +$! (and many other hands in the last 7+ years) +$! The most significant difference is that we now run the external t/TEST +$! rather than keeping a separately maintained test driver embedded here. $! $! Version 1.1 4-Dec-1995 $! Charles Bailey bailey@newman.upenn.edu -$ -$! A little basic setup +$! +$! Set up error handler and save things we'll restore later. +$ On Control_Y Then Goto Control_Y_exit $ On Error Then Goto wrapup $ olddef = F$Environment("Default") $ oldmsg = F$Environment("Message") -$ If F$Search("t.dir").nes."" -$ Then -$ Set Default [.t] -$ Else -$ If F$TrnLNm("Perl_Root").nes."" -$ Then -$ Set Default Perl_Root:[t] -$ Else -$ Write Sys$Error "Can't find test directory" -$ Exit 44 -$ EndIf -$ EndIf -$ Set Message /Facility/Severity/Identification/Text -$ +$ oldpriv = F$SetPrv("NOALL") ! downgrade privs for safety +$ discard = F$SetPrv("NETMBX,TMPMBX") ! only need these to run tests +$! +$! Process arguments. P1 is the file extension of the Perl images. +$! P2, when not empty, indicates that we are testing a version of Perl built +$! for the VMS debugger. The other arguments are passed directly to t/TEST. +$! $ exe = ".Exe" $ If p1.nes."" Then exe = p1 $ If F$Extract(0,1,exe) .nes. "." @@ -30,7 +29,8 @@ $ Write Sys$Error "The first parameter passed to Test.Com must be the file t $ Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited" $ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line." $ Write Sys$Error "" -$ Exit 44 +$ $status = 44 +$ goto wrapup $ EndIf $! $! "debug" perl if second parameter is nonblank @@ -40,209 +40,63 @@ $ ndbg = "" $ if p2.nes."" then dbg = "dbg" $ if p2.nes."" then ndbg = "ndbg" $! +$! Run using "TEST." unless something else (e.g. "harness.") was specified. +$ If F$Type(PERL_TEST_DRIVER) .eqs. "" Then PERL_TEST_DRIVER == "TEST." +$! +$! Make sure we are where we need to be. +$ If F$Search("t.dir").nes."" +$ Then +$ Set Default [.t] +$ Else +$ If F$TrnLNm("Perl_Root").nes."" +$ Then +$ Set Default Perl_Root:[t] +$ Else +$ Write Sys$Error "Can't find test directory" +$ $status = 44 +$ goto wrapup +$ EndIf +$ EndIf +$! $! Pick up a copy of perl to use for the tests -$ Delete/Log/NoConfirm Perl.;* -$ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. -$ -$! Make the environment look a little friendlier to tests which assume Unix -$ cat == "Type" -$ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input - .title echo - .psect data,wrt,noexe - dsc: - .word 0 - .byte 14 ; DSC$K_DTYPE_T - .byte 2 ; DSC$K_CLASS_D - .long 0 - .psect code,nowrt,exe - .entry echo,^m - movab dsc,r2 - pushab (r2) - calls #1,G^LIB$GET_FOREIGN - movl 4(r2),r3 - movzwl (r2),r0 - addl2 4(r2),r0 - cmpl r3,r0 - bgtru sym.3 - nop - sym.1: - movb (r3),r0 - cmpb r0,#65 - blss sym.2 - cmpb r0,#90 - bgtr sym.2 - cvtbl r0,r0 - addl2 #32,r0 - cvtlb r0,(r3) - sym.2: - incl r3 - movzwl (r2),r0 - addl2 4(r2),r0 - cmpl r3,r0 - blequ sym.1 - sym.3: - pushab (r2) - calls #1,G^LIB$PUT_OUTPUT - movl #1,r0 - ret - .end echo -$ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj; -$ Delete/Log/NoConfirm Echo.Obj;* -$ echo == "$" + F$Parse("Echo.Exe") -$ +$ If F$Search("Perl''exe'").nes."" Then Delete/Log/NoConfirm Perl'exe';* +$ If PERL_TEST_DRIVER .eqs. "minitest" +$ Then +$ Copy/Log/NoConfirm [-]miniperl'exe' []Perl'exe' +$ Else +$ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl'exe' +$ EndIf +$! +$! Pick up a copy of vmspipe.com to use for the tests +$ If F$Search("VMSPIPE.COM").nes."" then Delete/Log/Noconfirm VMSPIPE.COM;* +$ Copy/Log/NoConfirm [-]VMSPIPE.COM [] +$! +$! This may be set for the C compiler in descrip.mms, but it confuses the File::Find tests +$ if f$trnlnm("sys") .nes. "" then Define sys " " +$! $! And do it +$ Set Message /NoFacility/NoSeverity/NoIdentification/NoText $ Show Process/Accounting $ testdir = "Directory/NoHead/NoTrail/Column=1" -$ Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe' -$ set message/nofacil/nosever/noiden/notext -$ 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; - -@compexcl=('cpp.t'); -@ioexcl=('argv.t','dup.t','fs.t','pipe.t','openpid.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', 'dprof.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','misc.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 (<[.*]*.t>) { - s/.*[\[.]t./[./; - ($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 (24 - length($te)); - open(script,"$test") || die "Can't run $test.\n"; - $_ =