X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=1150ea3859835b6cc109569e4f4f7af8c509081f;hb=7dc9aaa56b11c3e04f31eb9de23451166e23126f;hp=8fe4f5f10411338ac1db5d54fdddcae66cfae265;hpb=22d4bb9ccb8701e68f9243547d7e3a3c55f70908;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index 8fe4f5f..1150ea3 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -9,6 +9,7 @@ * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu */ +#include #include #include #include @@ -29,6 +30,7 @@ #include #include #include +#include #include #include #include @@ -49,6 +51,9 @@ # define SS$_NOSUCHOBJECT 2696 #endif +/* We implement I/O here, so we will be mixing PerlIO and stdio calls. */ +#define PERLIO_NOT_STDIO 0 + /* Don't replace system definitions of vfork, getenv, and stat, * code below needs to get to the underlying CRTL routines. */ #define DONT_MASK_RTL_CALLS @@ -98,6 +103,9 @@ struct itmlst_3 { #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) #define getredirection(a,b) mp_getredirection(aTHX_ a,b) +/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ +#define PERL_LNM_MAX_ALLOWED_INDEX 127 + static char *__mystrtolower(char *str) { if (str) for (; *str; ++str) *str= tolower(*str); @@ -126,7 +134,7 @@ static int tz_updated = 1; /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ int -Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, +Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) { char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; @@ -139,20 +147,29 @@ Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen}, {0, 0, 0, 0}}; $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); -#if defined(USE_THREADS) +#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 */ - struct perl_thread *thr; if (PL_curinterp) { - thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); + aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv); } else { - thr = NULL; + aTHX = NULL; } +# else + if (PL_curinterp) { + aTHX = PERL_GET_INTERP; + } else { + aTHX = NULL; + } + +# endif #endif - if (!lnm || !eqv || idx > LNM$_MAX_INDEX) { + if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; } for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { @@ -209,13 +226,13 @@ Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, /* 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_THREADS) +#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); } -#if defined(USE_THREADS) +#if defined(USE_5005THREADS) } else { Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); } @@ -290,7 +307,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv; unsigned long int idx = 0; - int trnsuccess; + int trnsuccess, success, secure, saverr, savvmserr; SV *tmpsv; if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ @@ -314,16 +331,25 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) lnm = uplnm; } /* Impose security constraints only if tainting */ - if (sys) sys = PL_curinterp ? PL_tainting : will_taint; - if (vmstrnenv(lnm,eqv,idx, - sys ? fildev : NULL, + 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, #ifdef SECURE_INTERNAL_GETENV - sys ? PERL__TRNENV_SECURE : 0 + secure ? PERL__TRNENV_SECURE : 0 #else - 0 + 0 #endif - )) return eqv; - else return Nullch; + ); + /* 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. */ + if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); + return success ? eqv : Nullch; } } /* end of my_getenv() */ @@ -332,12 +358,12 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/ char * -my_getenv_len(const char *lnm, unsigned long *len, bool sys) +Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) { - dTHX; char *buf, *cp1, *cp2; unsigned long idx = 0; static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1]; + int secure, saverr, savvmserr; SV *tmpsv; if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ @@ -361,25 +387,31 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) idx = strtoul(cp2+1,NULL,0); lnm = buf; } - /* Impose security constraints only if tainting */ - if (sys) sys = PL_curinterp ? PL_tainting : will_taint; - if ((*len = vmstrnenv(lnm,buf,idx, - sys ? fildev : NULL, + 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, #ifdef SECURE_INTERNAL_GETENV - sys ? PERL__TRNENV_SECURE : 0 + secure ? PERL__TRNENV_SECURE : 0 #else - 0 + 0 #endif - ))) - return buf; - else - return Nullch; + ); + /* 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. */ + if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); + return *len ? buf : Nullch; } } /* end of my_getenv_len() */ /*}}}*/ -static void create_mbx(unsigned short int *, struct dsc$descriptor_s *); +static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *); static void riseandshine(unsigned long int dummy) { sys$wake(0,0); } @@ -390,9 +422,9 @@ prime_env_iter(void) * find, in preparation for iterating over it. */ { - dTHX; 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 @@ -407,11 +439,34 @@ prime_env_iter(void) $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES"); $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX; +#endif +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) static perl_mutex primenv_mutex; MUTEX_INIT(&primenv_mutex); #endif +#if defined(PERL_IMPLICIT_CONTEXT) + /* 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 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); if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } @@ -443,8 +498,9 @@ prime_env_iter(void) } 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; @@ -533,7 +589,9 @@ prime_env_iter(void) continue; } PERL_HASH(hash,key,keylen); - hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash); + 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 */ @@ -543,7 +601,9 @@ prime_env_iter(void) 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); } } } @@ -566,7 +626,7 @@ prime_env_iter(void) * Like setenv() returns 0 for success, non-zero on error. */ int -vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) +Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) { char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0; @@ -576,7 +636,6 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); $DESCRIPTOR(local,"_LOCAL"); - dTHX; for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { *cp2 = _toupper(*cp1); @@ -596,7 +655,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) if ((cp1 = strchr(environ[i],'=')) && !strncmp(environ[i],lnm,cp1 - environ[i])) { #ifdef HAS_SETENV - return setenv(lnm,eqv,1) ? vaxc$errno : 0; + return setenv(lnm,"",1) ? vaxc$errno : 0; } } ivenv = 1; retsts = SS$_NOLOGNAM; @@ -704,25 +763,25 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) void Perl_my_setenv(pTHX_ char *lnm,char *eqv) { - if (lnm && *lnm) { - int len = strlen(lnm); - if (len == 7) { - char uplnm[8]; - int i; - for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); - if (!strcmp(uplnm,"DEFAULT")) { - if (eqv && *eqv) chdir(eqv); - return; - } - } -#ifndef RTL_USES_UTC - if (len == 6 || len == 2) { - char uplnm[7]; + if (lnm && *lnm) { + int len = strlen(lnm); + if (len == 7) { + char uplnm[8]; int i; for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); - uplnm[len] = '\0'; - if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1; - if (!strcmp(uplnm,"TZ")) tz_updated = 1; + if (!strcmp(uplnm,"DEFAULT")) { + if (eqv && *eqv) chdir(eqv); + return; + } + } +#ifndef RTL_USES_UTC + if (len == 6 || len == 2) { + char uplnm[7]; + int i; + for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); + uplnm[len] = '\0'; + if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1; + if (!strcmp(uplnm,"TZ")) tz_updated = 1; } #endif } @@ -730,6 +789,30 @@ Perl_my_setenv(pTHX_ char *lnm,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 + */ +void +Perl_vmssetuserlnm(pTHX_ char *name, char *eqv) +{ + $DESCRIPTOR(d_tab, "LNM$PROCESS"); + struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; + unsigned long int iss, attr = LNM$M_CONFINE; + unsigned char acmode = PSL$C_USER; + struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0}, + {0, 0, 0, 0}}; + d_name.dsc$a_pointer = name; + d_name.dsc$w_length = strlen(name); + + lnmlst[0].buflen = strlen(eqv); + lnmlst[0].bufadr = eqv; + + iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst); + if (!(iss&1)) lib$signal(iss); +} +/*}}}*/ /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/ @@ -743,7 +826,7 @@ Perl_my_setenv(pTHX_ char *lnm,char *eqv) * be upcased by the caller. */ char * -my_crypt(const char *textpasswd, const char *usrname) +Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname) { # ifndef UAI$C_PREFERRED_ALGORITHM # define UAI$C_PREFERRED_ALGORITHM 127 @@ -823,12 +906,11 @@ Perl_do_rmdir(pTHX_ char *name) */ /*{{{int kill_file(char *name)*/ int -kill_file(char *name) +Perl_kill_file(pTHX_ char *name) { char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1]; unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1; - dTHX; struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; struct myacedef { unsigned char myace$b_length; @@ -925,10 +1007,9 @@ kill_file(char *name) /*{{{int my_mkdir(char *,Mode_t)*/ int -my_mkdir(char *dir, Mode_t mode) +Perl_my_mkdir(pTHX_ char *dir, Mode_t mode) { STRLEN dirlen = strlen(dir); - dTHX; /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; @@ -949,10 +1030,9 @@ my_mkdir(char *dir, Mode_t mode) /*{{{int my_chdir(char *)*/ int -my_chdir(char *dir) +Perl_my_chdir(pTHX_ char *dir) { STRLEN dirlen = strlen(dir); - dTHX; /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; @@ -979,7 +1059,6 @@ my_tmpfile(void) { FILE *fp; char *cp; - dTHX; if ((fp = tmpfile())) return fp; @@ -993,17 +1072,37 @@ my_tmpfile(void) } /*}}}*/ + +#ifndef HOMEGROWN_POSIX_SIGNALS +/* + * The C RTL's sigaction fails to check for invalid signal numbers so we + * help it out a bit. The docs are correct, but the actual routine doesn't + * do what the docs say it will. + */ +/*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/ +int +Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, + struct sigaction* oact) +{ + if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) { + SETERRNO(EINVAL, SS$_INVARG); + return -1; + } + return sigaction(sig, act, oact); +} +/*}}}*/ +#endif + /* default piping mailbox size */ #define PERL_BUFSIZ 512 static void -create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) +create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc) { unsigned long int mbxbufsiz; static unsigned long int syssize = 0; unsigned long int dviitm = DVI$_DEVNAM; - dTHX; char csize[LNM$C_NAMLENGTH+1]; if (!syssize) { @@ -1088,6 +1187,10 @@ struct _pipe { pInfo info; pCBuf curr; pCBuf curr2; +#if defined(PERL_IMPLICIT_CONTEXT) + void *thx; /* Either a thread or an interpreter */ + /* pointer, depending on how we're built */ +#endif }; @@ -1129,12 +1232,11 @@ static $DESCRIPTOR(nl_desc, "NL:"); static unsigned long int -pipe_exit_routine() +pipe_exit_routine(pTHX) { pInfo info; unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; int sts, did_stuff, need_eof; - dTHX; /* first we try sending an EOF...ignore if doesn't work, make sure we @@ -1199,7 +1301,6 @@ static void pipe_tochild2_ast(pPipe p); static void popen_completion_ast(pInfo info) { - dTHX; pInfo i = open_pipes; int iss; @@ -1231,9 +1332,9 @@ popen_completion_ast(pInfo info) if (info->in && !info->in_done) { /* only for mode=w */ if (info->in->shut_on_empty && info->in->need_wake) { info->in->need_wake = FALSE; - _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0)); + _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0)); } else { - _ckvmssts(sys$cancel(info->in->chan_out)); + _ckvmssts_noperl(sys$cancel(info->in->chan_out)); } } @@ -1241,20 +1342,20 @@ popen_completion_ast(pInfo info) info->out->shut_on_empty = TRUE; iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); if (iss == SS$_MBFULL) iss = SS$_NORMAL; - _ckvmssts(iss); + _ckvmssts_noperl(iss); } if (info->err && !info->err_done) { /* we were piping stderr */ info->err->shut_on_empty = TRUE; iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); if (iss == SS$_MBFULL) iss = SS$_NORMAL; - _ckvmssts(iss); + _ckvmssts_noperl(iss); } - _ckvmssts(sys$setef(pipe_ef)); + _ckvmssts_noperl(sys$setef(pipe_ef)); } -static unsigned long int setup_cmddsc(char *cmd, int check_img); +static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img); static void vms_execfree(pTHX); /* @@ -1264,7 +1365,7 @@ static void vms_execfree(pTHX); */ static unsigned short -popen_translate(char *logical, char *result) +popen_translate(pTHX_ char *logical, char *result) { int iss; $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE"); @@ -1324,9 +1425,8 @@ static void pipe_infromchild_ast(pPipe p); #define INITIAL_TOCHILDQUEUE 2 static pPipe -pipe_tochild_setup(char *rmbx, char *wmbx) +pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx) { - dTHX; pPipe p; pCBuf b; char mbx1[64], mbx2[64]; @@ -1339,8 +1439,8 @@ pipe_tochild_setup(char *rmbx, char *wmbx) New(1368, p, 1, Pipe); - create_mbx(&p->chan_in , &d_mbx1); - create_mbx(&p->chan_out, &d_mbx2); + create_mbx(aTHX_ &p->chan_in , &d_mbx1); + create_mbx(aTHX_ &p->chan_out, &d_mbx2); _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); p->buf = 0; @@ -1355,6 +1455,9 @@ pipe_tochild_setup(char *rmbx, char *wmbx) p->curr = 0; p->curr2 = 0; p->info = 0; +#ifdef PERL_IMPLICIT_CONTEXT + p->thx = aTHX; +#endif n = sizeof(CBuf) + p->bufsize; @@ -1376,10 +1479,12 @@ pipe_tochild_setup(char *rmbx, char *wmbx) static void pipe_tochild1_ast(pPipe p) { - dTHX; pCBuf b = p->curr; int iss = p->iosb.status; int eof = (iss == SS$_ENDOFFILE); +#ifdef PERL_IMPLICIT_CONTEXT + pTHX = p->thx; +#endif if (p->retry) { if (eof) { @@ -1436,12 +1541,14 @@ pipe_tochild1_ast(pPipe p) static void pipe_tochild2_ast(pPipe p) { - dTHX; pCBuf b = p->curr2; int iss = p->iosb2.status; int n = sizeof(CBuf) + p->bufsize; int done = (p->info && p->info->done) || iss == SS$_CANCEL || iss == SS$_ABORT; +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = p->thx; +#endif do { if (p->type) { /* type=1 has old buffer, dispose */ @@ -1489,9 +1596,8 @@ pipe_tochild2_ast(pPipe p) static pPipe -pipe_infromchild_setup(char *rmbx, char *wmbx) +pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx) { - dTHX; pPipe p; char mbx1[64], mbx2[64]; struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, @@ -1501,8 +1607,8 @@ pipe_infromchild_setup(char *rmbx, char *wmbx) unsigned int dviitm = DVI$_DEVBUFSIZ; New(1367, p, 1, Pipe); - create_mbx(&p->chan_in , &d_mbx1); - create_mbx(&p->chan_out, &d_mbx2); + create_mbx(aTHX_ &p->chan_in , &d_mbx1); + create_mbx(aTHX_ &p->chan_out, &d_mbx2); _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); New(1367, p->buf, p->bufsize, char); @@ -1510,6 +1616,9 @@ pipe_infromchild_setup(char *rmbx, char *wmbx) p->info = 0; p->type = 0; p->iosb.status = SS$_NORMAL; +#if defined(PERL_IMPLICIT_CONTEXT) + p->thx = aTHX; +#endif pipe_infromchild_ast(p); strcpy(wmbx, mbx1); @@ -1520,11 +1629,13 @@ pipe_infromchild_setup(char *rmbx, char *wmbx) static void pipe_infromchild_ast(pPipe p) { - dTHX; int iss = p->iosb.status; int eof = (iss == SS$_ENDOFFILE); int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0)); int kideof = (eof && (p->iosb.dvispec == p->info->pid)); +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = p->thx; +#endif if (p->info && p->info->closing && p->chan_out) { /* output shutdown */ _ckvmssts(sys$dassgn(p->chan_out)); @@ -1596,9 +1707,8 @@ pipe_infromchild_ast(pPipe p) } static pPipe -pipe_mbxtofd_setup(int fd, char *out) +pipe_mbxtofd_setup(pTHX_ int fd, char *out) { - dTHX; pPipe p; char mbx[64]; unsigned long dviitm = DVI$_DEVBUFSIZ; @@ -1621,7 +1731,7 @@ pipe_mbxtofd_setup(int fd, char *out) New(1366, p, 1, Pipe); p->fd_out = dup(fd); - create_mbx(&p->chan_in, &d_mbx); + create_mbx(aTHX_ &p->chan_in, &d_mbx); _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); New(1366, p->buf, p->bufsize+1, char); p->shut_on_empty = FALSE; @@ -1639,14 +1749,15 @@ pipe_mbxtofd_setup(int fd, char *out) static void pipe_mbxtofd_ast(pPipe p) { - dTHX; int iss = p->iosb.status; int done = p->info->done; int iss2; int eof = (iss == SS$_ENDOFFILE); int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0)); int err = !(iss&1) && !eof; - +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = p->thx; +#endif if (done && myeof) { /* end piping */ close(p->fd_out); @@ -1689,9 +1800,21 @@ struct _pipeloc { }; static pPLOC head_PLOC = 0; +void +free_pipelocs(pTHX_ void *head) +{ + pPLOC p, pnext; + + p = (pPLOC) head; + while (p) { + pnext = p->next; + Safefree(p); + p = pnext; + } +} static void -store_pipelocs() +store_pipelocs(pTHX) { int i; pPLOC p; @@ -1755,12 +1878,12 @@ store_pipelocs() p->dir[NAM$C_MAXRSS] = '\0'; } #endif - + Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC); } static char * -find_vmspipe(void) +find_vmspipe(pTHX) { static int vmspipe_file_status = 0; static char vmspipe_file[NAM$C_MAXRSS+1]; @@ -1802,7 +1925,7 @@ find_vmspipe(void) } static FILE * -vmspipe_tempfile(void) +vmspipe_tempfile(pTHX) { char file[NAM$C_MAXRSS+1]; FILE *fp; @@ -1843,17 +1966,19 @@ vmspipe_tempfile(void) fprintf(fp,"$ perl_del = \"delete\"\n"); fprintf(fp,"$ pif = \"if\"\n"); fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n"); - fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define sys$input 'perl_popen_in'\n"); - fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error 'perl_popen_err'\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,"$ perl_on\n"); fprintf(fp,"$ 'cmd\n"); fprintf(fp,"$ perl_status = $STATUS\n"); - fprintf(fp,"$ perl_del 'perl_cfile'\n"); + fprintf(fp,"$ perl_del 'perl_cfile'\n"); fprintf(fp,"$ perl_exit 'perl_status'\n"); fsync(fileno(fp)); @@ -1879,9 +2004,8 @@ vmspipe_tempfile(void) static PerlIO * -safe_popen(char *cmd, char *mode) +safe_popen(pTHX_ char *cmd, char *mode) { - dTHX; 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; @@ -1892,12 +2016,12 @@ safe_popen(char *cmd, char *mode) pInfo info; struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, symbol}; - struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T, - DSC$K_CLASS_S, out}; struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD"); $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN"); + $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT"); $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR"); /* once-per-program initialization... @@ -1929,11 +2053,11 @@ safe_popen(char *cmd, char *mode) /* see if we can find a VMSPIPE.COM */ tfilebuf[0] = '@'; - vmspipe = find_vmspipe(); + vmspipe = find_vmspipe(aTHX); if (vmspipe) { strcpy(tfilebuf+1,vmspipe); } else { /* uh, oh...we're in tempfile hell */ - tpipe = vmspipe_tempfile(); + 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"); @@ -1945,7 +2069,32 @@ safe_popen(char *cmd, char *mode) vmspipedsc.dsc$a_pointer = tfilebuf; vmspipedsc.dsc$w_length = strlen(tfilebuf); - if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } + sts = setup_cmddsc(aTHX_ cmd,0); + 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_PIPE)) { + Perl_warner(aTHX_ WARN_PIPE,"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno)); + } + return Nullfp; + } New(1301,info,1,Info); info->mode = *mode; @@ -1958,11 +2107,11 @@ safe_popen(char *cmd, char *mode) info->in_done = TRUE; info->out_done = TRUE; info->err_done = TRUE; + in[0] = out[0] = err[0] = '\0'; if (*mode == 'r') { /* piping from subroutine */ - in[0] = '\0'; - info->out = pipe_infromchild_setup(mbx,out); + info->out = pipe_infromchild_setup(aTHX_ mbx,out); if (info->out) { info->out->pipe_done = &info->out_done; info->out_done = FALSE; @@ -1979,15 +2128,15 @@ safe_popen(char *cmd, char *mode) if (!done) _ckvmssts(sys$clref(pipe_ef)); _ckvmssts(sys$setast(1)); if (!done) _ckvmssts(sys$waitfr(pipe_ef)); - } + } if (info->out->buf) Safefree(info->out->buf); Safefree(info->out); Safefree(info); return Nullfp; - } + } - info->err = pipe_mbxtofd_setup(fileno(stderr), err); + info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err); if (info->err) { info->err->pipe_done = &info->err_done; info->err_done = FALSE; @@ -1995,9 +2144,8 @@ safe_popen(char *cmd, char *mode) } } else { /* piping to subroutine , mode=w*/ - int melded; - info->in = pipe_tochild_setup(in,mbx); + info->in = pipe_tochild_setup(aTHX_ in,mbx); info->fp = PerlIO_open(mbx, mode); if (info->in) { info->in->pipe_done = &info->in_done; @@ -2023,40 +2171,24 @@ safe_popen(char *cmd, char *mode) if (info->in->buf) Safefree(info->in->buf); Safefree(info->in); Safefree(info); - return Nullfp; + return Nullfp; } - /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */ - - melded = FALSE; - fgetname(stderr, err); - if (strncmp(err,"SYS$ERROR:",10) == 0) { - fgetname(stdout, out); - if (strncmp(out,"SYS$OUTPUT:",11) == 0) { - if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) { - melded = TRUE; - } - } - } - info->out = pipe_mbxtofd_setup(fileno(stdout), out); + 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; } - if (!melded) { - info->err = pipe_mbxtofd_setup(fileno(stderr), err); - if (info->err) { - info->err->pipe_done = &info->err_done; - info->err_done = FALSE; - info->err->info = info; - } - } else { - err[0] = '\0'; - } + + 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; + } } - d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/ symbol[MAX_DCL_SYMBOL] = '\0'; @@ -2068,6 +2200,9 @@ safe_popen(char *cmd, char *mode) d_symbol.dsc$w_length = strlen(symbol); _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table)); + strncpy(symbol, out, MAX_DCL_SYMBOL); + d_symbol.dsc$w_length = strlen(symbol); + _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table)); p = VMScmd.dsc$a_pointer; while (*p && *p != '\n') p++; @@ -2084,7 +2219,7 @@ safe_popen(char *cmd, char *mode) info->next=open_pipes; /* prepend to list */ open_pipes=info; _ckvmssts(sys$setast(1)); - _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags, + _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags, 0, &info->pid, &info->completion, 0, popen_completion_ast,info,0,0,0)); @@ -2098,7 +2233,7 @@ safe_popen(char *cmd, char *mode) _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); PL_forkprocess = info->pid; @@ -2106,22 +2241,21 @@ safe_popen(char *cmd, char *mode) } /* end of safe_popen */ -/*{{{ FILE *my_popen(char *cmd, char *mode)*/ -FILE * +/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/ +PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) { TAINT_ENV(); TAINT_PROPER("popen"); PERL_FLUSHALL_FOR_CHILD; - return safe_popen(cmd,mode); + return safe_popen(aTHX_ cmd,mode); } /*}}}*/ -/*{{{ I32 my_pclose(FILE *fp)*/ -I32 Perl_my_pclose(pTHX_ FILE *fp) +/*{{{ I32 my_pclose(PerlIO *fp)*/ +I32 Perl_my_pclose(pTHX_ PerlIO *fp) { - dTHX; pInfo info, last = NULL; unsigned long int retsts; int done, iss; @@ -2143,7 +2277,7 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) * the first EOF closing the pipe (and DASSGN'ing the channel)... */ - fsync(fileno(info->fp)); /* first, flush data */ + PerlIO_flush(info->fp); /* first, flush data */ _ckvmssts(sys$setast(0)); info->closing = TRUE; @@ -2204,14 +2338,26 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) } /* end of my_pclose() */ -/* sort-of waitpid; use only with popen() */ +#if defined(__CRTL_VER) && __CRTL_VER >= 70100322 + /* Roll our own prototype because we want this regardless of whether + * _VMS_WAIT is defined. + */ + __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options ); +#endif +/* sort-of waitpid; special handling of pipe clean-up for subprocesses + created with popen(); otherwise partially emulate waitpid() unless + we have a suitable one from the CRTL that came with VMS 7.2 and later. + Also check processes not considered by the CRTL waitpid(). + */ /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ Pid_t -my_waitpid(Pid_t pid, int *statusp, int flags) +Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags) { pInfo info; int done; - dTHX; + int sts; + + if (statusp) *statusp = 0; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; @@ -2225,37 +2371,140 @@ my_waitpid(Pid_t pid, int *statusp, int flags) if (!done) _ckvmssts(sys$waitfr(pipe_ef)); } - *statusp = info->completion; + if (statusp) *statusp = info->completion; return pid; + } - else { /* we haven't heard of this child */ + else { /* this child is not one of our own pipe children */ + +#if defined(__CRTL_VER) && __CRTL_VER >= 70100322 + + /* 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 + * status as Perl has always tried to do. + */ + + sts = __vms_waitpid( pid, statusp, flags ); + + if ( sts == 0 || !(sts == -1 && errno == ECHILD) ) + return sts; + + /* If the real waitpid tells us the child does not exist, we + * fall through here to implement waiting for a child that + * was created by some means other than exec() (say, spawned + * from DCL) or to wait for a process that is not a subprocess + * of the current process. + */ + +#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */ + $DESCRIPTOR(intdsc,"0 00:00:01"); - unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; - unsigned long int interval[2],sts; + 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] = { + {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 + the first child we can find, and we definitely don't want to + pass a pid of -1 to $getjpi, where it is a wildcard operation. + */ + set_errno(ENOTSUP); + 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. + */ + sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL); + if (sts & 1) sts = jpi_iosb[0]; + if (!(sts & 1)) { + switch (sts) { + case SS$_NONEXPR: + set_errno(ECHILD); + break; + case SS$_NOPRIV: + set_errno(EACCES); + break; + default: + _ckvmssts(sts); + } + set_vaxc_errno(sts); + return -1; + } if (ckWARN(WARN_EXEC)) { - _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); - _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,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,"pid %x not a child",pid); + Perl_warner(aTHX_ WARN_EXEC, + "waitpid: process %x is not a child of process %x", + pid,mypid); } - _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()); + /* 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 (sts == SS$_NONEXPR) sts = SS$_NORMAL; - _ckvmssts(sts); - - /* There's no easy way to find the termination status a child we're - * not aware of beforehand. If we're really interested in the future, - * we can go looking for a termination mailbox, or chase after the - * accounting record for the process. + /* If the process doesn't have a termination mailbox, then simply check + * on it once a second until it's not there anymore. */ - *statusp = 0; + if (termination_mbu == 0) { + _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 ? */ + + _ckvmssts(sts); return pid; - } + + } /* else one of our own pipe children */ } /* end of waitpid() */ /*}}}*/ @@ -2523,6 +2772,10 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) dir[--dirlen] = '\0'; dir[dirlen-1] = ']'; } + if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) { + dir[--dirlen] = '\0'; + dir[dirlen-1] = '>'; + } if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) { /* If we've got an explicit filename, we can just shuffle the string. */ @@ -2745,6 +2998,7 @@ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) else if (ts) New(1312,retspec,retlen+16,char); else retspec = __fileify_retbuf; cp1 = strstr(esa,"]["); + if (!cp1) cp1 = strstr(esa,"]<"); dirlen = cp1 - esa; memcpy(retspec,esa,dirlen); if (!strncmp(cp1+2,"000000]",7)) { @@ -3364,7 +3618,7 @@ static void mp_expand_wild_cards(pTHX_ char *item, static int background_process(int argc, char **argv); -static void pipe_and_fork(char **cmargv); +static void pipe_and_fork(pTHX_ char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ static void @@ -3428,7 +3682,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) { if (j+1 >= argc) { - PerlIO_printf(Perl_debug_log,"No input file after < on command line"); + fprintf(stderr,"No input file after < on command line"); exit(LIB$_WRONUMARG); } in = argv[++j]; @@ -3443,7 +3697,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) { if (j+1 >= argc) { - PerlIO_printf(Perl_debug_log,"No output file after > on command line"); + fprintf(stderr,"No output file after > on command line"); exit(LIB$_WRONUMARG); } out = argv[++j]; @@ -3463,7 +3717,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) out = 1 + ap; if (j >= argc) { - PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line"); + fprintf(stderr,"No output file after > or >> on command line"); exit(LIB$_WRONUMARG); } continue; @@ -3485,7 +3739,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) err = 2 + ap; if (j >= argc) { - PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line"); + fprintf(stderr,"No output file after 2> or 2>> on command line"); exit(LIB$_WRONUMARG); } continue; @@ -3494,7 +3748,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) { if (j+1 >= argc) { - PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line"); + fprintf(stderr,"No command into which to pipe on command line"); exit(LIB$_WRONUMARG); } cmargc = argc-(j+1); @@ -3525,10 +3779,10 @@ mp_getredirection(pTHX_ int *ac, char ***av) { if (out != NULL) { - PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line"); + fprintf(stderr,"'|' and '>' may not both be specified on command line"); exit(LIB$_INVARGORD); } - pipe_and_fork(cmargv); + pipe_and_fork(aTHX_ cmargv); } /* Check for input from a pipe (mailbox) */ @@ -3544,7 +3798,7 @@ mp_getredirection(pTHX_ int *ac, char ***av) /* Input from a pipe, reopen it in binary mode to disable */ /* carriage control processing. */ - PerlIO_getname(stdin, mbxname); + fgetname(stdin, mbxname); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); @@ -3558,35 +3812,39 @@ mp_getredirection(pTHX_ int *ac, char ***av) freopen(mbxname, "rb", stdin); if (errno != 0) { - PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname); + fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname); exit(vaxc$errno); } } if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) { - PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in); + fprintf(stderr,"Can't open input file %s as stdin",in); exit(vaxc$errno); } if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) { - PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out); + fprintf(stderr,"Can't open output file %s as stdout",out); exit(vaxc$errno); } + if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out); + if (err != NULL) { if (strcmp(err,"&1") == 0) { - dup2(fileno(stdout), fileno(Perl_debug_log)); + dup2(fileno(stdout), fileno(stderr)); + Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT"); } else { FILE *tmperr; if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) { - PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err); + fprintf(stderr,"Can't open error file %s as stderr",err); exit(vaxc$errno); } fclose(tmperr); - if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2")) + if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2")) { exit(vaxc$errno); } + Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err); } } #ifdef ARGPROC_DEBUG @@ -3757,7 +4015,7 @@ static struct exit_control_block exit_block = 0 }; -static void pipe_and_fork(char **cmargv) +static void pipe_and_fork(pTHX_ char **cmargv) { char subcmd[2048]; $DESCRIPTOR(cmddsc, ""); @@ -3776,7 +4034,7 @@ static void pipe_and_fork(char **cmargv) cmddsc.dsc$a_pointer = subcmd; cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer); - create_mbx(&child_chan,&mbxdsc); + 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); @@ -3856,17 +4114,19 @@ vms_image_init(int *argcp, char ***argvp) unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)]; unsigned short int dummy, rlen; struct dsc$descriptor_s **tabvec; - dTHX; +#if defined(PERL_IMPLICIT_CONTEXT) + pTHX = NULL; +#endif struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy}, {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen}, { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy}, { 0, 0, 0, 0} }; - _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL)); - _ckvmssts(iosb[0]); + _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++) { if (iprv[i]) { /* Running image installed with privs? */ - _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */ + _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */ will_taint = TRUE; break; } @@ -3891,8 +4151,8 @@ vms_image_init(int *argcp, char ***argvp) if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr); jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int); jpilist[1].buflen = rsz * sizeof(unsigned long int); - _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL)); - _ckvmssts(iosb[0]); + _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL)); + _ckvmssts_noperl(iosb[0]); } mask = jpilist[1].bufadr; /* Check attribute flags for each identifier (2nd longword); protected @@ -3948,12 +4208,12 @@ vms_image_init(int *argcp, char ***argvp) tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T; tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D; tabvec[tabidx]->dsc$a_pointer = NULL; - _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx])); + _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx])); } if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; } getredirection(argcp,argvp); -#if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) ) +#if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) ) { # include (void) decc$set_reentrancy(C$C_MULTITHREAD); @@ -4204,8 +4464,7 @@ closedir(DIR *dd) * Collect all the version numbers for the current file. */ static void -collectversions(dd) - DIR *dd; +collectversions(pTHX_ DIR *dd) { struct dsc$descriptor_s pat; struct dsc$descriptor_s res; @@ -4213,7 +4472,6 @@ collectversions(dd) char *p, *text, buff[sizeof dd->entry.d_name]; int i; unsigned long context, tmpsts; - dTHX; /* Convenient shorthand. */ e = &dd->entry; @@ -4260,7 +4518,7 @@ collectversions(dd) */ /*{{{ struct dirent *readdir(DIR *dd)*/ struct dirent * -readdir(DIR *dd) +Perl_readdir(pTHX_ DIR *dd) { struct dsc$descriptor_s res; char *p, buff[sizeof dd->entry.d_name]; @@ -4305,7 +4563,7 @@ readdir(DIR *dd) dd->entry.d_namlen = strlen(dd->entry.d_name); dd->entry.vms_verscount = 0; - if (dd->vms_wantversions) collectversions(dd); + if (dd->vms_wantversions) collectversions(aTHX_ dd); return &dd->entry; } /* end of readdir() */ @@ -4327,10 +4585,9 @@ telldir(DIR *dd) */ /*{{{ void seekdir(DIR *dd,long count)*/ void -seekdir(DIR *dd, long count) +Perl_seekdir(pTHX_ DIR *dd, long count) { int vms_wantversions; - dTHX; /* If we haven't done anything yet... */ if (dd->count == 0) @@ -4407,9 +4664,8 @@ vms_execfree(pTHX) { } static char * -setup_argstr(SV *really, SV **mark, SV **sp) +setup_argstr(pTHX_ SV *really, SV **mark, SV **sp) { - dTHX; char *junk, *tmps = Nullch; register size_t cmdlen = 0; size_t rlen; @@ -4450,9 +4706,10 @@ setup_argstr(SV *really, SV **mark, SV **sp) } /* end of setup_argstr() */ +#define MAX_DCL_LINE_LENGTH 255 static unsigned long int -setup_cmddsc(char *cmd, int check_img) +setup_cmddsc(pTHX_ char *cmd, int check_img) { char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(defdsc,".EXE"); @@ -4462,11 +4719,9 @@ setup_cmddsc(char *cmd, int check_img) unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL; register char *s, *rest, *cp, *wordbreak; register int isdcl; - dTHX; - if (strlen(cmd) > - (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec))) - return LIB$_INVARG; + if (strlen(cmd) > MAX_DCL_LINE_LENGTH) + return CLI$_BUFOVF; /* continuation lines currently unsupported */ s = cmd; while (*s && isspace(*s)) s++; @@ -4546,14 +4801,14 @@ setup_cmddsc(char *cmd, int check_img) if (cando_by_name(S_IXUSR,0,resspec)) { 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 "); } else { strcpy(VMScmd.dsc$a_pointer,"@"); } strcat(VMScmd.dsc$a_pointer,resspec); if (rest) strcat(VMScmd.dsc$a_pointer,rest); VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer); - return retsts; + return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts); } else retsts = RMS$_PRV; } @@ -4570,16 +4825,15 @@ setup_cmddsc(char *cmd, int check_img) else { _ckvmssts(retsts); } } - return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts); + return (VMScmd.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts); } /* end of setup_cmddsc() */ /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ bool -vms_do_aexec(SV *really,SV **mark,SV **sp) +Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp) { - dTHX; if (sp > mark) { if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; @@ -4590,7 +4844,7 @@ vms_do_aexec(SV *really,SV **mark,SV **sp) else return do_aexec(really,mark,sp); } /* no vfork - act VMSish */ - return vms_do_exec(setup_argstr(really,mark,sp)); + return vms_do_exec(setup_argstr(aTHX_ really,mark,sp)); } @@ -4600,10 +4854,9 @@ vms_do_aexec(SV *really,SV **mark,SV **sp) /* {{{bool vms_do_exec(char *cmd) */ bool -vms_do_exec(char *cmd) +Perl_vms_do_exec(pTHX_ char *cmd) { - dTHX; if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called--; if (vfork_called < 0) { @@ -4618,7 +4871,7 @@ vms_do_exec(char *cmd) TAINT_ENV(); TAINT_PROPER("exec"); - if ((retsts = setup_cmddsc(cmd,1)) & 1) + if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1) retsts = lib$do_command(&VMScmd); switch (retsts) { @@ -4632,7 +4885,7 @@ vms_do_exec(char *cmd) set_errno(EACCES); break; case RMS$_SYN: set_errno(EINVAL); break; - case CLI$_BUFOVF: + 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(retsts); /* fall through */ @@ -4652,14 +4905,13 @@ vms_do_exec(char *cmd) } /* end of vms_do_exec() */ /*}}}*/ -unsigned long int do_spawn(char *); +unsigned long int Perl_do_spawn(pTHX_ char *); /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */ unsigned long int -do_aspawn(void *really,void **mark,void **sp) +Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp) { - dTHX; - if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp)); + if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp)); return SS$_ABORT; } /* end of do_aspawn() */ @@ -4667,10 +4919,9 @@ do_aspawn(void *really,void **mark,void **sp) /* {{{unsigned long int do_spawn(char *cmd) */ unsigned long int -do_spawn(char *cmd) +Perl_do_spawn(pTHX_ char *cmd) { unsigned long int sts, substs, hadcmd = 1; - dTHX; TAINT_ENV(); TAINT_PROPER("spawn"); @@ -4678,8 +4929,13 @@ do_spawn(char *cmd) hadcmd = 0; sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0); } - else if ((sts = setup_cmddsc(cmd,0)) & 1) { - sts = lib$spawn(&VMScmd,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)) { @@ -4694,7 +4950,7 @@ do_spawn(char *cmd) set_errno(EACCES); break; case RMS$_SYN: set_errno(EINVAL); break; - case CLI$_BUFOVF: + 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 */ @@ -4715,6 +4971,57 @@ do_spawn(char *cmd) } /* end of do_spawn() */ /*}}}*/ + +static unsigned int *sockflags, sockflagsize; + +/* + * Shim fdopen to identify sockets for my_fwrite later, since the stdio + * routines found in some versions of the CRTL can't deal with sockets. + * We don't shim the other file open routines since a socket isn't + * likely to be opened by a name. + */ +/*{{{ FILE *my_fdopen(int fd, const char *mode)*/ +FILE *my_fdopen(int fd, const char *mode) +{ + FILE *fp = fdopen(fd, (char *) mode); + + if (fp) { + unsigned int fdoff = fd / sizeof(unsigned int); + struct stat sbuf; /* native stat; we don't need flex_stat */ + if (!sockflagsize || fdoff > sockflagsize) { + if (sockflags) Renew( sockflags,fdoff+2,unsigned int); + else New (1324,sockflags,fdoff+2,unsigned int); + memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize); + sockflagsize = fdoff + 2; + } + if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode)) + sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int)); + } + return fp; + +} +/*}}}*/ + + +/* + * Clear the corresponding bit when the (possibly) socket stream is closed. + * There still a small hole: we miss an implicit close which might occur + * via freopen(). >> Todo + */ +/*{{{ int my_fclose(FILE *fp)*/ +int my_fclose(FILE *fp) { + if (fp) { + unsigned int fd = fileno(fp); + unsigned int fdoff = fd / sizeof(unsigned int); + + if (sockflagsize && fdoff <= sockflagsize) + sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int)); + } + return fclose(fp); +} +/*}}}*/ + + /* * A simple fwrite replacement which outputs itmsz*nitm chars without * introducing record boundaries every itmsz chars. @@ -4723,15 +5030,23 @@ do_spawn(char *cmd) * data with nulls sprinkled in the middle but also data with no null * byte at the end. */ -/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/ +/*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/ int -my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) +my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest) { register char *cp, *end, *cpd, *data; + register unsigned int fd = fileno(dest); + register unsigned int fdoff = fd / sizeof(unsigned int); int retval; - int bufsize = itmsz*nitm+1; + int bufsize = itmsz * nitm + 1; + + if (fdoff < sockflagsize && + (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) { + if (write(fd, src, itmsz * nitm) == EOF) return EOF; + return nitm; + } - _ckvmssts_noperl(lib$get_vm( &bufsize, &data )); + _ckvmssts_noperl(lib$get_vm(&bufsize, &data)); memcpy( data, src, itmsz*nitm ); data[itmsz*nitm] = '\0'; @@ -4747,7 +5062,7 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) cpd = cp + 1; } - if (data) _ckvmssts_noperl(lib$free_vm( &bufsize, &data )); + if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data)); return retval; } /* end of my_fwrite() */ @@ -4755,7 +5070,7 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) /*{{{ int my_flush(FILE *fp)*/ int -my_flush(FILE *fp) +Perl_my_flush(pTHX_ FILE *fp) { int res; if ((res = fflush(fp)) == 0 && fp) { @@ -4836,9 +5151,8 @@ static char __pw_namecache[UAI$S_IDENT+1]; /* * This routine does most of the work extracting the user information. */ -static int fillpasswd (const char *name, struct passwd *pwd) +static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) { - dTHX; static struct { unsigned char length; char pw_gecos[UAI$S_OWNER+1]; @@ -4918,15 +5232,14 @@ static int fillpasswd (const char *name, struct passwd *pwd) * Get information for a named user. */ /*{{{struct passwd *getpwnam(char *name)*/ -struct passwd *my_getpwnam(char *name) +struct passwd *Perl_my_getpwnam(pTHX_ char *name) { struct dsc$descriptor_s name_desc; union uicdef uic; unsigned long int status, sts; - dTHX; __pwdcache = __passwd_empty; - if (!fillpasswd(name, &__pwdcache)) { + if (!fillpasswd(aTHX_ name, &__pwdcache)) { /* We still may be able to determine pw_uid and pw_gid */ name_desc.dsc$w_length= strlen(name); name_desc.dsc$b_dtype= DSC$K_DTYPE_T; @@ -4957,13 +5270,12 @@ struct passwd *my_getpwnam(char *name) * Called by my_getpwent with uid=-1 to list all users. */ /*{{{struct passwd *my_getpwuid(Uid_t uid)*/ -struct passwd *my_getpwuid(Uid_t uid) +struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid) { const $DESCRIPTOR(name_desc,__pw_namecache); unsigned short lname; union uicdef uic; unsigned long int status; - dTHX; if (uid == (unsigned int) -1) { do { @@ -5003,7 +5315,7 @@ struct passwd *my_getpwuid(Uid_t uid) __pwdcache.pw_uid = uic.uic$l_uic; __pwdcache.pw_gid = uic.uic$v_group; - fillpasswd(__pw_namecache, &__pwdcache); + fillpasswd(aTHX_ __pw_namecache, &__pwdcache); return &__pwdcache; } /* end of my_getpwuid() */ @@ -5013,7 +5325,7 @@ struct passwd *my_getpwuid(Uid_t uid) * Get information for next user. */ /*{{{struct passwd *my_getpwent()*/ -struct passwd *my_getpwent() +struct passwd *Perl_my_getpwent(pTHX) { return (my_getpwuid((unsigned int) -1)); } @@ -5023,9 +5335,8 @@ struct passwd *my_getpwent() * Finish searching rights database for users. */ /*{{{void my_endpwent()*/ -void my_endpwent() +void Perl_my_endpwent(pTHX) { - dTHX; if (contxt) { _ckvmssts(sys$finish_rdb(&contxt)); contxt= 0; @@ -5368,7 +5679,7 @@ tz_parse_offset(char *s, int *offset) */ static int -tz_parse(time_t *w, int *dst, char *zone, int *gmtoff) +tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff) { time_t when; struct tm *w2; @@ -5494,9 +5805,8 @@ done: */ /*{{{time_t my_time(time_t *timep)*/ -time_t my_time(time_t *timep) +time_t Perl_my_time(pTHX_ time_t *timep) { - dTHX; time_t when; struct tm *tm_p; @@ -5548,9 +5858,8 @@ time_t my_time(time_t *timep) /*{{{struct tm *my_gmtime(const time_t *timep)*/ struct tm * -my_gmtime(const time_t *timep) +Perl_my_gmtime(pTHX_ const time_t *timep) { - dTHX; char *p; time_t when; struct tm *rsltmp; @@ -5579,9 +5888,8 @@ my_gmtime(const time_t *timep) /*{{{struct tm *my_localtime(const time_t *timep)*/ struct tm * -my_localtime(const time_t *timep) +Perl_my_localtime(pTHX_ const time_t *timep) { - dTHX; time_t when, whenutc; struct tm *rsltmp; int dst, offset; @@ -5646,9 +5954,8 @@ my_localtime(const time_t *timep) static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; /*{{{int my_utime(char *path, struct utimbuf *utimes)*/ -int my_utime(char *file, struct utimbuf *utimes) +int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes) { - dTHX; register int i; long int bintime[2], len = 2, lowbit, unixtime, secscale = 10000000; /* seconds --> 100 ns intervals */ @@ -5831,14 +6138,13 @@ int my_utime(char *file, struct utimbuf *utimes) * on the first call. */ #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */ -static mydev_t encode_dev (const char *dev) +static mydev_t encode_dev (pTHX_ const char *dev) { int i; unsigned long int f; mydev_t enc; char c; const char *q; - dTHX; if (!dev || !dev[0]) return 0; @@ -5884,7 +6190,6 @@ static int is_null_device(name) const char *name; { - dTHX; /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:". The underscore prefix, controller letter, and unit number are independently optional; for our purposes, the colon punctuation @@ -5948,7 +6253,7 @@ Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/ I32 -cando_by_name(I32 bit, Uid_t effective, char *fname) +Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname) { static char usrname[L_cuserid]; static struct dsc$descriptor_s usrdsc = @@ -5956,7 +6261,6 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) 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; - dTHX; 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}, @@ -6035,12 +6339,11 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/ int -flex_fstat(int fd, Stat_t *statbufp) +Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) { - dTHX; if (!fstat(fd,(stat_t *) statbufp)) { if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0'; - statbufp->st_dev = encode_dev(statbufp->st_devnam); + statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); # ifdef RTL_USES_UTC # ifdef VMSISH_TIME if (VMSISH_TIME) { @@ -6069,19 +6372,19 @@ flex_fstat(int fd, Stat_t *statbufp) /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/ int -flex_stat(const char *fspec, Stat_t *statbufp) +Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp) { - dTHX; char fileified[NAM$C_MAXRSS+1]; char temp_fspec[NAM$C_MAXRSS+300]; int retval = -1; + if (!fspec) return retval; strcpy(temp_fspec, fspec); if (statbufp == (Stat_t *) &PL_statcache) do_tovmsspec(temp_fspec,namecache,0); if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */ memset(statbufp,0,sizeof *statbufp); - statbufp->st_dev = encode_dev("_NLA0:"); + statbufp->st_dev = encode_dev(aTHX_ "_NLA0:"); statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; statbufp->st_uid = 0x00010001; statbufp->st_gid = 0x0001; @@ -6105,7 +6408,7 @@ flex_stat(const char *fspec, Stat_t *statbufp) } if (retval) retval = stat(temp_fspec,(stat_t *) statbufp); if (!retval) { - statbufp->st_dev = encode_dev(statbufp->st_devnam); + statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); # ifdef RTL_USES_UTC # ifdef VMSISH_TIME if (VMSISH_TIME) { @@ -6458,7 +6761,7 @@ candelete_fromperl(pTHX_ CV *cv) mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); if (SvTYPE(mysv) == SVt_PVGV) { - if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) { + if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); ST(0) = &PL_sv_no; XSRETURN(1); @@ -6495,7 +6798,7 @@ rmscopy_fromperl(pTHX_ CV *cv) mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); if (SvTYPE(mysv) == SVt_PVGV) { - if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) { + if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); ST(0) = &PL_sv_no; XSRETURN(1); @@ -6511,7 +6814,7 @@ rmscopy_fromperl(pTHX_ CV *cv) } mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); if (SvTYPE(mysv) == SVt_PVGV) { - if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) { + if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); ST(0) = &PL_sv_no; XSRETURN(1); @@ -6533,7 +6836,7 @@ rmscopy_fromperl(pTHX_ CV *cv) void -mod2fname(CV *cv) +mod2fname(pTHX_ CV *cv) { dXSARGS; char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1], @@ -6608,10 +6911,48 @@ mod2fname(CV *cv) } 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) +{ + int ix = RAND_MAX; + float x; + + VMSISH_HUSHED = 0; + + x = (float)ix; + MY_INV_RAND_MAX = 1./x; +} + + + +void init_os_extras() { - char* file = __FILE__; dTHX; + char* file = __FILE__; char temp_buff[512]; if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) { no_translate_barewords = TRUE; @@ -6629,8 +6970,9 @@ init_os_extras() 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(); + store_pipelocs(aTHX); return; }