applied suggested patch, modulo already applied parts

	Message-id: <01JAF9UAV9XG002O0W@mail.newman.upenn.edu>
	Subject: [Patch 5.005_56] VMS consolidated patch #2

p4raw-id: //depot/perl@3357

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;
 		}
diff --git a/vms/vms.c b/vms/vms.c
index 3e1bc3be3c..1212555d04 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -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;