Integrate with Sarathy.

p4raw-id: //depot/cfgperl@6140

5 files changed, 56 insertions, 52 deletions

diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm
index 2fc48530c0..c51863a4f3 100644
--- a/vms/ext/vmsish.pm
+++ b/vms/ext/vmsish.pm
@@ -44,12 +44,12 @@ default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
 
 =item C<vmsish hushed>
 
-This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR
+This suppresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR
 if Perl terminates with an error status.  This primarily effects error
-exits from things like compiler errors or "standard Perl" runtime errors,
+exits from things like Perl compiler errors or "standard Perl" runtime errors,
 where text error messages are also generated by Perl.
 
-The error exits from inside VMS.C are generally more serious, and are
+The error exits from inside the core are generally more serious, and are
 not supressed.
 
 =back
diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t
index 2a5b580bda..d63da57235 100644
--- a/vms/ext/vmsish.t
+++ b/vms/ext/vmsish.t
@@ -136,6 +136,7 @@ sub do_a_perl {
     local *P;
     open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
     print P "\$ set message/facil/sever/ident/text\n";
+    print P "\$ define/nolog/user sys\$error _nla0:\n";
     print P "\$ $Invoke_Perl @_\n";
     close P;
     my $x = `\@vmsish_test.com`;
diff --git a/vms/test.com b/vms/test.com
index bda5f7d07e..4f345cec0e 100644
--- a/vms/test.com
+++ b/vms/test.com
@@ -41,7 +41,7 @@ $   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.;*
+$   If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;*
 $   Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl.
 $
 $!  Make the environment look a little friendlier to tests which assume Unix
@@ -93,7 +93,7 @@ $
 $!  And do it
 $   Show Process/Accounting
 $   testdir = "Directory/NoHead/NoTrail/Column=1"
-$   Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe'
+$   Define '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 $
@@ -240,6 +240,7 @@ print sprintf("u=%g  s=%g  cu=%g  cs=%g  files=%d  tests=%d\n",
     $user,$sys,$cuser,$csys,$files,$totmax);
 $$END-OF-TEST$$
 $ wrapup:
+$   deassign 'dbg'Perlshr
 $   Show Process/Accounting
 $   If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
 $   Set Default &olddef
diff --git a/vms/vms.c b/vms/vms.c
index c50d828e7c..cc1184b6cf 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -732,8 +732,7 @@ my_crypt(const char *textpasswd, const char *usrname)
     usrdsc.dsc$a_pointer = usrname;
     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
       switch (sts) {
-        case SS$_NOGRPPRV:
-        case SS$_NOSYSPRV:
+        case SS$_NOGRPPRV: case SS$_NOSYSPRV:
           set_errno(EACCES);
           break;
         case RMS$_RNF:
@@ -832,15 +831,13 @@ kill_file(char *name)
     newace.myace$l_ident = oldace.myace$l_ident;
     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
       switch (aclsts) {
-        case RMS$_FNF:
-        case RMS$_DNF:
-        case RMS$_DIR:
-        case SS$_NOSUCHOBJECT:
+        case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
           set_errno(ENOENT); break;
+        case RMS$_DIR:
+          set_errno(ENOTDIR); break;
         case RMS$_DEV:
           set_errno(ENODEV); break;
-        case RMS$_SYN:
-        case SS$_INVFILFOROP:
+        case RMS$_SYN: case SS$_INVFILFOROP:
           set_errno(EINVAL); break;
         case RMS$_PRV:
           set_errno(EACCES); break;
@@ -897,6 +894,9 @@ my_mkdir(char *dir, Mode_t mode)
   STRLEN dirlen = strlen(dir);
   dTHX;
 
+  /* zero length string sometimes gives ACCVIO */
+  if (dirlen == 0) return -1;
+
   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
    * null file name/type.  However, it's commonplace under Unix,
    * so we'll allow it for a gain in portability.
@@ -1340,8 +1340,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
   retsts = sys$parse(&myfab,0,0);
   if (!(retsts & 1)) {
     mynam.nam$b_nop |= NAM$M_SYNCHK;
-    if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
-        retsts == RMS$_DEV || retsts == RMS$_DEV) {
+    if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
       retsts = sys$parse(&myfab,0,0);
       if (retsts & 1) goto expanded;
     }  
@@ -1484,7 +1483,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
     }
     dirlen = strlen(dir);
-    while (dir[dirlen-1] == '/') --dirlen;
+    while (dirlen && dir[dirlen-1] == '/') --dirlen;
     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
       strcpy(trndir,"/sys$disk/000000");
       dir = trndir;
@@ -1510,7 +1509,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
      *    ... do_fileify_dirspec("myroot",buf,1) ...
      * does something useful.
      */
-    if (!strcmp(dir+dirlen-2,".]")) {
+    if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
       dir[--dirlen] = '\0';
       dir[dirlen-1] = ']';
     }
@@ -1540,7 +1539,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
                  (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
           return do_fileify_dirspec("[-]",buf,ts);
       }
-      if (dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
+      if (dirlen && dir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
         dirlen -= 1;                 /* to last element */
         lastdir = strrchr(dir,'/');
       }
@@ -1567,7 +1566,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
         } while ((cp1 = strstr(cp1,"/.")) != NULL);
         lastdir = strrchr(dir,'/');
       }
-      else if (!strcmp(&dir[dirlen-7],"/000000")) {
+      else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
         /* Ditto for specs that end in an MFD -- let the VMS code
          * figure out whether it's a real device or a rooted logical. */
         dir[dirlen] = '/'; dir[dirlen+1] = '\0';
@@ -2687,14 +2686,13 @@ unsigned long int zero = 0, sts;
 	set_vaxc_errno(sts);
 	switch (sts)
 	    {
-	    case RMS$_FNF:
-	    case RMS$_DNF:
-	    case RMS$_DIR:
+	    case RMS$_FNF: case RMS$_DNF:
 		set_errno(ENOENT); break;
+	    case RMS$_DIR:
+		set_errno(ENOTDIR); break;
 	    case RMS$_DEV:
 		set_errno(ENODEV); break;
-	    case RMS$_FNM:
-	    case RMS$_SYN:
+	    case RMS$_FNM: case RMS$_SYN:
 		set_errno(EINVAL); break;
 	    case RMS$_PRV:
 		set_errno(EACCES); break;
@@ -3264,7 +3262,8 @@ readdir(DIR *dd)
         case RMS$_DEV:
           set_errno(ENODEV); break;
         case RMS$_DIR:
-        case RMS$_FNF:
+          set_errno(ENOTDIR); break;
+        case RMS$_FNF: case RMS$_DNF:
           set_errno(ENOENT); break;
         default:
           set_errno(EVMSERR);
@@ -3604,10 +3603,12 @@ vms_do_exec(char *cmd)
       retsts = lib$do_command(&VMScmd);
 
     switch (retsts) {
-      case RMS$_FNF:
+      case RMS$_FNF: case RMS$_DNF:
         set_errno(ENOENT); break;
-      case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
+      case RMS$_DIR:
         set_errno(ENOTDIR); break;
+      case RMS$_DEV:
+        set_errno(ENODEV); break;
       case RMS$_PRV:
         set_errno(EACCES); break;
       case RMS$_SYN:
@@ -3664,10 +3665,12 @@ do_spawn(char *cmd)
   
   if (!(sts & 1)) {
     switch (sts) {
-      case RMS$_FNF:
+      case RMS$_FNF:  case RMS$_DNF:
         set_errno(ENOENT); break;
-      case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
+      case RMS$_DIR:
         set_errno(ENOTDIR); break;
+      case RMS$_DEV:
+        set_errno(ENODEV); break;
       case RMS$_PRV:
         set_errno(EACCES); break;
       case RMS$_SYN:
@@ -4645,26 +4648,14 @@ cando_by_name(I32 bit, Uid_t effective, char *fname)
   }
 
   switch (bit) {
-    case S_IXUSR:
-    case S_IXGRP:
-    case S_IXOTH:
-      access = ARM$M_EXECUTE;
-      break;
-    case S_IRUSR:
-    case S_IRGRP:
-    case S_IROTH:
-      access = ARM$M_READ;
-      break;
-    case S_IWUSR:
-    case S_IWGRP:
-    case S_IWOTH:
-      access = ARM$M_WRITE;
-      break;
-    case S_IDUSR:
-    case S_IDGRP:
-    case S_IDOTH:
-      access = ARM$M_DELETE;
-      break;
+    case S_IXUSR: case S_IXGRP: case S_IXOTH:
+      access = ARM$M_EXECUTE; break;
+    case S_IRUSR: case S_IRGRP: case S_IROTH:
+      access = ARM$M_READ; break;
+    case S_IWUSR: case S_IWGRP: case S_IWOTH:
+      access = ARM$M_WRITE; break;
+    case S_IDUSR: case S_IDGRP: case S_IDOTH:
+      access = ARM$M_DELETE; break;
     default:
       return FALSE;
   }
@@ -4695,6 +4686,12 @@ cando_by_name(I32 bit, Uid_t effective, char *fname)
   if (retsts == SS$_ACCONFLICT) {
     return TRUE;
   }
+
+#if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 &&  defined(__DECC_VER) && __DECC_VER == 6009001
+  /* XXX Hideous kluge to accomodate error in specific version of RTL;
+     we hope it'll be buried soon */
+  if (retsts == 114762) return TRUE;
+#endif
   _ckvmssts(retsts);
 
   return FALSE;  /* Should never get here */
@@ -4885,9 +4882,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
     if (!((sts = sys$open(&fab_in)) & 1)) {
       set_vaxc_errno(sts);
       switch (sts) {
-        case RMS$_FNF:
-        case RMS$_DIR:
+        case RMS$_FNF: case RMS$_DNF:
           set_errno(ENOENT); break;
+        case RMS$_DIR:
+          set_errno(ENOTDIR); break;
         case RMS$_DEV:
           set_errno(ENODEV); break;
         case RMS$_SYN:
@@ -4929,8 +4927,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
     if (!((sts = sys$create(&fab_out)) & 1)) {
       set_vaxc_errno(sts);
       switch (sts) {
-        case RMS$_DIR:
+        case RMS$_DNF:
           set_errno(ENOENT); break;
+        case RMS$_DIR:
+          set_errno(ENOTDIR); break;
         case RMS$_DEV:
           set_errno(ENODEV); break;
         case RMS$_SYN:
diff --git a/vms/vmsish.h b/vms/vmsish.h
index c21f8f329e..a181e7c3d9 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -254,6 +254,8 @@
 
 #ifdef VMS_DO_SOCKETS
 #include "sockadapt.h"
+#define PERL_SOCK_SYSREAD_IS_RECV
+#define PERL_SOCK_SYSWRITE_IS_SEND
 #endif
 
 #define BIT_BUCKET "_NLA0:"