From: John E. Malmberg Date: Fri, 31 Mar 2006 00:39:23 +0000 (-0500) Subject: [patch@27638] Enable standard stat for VMS >=8.2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cfcfe5866579858930d3348c9cd02c24cb9e9807;p=p5sagit%2Fp5-mst-13.2.git [patch@27638] Enable standard stat for VMS >=8.2 From: "John E. Malmberg" Message-id: <442CC08A.30409@qsl.net> p4raw-id: //depot/perl@27648 --- diff --git a/configure.com b/configure.com index eebc998..62e4192 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 c684e7a..d2da891 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -47,6 +47,12 @@ #include #include #include +#if __CRTL_VER >= 70000000 /* FIXME to earliest version */ +#include +#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 #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 b9595fb..e4c234f 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)