diff options
| -rw-r--r-- | configure.com | 37 | ||||
| -rwxr-xr-x | t/op/filetest.t | 9 | ||||
| -rwxr-xr-x | t/op/taint.t | 9 | ||||
| -rw-r--r-- | t/pragma/warn/doio | 5 | ||||
| -rw-r--r-- | t/pragma/warn/mg | 4 | ||||
| -rw-r--r-- | t/pragma/warn/pp_sys | 2 | ||||
| -rw-r--r-- | t/pragma/warn/sv | 2 | ||||
| -rw-r--r-- | vms/descrip_mms.template | 2 | ||||
| -rw-r--r-- | vms/ext/vmsish.t | 2 | ||||
| -rw-r--r-- | vms/perlvms.pod | 16 | ||||
| -rw-r--r-- | vms/subconfigure.com | 88 | ||||
| -rw-r--r-- | vms/test.com | 18 | ||||
| -rw-r--r-- | vms/vms.c | 288 |
13 files changed, 362 insertions, 120 deletions
diff --git a/configure.com b/configure.com index e31d98bd65..388ba6b929 100644 --- a/configure.com +++ b/configure.com @@ -39,6 +39,7 @@ $ cat = "type" $ gcc_symbol = "gcc" $ ans = "" $ macros = "" +$ use_vmsdebug_perl = "N" $ use_debugging_perl = "Y" $ C_Compiler_Replace = "CC=" $ Thread_Live_Dangerously = "MT=" @@ -1670,6 +1671,24 @@ $ IF ans.eqs."socketshr" then has_socketshr = "T" $ endif $! $! +$! Ask if they want to build with VMS_DEBUG perl +$ echo "Perl can be built to run under the VMS debugger." +$ echo "You should only select this option if you are debugging" +$ echo "perl itself. This can be a useful feature if you are " +$ echo "embedding perl in a program." +$ echo "" +$ dflt = "N" +$ rp = "Build a VMS-DEBUG version of Perl? [''dflt'] " +$ GOSUB myread +$ if ans.eqs."" then ans = dflt +$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y") +$ THEN +$ use_vmsdebug_perl = "Y" +$ macros = macros + """__DEBUG__=1""," +$ ELSE +$ use_vmsdebug_perl = "N" +$ ENDIF +$! $! Ask if they want to build with MULTIPLICITY $ echo "The perl interpreter engine can be built in a way that makes it $ echo "possible for a program that embeds perl into it (and yep, you can @@ -1988,11 +2007,25 @@ $ ELSE $ WRITE CONFIG "$! This perl configured & administered by ''perladmin'" $ ENDIF $ WRITE CONFIG "$!" +$ prefix = prefix - "000000." $ IF F$LOCATE(".]",prefix) .EQ. F$LENGTH(prefix) THEN - prefix = prefix - "]" + ".]" $ WRITE CONFIG "$ define/translation=concealed Perl_Root ''prefix'" -$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl" -$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr.Exe" +$ write config "$ ext = "".exe""" +$ if sharedperl .eqs. "Y" +$ then +$ write config "$ if f$getsyi(""ARCH_NAME"") .nes. ""VAX"" then ext = "".AXE""" +$ endif +$ IF use_vmsdebug_perl .eqs. "Y" +$ then +$ WRITE CONFIG "$ dbgperl :== $Perl_Root:[000000]dbgPerl'ext'" +$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]ndbgPerl'ext'" +$ WRITE CONFIG "$ define dbgPerlShr Perl_Root:[000000]dbgPerlShr'ext'" +$ else +$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl'ext'" +$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr'ext'" +$ endif +$! $ IF (tzneedset) $ THEN $ WRITE CONFIG "$ define SYS$TIMEZONE_DIFFERENTIAL ''tzd'" diff --git a/t/op/filetest.t b/t/op/filetest.t index 9228b5730b..7e03c42949 100755 --- a/t/op/filetest.t +++ b/t/op/filetest.t @@ -3,6 +3,7 @@ # There are few filetest operators that are portable enough to test. # See pod/perlport.pod for details. +use Config; BEGIN { chdir 't' if -d 't'; } @@ -50,8 +51,12 @@ eval '$> = $oldeuid'; # switch uid back (may not be implemented) # this would fail for the euid 1 # (unless we have unpacked the source code as uid 1...) -print "not " unless -w 'op'; -print "ok 8\n"; +if ($Config{d_seteuid}) { + print "not " unless -w 'op'; + print "ok 8\n"; +} else { + print "ok 8 #skipped, no seteuid\n"; +} print "not " unless -x 'op'; # Hohum. Are directories -x everywhere? print "ok 9\n"; diff --git a/t/op/taint.t b/t/op/taint.t index d75bc1807a..fdd1c79b83 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -19,6 +19,13 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +BEGIN { + if ($^O eq 'VMS' && !defined($Config{d_setenv})) { + $ENV{PATH} = $ENV{PATH}; + $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; + } +} + my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; @@ -33,7 +40,7 @@ if ($Is_VMS) { } eval <<EndOfCleanup; END { - \$ENV{PATH} = ''; + \$ENV{PATH} = '' if $Config{d_setenv}; warn "# Note: logical name 'PATH' may have been deleted\n"; \@ENV{keys %old} = values %old; } diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index cd0d55831a..97f0804bfa 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -44,7 +44,8 @@ __END__ # doio.c use warning 'io' ; -open(F, "|$^X -e 1|") +open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(F); EXPECT Can't do bidirectional pipe at - line 3. ######## @@ -111,4 +112,4 @@ use warning 'io' ; exec "lskdjfalksdjfdjfkls", "abc" ; EXPECT OPTION regex -Can't exec "lskdjfalksdjfdjfkls": .+ +Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ diff --git a/t/pragma/warn/mg b/t/pragma/warn/mg index 44e7634952..14307e0de0 100644 --- a/t/pragma/warn/mg +++ b/t/pragma/warn/mg @@ -16,8 +16,8 @@ No such signal: SIGFRED at - line 3. ######## # mg.c use warning 'signal' ; -if ($^O eq 'MSWin32') { - print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; } $|=1; $SIG{"INT"} = "fred"; kill "INT",$$; diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 7588827744..8f2c255bc3 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -113,7 +113,7 @@ ghi . $= = 1 ; $- =1 ; -open STDOUT, ">/dev/null" ; +open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; write ; EXPECT page overflow at - line 13. diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index 0f1d83c2e5..f453de96d3 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -181,7 +181,7 @@ Subroutine fred redefined at - line 5. ######## # sv.c use warning 'printf' ; -open F, ">/dev/null" ; +open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; printf F "%q\n" ; my $a = sprintf "%q" ; printf F "%" ; diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index db39c7f7e6..206740890e 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -788,7 +788,7 @@ perly$(O) : perly.c, perly.h, $(h) Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t - - @[.VMS]Test.Com "$(E)" + - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)" # install ought not need a source, but it doesn't work if one's not # there. Go figure... diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index f68b3ac89c..24a9f437ef 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -115,7 +115,7 @@ else { print "ok 5\n"; } } else { print "ok 15\n"; } - if ($utcmtime - $vmsmtime + $offset > 10) { + if ($vmsmtime - $utcmtime + $offset > 10) { print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; } else { print "ok 16\n"; } diff --git a/vms/perlvms.pod b/vms/perlvms.pod index 56f66497d8..1705bf882f 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -715,17 +715,24 @@ that F<PERL_ENV_TABLES> is set up so that the logical name C<story> is found, rather than a CLI symbol or CRTL C<environ> element with the same name. -When an element of C<%ENV> is set to a non-empty string, the +When an element of C<%ENV> is set to a defined string, the corresponding definition is made in the location to which the first translation of F<PERL_ENV_TABLES> points. If this causes a logical name to be created, it is defined in supervisor mode. +(The same is done if an existing logical name was defined in +executive or kernel mode; an existing user or supervisor mode +logical name is reset to the new value.) If the value is an empty +string, the logical name's translation is defined as a single NUL +(ASCII 00) character, since a logical name cannot translate to a +zero-length string. (This restriction does not apply to CLI symbols +or CRTL C<environ> values; they are set to the empty string.) An element of the CRTL C<environ> array can be set only if your copy of Perl knows about the CRTL's C<setenv()> function. (This is present only in some versions of the DECCRTL; check C<$Config{d_setenv}> to see whether your copy of Perl was built with a CRTL that has this function.) -When an element of C<%ENV> is set to an empty string or C<undef>, +When an element of C<%ENV> is set to C<undef>, the element is looked up as if it were being read, and if it is found, it is deleted. (An item "deleted" from the CRTL C<environ> array is set to the empty string; this can only be done if your @@ -734,8 +741,9 @@ C<delete> to remove an element from C<%ENV> has a similar effect, but after the element is deleted, another attempt is made to look up the element, so an inner-mode logical name or a name in another location will replace the logical name just deleted. -It is not possible at present to define a search list logical name -via %ENV. +In either case, only the first value found searching PERL_ENV_TABLES +is altered. It is not possible at present to define a search list +logical name via %ENV. The element C<$ENV{DEFAULT}> is special: when read, it returns Perl's current default device and directory, and when set, it diff --git a/vms/subconfigure.com b/vms/subconfigure.com index 039f4dda30..d96c845a80 100644 --- a/vms/subconfigure.com +++ b/vms/subconfigure.com @@ -1,4 +1,4 @@ - $! SUBCONFIGURE.COM - build a config.sh for VMS Perl. +$! SUBCONFIGURE.COM - build a config.sh for VMS Perl. $! $! Note for folks from other platforms changing things in here: $! Fancy changes (based on compiler capabilities or VMS version or @@ -2448,6 +2448,77 @@ $ $ perl_ptrsize=line $ WRITE_RESULT "ptrsize is ''perl_ptrsize'" $! +$! +$! Check rand48 and its ilk +$! +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "int main() +$ WS "{" +$ WS "srand48(12L);" +$ WS "exit(0); +$ WS "}" +$ CS +$! copy temp.c sys$output +$! +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ ON ERROR THEN CONTINUE +$ ON WARNING THEN CONTINUE +$ 'Checkcc' temp +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp,temp.opt/opt +$ else +$ link temp +$ endif +$ teststatus = f$extract(9,1,$status) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_drand01="random()" +$ perl_randseedtype = "unsigned" +$ perl_seedfunc = "srandom" +$ ENDIF +$ OS +$ WS "#ifdef __DECC +$ WS "#include <stdlib.h> +$ WS "#endif +$ WS "#include <stdio.h> +$ WS "int main() +$ WS "{" +$ WS "srandom(12);" +$ WS "exit(0); +$ WS "}" +$ CS +$! copy temp.c sys$output +$! +$ DEFINE SYS$ERROR _NLA0: +$ DEFINE SYS$OUTPUT _NLA0: +$ ON ERROR THEN CONTINUE +$ ON WARNING THEN CONTINUE +$ 'Checkcc' temp +$ If (Needs_Opt.eqs."Yes") +$ THEN +$ link temp,temp.opt/opt +$ else +$ link temp +$ endif +$ teststatus = f$extract(9,1,$status) +$ DEASSIGN SYS$OUTPUT +$ DEASSIGN SYS$ERROR +$ if (teststatus.nes."1") +$ THEN +$ perl_drand01="(((float)rand())/((float)RAND_MAX))" +$ perl_randseedtype = "unsigned" +$ perl_seedfunc = "srand" +$ ENDIF +$ WRITE_RESULT "drand01 is ''perl_drand01'" +$! $ set nover $! Done with compiler checks. Clean up. $ if f$search("temp.c").nes."" then DELETE/NOLOG temp.c;* @@ -2645,6 +2716,14 @@ $ THEN $ perl_ccflags="/Include=[]/Obj=''perl_obj_ext'/NoList''cc_flags'" $ ENDIF $ ENDIF +$ if use_vmsdebug_perl .eqs. "Y" +$ then +$ perl_optimize="/Debug/NoOpt" +$ perl_dbgprefix = "DBG" +$ else +$ perl_optimize= "" +$ perl_dbgprefix = "" +$ endif $! $! Finally clean off any leading zeros from the patchlevel or subversion $ perl_patchlevel = perl_patchlevel + 0 @@ -2700,6 +2779,8 @@ $ WC "vms_cc_type='" + perl_vms_cc_type + "'" $ WC "d_attribut='" + perl_d_attribut + "'" $ WC "cc='" + perl_cc + "'" $ WC "ccflags='" + perl_ccflags + "'" +$ WC "optimize='" + perl_optimize + "'" +$ WC "dbgprefix='" + perl_dbgprefix + "'" $ WC "d_vms_do_sockets='" + perl_d_vms_do_sockets + "'" $ WC "d_socket='" + perl_d_socket + "'" $ WC "d_sockpair='" + perl_d_sockpair + "'" @@ -3283,7 +3364,8 @@ $ exts1 = F$Edit(p1,"Compress") $ p2 = F$Edit(p2,"Upcase,Compress,Trim") $ If F$Locate("MCR ",p2).eq.0 Then p2 = F$Extract(3,255,p2) $ miniperl = "$" + F$Search(F$Parse(p2,".Exe")) -$ mmk = p3 +$ makeutil = p3 +$ if f$type('p3') .nes. "" then makeutil = 'p3' $ targ = F$Edit(p4,"Lowercase") $ i = 0 $ next_ext: @@ -3315,7 +3397,7 @@ $ On Error Then Continue $ EndIf $ If redesc Then - miniperl "-I[''up'.lib]" Makefile.PL "INST_LIB=[''up'.lib]" "INST_ARCHLIB=[''up'.lib]" -$ mmk 'targ' +$ makeutil 'targ' $ i = i + 1 $ Set Def &def $ Goto next_ext diff --git a/vms/test.com b/vms/test.com index 15c0e8a949..039d844ea9 100644 --- a/vms/test.com +++ b/vms/test.com @@ -32,9 +32,17 @@ $ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command $ Write Sys$Error "" $ Exit 44 $ EndIf +$! +$! "debug" perl if second parameter is nonblank +$! +$ dbg = "" +$ ndbg = "" +$ if p2.nes."" then dbg = "dbg" +$ if p2.nes."" then ndbg = "ndbg" +$! $! Pick up a copy of perl to use for the tests $ Delete/Log/NoConfirm Perl.;* -$ Copy/Log/NoConfirm [-]Perl'exe' []Perl. +$ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. $ $! Make the environment look a little friendlier to tests which assume Unix $ cat = "Type" @@ -85,8 +93,8 @@ $ $! And do it $ Show Process/Accounting $ testdir = "Directory/NoHead/NoTrail/Column=1" -$ Define/User Perlshr Sys$Disk:[-]PerlShr'exe' -$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p2'" "''p3'" "''p4'" "''p5'" "''p6'" +$ Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe' +$ 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 @@ -166,6 +174,7 @@ while ($test = shift) { open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test |") || (print "can't run.\n"); $ok = 0; $next = 0; + $pending_not = 0; while (<results>) { if ($verbose) { print "$te$_"; @@ -182,7 +191,10 @@ while ($test = shift) { $next = $1, $ok = 0, last if /^not ok ([0-9]*)/; next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix' if (/^ok (.*)/ && $1 == $next) { + $next = $1, $ok=0, last if $pending_not; $next = $next + 1; + } elsif (/^not/) { + $pending_not = 1; } else { $ok = 0; } @@ -2,8 +2,8 @@ * * VMS-specific routines for perl5 * - * Last revised: 13-Sep-1998 by Charles Bailey bailey@newman.upenn.edu - * Version: 5.5.2 + * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu + * Version: 5.5.58 */ #include <acedef.h> @@ -51,6 +51,10 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* Anticipating future expansion in lexical warnings . . . */ +#ifndef WARN_INTERNAL +# define WARN_INTERNAL WARN_MISC +#endif /* gcc's header files don't #define direct access macros * corresponding to VAXC's variant structs */ @@ -153,9 +157,10 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0); if (retsts & 1) { if (eqvlen > 1024) { - if (PL_curinterp && PL_dowarn) warn("Value of CLI symbol \"%s\" too long",lnm); - eqvlen = 1024; set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); + eqvlen = 1024; + if (ckWARN(WARN_MISC)) + warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); } strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); } @@ -297,7 +302,7 @@ prime_env_iter(void) { dTHR; static int primed = 0; - HV *seenhv = NULL, *envhv = GvHVn(PL_envgv); + HV *seenhv = NULL, *envhv; char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch; unsigned short int chan; #ifndef CLI$M_TRUSTED @@ -317,9 +322,10 @@ prime_env_iter(void) MUTEX_INIT(&primenv_mutex); #endif - if (primed) return; + if (primed || !PL_envgv) return; MUTEX_LOCK(&primenv_mutex); if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } + envhv = GvHVn(PL_envgv); /* Perform a dummy fetch as an lval to insure that the hash table is * set up. Otherwise, the hv_store() will turn into a nullop. */ (void) hv_fetch(envhv,"DEFAULT",7,TRUE); @@ -342,8 +348,8 @@ prime_env_iter(void) int j; for (j = 0; environ[j]; j++) { if (!(start = strchr(environ[j],'='))) { - if (PL_curinterp && PL_dowarn) - warn("Ill-formed CRTL environ value \"%s\"\n",environ[j]); + if (ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]); } else { start++; @@ -411,8 +417,8 @@ prime_env_iter(void) } continue; } - if (sts == SS$_BUFFEROVF && PL_curinterp && PL_dowarn) - warn("Buffer overflow in prime_env_iter: %s",buf); + if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf); for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ; if (*cp1 == '(' || /* Logical name table name */ @@ -424,8 +430,8 @@ prime_env_iter(void) while (*cp2 && *cp2 != '=') cp2++; while (*cp2 && *cp2 != '"') cp2++; for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ; - if (!keylen || (cp1 - cp2 <= 0)) { - warn("Ill-formed message in prime_env_iter: |%s|",buf); + if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) { + warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf); continue; } /* Skip "" surrounding translation */ @@ -460,6 +466,7 @@ prime_env_iter(void) * vmstrnenv(). If an element is to be deleted, it's removed from * the first place it's found. If it's to be set, it's set in the * place designated by the first element of the table vector. + * Like setenv() returns 0 for success, non-zero on error. */ int vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) @@ -483,23 +490,25 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) lnmdsc.dsc$w_length = cp1 - lnm; if (!tabvec || !*tabvec) tabvec = env_tables; - if (!eqv || !*eqv) { /* we're deleting a symbol */ + if (!eqv) { /* we're deleting n element */ for (curtab = 0; tabvec[curtab]; curtab++) { if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) { int i; -#ifdef HAS_SETENV for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */ if ((cp1 = strchr(environ[i],'=')) && !strncmp(environ[i],lnm,cp1 - environ[i])) { - setenv(lnm,eqv,1); - return; +#ifdef HAS_SETENV + return setenv(lnm,eqv,1) ? vaxc$errno : 0; } } ivenv = 1; retsts = SS$_NOLOGNAM; #else - if (PL_curinterp && PL_dowarn) - warn("This Perl can't reset CRTL environ elements (%s)",lnm) - ivenv = 1; retsts = SS$_NOSUCHPGM; + if (ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm); + ivenv = 1; retsts = SS$_NOSUCHPGM; + break; + } + } #endif } else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && @@ -511,8 +520,8 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) symtype = LIB$K_CLI_LOCAL_SYM; else symtype = LIB$K_CLI_GLOBAL_SYM; retsts = lib$delete_symbol(&lnmdsc,&symtype); - if (retsts = LIB$_INVSYMNAM) { ivsym = 1; continue; } - if (retsts = LIB$_NOSUCHSYM) continue; + if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } + if (retsts == LIB$_NOSUCHSYM) continue; break; } else if (!ivlnm) { @@ -527,10 +536,10 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) else { /* we're defining a value */ if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) { #ifdef HAS_SETENV - return setenv(lnm,eqv,1) ? vaxc$errno : SS$_NORMAL; + return setenv(lnm,eqv,1) ? vaxc$errno : 0; #else - if (PL_curinterp && PL_dowarn) - warn("This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv) + if (ckWARN(WARN_INTERNAL)) + warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv); retsts = SS$_NOSUCHPGM; #endif } @@ -547,7 +556,10 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) else symtype = LIB$K_CLI_GLOBAL_SYM; retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype); } - else retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); + else { + if (!*eqv) eqvdsc.dsc$w_length = 1; + retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); + } } } if (!(retsts & 1)) { @@ -567,7 +579,15 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) set_vaxc_errno(retsts); return (int) retsts || 44; /* retsts should never be 0, but just in case */ } - else if (retsts != SS$_NORMAL) { /* alternate success codes */ + else { + /* We reset error values on success because Perl does an hv_fetch() + * before each hv_store(), and if the thing we're setting didn't + * previously exist, we've got a leftover error message. (Of course, + * this fails in the face of + * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo'; + * in that the error reported in $! isn't spurious, + * but it's right more often than not.) + */ set_errno(0); set_vaxc_errno(retsts); return 0; } @@ -855,19 +875,78 @@ static struct pipe_details *open_pipes = NULL; static $DESCRIPTOR(nl_desc, "NL:"); static int waitpid_asleep = 0; +/* Send an EOF to a mbx. N.B. We don't check that fp actually points + * to a mbx; that's the caller's responsibility. + */ +static unsigned long int +pipe_eof(FILE *fp) +{ + char devnam[NAM$C_MAXRSS+1], *cp; + unsigned long int chan, iosb[2], retsts, retsts2; + struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; + + if (fgetname(fp,devnam,1)) { + /* It oughta be a mailbox, so fgetname should give just the device + * name, but just in case . . . */ + if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; + devdsc.dsc$w_length = strlen(devnam); + _ckvmssts(sys$assign(&devdsc,&chan,0,0)); + retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); + if (retsts & 1) retsts = iosb[0]; + retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ + if (retsts & 1) retsts = retsts2; + _ckvmssts(retsts); + return retsts; + } + else _ckvmssts(vaxc$errno); /* Should never happen */ + return (unsigned long int) vaxc$errno; +} + static unsigned long int pipe_exit_routine() { + struct pipe_details *info; unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; - int sts; + int sts, did_stuff; + + /* + first we try sending an EOF...ignore if doesn't work, make sure we + don't hang + */ + did_stuff = 0; + info = open_pipes; + + while (info) { + if (info->mode != 'r' && !info->done) { + if (pipe_eof(info->fp) & 1) did_stuff = 1; + } + info = info->next; + } + if (did_stuff) sleep(1); /* wait for EOF to have an effect */ - while (open_pipes != NULL) { - if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/ - _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort)); - sleep(1); + did_stuff = 0; + info = open_pipes; + while (info) { + if (!info->done) { /* Tap them gently on the shoulder . . .*/ + sts = sys$forcex(&info->pid,0,&abort); + if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); + did_stuff = 1; } - if (!open_pipes->done) /* We tried to be nice . . . */ - _ckvmssts(sys$delprc(&open_pipes->pid,0)); + info = info->next; + } + if (did_stuff) sleep(1); /* wait for them to respond */ + + info = open_pipes; + while (info) { + if (!info->done) { /* We tried to be nice . . . */ + sts = sys$delprc(&info->pid,0); + if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); + info->done = 1; /* so my_pclose doesn't try to write EOF */ + } + info = info->next; + } + + while(open_pipes) { if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno; else if (!(sts & 1)) retsts = sts; } @@ -981,25 +1060,7 @@ I32 my_pclose(FILE *fp) /* If we were writing to a subprocess, insure that someone reading from * the mailbox gets an EOF. It looks like a simple fclose() doesn't * produce an EOF record in the mailbox. */ - if (info->mode != 'r') { - char devnam[NAM$C_MAXRSS+1], *cp; - unsigned long int chan, iosb[2], retsts, retsts2; - struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; - - if (fgetname(info->fp,devnam,1)) { - /* It oughta be a mailbox, so fgetname should give just the device - * name, but just in case . . . */ - if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; - devdsc.dsc$w_length = strlen(devnam); - _ckvmssts(sys$assign(&devdsc,&chan,0,0)); - retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0); - if (retsts & 1) retsts = iosb[0]; - retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ - if (retsts & 1) retsts = retsts2; - _ckvmssts(retsts); - } - else _ckvmssts(vaxc$errno); /* Should never happen */ - } + if (info->mode != 'r' && !info->done) pipe_eof(info->fp); PerlIO_close(info->fp); if (info->done) retsts = info->completion; @@ -1038,11 +1099,11 @@ my_waitpid(Pid_t pid, int *statusp, int flags) unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; unsigned long int interval[2],sts; - if (PL_dowarn) { + if (ckWARN(WARN_EXEC)) { _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); if (ownerpid != mypid) - warn("pid %x not a child",pid); + warner(WARN_EXEC,"pid %x not a child",pid); } _ckvmssts(sys$bintim(&intdsc,interval)); @@ -1118,7 +1179,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) struct FAB myfab = cc$rms_fab; struct NAM mynam = cc$rms_nam; STRLEN speclen; - unsigned long int retsts, haslower = 0, isunix = 0; + unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; if (!filespec || !*filespec) { set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); @@ -1187,13 +1248,37 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) if (islower(*out)) { haslower = 1; break; } if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } else { out = esa; speclen = mynam.nam$b_esl; } - if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) && - (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';'))) - speclen = mynam.nam$l_ver - out; - if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && - (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' || - defspec[myfab.fab$b_dns-2] == '.')) - speclen = mynam.nam$l_type - out; + /* Trim off null fields added by $PARSE + * If type > 1 char, must have been specified in original or default spec + * (not true for version; $SEARCH may have added version of existing file). + */ + trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER); + trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && + (mynam.nam$l_ver - mynam.nam$l_type == 1); + if (trimver || trimtype) { + if (defspec && *defspec) { + char defesa[NAM$C_MAXRSS]; + struct FAB deffab = cc$rms_fab; + struct NAM defnam = cc$rms_nam; + + deffab.fab$l_nam = &defnam; + deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns; + defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa; + defnam.nam$b_nop = NAM$M_SYNCHK; + if (sys$parse(&deffab,0,0) & 1) { + if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); + if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); + } + } + if (trimver) speclen = mynam.nam$l_ver - out; + if (trimtype) { + /* If we didn't already trim version, copy down */ + if (speclen > mynam.nam$l_ver - out) + memcpy(mynam.nam$l_type, mynam.nam$l_ver, + speclen - (mynam.nam$l_ver - out)); + speclen -= mynam.nam$l_ver - mynam.nam$l_type; + } + } /* If we just had a directory spec on input, $PARSE "helpfully" * adds an empty name and type for us */ if (mynam.nam$l_name == mynam.nam$l_type && @@ -3116,12 +3201,12 @@ seekdir(DIR *dd, long count) * in 'VMSish fashion' (i.e. not after a call to vfork) The args * are concatenated to form a DCL command string. If the first arg * begins with '$' (i.e. the perl script had "\$ Type" or some such), - * the the command string is hrnded off to DCL directly. Otherwise, + * the the command string is handed off to DCL directly. Otherwise, * the first token of the command is taken as the filespec of an image * to run. The filespec is expanded using a default type of '.EXE' and - * the process defaults for device, directory, etc., and the resultant + * the process defaults for device, directory, etc., and if found, the resultant * filespec is invoked using the DCL verb 'MCR', and passed the rest of - * the command string as parameters. This is perhaps a bit compicated, + * the command string as parameters. This is perhaps a bit complicated, * but I hope it will form a happy medium between what VMS folks expect * from lib$spawn and what Unix folks expect from exec. */ @@ -3187,8 +3272,10 @@ setup_argstr(SV *really, SV **mark, SV **sp) else *PL_Cmd = '\0'; while (++mark <= sp) { if (*mark) { - strcat(PL_Cmd," "); - strcat(PL_Cmd,SvPVx(*mark,n_a)); + char *s = SvPVx(*mark,n_a); + if (!*s) continue; + if (*PL_Cmd) strcat(PL_Cmd," "); + strcat(PL_Cmd,s); } } return PL_Cmd; @@ -3203,7 +3290,7 @@ setup_cmddsc(char *cmd, int check_img) $DESCRIPTOR(defdsc,".EXE"); $DESCRIPTOR(resdsc,resspec); struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - unsigned long int cxt = 0, flags = 1, retsts; + unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL; register char *s, *rest, *cp; register int isdcl = 0; @@ -3221,43 +3308,45 @@ setup_cmddsc(char *cmd, int check_img) } } else isdcl = 1; - if (isdcl) { /* It's a DCL command, just do it. */ - VMScmd.dsc$w_length = strlen(cmd); - if (cmd == PL_Cmd) { - VMScmd.dsc$a_pointer = PL_Cmd; - PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */ - } - else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); - } - else { /* assume first token is an image spec */ + if (!isdcl) { cmd = s; while (*s && !isspace(*s)) s++; rest = *s ? s : 0; imgdsc.dsc$a_pointer = cmd; imgdsc.dsc$w_length = s - cmd; retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); - if (!(retsts & 1)) { - /* just hand off status values likely to be due to user error */ - if (retsts == RMS$_FNF || retsts == RMS$_DNF || - retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || - (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; - else { _ckvmssts(retsts); } - } - else { + if (retsts & 1) { _ckvmssts(lib$find_file_end(&cxt)); s = resspec; while (*s && !isspace(*s)) s++; *s = '\0'; - if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV; - New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); - strcpy(VMScmd.dsc$a_pointer,"$ MCR "); - strcat(VMScmd.dsc$a_pointer,resspec); - if (rest) strcat(VMScmd.dsc$a_pointer,rest); - VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); + if (cando_by_name(S_IXUSR,0,resspec)) { + New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char); + strcpy(VMScmd.dsc$a_pointer,"$ MCR "); + strcat(VMScmd.dsc$a_pointer,resspec); + if (rest) strcat(VMScmd.dsc$a_pointer,rest); + VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); + return retsts; + } + else retsts = RMS$_PRV; } } + /* It's either a DCL command or we couldn't find a suitable image */ + VMScmd.dsc$w_length = strlen(cmd); + if (cmd == PL_Cmd) { + VMScmd.dsc$a_pointer = PL_Cmd; + PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */ + } + else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length); + if (!(retsts & 1)) { + /* just hand off status values likely to be due to user error */ + if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV || + retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN || + (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; + else { _ckvmssts(retsts); } + } - return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL); + return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts); } /* end of setup_cmddsc() */ @@ -3324,8 +3413,10 @@ vms_do_exec(char *cmd) set_errno(EVMSERR); } set_vaxc_errno(retsts); - if (PL_dowarn) - warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno)); + if (ckWARN(WARN_EXEC)) { + warner(WARN_EXEC,"Can't exec \"%*s\": %s", + VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno)); + } vms_execfree(); } @@ -3381,9 +3472,12 @@ do_spawn(char *cmd) set_errno(EVMSERR); } set_vaxc_errno(sts); - if (PL_dowarn) - warn("Can't spawn \"%s\": %s", - hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno)); + if (ckWARN(WARN_EXEC)) { + warner(WARN_EXEC,"Can't spawn \"%*s\": %s", + hadcmd ? VMScmd.dsc$w_length : 0, + hadcmd ? VMScmd.dsc$a_pointer : "", + Strerror(errno)); + } } vms_execfree(); return substs; |