* 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
*/
-#include <accdef.h>
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
/* 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)
+
static char *__mystrtolower(char *str)
{
if (str) for (; *str; ++str) *str= tolower(*str);
/* munching */
static int no_translate_barewords;
-/* Temp for subprocess commands */
-static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
-
#ifndef RTL_USES_UTC
static int tz_updated = 1;
#endif
+/* my_maxidx
+ * Routine to retrieve the maximum equivalence index for an input
+ * logical name. Some calls to this routine have no knowledge if
+ * the variable is a logical or not. So on error we return a max
+ * index of zero.
+ */
+/*{{{int my_maxidx(char *lnm) */
+static int
+my_maxidx(char *lnm)
+{
+ int status;
+ int midx;
+ int attr = LNM$M_CASE_BLIND;
+ struct dsc$descriptor lnmdsc;
+ struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
+ {0, 0, 0, 0}};
+
+ lnmdsc.dsc$w_length = strlen(lnm);
+ lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ lnmdsc.dsc$b_class = DSC$K_CLASS_S;
+ lnmdsc.dsc$a_pointer = lnm;
+
+ status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
+ if ((status & 1) == 0)
+ midx = 0;
+
+ return (midx);
+}
+/*}}}*/
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
unsigned long int retsts, attr = LNM$M_CASE_BLIND;
+ int midx;
unsigned char acmode;
struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
#if defined(PERL_IMPLICIT_CONTEXT)
pTHX = NULL;
-# if defined(USE_5005THREADS)
- /* We jump through these hoops because we can be called at */
- /* platform-specific initialization time, which is before anything is */
- /* set up--we can't even do a plain dTHX since that relies on the */
- /* interpreter structure to be initialized */
- if (PL_curinterp) {
- aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
- } else {
- aTHX = NULL;
- }
-# else
if (PL_curinterp) {
aTHX = PERL_GET_INTERP;
} else {
aTHX = NULL;
}
-
-# endif
#endif
- if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
+ if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
}
for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
retsts = SS$_NOLOGNAM;
for (i = 0; environ[i]; i++) {
if ((eq = strchr(environ[i],'=')) &&
+ lnmdsc.dsc$w_length == (eq - environ[i]) &&
!strncmp(environ[i],uplnm,eq - environ[i])) {
eq++;
for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
/* fully initialized, in which case either thr or PL_curcop */
/* might be bogus. We have to check, since ckWARN needs them */
/* both to be valid if running threaded */
-#if defined(USE_5005THREADS)
- if (thr && PL_curcop) {
-#endif
if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
}
-#if defined(USE_5005THREADS)
- } else {
- Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
- }
-#endif
-
}
strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
}
}
}
else if (!ivlnm) {
- retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
- if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
- if (retsts == SS$_NOLOGNAM) continue;
- /* PPFs have a prefix */
- if (
+ if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
+ midx = my_maxidx((char *) lnm);
+ for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
+ lnmlst[1].bufadr = cp1;
+ eqvlen = 0;
+ retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
+ if (retsts == SS$_NOLOGNAM) break;
+ /* PPFs have a prefix */
+ if (
#if INTSIZE == 4
- *((int *)uplnm) == *((int *)"SYS$") &&
+ *((int *)uplnm) == *((int *)"SYS$") &&
#endif
- eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
- ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
- (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
- (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
- (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
- memcpy(eqv,eqv+4,eqvlen-4);
- eqvlen -= 4;
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
+ (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
+ (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
+ (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
+ memcpy(eqv,eqv+4,eqvlen-4);
+ eqvlen -= 4;
+ }
+ cp1 += eqvlen;
+ *cp1 = '\0';
+ }
+ if ((retsts == SS$_IVLOGNAM) ||
+ (retsts == SS$_NOLOGNAM)) { continue; }
+ }
+ else {
+ retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
+ if (retsts == SS$_NOLOGNAM) continue;
+ eqv[eqvlen] = '\0';
}
+ eqvlen = strlen(eqv);
break;
}
}
char *
Perl_my_getenv(pTHX_ const char *lnm, bool sys)
{
- static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
+ static char *__my_getenv_eqv = NULL;
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
unsigned long int idx = 0;
int trnsuccess, success, secure, saverr, savvmserr;
+ int midx, flags;
SV *tmpsv;
+ midx = my_maxidx((char *) lnm) + 1;
+
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
/* Set up a temporary buffer for the return value; Perl will
* clean it up at the next statement transition */
- tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
if (!tmpsv) return NULL;
eqv = SvPVX(tmpsv);
}
- else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
+ else {
+ /* Assume no interpreter ==> single thread */
+ if (__my_getenv_eqv != NULL) {
+ Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ else {
+ New(1380,__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ eqv = __my_getenv_eqv;
+ }
+
for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
getcwd(eqv,LNM$C_NAMLENGTH);
return eqv;
}
else {
- if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(uplnm,lnm);
- uplnm[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0);
- lnm = uplnm;
- }
/* Impose security constraints only if tainting */
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? PL_tainting : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
- else secure = 0;
- success = vmstrnenv(lnm,eqv,idx,
- secure ? fildev : NULL,
+ else {
+ secure = 0;
+ }
+
+ flags =
#ifdef SECURE_INTERNAL_GETENV
- secure ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- );
+ ;
+
+ /* For the getenv interface we combine all the equivalence names
+ * of a search list logical into one value to acquire a maximum
+ * value length of 255*128 (assuming %ENV is using logicals).
+ */
+ flags |= PERL__TRNENV_JOIN_SEARCHLIST;
+
+ /* If the name contains a semicolon-delimited index, parse it
+ * off and make sure we only retrieve the equivalence name for
+ * that index. */
+ if ((cp2 = strchr(lnm,';')) != NULL) {
+ strcpy(uplnm,lnm);
+ uplnm[cp2-lnm] = '\0';
+ idx = strtoul(cp2+1,NULL,0);
+ lnm = uplnm;
+ flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
+ }
+
+ success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
+
/* Discard NOLOGNAM on internal calls since we're often looking
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
{
char *buf, *cp1, *cp2;
unsigned long idx = 0;
- static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+ int midx, flags;
+ static char *__my_getenv_len_eqv = NULL;
int secure, saverr, savvmserr;
SV *tmpsv;
+ midx = my_maxidx((char *) lnm) + 1;
+
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
/* Set up a temporary buffer for the return value; Perl will
* clean it up at the next statement transition */
- tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
if (!tmpsv) return NULL;
buf = SvPVX(tmpsv);
}
- else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
+ else {
+ /* Assume no interpreter ==> single thread */
+ if (__my_getenv_len_eqv != NULL) {
+ Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ else {
+ New(1381,__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ buf = __my_getenv_len_eqv;
+ }
+
for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
getcwd(buf,LNM$C_NAMLENGTH);
return buf;
}
else {
- if ((cp2 = strchr(lnm,';')) != NULL) {
- strcpy(buf,lnm);
- buf[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0);
- lnm = buf;
- }
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? PL_tainting : will_taint;
saverr = errno; savvmserr = vaxc$errno;
}
- else secure = 0;
- *len = vmstrnenv(lnm,buf,idx,
- secure ? fildev : NULL,
+ else {
+ secure = 0;
+ }
+
+ flags =
#ifdef SECURE_INTERNAL_GETENV
- secure ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- );
+ ;
+
+ flags |= PERL__TRNENV_JOIN_SEARCHLIST;
+
+ if ((cp2 = strchr(lnm,';')) != NULL) {
+ strcpy(buf,lnm);
+ buf[cp2-lnm] = '\0';
+ idx = strtoul(cp2+1,NULL,0);
+ lnm = buf;
+ flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
+ }
+
+ *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
+
/* Discard NOLOGNAM on internal calls since we're often looking
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
{
static int primed = 0;
HV *seenhv = NULL, *envhv;
+ SV *sv = NULL;
char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
unsigned short int chan;
#ifndef CLI$M_TRUSTED
#if defined(PERL_IMPLICIT_CONTEXT)
pTHX;
#endif
-#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
static perl_mutex primenv_mutex;
MUTEX_INIT(&primenv_mutex);
#endif
/* platform-specific initialization time, which is before anything is */
/* set up--we can't even do a plain dTHX since that relies on the */
/* interpreter structure to be initialized */
-#if defined(USE_5005THREADS)
- if (PL_curinterp) {
- aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
- } else {
- aTHX = NULL;
- }
-#else
if (PL_curinterp) {
aTHX = PERL_GET_INTERP;
} else {
aTHX = NULL;
}
#endif
-#endif
if (primed || !PL_envgv) return;
MUTEX_LOCK(&primenv_mutex);
for (j = 0; environ[j]; j++) {
if (!(start = strchr(environ[j],'='))) {
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
}
else {
start++;
- (void) hv_store(envhv,environ[j],start - environ[j] - 1,
- newSVpv(start,0),0);
+ sv = newSVpv(start,0);
+ SvTAINTED_on(sv);
+ (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
}
}
continue;
continue;
}
if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
if (*cp1 == '(' || /* Logical name table name */
cp1--; /* stop on last non-space char */
}
if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
continue;
}
PERL_HASH(hash,key,keylen);
- hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
+
+ if (cp1 == cp2 && *cp2 == '.') {
+ /* A single dot usually means an unprintable character, such as a null
+ * to indicate a zero-length value. Get the actual value to make sure.
+ */
+ char lnm[LNM$C_NAMLENGTH+1];
+ char eqv[LNM$C_NAMLENGTH+1];
+ strncpy(lnm, key, keylen);
+ int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
+ sv = newSVpvn(eqv, strlen(eqv));
+ }
+ else {
+ sv = newSVpvn(cp2,cp1 - cp2 + 1);
+ }
+
+ SvTAINTED_on(sv);
+ hv_store(envhv,key,keylen,sv,hash);
hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
}
if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
int trnlen, i;
for (i = 0; ppfs[i]; i++) {
trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
- hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
+ sv = newSVpv(eqv,trnlen);
+ SvTAINTED_on(sv);
+ hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
}
}
}
/*}}}*/
-/*{{{ int vmssetenv(char *lnm, char *eqv)*/
+/*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
/* Define or delete an element in the same "environment" as
* vmstrnenv(). If an element is to be deleted, it's removed from
* the first place it's found. If it's to be set, it's set in the
* Like setenv() returns 0 for success, non-zero on error.
*/
int
-Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
+Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
{
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
+ int nseg = 0, j;
unsigned long int retsts, usermode = PSL$C_USER;
+ struct itmlst_3 *ile, *ilist;
struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL");
- for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
+ if (!lnm) {
+ set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
+ return SS$_IVLOGNAM;
+ }
+
+ for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
*cp2 = _toupper(*cp1);
if (cp1 - lnm > LNM$C_NAMLENGTH) {
set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
for (curtab = 0; tabvec[curtab]; curtab++) {
if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
int i;
- for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
+ for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
if ((cp1 = strchr(environ[i],'=')) &&
+ lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
!strncmp(environ[i],lnm,cp1 - environ[i])) {
#ifdef HAS_SETENV
return setenv(lnm,"",1) ? vaxc$errno : 0;
ivenv = 1; retsts = SS$_NOLOGNAM;
#else
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
ivenv = 1; retsts = SS$_NOSUCHPGM;
break;
}
return setenv(lnm,eqv,1) ? vaxc$errno : 0;
#else
if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
retsts = SS$_NOSUCHPGM;
#endif
}
else {
- eqvdsc.dsc$a_pointer = eqv;
+ eqvdsc.dsc$a_pointer = (char *)eqv;
eqvdsc.dsc$w_length = strlen(eqv);
if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
!str$case_blind_compare(&tmpdsc,&clisym)) {
else {
if (!*eqv) eqvdsc.dsc$w_length = 1;
if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
- eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
- if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+
+ nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
+ if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
+ lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
+ eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
+ nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
+ }
+
+ New(1382,ilist,nseg+1,struct itmlst_3);
+ ile = ilist;
+ if (!ile) {
+ set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
+ return SS$_INSFMEM;
}
+ memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
+
+ for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
+ ile->itmcode = LNM$_STRING;
+ ile->bufadr = c;
+ if ((j+1) == nseg) {
+ ile->buflen = strlen(c);
+ /* in case we are truncating one that's too long */
+ if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
+ }
+ else {
+ ile->buflen = LNM$C_NAMLENGTH;
+ }
+ }
+
+ retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
+ Safefree (ilist);
+ }
+ else {
+ retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
- retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
}
}
} /* end of vmssetenv() */
/*}}}*/
-/*{{{ void my_setenv(char *lnm, char *eqv)*/
+/*{{{ void my_setenv(const char *lnm, const char *eqv)*/
/* This has to be a function since there's a prototype for it in proto.h */
void
-Perl_my_setenv(pTHX_ char *lnm,char *eqv)
+Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
{
if (lnm && *lnm) {
int len = strlen(lnm);
}
/*}}}*/
-/*{{{static void vmssetuserlnm(char *name, char *eqv);
+/*{{{static void vmssetuserlnm(char *name, char *eqv); */
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
/*}}}*/
#endif
+#ifdef KILL_BY_SIGPRC
+#include <errnodef.h>
+
+/* We implement our own kill() using the undocumented system service
+ sys$sigprc for one of two reasons:
+
+ 1.) If the kill() in an older CRTL uses sys$forcex, causing the
+ target process to do a sys$exit, which usually can't be handled
+ gracefully...certainly not by Perl and the %SIG{} mechanism.
+
+ 2.) If the kill() in the CRTL can't be called from a signal
+ handler without disappearing into the ether, i.e., the signal
+ it purportedly sends is never trapped. Still true as of VMS 7.3.
+
+ sys$sigprc has the same parameters as sys$forcex, but throws an exception
+ in the target process rather than calling sys$exit.
+
+ Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
+ on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
+ provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
+ with condition codes C$_SIG0+nsig*8, catching the exception on the
+ target process and resignaling with appropriate arguments.
+
+ But we don't have that VMS 7.0+ exception handler, so if you
+ Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
+
+ Also note that SIGTERM is listed in the docs as being "unimplemented",
+ yet always seems to be signaled with a VMS condition code of 4 (and
+ correctly handled for that code). So we hardwire it in.
+
+ Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
+ number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
+ than signalling with an unrecognized (and unhandled by CRTL) code.
+*/
+
+#define _MY_SIG_MAX 17
+
+unsigned int
+Perl_sig_to_vmscondition(int sig)
+{
+ static unsigned int sig_code[_MY_SIG_MAX+1] =
+ {
+ 0, /* 0 ZERO */
+ SS$_HANGUP, /* 1 SIGHUP */
+ SS$_CONTROLC, /* 2 SIGINT */
+ SS$_CONTROLY, /* 3 SIGQUIT */
+ SS$_RADRMOD, /* 4 SIGILL */
+ SS$_BREAK, /* 5 SIGTRAP */
+ SS$_OPCCUS, /* 6 SIGABRT */
+ SS$_COMPAT, /* 7 SIGEMT */
+#ifdef __VAX
+ SS$_FLTOVF, /* 8 SIGFPE VAX */
+#else
+ SS$_HPARITH, /* 8 SIGFPE AXP */
+#endif
+ SS$_ABORT, /* 9 SIGKILL */
+ SS$_ACCVIO, /* 10 SIGBUS */
+ SS$_ACCVIO, /* 11 SIGSEGV */
+ SS$_BADPARAM, /* 12 SIGSYS */
+ SS$_NOMBX, /* 13 SIGPIPE */
+ SS$_ASTFLT, /* 14 SIGALRM */
+ 4, /* 15 SIGTERM */
+ 0, /* 16 SIGUSR1 */
+ 0 /* 17 SIGUSR2 */
+ };
+
+#if __VMS_VER >= 60200000
+ static int initted = 0;
+ if (!initted) {
+ initted = 1;
+ sig_code[16] = C$_SIGUSR1;
+ sig_code[17] = C$_SIGUSR2;
+ }
+#endif
+
+ if (sig < _SIG_MIN) return 0;
+ if (sig > _MY_SIG_MAX) return 0;
+ return sig_code[sig];
+}
+
+
+int
+Perl_my_kill(int pid, int sig)
+{
+ dTHX;
+ int iss;
+ unsigned int code;
+ int sys$sigprc(unsigned int *pidadr,
+ struct dsc$descriptor_s *prcname,
+ unsigned int code);
+
+ code = Perl_sig_to_vmscondition(sig);
+
+ if (!pid || !code) {
+ return -1;
+ }
+
+ iss = sys$sigprc((unsigned int *)&pid,0,code);
+ if (iss&1) return 0;
+
+ switch (iss) {
+ case SS$_NOPRIV:
+ set_errno(EPERM); break;
+ case SS$_NONEXPR:
+ case SS$_NOSUCHNODE:
+ case SS$_UNREACHABLE:
+ set_errno(ESRCH); break;
+ case SS$_INSFMEM:
+ set_errno(ENOMEM); break;
+ default:
+ _ckvmssts(iss);
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(iss);
+
+ return -1;
+}
+#endif
+
/* default piping mailbox size */
#define PERL_BUFSIZ 512
struct pipe_details
{
pInfo next;
- PerlIO *fp; /* stdio file pointer to pipe mailbox */
+ PerlIO *fp; /* file pointer to pipe mailbox */
+ int useFILE; /* using stdio, not perlio */
int pid; /* PID of subprocess */
int mode; /* == 'r' if pipe open for reading */
int done; /* subprocess has completed */
+ int waiting; /* waiting for completion/closure */
int closing; /* my_pclose is closing this pipe */
unsigned long completion; /* termination status of subprocess */
pPipe in; /* pipe in to sub */
unsigned long int exit_status;
};
+typedef struct _closed_pipes Xpipe;
+typedef struct _closed_pipes* pXpipe;
+
+struct _closed_pipes {
+ int pid; /* PID of subprocess */
+ unsigned long completion; /* termination status of subprocess */
+};
+#define NKEEPCLOSED 50
+static Xpipe closed_list[NKEEPCLOSED];
+static int closed_index = 0;
+static int closed_num = 0;
+
#define RETRY_DELAY "0 ::0.20"
#define MAX_RETRY 50
static pInfo open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");
+#define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
+
+
static unsigned long int
pipe_exit_routine(pTHX)
{
pInfo info;
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
- int sts, did_stuff, need_eof;
+ int sts, did_stuff, need_eof, j;
+
+ /*
+ flush any pending i/o
+ */
+ info = open_pipes;
+ while (info) {
+ if (info->fp) {
+ if (!info->useFILE)
+ PerlIO_flush(info->fp); /* first, flush data */
+ else
+ fflush((FILE *)info->fp);
+ }
+ info = info->next;
+ }
/*
- first we try sending an EOF...ignore if doesn't work, make sure we
+ next we try sending an EOF...ignore if doesn't work, make sure we
don't hang
*/
did_stuff = 0;
if (info->in && !info->in->shut_on_empty) {
_ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
0, 0, 0, 0, 0, 0));
+ info->waiting = 1;
did_stuff = 1;
}
_ckvmssts(sys$setast(1));
info = info->next;
}
- if (did_stuff) sleep(1); /* wait for EOF to have an effect */
+
+ /* wait for EOF to have effect, up to ~ 30 sec [default] */
+
+ for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
+ int nwait = 0;
+
+ info = open_pipes;
+ while (info) {
+ _ckvmssts(sys$setast(0));
+ if (info->waiting && info->done)
+ info->waiting = 0;
+ nwait += info->waiting;
+ _ckvmssts(sys$setast(1));
+ info = info->next;
+ }
+ if (!nwait) break;
+ sleep(1);
+ }
did_stuff = 0;
info = open_pipes;
_ckvmssts(sys$setast(1));
info = info->next;
}
- if (did_stuff) sleep(1); /* wait for them to respond */
+
+ /* again, wait for effect */
+
+ for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
+ int nwait = 0;
+
+ info = open_pipes;
+ while (info) {
+ _ckvmssts(sys$setast(0));
+ if (info->waiting && info->done)
+ info->waiting = 0;
+ nwait += info->waiting;
+ _ckvmssts(sys$setast(1));
+ info = info->next;
+ }
+ if (!nwait) break;
+ sleep(1);
+ }
info = open_pipes;
while (info) {
{
pInfo i = open_pipes;
int iss;
+ pXpipe x;
+
+ info->completion &= 0x0FFFFFFF; /* strip off "control" field */
+ closed_list[closed_index].pid = info->pid;
+ closed_list[closed_index].completion = info->completion;
+ closed_index++;
+ if (closed_index == NKEEPCLOSED)
+ closed_index = 0;
+ closed_num++;
while (i) {
if (i == info) break;
}
if (!i) return; /* unlinked, probably freed too */
- info->completion &= 0x0FFFFFFF; /* strip off "control" field */
info->done = TRUE;
/*
}
-static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
-static void vms_execfree(pTHX);
+static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
+static void vms_execfree(struct dsc$descriptor_s *vmscmd);
/*
we actually differ from vmstrnenv since we use this to
return ifi; /* this is the RMS internal file id */
}
-#define MAX_DCL_SYMBOL 255
static void pipe_infromchild_ast(pPipe p);
/*
free_pipelocs(pTHX_ void *head)
{
pPLOC p, pnext;
+ pPLOC *pHead = (pPLOC *)head;
- p = (pPLOC) head;
+ p = *pHead;
while (p) {
pnext = p->next;
Safefree(p);
p = pnext;
}
+ *pHead = 0;
}
static void
{
int i;
pPLOC p;
- AV *av = GvAVn(PL_incgv);
+ AV *av = 0;
SV *dirsv;
GV *gv;
char *dir, *x;
char temp[NAM$C_MAXRSS+1];
STRLEN n_a;
+ if (head_PLOC)
+ free_pipelocs(aTHX_ &head_PLOC);
+
/* the . directory from @INC comes last */
New(1370,p,1,PLOC);
/* get the directory from $^X */
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
+#else
if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
+#endif
strcpy(temp, PL_origargv[0]);
x = strrchr(temp,']');
if (x) x[1] = '\0';
/* reverse order of @INC entries, skip "." since entered above */
- for (i = 0; i <= AvFILL(av); i++) {
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
+ if (PL_incgv) av = GvAVn(PL_incgv);
+
+ for (i = 0; av && i <= AvFILL(av); i++) {
dirsv = *av_fetch(av,i,TRUE);
if (SvROK(dirsv)) continue;
p->dir[NAM$C_MAXRSS] = '\0';
}
#endif
- Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
}
}
if (!fp) return 0; /* we're hosed */
- fprintf(fp,"$! 'f$verify(0)\n");
+ fprintf(fp,"$! 'f$verify(0)'\n");
fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
fprintf(fp,"$ perl_define = \"define/nolog\"\n");
fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
- fprintf(fp,"$ cmd = perl_popen_cmd\n");
- fprintf(fp,"$! --- get rid of global symbols\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
+ fprintf(fp,"$! --- build command line to get max possible length\n");
+ fprintf(fp,"$c=perl_popen_cmd0\n");
+ fprintf(fp,"$c=c+perl_popen_cmd1\n");
+ fprintf(fp,"$c=c+perl_popen_cmd2\n");
+ fprintf(fp,"$x=perl_popen_cmd3\n");
+ fprintf(fp,"$c=c+x\n");
fprintf(fp,"$ perl_on\n");
- fprintf(fp,"$ 'cmd\n");
+ fprintf(fp,"$ 'c'\n");
fprintf(fp,"$ perl_status = $STATUS\n");
fprintf(fp,"$ perl_del 'perl_cfile'\n");
fprintf(fp,"$ perl_exit 'perl_status'\n");
static PerlIO *
-safe_popen(pTHX_ char *cmd, char *mode)
+safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
{
static int handler_set_up = FALSE;
- unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
- unsigned int table = LIB$K_CLI_GLOBAL_SYM;
- char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
+ unsigned long int sts, flags = CLI$M_NOWAIT;
+ /* The use of a GLOBAL table (as was done previously) rendered
+ * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
+ * environment. Hence we've switched to LOCAL symbol table.
+ */
+ unsigned int table = LIB$K_CLI_LOCAL_SYM;
+ int j, wait = 0;
+ char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
char in[512], out[512], err[512], mbx[512];
FILE *tpipe = 0;
char tfilebuf[NAM$C_MAXRSS+1];
pInfo info;
+ char cmd_sym_name[20];
struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, symbol};
struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, 0};
-
- $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
+ struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, cmd_sym_name};
+ struct dsc$descriptor_s *vmscmd;
$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
$DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
+ if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
+
/* once-per-program initialization...
note that the SETAST calls and the dual test of pipe_ef
makes sure that only the FIRST thread through here does
tpipe = vmspipe_tempfile(aTHX);
if (!tpipe) { /* a fish popular in Boston */
if (ckWARN(WARN_PIPE)) {
- Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
}
return Nullfp;
}
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
- sts = setup_cmddsc(aTHX_ cmd,0);
+ sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
if (!(sts & 1)) {
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
set_errno(EVMSERR);
}
set_vaxc_errno(sts);
- if (ckWARN(WARN_PIPE)) {
- Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
+ if (*mode != 'n' && ckWARN(WARN_PIPE)) {
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
}
+ *psts = sts;
return Nullfp;
}
New(1301,info,1,Info);
+ strcpy(mode,in_mode);
info->mode = *mode;
info->done = FALSE;
info->completion = 0;
info->in = 0;
info->out = 0;
info->err = 0;
+ info->fp = Nullfp;
+ info->useFILE = 0;
+ info->waiting = 0;
info->in_done = TRUE;
info->out_done = TRUE;
info->err_done = TRUE;
in[0] = out[0] = err[0] = '\0';
+ if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
+ info->useFILE = 1;
+ strcpy(p,p+1);
+ }
+ if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
+ wait = 1;
+ strcpy(p,p+1);
+ }
+
if (*mode == 'r') { /* piping from subroutine */
info->out = pipe_infromchild_setup(aTHX_ mbx,out);
info->out_done = FALSE;
info->out->info = info;
}
+ if (!info->useFILE) {
info->fp = PerlIO_open(mbx, mode);
+ } else {
+ info->fp = (PerlIO *) freopen(mbx, mode, stdin);
+ Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
+ }
+
if (!info->fp && info->out) {
sys$cancel(info->out->chan_out);
if (info->out->buf) Safefree(info->out->buf);
Safefree(info->out);
Safefree(info);
+ *psts = RMS$_FNF;
return Nullfp;
}
info->err->info = info;
}
- } else { /* piping to subroutine , mode=w*/
+ } else if (*mode == 'w') { /* piping to subroutine */
+
+ info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
+ if (info->out) {
+ info->out->pipe_done = &info->out_done;
+ info->out_done = FALSE;
+ info->out->info = info;
+ }
+
+ info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
+ if (info->err) {
+ info->err->pipe_done = &info->err_done;
+ info->err_done = FALSE;
+ info->err->info = info;
+ }
info->in = pipe_tochild_setup(aTHX_ in,mbx);
+ if (!info->useFILE) {
info->fp = PerlIO_open(mbx, mode);
+ } else {
+ info->fp = (PerlIO *) freopen(mbx, mode, stdout);
+ Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
+ }
+
if (info->in) {
info->in->pipe_done = &info->in_done;
info->in_done = FALSE;
if (info->in->buf) Safefree(info->in->buf);
Safefree(info->in);
Safefree(info);
+ *psts = RMS$_FNF;
return Nullfp;
}
+ } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
if (info->out) {
info->out->pipe_done = &info->out_done;
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
- p = VMScmd.dsc$a_pointer;
+ p = vmscmd->dsc$a_pointer;
while (*p && *p != '\n') p++;
*p = '\0'; /* truncate on \n */
- p = VMScmd.dsc$a_pointer;
+ p = vmscmd->dsc$a_pointer;
while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
if (*p == '$') p++; /* remove leading $ */
while (*p == ' ' || *p == '\t') p++;
+
+ for (j = 0; j < 4; j++) {
+ sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
+ d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
+
strncpy(symbol, p, MAX_DCL_SYMBOL);
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
+ if (strlen(p) > MAX_DCL_SYMBOL) {
+ p += MAX_DCL_SYMBOL;
+ } else {
+ p += strlen(p);
+ }
+ }
_ckvmssts(sys$setast(0));
info->next=open_pipes; /* prepend to list */
open_pipes=info;
_ckvmssts(sys$setast(1));
- _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
+ /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
+ * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
+ * have SYS$COMMAND if we need it.
+ */
+ _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
0, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
if (tpipe) fclose(tpipe);
- /* once the subprocess is spawned, its copied the symbols and
+ /* once the subprocess is spawned, it has copied the symbols and
we can get rid of ours */
+ for (j = 0; j < 4; j++) {
+ sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
+ d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
_ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
+ }
_ckvmssts(lib$delete_symbol(&d_sym_in, &table));
_ckvmssts(lib$delete_symbol(&d_sym_err, &table));
_ckvmssts(lib$delete_symbol(&d_sym_out, &table));
- vms_execfree(aTHX);
+ vms_execfree(vmscmd);
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
PL_forkprocess = info->pid;
+
+ if (wait) {
+ int done = 0;
+ while (!done) {
+ _ckvmssts(sys$setast(0));
+ done = info->done;
+ if (!done) _ckvmssts(sys$clref(pipe_ef));
+ _ckvmssts(sys$setast(1));
+ if (!done) _ckvmssts(sys$waitfr(pipe_ef));
+ }
+ *psts = info->completion;
+ my_pclose(info->fp);
+ } else {
+ *psts = SS$_NORMAL;
+ }
return info->fp;
} /* end of safe_popen */
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
+ int sts;
TAINT_ENV();
TAINT_PROPER("popen");
PERL_FLUSHALL_FOR_CHILD;
- return safe_popen(aTHX_ cmd,mode);
+ return safe_popen(aTHX_ cmd,mode,&sts);
}
/*}}}*/
* well, at least sometimes it *does*, so we have to watch out for
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
-
+ if (info->fp) {
+ if (!info->useFILE)
PerlIO_flush(info->fp); /* first, flush data */
+ else
+ fflush((FILE *)info->fp);
+ }
_ckvmssts(sys$setast(0));
info->closing = TRUE;
_ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
0, 0, 0, 0, 0, 0));
_ckvmssts(sys$setast(1));
+ if (info->fp) {
+ if (!info->useFILE)
PerlIO_close(info->fp);
-
+ else
+ fclose((FILE *)info->fp);
+ }
/*
we have to wait until subprocess completes, but ALSO wait until all
the i/o completes...otherwise we'll be freeing the "info" structure
} /* end of my_pclose() */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* Roll our own prototype because we want this regardless of whether
* _VMS_WAIT is defined.
*/
pInfo info;
int done;
int sts;
+ int j;
if (statusp) *statusp = 0;
if (statusp) *statusp = info->completion;
return pid;
+ }
+
+ /* child that already terminated? */
+ for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
+ if (closed_list[j].pid == pid) {
+ if (statusp) *statusp = closed_list[j].completion;
+ return pid;
+ }
}
- else { /* this child is not one of our own pipe children */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70100322
+ /* fall through if this child is not one of our own pipe children */
+
+#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* waitpid() became available in the CRTL as of VMS 7.0, but only
* in 7.2 did we get a version that fills in the VMS completion
* of the current process.
*/
-#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
+#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
+ {
$DESCRIPTOR(intdsc,"0 00:00:01");
unsigned long int ownercode = JPI$_OWNER, ownerpid;
unsigned long int pidcode = JPI$_PID, mypid;
unsigned long int interval[2];
- int termination_mbu = 0;
- unsigned short qio_iosb[4];
unsigned int jpi_iosb[2];
- struct itmlst_3 jpilist[3] = {
+ struct itmlst_3 jpilist[2] = {
{sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
- {sizeof(termination_mbu), JPI$_TMBU, &termination_mbu, 0},
{ 0, 0, 0, 0}
};
- char trmmbx[NAM$C_DVI+1];
- $DESCRIPTOR(trmmbxdsc,trmmbx);
- struct accdef trmmsg;
- unsigned short int mbxchan;
if (pid <= 0) {
/* Sorry folks, we don't presently implement rooting around for
return -1;
}
- /* Get the owner of the child so I can warn if it's not mine, plus
- * get the termination mailbox. If the process doesn't exist or I
- * don't have the privs to look at it, I can go home early.
+ /* Get the owner of the child so I can warn if it's not mine. If the
+ * process doesn't exist or I don't have the privs to look at it,
+ * I can go home early.
*/
sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
if (sts & 1) sts = jpi_iosb[0];
/* remind folks they are asking for non-standard waitpid behavior */
_ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
if (ownerpid != mypid)
- Perl_warner(aTHX_ WARN_EXEC,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"waitpid: process %x is not a child of process %x",
pid,mypid);
}
- /* It's possible to have a mailbox unit number but no actual mailbox; we
- * check for this by assigning a channel to it, which we need anyway.
- */
- if (termination_mbu != 0) {
- sprintf(trmmbx, "MBA%d:", termination_mbu);
- trmmbxdsc.dsc$w_length = strlen(trmmbx);
- sts = sys$assign(&trmmbxdsc, &mbxchan, 0, 0);
- if (sts == SS$_NOSUCHDEV) {
- termination_mbu = 0; /* set up to take "no mailbox" case */
- sts = SS$_NORMAL;
- }
- _ckvmssts(sts);
- }
- /* If the process doesn't have a termination mailbox, then simply check
- * on it once a second until it's not there anymore.
- */
- if (termination_mbu == 0) {
- _ckvmssts(sys$bintim(&intdsc,interval));
- while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
+ /* simply check on it once a second until it's not there anymore. */
+
+ _ckvmssts(sys$bintim(&intdsc,interval));
+ while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
_ckvmssts(sys$schdwk(0,0,interval,0));
_ckvmssts(sys$hiber());
- }
- if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
- }
- else {
- /* If we do have a termination mailbox, post reads to it until we get a
- * termination message, discarding messages of the wrong type or for other
- * processes. If there is a place to put the final status, then do so.
- */
- sts = SS$_NORMAL;
- while (sts & 1) {
- memset((void *) &trmmsg, 0, sizeof(trmmsg));
- sts = sys$qiow(0,mbxchan,IO$_READVBLK,&qio_iosb,0,0,
- &trmmsg,ACC$K_TERMLEN,0,0,0,0);
- if (sts & 1) sts = qio_iosb[0];
-
- if ( sts & 1
- && trmmsg.acc$w_msgtyp == MSG$_DELPROC
- && trmmsg.acc$l_pid == pid ) {
-
- if (statusp) *statusp = trmmsg.acc$l_finalsts;
- sts = sys$dassgn(mbxchan);
- break;
- }
- }
- } /* termination_mbu ? */
+ }
+ if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
_ckvmssts(sts);
return pid;
-
- } /* else one of our own pipe children */
-
+ }
} /* end of waitpid() */
/*}}}*/
/*}}}*/
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;
}
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);
}
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;
+ STRLEN trnlen;
if (!dir || !*dir) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
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)) {
- STRLEN trnlen = strlen(trndir);
+ trnlnm_iter_count++;
+ if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
+ trnlen = strlen(trndir);
/* Trap simple rooted lnms, and return lnm:[000000] */
if (!strcmp(trndir+trnlen-2,".]")) {
{
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;
+ int devlen, dirlen, retlen = NAM$C_MAXRSS+1;
+ int expand = 1; /* guarantee room for leading and trailing slashes */
+ unsigned short int trnlnm_iter_count;
if (spec == NULL) return NULL;
if (strlen(spec) > NAM$C_MAXRSS) return NULL;
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)) {
struct list_item **tail,
int *count);
-static int background_process(int argc, char **argv);
+static int background_process(pTHX_ int argc, char **argv);
static void pipe_and_fork(pTHX_ char **cmargv);
*/
ap = argv[argc-1];
if (0 == strcmp("&", ap))
- exit(background_process(--argc, argv));
+ exit(background_process(aTHX_ --argc, argv));
if (*ap && '&' == ap[strlen(ap)-1])
{
ap[strlen(ap)-1] = '\0';
- exit(background_process(argc, argv));
+ exit(background_process(aTHX_ argc, argv));
}
/*
* Now we handle the general redirection cases that involve '>', '>>',
int expcount = 0;
unsigned long int context = 0;
int isunix = 0;
+int item_len = 0;
char *had_version;
char *had_device;
int had_directory;
add_item(head, tail, item, count);
return;
}
+ else
+ {
+ /* "double quoted" wild card expressions pass as is */
+ /* From DCL that means using e.g.: */
+ /* perl program """perl.*""" */
+ item_len = strlen(item);
+ if ( '"' == *item && '"' == item[item_len-1] )
+ {
+ item++;
+ item[item_len-2] = '\0';
+ add_item(head, tail, item, count);
+ return;
+ }
+ }
resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
resultspec.dsc$b_class = DSC$K_CLASS_D;
resultspec.dsc$a_pointer = NULL;
0
};
-static void pipe_and_fork(pTHX_ char **cmargv)
+static void
+pipe_and_fork(pTHX_ char **cmargv)
{
- char subcmd[2048];
- $DESCRIPTOR(cmddsc, "");
- static char mbxname[64];
- $DESCRIPTOR(mbxdsc, mbxname);
- int pid, j;
- unsigned long int zero = 0, one = 1;
-
- strcpy(subcmd, cmargv[0]);
- for (j = 1; NULL != cmargv[j]; ++j)
- {
- strcat(subcmd, " \"");
- strcat(subcmd, cmargv[j]);
- strcat(subcmd, "\"");
+ PerlIO *fp;
+ struct dsc$descriptor_s *vmscmd;
+ char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
+ int sts, j, l, ismcr, quote, tquote = 0;
+
+ sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
+ vms_execfree(vmscmd);
+
+ j = l = 0;
+ p = subcmd;
+ q = cmargv[0];
+ ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
+ && toupper(*(q+2)) == 'R' && !*(q+3);
+
+ while (q && l < MAX_DCL_LINE_LENGTH) {
+ if (!*q) {
+ if (j > 0 && quote) {
+ *p++ = '"';
+ l++;
+ }
+ q = cmargv[++j];
+ if (q) {
+ if (ismcr && j > 1) quote = 1;
+ tquote = (strchr(q,' ')) != NULL || *q == '\0';
+ *p++ = ' ';
+ l++;
+ if (quote || tquote) {
+ *p++ = '"';
+ l++;
+ }
+ }
+ } else {
+ if ((quote||tquote) && *q == '"') {
+ *p++ = '"';
+ l++;
}
- cmddsc.dsc$a_pointer = subcmd;
- cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
+ *p++ = *q++;
+ l++;
+ }
+ }
+ *p = '\0';
- create_mbx(aTHX_ &child_chan,&mbxdsc);
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
- PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
-#endif
- _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
- 0, &pid, child_st, &zero, sig_child,
- &child_chan));
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
-#endif
- sys$dclexh(&exit_block);
- if (NULL == freopen(mbxname, "wb", stdout))
- {
- PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
+ fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
+ if (fp == Nullfp) {
+ PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
}
}
-static int background_process(int argc, char **argv)
+static int background_process(pTHX_ int argc, char **argv)
{
char command[2048] = "$";
$DESCRIPTOR(value, "");
{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
{ 0, 0, 0, 0} };
+#ifdef KILL_BY_SIGPRC
+ (void) Perl_csighandler_init();
+#endif
+
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
* hasn't been allocated when vms_image_init() is called.
*/
if (will_taint) {
- char ***newap;
- New(1320,newap,*argcp+2,char **);
- newap[0] = argvp[0];
- *newap[1] = "-T";
- Copy(argvp[1],newap[2],*argcp-1,char **);
+ char **newargv, **oldargv;
+ oldargv = *argvp;
+ New(1320,newargv,(*argcp)+2,char *);
+ newargv[0] = oldargv[0];
+ New(1320,newargv[1],3,char);
+ strcpy(newargv[1], "-T");
+ Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
+ (*argcp)++;
+ newargv[*argcp] = NULL;
/* We orphan the old argv, since we don't know where it's come from,
* so we don't know how to free it.
*/
- *argcp++; argvp = newap;
+ *argvp = newargv;
}
else { /* Did user explicitly request tainting? */
int i;
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
getredirection(argcp,argvp);
-#if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
+#if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
{
# include <reentrancy.h>
(void) decc$set_reentrancy(C$C_MULTITHREAD);
* Minor modifications to original routines.
*/
+/* readdir may have been redefined by reentr.h, so make sure we get
+ * the local version for what we do here.
+ */
+#ifdef readdir
+# undef readdir
+#endif
+#if !defined(PERL_IMPLICIT_CONTEXT)
+# define readdir Perl_readdir
+#else
+# define readdir(a) Perl_readdir(aTHX_ a)
+#endif
+
/* Number of elements in vms_versions array */
#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
if (do_tovmspath(name,dir,0) == NULL) {
return NULL;
}
+ /* Check access before stat; otherwise stat does not
+ * accurately report whether it's a directory.
+ */
+ if (!cando_by_name(S_IRUSR,0,dir)) {
+ /* cando_by_name has already set errno */
+ return NULL;
+ }
if (flex_stat(dir,&sb) == -1) return NULL;
if (!S_ISDIR(sb.st_mode)) {
set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
return NULL;
}
- if (!cando_by_name(S_IRUSR,0,dir)) {
- set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
- return NULL;
- }
/* Get memory for the handle, and the pattern. */
New(1306,dd,1,DIR);
New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
dd->pat.dsc$b_class = DSC$K_CLASS_S;
+#if defined(USE_ITHREADS)
+ New(1308,dd->mutex,1,perl_mutex);
+ MUTEX_INIT( (perl_mutex *) dd->mutex );
+#else
+ dd->mutex = NULL;
+#endif
return dd;
} /* end of opendir() */
{
(void)lib$find_file_end(&dd->context);
Safefree(dd->pattern);
+#if defined(USE_ITHREADS)
+ MUTEX_DESTROY( (perl_mutex *) dd->mutex );
+ Safefree(dd->mutex);
+#endif
Safefree((char *)dd);
}
/*}}}*/
/*}}}*/
/*
+ * Read the next entry from the directory -- thread-safe version.
+ */
+/*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
+int
+Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
+{
+ int retval;
+
+ MUTEX_LOCK( (perl_mutex *) dd->mutex );
+
+ entry = readdir(dd);
+ *result = entry;
+ retval = ( *result == NULL ? errno : 0 );
+
+ MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
+
+ return retval;
+
+} /* end of readdir_r() */
+/*}}}*/
+
+/*
* Return something that can be used in a seekdir later.
*/
/*{{{ long telldir(DIR *dd)*/
*
* vms_do_aexec() and vms_do_exec() are called in response to the
* perl 'exec' function. If this follows a vfork call, then they
- * call out the the regular perl routines in doio.c which do an
+ * call out the regular perl routines in doio.c which do an
* execvp (for those who really want to try this under VMS).
* Otherwise, they do exactly what the perl docs say exec should
* do - terminate the current script and invoke a new command
* in 'VMSish fashion' (i.e. not after a call to vfork) The args
* are concatenated to form a DCL command string. If the first arg
* begins with '$' (i.e. the perl script had "\$ Type" or some such),
- * the the command string is handed off to DCL directly. Otherwise,
+ * the command string is handed off to DCL directly. Otherwise,
* the first token of the command is taken as the filespec of an image
* to run. The filespec is expanded using a default type of '.EXE' and
* the process defaults for device, directory, etc., and if found, the resultant
static void
-vms_execfree(pTHX) {
- if (PL_Cmd) {
- if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
- PL_Cmd = Nullch;
- }
- if (VMScmd.dsc$a_pointer) {
- Safefree(VMScmd.dsc$a_pointer);
- VMScmd.dsc$w_length = 0;
- VMScmd.dsc$a_pointer = Nullch;
+vms_execfree(struct dsc$descriptor_s *vmscmd)
+{
+ if (vmscmd) {
+ if (vmscmd->dsc$a_pointer) {
+ Safefree(vmscmd->dsc$a_pointer);
+ }
+ Safefree(vmscmd);
}
}
} /* end of setup_argstr() */
-#define MAX_DCL_LINE_LENGTH 255
static unsigned long int
-setup_cmddsc(pTHX_ char *cmd, int check_img)
+setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
+ struct dsc$descriptor_s **pvmscmd)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
$DESCRIPTOR(defdsc2,".");
$DESCRIPTOR(resdsc,resspec);
+ struct dsc$descriptor_s *vmscmd;
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register char *s, *rest, *cp, *wordbreak;
register int isdcl;
+ New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
+ vmscmd->dsc$a_pointer = NULL;
+ vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
+ vmscmd->dsc$b_class = DSC$K_CLASS_S;
+ vmscmd->dsc$w_length = 0;
+ if (pvmscmd) *pvmscmd = vmscmd;
+
+ if (suggest_quote) *suggest_quote = 0;
+
if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
return CLI$_BUFOVF; /* continuation lines currently unsupported */
s = cmd;
* - if it doesn't, caller tells us whether to default to a DCL
* command, or to a local image unless told it's DCL (by leading '$')
*/
- if (*s == '@') isdcl = 1;
- else {
+ if (*s == '@') {
+ isdcl = 1;
+ if (suggest_quote) *suggest_quote = 1;
+ } else {
register char *filespec = strpbrk(s,":<[.;");
rest = wordbreak = strpbrk(s," \"\t/");
if (!wordbreak) wordbreak = s + strlen(s);
if (check_img && isdcl) return RMS$_FNF;
if (cando_by_name(S_IXUSR,0,resspec)) {
- New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+ New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
if (!isdcl) {
- strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
+ strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
+ if (suggest_quote) *suggest_quote = 1;
} else {
- strcpy(VMScmd.dsc$a_pointer,"@");
+ strcpy(vmscmd->dsc$a_pointer,"@");
+ if (suggest_quote) *suggest_quote = 1;
}
- strcat(VMScmd.dsc$a_pointer,resspec);
- if (rest) strcat(VMScmd.dsc$a_pointer,rest);
- VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
- return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ strcat(vmscmd->dsc$a_pointer,resspec);
+ if (rest) strcat(vmscmd->dsc$a_pointer,rest);
+ vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
+ return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
}
else retsts = RMS$_PRV;
}
}
/* It's either a DCL command or we couldn't find a suitable image */
- VMScmd.dsc$w_length = strlen(cmd);
- if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
- else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
+ vmscmd->dsc$w_length = strlen(cmd);
+/* if (cmd == PL_Cmd) {
+ vmscmd->dsc$a_pointer = PL_Cmd;
+ if (suggest_quote) *suggest_quote = 1;
+ }
+ else */
+ vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
+
+ /* check if it's a symbol (for quoting purposes) */
+ if (suggest_quote && !*suggest_quote) {
+ int iss;
+ char equiv[LNM$C_NAMLENGTH];
+ struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ eqvdsc.dsc$a_pointer = equiv;
+
+ iss = lib$get_symbol(vmscmd,&eqvdsc);
+ if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
+ }
if (!(retsts & 1)) {
/* just hand off status values likely to be due to user error */
if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
else { _ckvmssts(retsts); }
}
- return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
} /* end of setup_cmddsc() */
bool
Perl_vms_do_exec(pTHX_ char *cmd)
{
+ struct dsc$descriptor_s *vmscmd;
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
TAINT_ENV();
TAINT_PROPER("exec");
- if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
- retsts = lib$do_command(&VMScmd);
+ if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
+ retsts = lib$do_command(vmscmd);
switch (retsts) {
case RMS$_FNF: case RMS$_DNF:
}
set_vaxc_errno(retsts);
if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
- VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
+ vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
}
- vms_execfree(aTHX);
+ vms_execfree(vmscmd);
}
return FALSE;
unsigned long int
Perl_do_spawn(pTHX_ char *cmd)
{
- unsigned long int sts, substs, hadcmd = 1;
+ unsigned long int sts, substs;
TAINT_ENV();
TAINT_PROPER("spawn");
if (!cmd || !*cmd) {
- hadcmd = 0;
sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
- }
- else {
- sts = setup_cmddsc(aTHX_ cmd,0);
- if (sts & 1) {
- sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
- } else {
- substs = sts; /* didn't spawn, use command setup failure for return */
+ if (!(sts & 1)) {
+ switch (sts) {
+ 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$_PRV:
+ set_errno(EACCES); break;
+ case RMS$_SYN:
+ set_errno(EINVAL); break;
+ case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
+ set_errno(E2BIG); break;
+ case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
+ _ckvmssts(sts); /* fall through */
+ default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(sts);
+ if (ckWARN(WARN_EXEC)) {
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
+ Strerror(errno));
+ }
}
+ sts = substs;
}
-
- if (!(sts & 1)) {
- switch (sts) {
- 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$_PRV:
- set_errno(EACCES); break;
- case RMS$_SYN:
- set_errno(EINVAL); break;
- case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
- set_errno(E2BIG); break;
- case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
- _ckvmssts(sts); /* fall through */
- default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
- set_errno(EVMSERR);
- }
- set_vaxc_errno(sts);
- if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
- hadcmd ? VMScmd.dsc$w_length : 0,
- hadcmd ? VMScmd.dsc$a_pointer : "",
- Strerror(errno));
- }
+ else {
+ (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
}
- vms_execfree(aTHX);
- return substs;
-
+ return sts;
} /* end of do_spawn() */
/*}}}*/
int my_sigismember(sigset_t *set, int sig) {
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set & (1 << (sig - 1));
+ return *set & (1 << (sig - 1));
}
/*}}}*/
# endif
dst = -1;
#ifndef RTL_USES_UTC
- if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
+ if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
when = whenutc - offset; /* pseudolocal time*/
}
# endif
*/
static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
-/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
-int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
+/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
+int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
{
register int i;
long int bintime[2], len = 2, lowbit, unixtime,
set_vaxc_errno(LIB$_INVARG);
return -1;
}
- if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
+ if (do_tovmsspec((char *)file,vmsspec,0) == NULL) return -1;
if (utimes != NULL) {
/* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
* subset of the applicable information.
*/
bool
-Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
+Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp)
{
char fname_phdev[NAM$C_MAXRSS+1];
if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
{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},
{sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
- struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
+ {0,0,0,0}};
+ struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
{0,0,0,0}};
+ struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
if (!fname || !*fname) return FALSE;
/* 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;
namdsc.dsc$a_pointer = fileified;
}
- if (!usrdsc.dsc$w_length) {
- cuserid(usrname);
- usrdsc.dsc$w_length = strlen(usrname);
- }
-
switch (bit) {
case S_IXUSR: case S_IXGRP: case S_IXOTH:
access = ARM$M_EXECUTE; break;
return FALSE;
}
+ /* 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. 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));
+
+ /* allocate space for the profile and get it filled in */
+ New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
+ _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
+ &usrprodsc.dsc$w_length,0));
+
+ /* use the profile to check access to the file; free profile & analyze results */
+ 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) {
else set_errno(ENOENT);
return FALSE;
}
- if (retsts == SS$_NORMAL) {
- if (!privused) return TRUE;
- /* We can get access, but only by using privs. Do we have the
- necessary privs currently enabled? */
- _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
- if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
- !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
- !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
- if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
- return TRUE;
- }
- if (retsts == SS$_ACCONFLICT) {
+ if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
return TRUE;
}
_ckvmssts(retsts);
char fileified[NAM$C_MAXRSS+1];
char temp_fspec[NAM$C_MAXRSS+300];
int retval = -1;
+ int saved_errno, saved_vaxc_errno;
+ if (!fspec) return retval;
+ saved_errno = errno; saved_vaxc_errno = vaxc$errno;
strcpy(temp_fspec, fspec);
if (statbufp == (Stat_t *) &PL_statcache)
do_tovmsspec(temp_fspec,namecache,0);
}
# endif
}
+ /* If we were successful, leave errno where we found it */
+ if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
return retval;
} /* end of flex_stat() */
}
void
+hushexit_fromperl(pTHX_ CV *cv)
+{
+ dXSARGS;
+
+ if (items > 0) {
+ VMSISH_HUSHED = SvTRUE(ST(0));
+ }
+ ST(0) = boolSV(VMSISH_HUSHED);
+ XSRETURN(1);
+}
+
+void
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
+ struct interp_intern *dst)
+{
+ memcpy(dst,src,sizeof(struct interp_intern));
+}
+
+void
+Perl_sys_intern_clear(pTHX)
+{
+}
+
+void
+Perl_sys_intern_init(pTHX)
+{
+ unsigned int ix = RAND_MAX;
+ double x;
+
+ VMSISH_HUSHED = 0;
+
+ x = (float)ix;
+ MY_INV_RAND_MAX = 1./x;
+}
+
+void
init_os_extras()
{
dTHX;
newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
+ newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
- store_pipelocs(aTHX);
+ store_pipelocs(aTHX); /* will redo any earlier attempts */
return;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff