assorted help for older VMS systems

   From: "Craig A. Berry" <craigberry@mac.com>
   Message-Id: <a05111b05b92ec91d165b@[172.16.52.1]>
p4raw-link: @17206 on //depot/perl: c5d9854390e492eb0f0360555ff8df0dad92cc9c

p4raw-id: //depot/perl@17227

diff --git a/configure.com b/configure.com
index ebe69af..d949bb2 100644 (file)
--- a/configure.com
+++ b/configure.com
@@ -4730,7 +4730,12 @@ $   d_wctomb="define"
 $   i_locale="define"
 $   i_langinfo="define"
 $   d_locconv="define"
-$   d_nl_langinfo="define"
+$   IF vms_ver .GES. "6.2"
+$   THEN
+$     d_nl_langinfo="define"
+$   ELSE
+$     d_nl_langinfo="undef"
+$   ENDIF
 $   d_setlocale="define"
 $   vms_cc_type="decc"
 $ ELSE

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 14e330b..726eecf 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -2580,7 +2580,8 @@ functionality and better error handling. [561]
 
 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.
+between reported access and actual access.  This improvement is only
+available on VMS v6.0 and later.
 
 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

diff --git a/pp_pack.c b/pp_pack.c
index d3fd37a..486c4f7 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2101,7 +2101,18 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                     afloat = _float_constants[0];   /* single prec. inf. */
                else afloat = (float)SvNV(fromstr);
 #else
+# if defined(VMS) && !defined(__IEEE_FP)
+/* IEEE fp overflow shenanigans are unavailable on VAX and optional
+ * on Alpha; fake it if we don't have them.
+ */
+               if (SvNV(fromstr) > FLT_MAX)
+                    afloat = FLT_MAX;
+               else if (SvNV(fromstr) < -FLT_MAX)
+                    afloat = -FLT_MAX;
+               else afloat = (float)SvNV(fromstr);
+# else
                afloat = (float)SvNV(fromstr);
+# endif
 #endif
                sv_catpvn(cat, (char *)&afloat, sizeof (float));
            }
@@ -2122,7 +2133,18 @@ Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beg
                     adouble = _double_constants[0];   /* double prec. inf. */
                else adouble = (double)SvNV(fromstr);
 #else
+# if defined(VMS) && !defined(__IEEE_FP)
+/* IEEE fp overflow shenanigans are unavailable on VAX and optional
+ * on Alpha; fake it if we don't have them.
+ */
+               if (SvNV(fromstr) > DBL_MAX)
+                    adouble = DBL_MAX;
+               else if (SvNV(fromstr) < -DBL_MAX)
+                    adouble = -DBL_MAX;
+               else adouble = (double)SvNV(fromstr);
+# else
                adouble = (double)SvNV(fromstr);
+# endif
 #endif
                sv_catpvn(cat, (char *)&adouble, sizeof (double));
            }

diff --git a/vms/vms.c b/vms/vms.c
index a147bd8..f0e4121 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -3341,6 +3341,7 @@ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
     unsigned long int retlen;
     char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
     unsigned short int trnlnm_iter_count;
+    STRLEN trnlen;
 
     if (!dir || !*dir) {
       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
@@ -3354,7 +3355,7 @@ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
           && my_trnlnm(trndir,trndir,0)) {
       trnlnm_iter_count++; 
       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
-      STRLEN trnlen = strlen(trndir);
+      trnlen = strlen(trndir);
 
       /* Trap simple rooted lnms, and return lnm:[000000] */
       if (!strcmp(trndir+trnlen-2,".]")) {
@@ -6636,13 +6637,17 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
 
   /* Before we call $check_access, create a user profile with the current
    * process privs since otherwise it just uses the default privs from the
-   * UAF and might give false positives or negatives.
+   * UAF and might give false positives or negatives.  This only works on
+   * VMS versions v6.0 and later since that's when sys$create_user_profile
+   * became available.
    */
 
   /* get current process privs and username */
   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
   _ckvmssts(iosb[0]);
 
+#if defined(__VMS_VER) && __VMS_VER >= 60000000
+
   /* find out the space required for the profile */
   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
                                     &usrprodsc.dsc$w_length,0));
@@ -6656,6 +6661,13 @@ Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
   Safefree(usrprodsc.dsc$a_pointer);
   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
+
+#else
+
+  retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+
+#endif
+
   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {