logical name translation iteration limits

From: "Craig A. Berry" <craigberry@mac.com>
Message-Id: <a0511170ab9145b5af8f9@[172.16.52.1]>

p4raw-id: //depot/perl@16770

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index eb219b7..2f1d6cf 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -2394,8 +2394,7 @@ unimplemented.  It now works as documented.
 
 The C<waitpid> emulation has been improved.  The worst bug (now fixed)
 was that a pid of -1 would cause a wildcard search of all processes on
-the system.  The most significant enhancement is that we can now
-usually get the completion status of a terminated process.
+the system.  
 
 POSIX-style signals are now emulated much better on VMS versions prior
 to 7.0.
@@ -2407,6 +2406,14 @@ File access tests now use current process privileges rather than the
 user's default privileges, which could sometimes result in a mismatch
 between reported access and actual access.
 
+There is a new C<kill> implementation based on C<sys$sigprc> that allows 
+older VMS systems (pre-7.0) to use C<kill> to send signals rather than
+simply force exit.  This implementation also allows later systems to
+call C<kill> from within a signal handler.
+
+Iterative logical name translations are now limited to 10 iterations in
+imitation of SHOW LOGICAL and other OpenVMS facilities.
+
 =item *
 
 Windows

diff --git a/vms/vms.c b/vms/vms.c
index 52ce6ef..a147bd8 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -105,6 +105,12 @@ struct itmlst_3 {
 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 
+/* OpenVMS User's Guide says at least 9 iterative translations will be performed,
+ * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
+ * the Perl facility.
+ */
+#define PERL_LNM_MAX_ITER 10
+
 #define MAX_DCL_SYMBOL              255     /* well, what *we* can set, at least*/
 #define MAX_DCL_LINE_LENGTH        (4*MAX_DCL_SYMBOL-4)
 
@@ -3007,6 +3013,7 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
     char *retspec, *cp1, *cp2, *lastdir;
     char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
+    unsigned short int trnlnm_iter_count;
 
     if (!dir || !*dir) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
@@ -3023,7 +3030,11 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
     }
     if (!strpbrk(dir+1,"/]>:")) {
       strcpy(trndir,*dir == '/' ? dir + 1: dir);
-      while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
+      trnlnm_iter_count = 0;
+      while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
+        trnlnm_iter_count++; 
+        if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
+      }
       dir = trndir;
       dirlen = strlen(dir);
     }
@@ -3329,6 +3340,7 @@ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
     static char __pathify_retbuf[NAM$C_MAXRSS+1];
     unsigned long int retlen;
     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
+    unsigned short int trnlnm_iter_count;
 
     if (!dir || !*dir) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
@@ -3337,8 +3349,11 @@ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
     if (*dir) strcpy(trndir,dir);
     else getcwd(trndir,sizeof trndir - 1);
 
+    trnlnm_iter_count = 0;
     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
           && my_trnlnm(trndir,trndir,0)) {
+      trnlnm_iter_count++; 
+      if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
       STRLEN trnlen = strlen(trndir);
 
       /* Trap simple rooted lnms, and return lnm:[000000] */
@@ -3515,6 +3530,7 @@ static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
   static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
   char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
   int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
+  unsigned short int trnlnm_iter_count;
 
   if (spec == NULL) return NULL;
   if (strlen(spec) > NAM$C_MAXRSS) return NULL;
@@ -3561,11 +3577,14 @@ static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
         if (ts) Safefree(rslt);
         return NULL;
       }
+      trnlnm_iter_count = 0;
       do {
         cp3 = tmp;
         while (*cp3 != ':' && *cp3) cp3++;
         *(cp3++) = '\0';
         if (strchr(cp3,']') != NULL) break;
+        trnlnm_iter_count++; 
+        if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
       } while (vmstrnenv(tmp,tmp,0,fildev,0));
       if (ts && !buf &&
           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
@@ -6569,7 +6588,7 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
-  unsigned short int retlen;
+  unsigned short int retlen, trnlnm_iter_count;
   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   union prvdef curprv;
   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
@@ -6585,7 +6604,11 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
   /* Make sure we expand logical names, since sys$check_access doesn't */
   if (!strpbrk(fname,"/]>:")) {
     strcpy(fileified,fname);
-    while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
+    trnlnm_iter_count = 0;
+    while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
+        trnlnm_iter_count++; 
+        if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
+    }
     fname = fileified;
   }
   if (!do_tovmsspec(fname,vmsname,1)) return FALSE;