[patch@27638] Enable standard stat for VMS >=8.2

	From: "John E. Malmberg" <wb8tyw@qsl.net>
	Message-id: <442CC08A.30409@qsl.net>

p4raw-id: //depot/perl@27648

3 files changed, 107 insertions, 29 deletions

diff --git a/configure.com b/configure.com
index eebc998f32..62e4192efb 100644
--- a/configure.com
+++ b/configure.com
@@ -50,6 +50,7 @@ $ use_vmsdebug_perl = "n"
 $ use64bitall = "n"
 $ use64bitint = "n"
 $ uselargefiles = "n"
+$ usestdstat = "n"
 $ usesitecustomize = "n"
 $ C_Compiler_Replace = "CC="
 $ thread_upcalls = "MTU="
@@ -4872,6 +4873,8 @@ $  ENDIF
 $!
 $  IF uselargefiles .OR. uselargefiles .eqs. "define"
 $  THEN
+$    echo4 "Largefile support enabled (plus standard stat support on V8.2 and later)"
+$    usestdstat = "y"
 $    IF (vms_ver .GES. "8.2") .AND. (archname .NES. "VMS_VAX")
 $    THEN
 $      echo4 -
@@ -5616,13 +5619,12 @@ $ WC "cccdlflags='" + cccdlflags + "'"
 $ WC "ccdlflags='" + ccdlflags + "'"
 $ IF uselargefiles .OR. uselargefiles .EQS. "define"
 $ THEN
-$!    Perl can not use _USE_STD_STAT at the moment
-$!    IF d_symlink .OR. d_symlink .EQS. "define"
-$!    THEN
-$!	ccdefines = "_USE_STD_STAT=1"
-$!    ELSE
+$    IF usestdstat .OR. usestdstat .EQS. "define"
+$    THEN
+$	ccdefines = "_USE_STD_STAT=1"
+$    ELSE
 $	ccdefines = "_LARGEFILE=1"
-$!    ENDIF
+$    ENDIF
 $ ELSE
 $     ccdefines = ""
 $ ENDIF
@@ -6653,13 +6655,12 @@ $   MALLOC_REPLACE = "MALLOC="
 $ ENDIF
 $ IF uselargefiles .OR. uselargefiles .EQS. "define"
 $ THEN
-$!    Perl can not use _USE_STD_STAT at the moment
-$!   IF d_symlink .or. d_symlink .eqs. "define"
-$!   THEN
-$!      LARGEFILE_REPLACE = "LARGEFILE=LARGEFILE=_USE_STD_STAT=1"
-$!   ELSE
+$   IF usestdstat .or. usestdstat .eqs. "define"
+$   THEN
+$      LARGEFILE_REPLACE = "LARGEFILE=LARGEFILE=_USE_STD_STAT=1"
+$   ELSE
 $      LARGEFILE_REPLACE = "LARGEFILE=LARGEFILE=_LARGEFILE=1"
-$!   ENDIF
+$   ENDIF
 $ ELSE
 $   LARGEFILE_REPLACE = "LARGEFILE="
 $ ENDIF
diff --git a/vms/vms.c b/vms/vms.c
index c684e7a753..d2da89109a 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -47,6 +47,12 @@
 #include <uicdef.h>
 #include <stsdef.h>
 #include <rmsdef.h>
+#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
+#include <efndef.h>
+#define NO_EFN EFN$C_ENF
+#else
+#define NO_EFN 0;
+#endif
 
 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
 int   decc$feature_get_index(const char *name);
@@ -57,6 +63,32 @@ int   decc$feature_set_value(int index, int mode, int value);
 #include <unixlib.h>
 #endif
 
+#pragma member_alignment save
+#pragma nomember_alignment longword
+struct item_list_3 {
+	unsigned short len;
+	unsigned short code;
+	void * bufadr;
+	unsigned short * retadr;
+};
+#pragma member_alignment restore
+
+/* More specific prototype than in starlet_c.h makes programming errors
+   more visible.
+ */
+#ifdef sys$getdviw
+#undef sys$getdviw
+#endif
+int sys$getdviw
+       (unsigned long efn,
+	unsigned short chan,
+	const struct dsc$descriptor_s * devnam,
+	const struct item_list_3 * itmlst,
+	void * iosb,
+	void * (astadr)(unsigned long),
+	void * astprm,
+	void * nullarg);
+
 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 
 static int set_feature_default(const char *name, int value)
@@ -3068,14 +3100,43 @@ pipe_mbxtofd_setup(pTHX_ int fd, char *out)
     /* things like terminals and mbx's don't need this filter */
     if (fd && fstat(fd,&s) == 0) {
         unsigned long dviitm = DVI$_DEVCHAR, devchar;
-        struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
-                                         DSC$K_CLASS_S, s.st_dev};
-
-        _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
-        if (!(devchar & DEV$M_DIR)) {  /* non directory structured...*/
-            strcpy(out, s.st_dev);
-            return 0;
-        }
+	char device[65];
+	unsigned short dev_len;
+	struct dsc$descriptor_s d_dev;
+	char * cptr;
+	struct item_list_3 items[3];
+	int status;
+	unsigned short dvi_iosb[4];
+
+	cptr = getname(fd, out, 1);
+	if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
+	d_dev.dsc$a_pointer = out;
+	d_dev.dsc$w_length = strlen(out);
+	d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
+	d_dev.dsc$b_class = DSC$K_CLASS_S;
+
+	items[0].len = 4;
+	items[0].code = DVI$_DEVCHAR;
+	items[0].bufadr = &devchar;
+	items[0].retadr = NULL;
+	items[1].len = 64;
+	items[1].code = DVI$_FULLDEVNAM;
+	items[1].bufadr = device;
+	items[1].retadr = &dev_len;
+	items[2].len = 0;
+	items[2].code = 0;
+
+	status = sys$getdviw
+	        (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
+	_ckvmssts(status);
+	if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
+	    device[dev_len] = 0;
+
+	    if (!(devchar & DEV$M_DIR)) {
+		strcpy(out, device);
+		return 0;
+	    }
+	}
     }
 
     _ckvmssts(lib$get_vm(&n, &p));
@@ -3418,7 +3479,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
     unsigned int table = LIB$K_CLI_LOCAL_SYM;
     int j, wait = 0, n;
     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
-    char in[512], out[512], err[512], mbx[512];
+    char *in, *out, *err, mbx[512];
     FILE *tpipe = 0;
     char tfilebuf[NAM$C_MAXRSS+1];
     pInfo info = NULL;
@@ -3525,6 +3586,14 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
     info->in_done    = TRUE;
     info->out_done   = TRUE;
     info->err_done   = TRUE;
+
+    in = PerlMem_malloc(VMS_MAXRSS);
+    if (in == NULL) _ckvmssts(SS$_INSFMEM);
+    out = PerlMem_malloc(VMS_MAXRSS);
+    if (out == NULL) _ckvmssts(SS$_INSFMEM);
+    err = PerlMem_malloc(VMS_MAXRSS);
+    if (err == NULL) _ckvmssts(SS$_INSFMEM);
+
     in[0] = out[0] = err[0] = '\0';
 
     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
@@ -3670,6 +3739,11 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
     d_symbol.dsc$w_length = strlen(symbol);
     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
 
+    /* Done with the names for the pipes */
+    PerlMem_free(err);
+    PerlMem_free(out);
+    PerlMem_free(in);
+
     p = vmscmd->dsc$a_pointer;
     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
     if (*p == '$') p++;                         /* remove leading $ */
@@ -9942,6 +10016,11 @@ static mydev_t encode_dev (pTHX_ const char *dev)
   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
 
 }  /* end of encode_dev() */
+#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
+	device_no = encode_dev(aTHX_ devname)
+#else
+#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
+	device_no = new_dev_no
 #endif
 
 static int
@@ -10127,9 +10206,8 @@ Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
     PerlMem_free(vms_filename);
 
     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
-#ifndef _USE_STD_STAT
-    statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
-#endif
+    VMS_DEVICE_ENCODE
+	(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
 
 #   ifdef RTL_USES_UTC
 #   ifdef VMSISH_TIME
@@ -10186,7 +10264,7 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
     if (decc_bug_devnull != 0) {
       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
 	memset(statbufp,0,sizeof *statbufp);
-	statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
+        VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
 	statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
 	statbufp->st_uid = 0x00010001;
 	statbufp->st_gid = 0x0001;
@@ -10240,9 +10318,8 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
 	statbufp->st_devnam[0] = 0;
 
       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
-#ifndef _USE_STD_STAT
-      statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
-#endif
+      VMS_DEVICE_ENCODE
+	(statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
 #     ifdef RTL_USES_UTC
 #     ifdef VMSISH_TIME
       if (VMSISH_TIME) {
diff --git a/vms/vmsish.h b/vms/vmsish.h
index b9595fb284..e4c234f886 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -717,7 +717,7 @@ struct mystat
 
 #ifdef _USE_STD_STAT
 #define VMS_INO_T_COMPARE(__a, __b) (__a != __b)
-#define VMS_INO_T_COPY(__a, __b) a = b
+#define VMS_INO_T_COPY(__a, __b) __a = __b
 #else
 #define VMS_INO_T_COMPARE(__a, __b) memcmp(&__a, &__b, 6)
 #define VMS_INO_T_COPY(__a, __b) memcpy(&__a, &__b, 6)