/* vms.c * * VMS-specific routines for perl5 * Version: 5.7.0 * * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name, * and Perl_cando by Craig Berry * 29-Aug-2000 Charles Lane's piping improvements rolled in * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* Older versions of ssdef.h don't have these */ #ifndef SS$_INVFILFOROP # define SS$_INVFILFOROP 3930 #endif #ifndef SS$_NOSUCHOBJECT # define SS$_NOSUCHOBJECT 2696 #endif /* 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 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* Anticipating future expansion in lexical warnings . . . */ #ifndef WARN_INTERNAL # define WARN_INTERNAL WARN_MISC #endif #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000 # define RTL_USES_UTC 1 #endif /* gcc's header files don't #define direct access macros * corresponding to VAXC's variant structs */ #ifdef __GNUC__ # define uic$v_format uic$r_uic_form.uic$v_format # define uic$v_group uic$r_uic_form.uic$v_group # define uic$v_member uic$r_uic_form.uic$v_member # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv #endif #if defined(NEED_AN_H_ERRNO) dEXT int h_errno; #endif struct itmlst_3 { unsigned short int buflen; unsigned short int itmcode; void *bufadr; unsigned short int *retlen; }; #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c) #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c) #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c) #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c) #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e) #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c) #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c) #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); return str; } static struct dsc$descriptor_s fildevdsc = { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" }; static struct dsc$descriptor_s crtlenvdsc = { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" }; static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL }; static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL }; static struct dsc$descriptor_s **env_tables = defenv; static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */ /* True if we shouldn't treat barewords as logicals during directory */ /* 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 /*{{{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, struct dsc$descriptor_s **tabvec, unsigned long int flags) { 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; 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}; struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0}, {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen}, {0, 0, 0, 0}}; $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); #if defined(USE_THREADS) /* 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); } else { thr = NULL; } #endif 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++) { *cp2 = _toupper(*cp1); if (cp1 - lnm > LNM$C_NAMLENGTH) { set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); return 0; } } lnmdsc.dsc$w_length = cp1 - lnm; lnmdsc.dsc$a_pointer = uplnm; uplnm[lnmdsc.dsc$w_length] = '\0'; secure = flags & PERL__TRNENV_SECURE; acmode = secure ? PSL$C_EXEC : PSL$C_USER; if (!tabvec || !*tabvec) tabvec = env_tables; for (curtab = 0; tabvec[curtab]; curtab++) { if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) { if (!ivenv && !secure) { char *eq, *end; int i; if (!environ) { ivenv = 1; Perl_warn(aTHX_ "Can't read CRTL environ\n"); continue; } retsts = SS$_NOLOGNAM; for (i = 0; environ[i]; i++) { if ((eq = strchr(environ[i],'=')) && !strncmp(environ[i],uplnm,eq - environ[i])) { eq++; for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen]; if (!eqvlen) continue; retsts = SS$_NORMAL; break; } } if (retsts != SS$_NOLOGNAM) break; } } else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) { if (!ivsym && !secure) { unsigned short int deflen = LNM$C_NAMLENGTH; struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; /* dynamic dsc to accomodate possible long value */ _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc)); retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0); if (retsts & 1) { if (eqvlen > 1024) { set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); eqvlen = 1024; /* Special hack--we might be called before the interpreter's */ /* 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 (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) } else { Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm); } #endif } strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); } _ckvmssts(lib$sfree1_dd(&eqvdsc)); if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } if (retsts == LIB$_NOSUCHSYM) continue; break; } } 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 INTSIZE == 4 *((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; } break; } } if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; } else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM || retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB || retsts == SS$_NOLOGNAM) { set_errno(EINVAL); set_vaxc_errno(retsts); } else _ckvmssts(retsts); return 0; } /* end of vmstrnenv */ /*}}}*/ /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/ /* Define as a function so we can access statics. */ int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) { return vmstrnenv(lnm,eqv,idx,fildev, #ifdef SECURE_INTERNAL_GETENV (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0 #else 0 #endif ); } /*}}}*/ /* my_getenv * Note: Uses Perl temp to store result so char * can be returned to * caller; this pointer will be invalidated at next Perl statement * transition. * We define this as a function rather than a macro in terms of my_getenv_len() * so that it'll work when PL_curinterp is undefined (and we therefore can't * allocate SVs). */ /*{{{ char *my_getenv(const char *lnm, bool sys)*/ char * 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, success, secure, saverr, savvmserr; SV *tmpsv; 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)); if (!tmpsv) return NULL; eqv = SvPVX(tmpsv); } else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */ 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, #ifdef SECURE_INTERNAL_GETENV secure ? PERL__TRNENV_SECURE : 0 #else 0 #endif ); /* 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() */ /*}}}*/ /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/ char * my_getenv_len(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 */ /* 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)); if (!tmpsv) return NULL; buf = SvPVX(tmpsv); } else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */ 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); *len = strlen(buf); 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, #ifdef SECURE_INTERNAL_GETENV secure ? PERL__TRNENV_SECURE : 0 #else 0 #endif ); /* 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 riseandshine(unsigned long int dummy) { sys$wake(0,0); } /*{{{ void prime_env_iter() */ void prime_env_iter(void) /* Fill the %ENV associative array with all logical names we can * find, in preparation for iterating over it. */ { dTHX; static int primed = 0; HV *seenhv = NULL, *envhv; char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch; unsigned short int chan; #ifndef CLI$M_TRUSTED # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */ #endif unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED; unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0; long int i; bool have_sym = FALSE, have_lnm = FALSE; struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:"); $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) static perl_mutex primenv_mutex; MUTEX_INIT(&primenv_mutex); #endif if (primed || !PL_envgv) return; MUTEX_LOCK(&primenv_mutex); if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; } envhv = GvHVn(PL_envgv); /* Perform a dummy fetch as an lval to insure that the hash table is * set up. Otherwise, the hv_store() will turn into a nullop. */ (void) hv_fetch(envhv,"DEFAULT",7,TRUE); for (i = 0; env_tables[i]; i++) { if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1; if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1; } if (have_sym || have_lnm) { long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0)); _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length)); } for (i--; i >= 0; i--) { if (!str$case_blind_compare(env_tables[i],&crtlenv)) { char *start; int j; 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]); } else { start++; (void) hv_store(envhv,environ[j],start - environ[j] - 1, newSVpv(start,0),0); } } continue; } else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) { strcpy(cmd,"Show Symbol/Global *"); cmddsc.dsc$w_length = 20; if (env_tables[i]->dsc$w_length == 12 && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) && !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *"); flags = defflags | CLI$M_NOLOGNAM; } else { strcpy(cmd,"Show Logical *"); if (str$case_blind_compare(env_tables[i],&fildevdsc)) { strcat(cmd," /Table="); strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length); cmddsc.dsc$w_length = strlen(cmd); } else cmddsc.dsc$w_length = 14; /* N.B. We test this below */ flags = defflags | CLI$M_NOCLISYM; } /* Create a new subprocess to execute each command, to exclude the * remote possibility that someone could subvert a mbx or file used * to write multiple commands to a single subprocess. */ do { retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs, 0,&riseandshine,0,0,&clidsc,&clitabdsc); flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */ defflags &= ~CLI$M_TRUSTED; } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED)); _ckvmssts(retsts); if (!buf) New(1322,buf,mbxbufsiz + 1,char); if (seenhv) SvREFCNT_dec(seenhv); seenhv = newHV(); while (1) { char *cp1, *cp2, *key; unsigned long int sts, iosb[2], retlen, keylen; register U32 hash; sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0); if (sts & 1) sts = iosb[0] & 0xffff; if (sts == SS$_ENDOFFILE) { int wakect = 0; while (substs == 0) { sys$hiber(); wakect++;} if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */ _ckvmssts(substs); break; } _ckvmssts(sts); retlen = iosb[0] >> 16; if (!retlen) continue; /* blank line */ buf[retlen] = '\0'; if (iosb[1] != subpid) { if (iosb[1]) { Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf); } continue; } if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf); for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ; if (*cp1 == '(' || /* Logical name table name */ *cp1 == '=' /* Next eqv of searchlist */) continue; if (*cp1 == '"') cp1++; for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ; key = cp1; keylen = cp2 - cp1; if (keylen && hv_exists(seenhv,key,keylen)) continue; while (*cp2 && *cp2 != '=') cp2++; while (*cp2 && *cp2 == '=') cp2++; while (*cp2 && *cp2 == ' ') cp2++; if (*cp2 == '"') { /* String translation; may embed "" */ for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ; cp2++; cp1--; /* Skip "" surrounding translation */ } else { /* Numeric translation */ for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ; 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); continue; } PERL_HASH(hash,key,keylen); hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash); hv_store(seenhv,key,keylen,&PL_sv_yes,hash); } if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */ /* get the PPFs for this process, not the subprocess */ char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL}; char eqv[LNM$C_NAMLENGTH+1]; 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); } } } primed = 1; if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan)); if (buf) Safefree(buf); if (seenhv) SvREFCNT_dec(seenhv); MUTEX_UNLOCK(&primenv_mutex); return; } /* end of prime_env_iter */ /*}}}*/ /*{{{ int vmssetenv(char *lnm, 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 * place designated by the first element of the table vector. * Like setenv() returns 0 for success, non-zero on error. */ int vmssetenv(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; unsigned long int retsts, usermode = PSL$C_USER; 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"); dTHX; for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { *cp2 = _toupper(*cp1); if (cp1 - lnm > LNM$C_NAMLENGTH) { set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM); return SS$_IVLOGNAM; } } lnmdsc.dsc$w_length = cp1 - lnm; if (!tabvec || !*tabvec) tabvec = env_tables; if (!eqv) { /* we're deleting n element */ 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 */ if ((cp1 = strchr(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); ivenv = 1; retsts = SS$_NOSUCHPGM; break; } } #endif } else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) { unsigned int symtype; if (tabvec[curtab]->dsc$w_length == 12 && (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) && !str$case_blind_compare(&tmpdsc,&local)) symtype = LIB$K_CLI_LOCAL_SYM; else symtype = LIB$K_CLI_GLOBAL_SYM; retsts = lib$delete_symbol(&lnmdsc,&symtype); if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; } if (retsts == LIB$_NOSUCHSYM) continue; break; } else if (!ivlnm) { retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; } if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break; retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */ if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break; } } } else { /* we're defining a value */ if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) { #ifdef HAS_SETENV 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); retsts = SS$_NOSUCHPGM; #endif } else { eqvdsc.dsc$a_pointer = eqv; eqvdsc.dsc$w_length = strlen(eqv); if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) { unsigned int symtype; if (tabvec[0]->dsc$w_length == 12 && (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) && !str$case_blind_compare(&tmpdsc,&local)) symtype = LIB$K_CLI_LOCAL_SYM; else symtype = LIB$K_CLI_GLOBAL_SYM; retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype); } 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); } } retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); } } } if (!(retsts & 1)) { switch (retsts) { case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM: case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB: set_errno(EVMSERR); break; case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM: case LIB$_NOSUCHSYM: case SS$_NOLOGNAM: set_errno(EINVAL); break; case SS$_NOPRIV: set_errno(EACCES); default: _ckvmssts(retsts); set_errno(EVMSERR); } set_vaxc_errno(retsts); return (int) retsts || 44; /* retsts should never be 0, but just in case */ } else { /* We reset error values on success because Perl does an hv_fetch() * before each hv_store(), and if the thing we're setting didn't * previously exist, we've got a leftover error message. (Of course, * this fails in the face of * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo'; * in that the error reported in $! isn't spurious, * but it's right more often than not.) */ set_errno(0); set_vaxc_errno(retsts); return 0; } } /* end of vmssetenv() */ /*}}}*/ /*{{{ void my_setenv(char *lnm, 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) { 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]; 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 } (void) vmssetenv(lnm,eqv,NULL); } /*}}}*/ /*{{{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(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)*/ /* my_crypt - VMS password hashing * my_crypt() provides an interface compatible with the Unix crypt() * C library function, and uses sys$hash_password() to perform VMS * password hashing. The quadword hashed password value is returned * as a NUL-terminated 8 character string. my_crypt() does not change * the case of its string arguments; in order to match the behavior * of LOGINOUT et al., alphabetic characters in both arguments must * be upcased by the caller. */ char * my_crypt(const char *textpasswd, const char *usrname) { # ifndef UAI$C_PREFERRED_ALGORITHM # define UAI$C_PREFERRED_ALGORITHM 127 # endif unsigned char alg = UAI$C_PREFERRED_ALGORITHM; unsigned short int salt = 0; unsigned long int sts; struct const_dsc { unsigned short int dsc$w_length; unsigned char dsc$b_type; unsigned char dsc$b_class; const char * dsc$a_pointer; } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; struct itmlst_3 uailst[3] = { { sizeof alg, UAI$_ENCRYPT, &alg, 0}, { sizeof salt, UAI$_SALT, &salt, 0}, { 0, 0, NULL, NULL}}; static char hash[9]; usrdsc.dsc$w_length = strlen(usrname); usrdsc.dsc$a_pointer = usrname; if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) { switch (sts) { case SS$_NOGRPPRV: case SS$_NOSYSPRV: set_errno(EACCES); break; case RMS$_RNF: set_errno(ESRCH); /* There isn't a Unix no-such-user error */ break; default: set_errno(EVMSERR); } set_vaxc_errno(sts); if (sts != RMS$_RNF) return NULL; } txtdsc.dsc$w_length = strlen(textpasswd); txtdsc.dsc$a_pointer = textpasswd; if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) { set_errno(EVMSERR); set_vaxc_errno(sts); return NULL; } return (char *) hash; } /* end of my_crypt() */ /*}}}*/ static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned); static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int); static char *mp_do_tovmsspec(pTHX_ char *, char *, int); /*{{{int do_rmdir(char *name)*/ int Perl_do_rmdir(pTHX_ char *name) { char dirfile[NAM$C_MAXRSS+1]; int retval; Stat_t st; if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1; if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; else retval = kill_file(dirfile); return retval; } /* end of do_rmdir */ /*}}}*/ /* kill_file * Delete any file to which user has control access, regardless of whether * delete access is explicitly allowed. * Limitations: User must have write access to parent directory. * Does not block signals or ASTs; if interrupted in midstream * may leave file with an altered ACL. * HANDLE WITH CARE! */ /*{{{int kill_file(char *name)*/ int kill_file(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; unsigned char myace$b_type; unsigned short int myace$w_flags; unsigned long int myace$l_access; unsigned long int myace$l_ident; } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0, ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0}, oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; struct itmlst_3 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0}, {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}}, addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}}, dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}}, lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}}, ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}}; /* Expand the input spec using RMS, since the CRTL remove() and * system services won't do this by themselves, so we may miss * a file "hiding" behind a logical name or search list. */ if (do_tovmsspec(name,vmsname,0) == NULL) return -1; if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1; if (!remove(rspec)) return 0; /* Can we just get rid of it? */ /* If not, can changing protections help? */ if (vaxc$errno != RMS$_PRV) return -1; /* No, so we get our own UIC to use as a rights identifier, * and the insert an ACE at the head of the ACL which allows us * to delete the file. */ _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0)); fildsc.dsc$w_length = strlen(rspec); fildsc.dsc$a_pointer = rspec; cxt = 0; newace.myace$l_ident = oldace.myace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { switch (aclsts) { case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: set_errno(ENOENT); break; case RMS$_DIR: set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; case RMS$_SYN: case SS$_INVFILFOROP: set_errno(EINVAL); break; case RMS$_PRV: set_errno(EACCES); break; default: _ckvmssts(aclsts); } set_vaxc_errno(aclsts); return -1; } /* Grab any existing ACEs with this identifier in case we fail */ aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt); if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY || fndsts == SS$_NOMOREACE ) { /* Add the new ACE . . . */ if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) goto yourroom; if ((rmsts = remove(name))) { /* We blew it - dir with files in it, no write priv for * parent directory, etc. Put things back the way they were. */ if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) goto yourroom; if (fndsts & 1) { addlst[0].bufadr = &oldace; if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1)) goto yourroom; } } } yourroom: fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0); /* We just deleted it, so of course it's not there. Some versions of * VMS seem to return success on the unlock operation anyhow (after all * the unlock is successful), but others don't. */ if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL; if (aclsts & 1) aclsts = fndsts; if (!(aclsts & 1)) { set_errno(EVMSERR); set_vaxc_errno(aclsts); return -1; } return rmsts; } /* end of kill_file() */ /*}}}*/ /*{{{int my_mkdir(char *,Mode_t)*/ int my_mkdir(char *dir, Mode_t mode) { STRLEN dirlen = strlen(dir); dTHX; /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; /* CRTL mkdir() doesn't tolerate trailing /, since that implies * null file name/type. However, it's commonplace under Unix, * so we'll allow it for a gain in portability. */ if (dir[dirlen-1] == '/') { char *newdir = savepvn(dir,dirlen-1); int ret = mkdir(newdir,mode); Safefree(newdir); return ret; } else return mkdir(dir,mode); } /* end of my_mkdir */ /*}}}*/ /*{{{int my_chdir(char *)*/ int my_chdir(char *dir) { STRLEN dirlen = strlen(dir); dTHX; /* zero length string sometimes gives ACCVIO */ if (dirlen == 0) return -1; /* some versions of CRTL chdir() doesn't tolerate trailing /, since * that implies * null file name/type. However, it's commonplace under Unix, * so we'll allow it for a gain in portability. */ if (dir[dirlen-1] == '/') { char *newdir = savepvn(dir,dirlen-1); int ret = chdir(newdir); Safefree(newdir); return ret; } else return chdir(dir); } /* end of my_chdir */ /*}}}*/ /*{{{FILE *my_tmpfile()*/ FILE * my_tmpfile(void) { FILE *fp; char *cp; dTHX; if ((fp = tmpfile())) return fp; New(1323,cp,L_tmpnam+24,char); strcpy(cp,"Sys$Scratch:"); tmpnam(cp+strlen(cp)); strcat(cp,".Perltmp"); fp = fopen(cp,"w+","fop=dlt"); Safefree(cp); return fp; } /*}}}*/ /* default piping mailbox size */ #define PERL_BUFSIZ 512 static void create_mbx(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) { unsigned long syiitm = SYI$_MAXBUF; /* * Get the SYSGEN parameter MAXBUF * * If the logical 'PERL_MBX_SIZE' is defined * use the value of the logical instead of PERL_BUFSIZ, but * keep the size between 128 and MAXBUF. * */ _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0)); } if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) { mbxbufsiz = atoi(csize); } else { mbxbufsiz = PERL_BUFSIZ; } if (mbxbufsiz < 128) mbxbufsiz = 128; if (mbxbufsiz > syssize) mbxbufsiz = syssize; _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0'; } /* end of create_mbx() */ /*{{{ my_popen and my_pclose*/ typedef struct _iosb IOSB; typedef struct _iosb* pIOSB; typedef struct _pipe Pipe; typedef struct _pipe* pPipe; typedef struct pipe_details Info; typedef struct pipe_details* pInfo; typedef struct _srqp RQE; typedef struct _srqp* pRQE; typedef struct _tochildbuf CBuf; typedef struct _tochildbuf* pCBuf; struct _iosb { unsigned short status; unsigned short count; unsigned long dvispec; }; #pragma member_alignment save #pragma nomember_alignment quadword struct _srqp { /* VMS self-relative queue entry */ unsigned long qptr[2]; }; #pragma member_alignment restore static RQE RQE_ZERO = {0,0}; struct _tochildbuf { RQE q; int eof; unsigned short size; char *buf; }; struct _pipe { RQE free; RQE wait; int fd_out; unsigned short chan_in; unsigned short chan_out; char *buf; unsigned int bufsize; IOSB iosb; IOSB iosb2; int *pipe_done; int retry; int type; int shut_on_empty; int need_wake; pPipe *home; pInfo info; pCBuf curr; pCBuf curr2; }; struct pipe_details { pInfo next; PerlIO *fp; /* stdio file pointer to pipe mailbox */ int pid; /* PID of subprocess */ int mode; /* == 'r' if pipe open for reading */ int done; /* subprocess has completed */ int closing; /* my_pclose is closing this pipe */ unsigned long completion; /* termination status of subprocess */ pPipe in; /* pipe in to sub */ pPipe out; /* pipe out of sub */ pPipe err; /* pipe of sub's sys$error */ int in_done; /* true when in pipe finished */ int out_done; int err_done; }; struct exit_control_block { struct exit_control_block *flink; unsigned long int (*exit_routine)(); unsigned long int arg_count; unsigned long int *status_address; unsigned long int exit_status; }; #define RETRY_DELAY "0 ::0.20" #define MAX_RETRY 50 static int pipe_ef = 0; /* first call to safe_popen inits these*/ static unsigned long mypid; static unsigned long delaytime[2]; static pInfo open_pipes = NULL; static $DESCRIPTOR(nl_desc, "NL:"); static unsigned long int pipe_exit_routine() { 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 don't hang */ did_stuff = 0; info = open_pipes; while (info) { int need_eof; _ckvmssts(sys$setast(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)); did_stuff = 1; } _ckvmssts(sys$setast(1)); info = info->next; } if (did_stuff) sleep(1); /* wait for EOF to have an effect */ did_stuff = 0; info = open_pipes; while (info) { _ckvmssts(sys$setast(0)); if (!info->done) { /* Tap them gently on the shoulder . . .*/ sts = sys$forcex(&info->pid,0,&abort); if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); did_stuff = 1; } _ckvmssts(sys$setast(1)); info = info->next; } if (did_stuff) sleep(1); /* wait for them to respond */ info = open_pipes; while (info) { _ckvmssts(sys$setast(0)); if (!info->done) { /* We tried to be nice . . . */ sts = sys$delprc(&info->pid,0); if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); } _ckvmssts(sys$setast(1)); info = info->next; } while(open_pipes) { if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno; else if (!(sts & 1)) retsts = sts; } return retsts; } static struct exit_control_block pipe_exitblock = {(struct exit_control_block *) 0, pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0}; static void pipe_mbxtofd_ast(pPipe p); static void pipe_tochild1_ast(pPipe p); static void pipe_tochild2_ast(pPipe p); static void popen_completion_ast(pInfo info) { dTHX; pInfo i = open_pipes; int iss; while (i) { if (i == info) break; i = i->next; } if (!i) return; /* unlinked, probably freed too */ info->completion &= 0x0FFFFFFF; /* strip off "control" field */ info->done = TRUE; /* Writing to subprocess ... if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe chan_out may be waiting for "done" flag, or hung waiting for i/o completion to child...cancel the i/o. This will put it into "snarf mode" (done but no EOF yet) that discards input. Output from subprocess (stdout, stderr) needs to be flushed and shut down. We try sending an EOF, but if the mbx is full the pipe routine should still catch the "shut_on_empty" flag, telling it to use immediate-style reads so that "mbx empty" -> EOF. */ 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)); } else { _ckvmssts(sys$cancel(info->in->chan_out)); } } if (info->out && !info->out_done) { /* were we also piping output? */ 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); } 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(sys$setef(pipe_ef)); } static unsigned long int setup_cmddsc(char *cmd, int check_img); static void vms_execfree(pTHX); /* we actually differ from vmstrnenv since we use this to get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really* are pointing to the same thing */ static unsigned short popen_translate(char *logical, char *result) { int iss; $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE"); $DESCRIPTOR(d_log,""); struct _il3 { unsigned short length; unsigned short code; char * buffer_addr; unsigned short *retlenaddr; } itmlst[2]; unsigned short l, ifi; d_log.dsc$a_pointer = logical; d_log.dsc$w_length = strlen(logical); itmlst[0].code = LNM$_STRING; itmlst[0].length = 255; itmlst[0].buffer_addr = result; itmlst[0].retlenaddr = &l; itmlst[1].code = 0; itmlst[1].length = 0; itmlst[1].buffer_addr = 0; itmlst[1].retlenaddr = 0; iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst); if (iss == SS$_NOLOGNAM) { iss = SS$_NORMAL; l = 0; } if (!(iss&1)) lib$signal(iss); result[l] = '\0'; /* logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI) strip it off and return the ifi, if any */ ifi = 0; if (result[0] == 0x1b && result[1] == 0x00) { memcpy(&ifi,result+2,2); strcpy(result,result+4); } return ifi; /* this is the RMS internal file id */ } #define MAX_DCL_SYMBOL 255 static void pipe_infromchild_ast(pPipe p); /* I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate inside an AST routine without worrying about reentrancy and which Perl memory allocator is being used. We read data and queue up the buffers, then spit them out one at a time to the output mailbox when the output mailbox is ready for one. */ #define INITIAL_TOCHILDQUEUE 2 static pPipe pipe_tochild_setup(char *rmbx, char *wmbx) { dTHX; pPipe p; pCBuf b; char mbx1[64], mbx2[64]; struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx1}, d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx2}; unsigned int dviitm = DVI$_DEVBUFSIZ; int j, n; New(1368, p, 1, Pipe); create_mbx(&p->chan_in , &d_mbx1); create_mbx(&p->chan_out, &d_mbx2); _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); p->buf = 0; p->shut_on_empty = FALSE; p->need_wake = FALSE; p->type = 0; p->retry = 0; p->iosb.status = SS$_NORMAL; p->iosb2.status = SS$_NORMAL; p->free = RQE_ZERO; p->wait = RQE_ZERO; p->curr = 0; p->curr2 = 0; p->info = 0; n = sizeof(CBuf) + p->bufsize; for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) { _ckvmssts(lib$get_vm(&n, &b)); b->buf = (char *) b + sizeof(CBuf); _ckvmssts(lib$insqhi(b, &p->free)); } pipe_tochild2_ast(p); pipe_tochild1_ast(p); strcpy(wmbx, mbx1); strcpy(rmbx, mbx2); return p; } /* reads the MBX Perl is writing, and queues */ static void pipe_tochild1_ast(pPipe p) { dTHX; pCBuf b = p->curr; int iss = p->iosb.status; int eof = (iss == SS$_ENDOFFILE); if (p->retry) { if (eof) { p->shut_on_empty = TRUE; b->eof = TRUE; _ckvmssts(sys$dassgn(p->chan_in)); } else { _ckvmssts(iss); } b->eof = eof; b->size = p->iosb.count; _ckvmssts(lib$insqhi(b, &p->wait)); if (p->need_wake) { p->need_wake = FALSE; _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0)); } } else { p->retry = 1; /* initial call */ } if (eof) { /* flush the free queue, return when done */ int n = sizeof(CBuf) + p->bufsize; while (1) { iss = lib$remqti(&p->free, &b); if (iss == LIB$_QUEWASEMP) return; _ckvmssts(iss); _ckvmssts(lib$free_vm(&n, &b)); } } iss = lib$remqti(&p->free, &b); if (iss == LIB$_QUEWASEMP) { int n = sizeof(CBuf) + p->bufsize; _ckvmssts(lib$get_vm(&n, &b)); b->buf = (char *) b + sizeof(CBuf); } else { _ckvmssts(iss); } p->curr = b; iss = sys$qio(0,p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0), &p->iosb, pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0); if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL; _ckvmssts(iss); } /* writes queued buffers to output, waits for each to complete before doing the next */ 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; do { if (p->type) { /* type=1 has old buffer, dispose */ if (p->shut_on_empty) { _ckvmssts(lib$free_vm(&n, &b)); } else { _ckvmssts(lib$insqhi(b, &p->free)); } p->type = 0; } iss = lib$remqti(&p->wait, &b); if (iss == LIB$_QUEWASEMP) { if (p->shut_on_empty) { if (done) { _ckvmssts(sys$dassgn(p->chan_out)); *p->pipe_done = TRUE; _ckvmssts(sys$setef(pipe_ef)); } else { _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); } return; } p->need_wake = TRUE; return; } _ckvmssts(iss); p->type = 1; } while (done); p->curr2 = b; if (b->eof) { _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); } else { _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK, &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0)); } return; } static pPipe pipe_infromchild_setup(char *rmbx, char *wmbx) { dTHX; pPipe p; char mbx1[64], mbx2[64]; struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx1}, d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx2}; unsigned int dviitm = DVI$_DEVBUFSIZ; New(1367, p, 1, Pipe); create_mbx(&p->chan_in , &d_mbx1); create_mbx(&p->chan_out, &d_mbx2); _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); New(1367, p->buf, p->bufsize, char); p->shut_on_empty = FALSE; p->info = 0; p->type = 0; p->iosb.status = SS$_NORMAL; pipe_infromchild_ast(p); strcpy(wmbx, mbx1); strcpy(rmbx, mbx2); return p; } 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 (p->info && p->info->closing && p->chan_out) { /* output shutdown */ _ckvmssts(sys$dassgn(p->chan_out)); p->chan_out = 0; } /* read completed: input shutdown if EOF from self (done or shut_on_empty) output shutdown if closing flag set (my_pclose) send data/eof from child or eof from self otherwise, re-read (snarf of data from child) */ if (p->type == 1) { p->type = 0; if (myeof && p->chan_in) { /* input shutdown */ _ckvmssts(sys$dassgn(p->chan_in)); p->chan_in = 0; } if (p->chan_out) { if (myeof || kideof) { /* pass EOF to parent */ _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb, pipe_infromchild_ast, p, 0, 0, 0, 0, 0, 0)); return; } else if (eof) { /* eat EOF --- fall through to read*/ } else { /* transmit data */ _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb, pipe_infromchild_ast,p, p->buf, p->iosb.count, 0, 0, 0, 0)); return; } } } /* everything shut? flag as done */ if (!p->chan_in && !p->chan_out) { *p->pipe_done = TRUE; _ckvmssts(sys$setef(pipe_ef)); return; } /* write completed (or read, if snarfing from child) if still have input active, queue read...immediate mode if shut_on_empty so we get EOF if empty otherwise, check if Perl reading, generate EOFs as needed */ if (p->type == 0) { p->type = 1; if (p->chan_in) { iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb, pipe_infromchild_ast,p, p->buf, p->bufsize, 0, 0, 0, 0); if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL; _ckvmssts(iss); } else { /* send EOFs for extra reads */ p->iosb.status = SS$_ENDOFFILE; p->iosb.dvispec = 0; _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN, 0, 0, 0, pipe_infromchild_ast, p, 0, 0, 0, 0)); } } } static pPipe pipe_mbxtofd_setup(int fd, char *out) { dTHX; pPipe p; char mbx[64]; unsigned long dviitm = DVI$_DEVBUFSIZ; struct stat s; struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx}; /* things like terminals and mbx's don't need this filter */ if (fd && fstat(fd,&s) == 0) { unsigned long dviitm = DVI$_DEVCHAR, devchar; struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T, DSC$K_CLASS_S, s.st_dev}; _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0)); if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/ strcpy(out, s.st_dev); return 0; } } New(1366, p, 1, Pipe); p->fd_out = dup(fd); create_mbx(&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; p->retry = 0; p->info = 0; strcpy(out, mbx); _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb, pipe_mbxtofd_ast, p, p->buf, p->bufsize, 0, 0, 0, 0)); return p; } 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 (done && myeof) { /* end piping */ close(p->fd_out); sys$dassgn(p->chan_in); *p->pipe_done = TRUE; _ckvmssts(sys$setef(pipe_ef)); return; } if (!err && !eof) { /* good data to send to file */ p->buf[p->iosb.count] = '\n'; iss2 = write(p->fd_out, p->buf, p->iosb.count+1); if (iss2 < 0) { p->retry++; if (p->retry < MAX_RETRY) { _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p)); return; } } p->retry = 0; } else if (err) { _ckvmssts(iss); } iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb, pipe_mbxtofd_ast, p, p->buf, p->bufsize, 0, 0, 0, 0); if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL; _ckvmssts(iss); } typedef struct _pipeloc PLOC; typedef struct _pipeloc* pPLOC; struct _pipeloc { pPLOC next; char dir[NAM$C_MAXRSS+1]; }; static pPLOC head_PLOC = 0; void free_pipelocs(void *head) { pPLOC p, pnext; p = (pPLOC) head; while (p) { pnext = p->next; Safefree(p); p = pnext; } } static void store_pipelocs() { int i; pPLOC p; AV *av = GvAVn(PL_incgv); SV *dirsv; GV *gv; char *dir, *x; char *unixdir; char temp[NAM$C_MAXRSS+1]; STRLEN n_a; /* the . directory from @INC comes last */ New(1370,p,1,PLOC); p->next = head_PLOC; head_PLOC = p; strcpy(p->dir,"./"); /* get the directory from $^X */ if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */ strcpy(temp, PL_origargv[0]); x = strrchr(temp,']'); if (x) x[1] = '\0'; if ((unixdir = tounixpath(temp, Nullch)) != Nullch) { New(1370,p,1,PLOC); p->next = head_PLOC; head_PLOC = p; strncpy(p->dir,unixdir,sizeof(p->dir)-1); p->dir[NAM$C_MAXRSS] = '\0'; } } /* reverse order of @INC entries, skip "." since entered above */ for (i = 0; i <= AvFILL(av); i++) { dirsv = *av_fetch(av,i,TRUE); if (SvROK(dirsv)) continue; dir = SvPVx(dirsv,n_a); if (strcmp(dir,".") == 0) continue; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) continue; New(1370,p,1,PLOC); p->next = head_PLOC; head_PLOC = p; strncpy(p->dir,unixdir,sizeof(p->dir)-1); p->dir[NAM$C_MAXRSS] = '\0'; } /* most likely spot (ARCHLIB) put first in the list */ #ifdef ARCHLIB_EXP if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) { New(1370,p,1,PLOC); p->next = head_PLOC; head_PLOC = p; strncpy(p->dir,unixdir,sizeof(p->dir)-1); p->dir[NAM$C_MAXRSS] = '\0'; } #endif Perl_call_atexit(&free_pipelocs, head_PLOC); } static char * find_vmspipe(void) { static int vmspipe_file_status = 0; static char vmspipe_file[NAM$C_MAXRSS+1]; /* already found? Check and use ... need read+execute permission */ if (vmspipe_file_status == 1) { if (cando_by_name(S_IRUSR, 0, vmspipe_file) && cando_by_name(S_IXUSR, 0, vmspipe_file)) { return vmspipe_file; } vmspipe_file_status = 0; } /* scan through stored @INC, $^X */ if (vmspipe_file_status == 0) { char file[NAM$C_MAXRSS+1]; pPLOC p = head_PLOC; while (p) { strcpy(file, p->dir); strncat(file, "vmspipe.com",NAM$C_MAXRSS); file[NAM$C_MAXRSS] = '\0'; p = p->next; if (!do_tovmsspec(file,vmspipe_file,0)) continue; if (cando_by_name(S_IRUSR, 0, vmspipe_file) && cando_by_name(S_IXUSR, 0, vmspipe_file)) { vmspipe_file_status = 1; return vmspipe_file; } } vmspipe_file_status = -1; /* failed, use tempfiles */ } return 0; } static FILE * vmspipe_tempfile(void) { char file[NAM$C_MAXRSS+1]; FILE *fp; static int index = 0; stat_t s0, s1; /* create a tempfile */ /* we can't go from W, shr=get to R, shr=get without an intermediate vulnerable state, so don't bother trying... and lib$spawn doesn't shr=put, so have to close the write So... match up the creation date/time and the FID to make sure we're dealing with the same file */ index++; sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index); fp = fopen(file,"w"); if (!fp) { sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index); fp = fopen(file,"w"); if (!fp) { sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index); fp = fopen(file,"w"); } } if (!fp) return 0; /* we're hosed */ 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,"$ perl_on = \"set noon\"\n"); fprintf(fp,"$ perl_exit = \"exit\"\n"); 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/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_exit 'perl_status'\n"); fsync(fileno(fp)); fgetname(fp, file, 1); fstat(fileno(fp), &s0); fclose(fp); fp = fopen(file,"r","shr=get"); if (!fp) return 0; fstat(fileno(fp), &s1); if (s0.st_ino[0] != s1.st_ino[0] || s0.st_ino[1] != s1.st_ino[1] || s0.st_ino[2] != s1.st_ino[2] || s0.st_ctime != s1.st_ctime ) { fclose(fp); return 0; } return fp; } static PerlIO * safe_popen(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; char *p, 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; 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"); $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... note that the SETAST calls and the dual test of pipe_ef makes sure that only the FIRST thread through here does the initialization...all other threads wait until it's done. Yeah, uglier than a pthread call, it's got all the stuff inline rather than in a separate routine. */ if (!pipe_ef) { _ckvmssts(sys$setast(0)); if (!pipe_ef) { unsigned long int pidcode = JPI$_PID; $DESCRIPTOR(d_delay, RETRY_DELAY); _ckvmssts(lib$get_ef(&pipe_ef)); _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0)); _ckvmssts(sys$bintim(&d_delay, delaytime)); } if (!handler_set_up) { _ckvmssts(sys$dclexh(&pipe_exitblock)); handler_set_up = TRUE; } _ckvmssts(sys$setast(1)); } /* see if we can find a VMSPIPE.COM */ tfilebuf[0] = '@'; vmspipe = find_vmspipe(); if (vmspipe) { strcpy(tfilebuf+1,vmspipe); } else { /* uh, oh...we're in tempfile hell */ tpipe = vmspipe_tempfile(); 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"); } return Nullfp; } fgetname(tpipe,tfilebuf+1,1); } vmspipedsc.dsc$a_pointer = tfilebuf; vmspipedsc.dsc$w_length = strlen(tfilebuf); if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } New(1301,info,1,Info); info->mode = *mode; info->done = FALSE; info->completion = 0; info->closing = FALSE; info->in = 0; info->out = 0; info->err = 0; 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 */ info->out = pipe_infromchild_setup(mbx,out); if (info->out) { info->out->pipe_done = &info->out_done; info->out_done = FALSE; info->out->info = info; } info->fp = PerlIO_open(mbx, mode); if (!info->fp && info->out) { sys$cancel(info->out->chan_out); while (!info->out_done) { int done; _ckvmssts(sys$setast(0)); done = info->out_done; 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); if (info->err) { info->err->pipe_done = &info->err_done; info->err_done = FALSE; info->err->info = info; } } else { /* piping to subroutine , mode=w*/ info->in = pipe_tochild_setup(in,mbx); info->fp = PerlIO_open(mbx, mode); if (info->in) { info->in->pipe_done = &info->in_done; info->in_done = FALSE; info->in->info = info; } /* error cleanup */ if (!info->fp && info->in) { info->done = TRUE; _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0, 0, 0, 0, 0, 0, 0, 0, 0)); while (!info->in_done) { int done; _ckvmssts(sys$setast(0)); done = info->in_done; if (!done) _ckvmssts(sys$clref(pipe_ef)); _ckvmssts(sys$setast(1)); if (!done) _ckvmssts(sys$waitfr(pipe_ef)); } if (info->in->buf) Safefree(info->in->buf); Safefree(info->in); Safefree(info); return Nullfp; } info->out = pipe_mbxtofd_setup(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(fileno(stderr), err); if (info->err) { info->err->pipe_done = &info->err_done; info->err_done = FALSE; info->err->info = info; } } symbol[MAX_DCL_SYMBOL] = '\0'; strncpy(symbol, in, MAX_DCL_SYMBOL); d_symbol.dsc$w_length = strlen(symbol); _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table)); strncpy(symbol, err, MAX_DCL_SYMBOL); 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++; *p = '\0'; /* truncate on \n */ p = VMScmd.dsc$a_pointer; while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */ if (*p == '$') p++; /* remove leading $ */ while (*p == ' ' || *p == '\t') p++; strncpy(symbol, p, MAX_DCL_SYMBOL); d_symbol.dsc$w_length = strlen(symbol); _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table)); _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, 0, &info->pid, &info->completion, 0, popen_completion_ast,info,0,0,0)); /* if we were using a tempfile, close it now */ if (tpipe) fclose(tpipe); /* once the subprocess is spawned, its copied the symbols and we can get rid of ours */ _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; return info->fp; } /* end of safe_popen */ /*{{{ FILE *my_popen(char *cmd, char *mode)*/ FILE * Perl_my_popen(pTHX_ char *cmd, char *mode) { TAINT_ENV(); TAINT_PROPER("popen"); PERL_FLUSHALL_FOR_CHILD; return safe_popen(cmd,mode); } /*}}}*/ /*{{{ I32 my_pclose(FILE *fp)*/ I32 Perl_my_pclose(pTHX_ FILE *fp) { dTHX; pInfo info, last = NULL; unsigned long int retsts; int done, iss; for (info = open_pipes; info != NULL; last = info, info = info->next) if (info->fp == fp) break; if (info == NULL) { /* no such pipe open */ set_errno(ECHILD); /* quoth POSIX */ set_vaxc_errno(SS$_NONEXPR); return -1; } /* If we were writing to a subprocess, insure that someone reading from * the mailbox gets an EOF. It looks like a simple fclose() doesn't * produce an EOF record in the mailbox. * * well, at least sometimes it *does*, so we have to watch out for * the first EOF closing the pipe (and DASSGN'ing the channel)... */ fsync(fileno(info->fp)); /* first, flush data */ _ckvmssts(sys$setast(0)); info->closing = TRUE; done = info->done && info->in_done && info->out_done && info->err_done; /* hanging on write to Perl's input? cancel it */ if (info->mode == 'r' && info->out && !info->out_done) { if (info->out->chan_out) { _ckvmssts(sys$cancel(info->out->chan_out)); if (!info->out->chan_in) { /* EOF generation, need AST */ _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0)); } } } if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */ _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, 0, 0, 0, 0, 0, 0)); _ckvmssts(sys$setast(1)); PerlIO_close(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 that the i/o ASTs could still be using... */ while (!done) { _ckvmssts(sys$setast(0)); done = info->done && info->in_done && info->out_done && info->err_done; if (!done) _ckvmssts(sys$clref(pipe_ef)); _ckvmssts(sys$setast(1)); if (!done) _ckvmssts(sys$waitfr(pipe_ef)); } retsts = info->completion; /* remove from list of open pipes */ _ckvmssts(sys$setast(0)); if (last) last->next = info->next; else open_pipes = info->next; _ckvmssts(sys$setast(1)); /* free buffers and structures */ if (info->in) { if (info->in->buf) Safefree(info->in->buf); Safefree(info->in); } if (info->out) { if (info->out->buf) Safefree(info->out->buf); Safefree(info->out); } if (info->err) { if (info->err->buf) Safefree(info->err->buf); Safefree(info->err); } Safefree(info); return retsts; } /* end of my_pclose() */ /* sort-of waitpid; use only with popen() */ /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/ Pid_t my_waitpid(Pid_t pid, int *statusp, int flags) { pInfo info; int done; dTHX; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; if (info != NULL) { /* we know about this child */ while (!info->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)); } *statusp = info->completion; return pid; } else { /* we haven't heard of this child */ $DESCRIPTOR(intdsc,"0 00:00:01"); unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid; unsigned long int interval[2],sts; if (ckWARN(WARN_EXEC)) { _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); if (ownerpid != mypid) Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid); } _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; _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. */ *statusp = 0; return pid; } } /* end of waitpid() */ /*}}}*/ /*}}}*/ /*}}}*/ /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */ char * my_gconvert(double val, int ndig, int trail, char *buf) { static char __gcvtbuf[DBL_DIG+1]; char *loc; loc = buf ? buf : __gcvtbuf; #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */ if (val < 1) { sprintf(loc,"%.*g",ndig,val); return loc; } #endif if (val) { if (!buf && ndig > DBL_DIG) ndig = DBL_DIG; return gcvt(val,ndig,loc); } else { loc[0] = '0'; loc[1] = '\0'; return loc; } } /*}}}*/ /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/ /* Shortcut for common case of simple calls to $PARSE and $SEARCH * to expand file specification. Allows for a single default file * specification and a simple mask of options. If outbuf is non-NULL, * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which * the resultant file specification is placed. If outbuf is NULL, the * resultant file specification is placed into a static buffer. * The third argument, if non-NULL, is taken to be a default file * specification string. The fourth argument is unused at present. * rmesexpand() returns the address of the resultant string if * successful, and NULL on error. */ static char *mp_do_tounixspec(pTHX_ char *, char *, int); static char * mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) { static char __rmsexpand_retbuf[NAM$C_MAXRSS+1]; char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1]; char esa[NAM$C_MAXRSS], *cp, *out = NULL; struct FAB myfab = cc$rms_fab; struct NAM mynam = cc$rms_nam; STRLEN speclen; unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; if (!filespec || !*filespec) { set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); return NULL; } if (!outbuf) { if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char); else outbuf = __rmsexpand_retbuf; } if ((isunix = (strchr(filespec,'/') != NULL))) { if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL; filespec = vmsfspec; } myfab.fab$l_fna = filespec; myfab.fab$b_fns = strlen(filespec); myfab.fab$l_nam = &mynam; if (defspec && *defspec) { if (strchr(defspec,'/') != NULL) { if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL; defspec = tmpfspec; } myfab.fab$l_dna = defspec; myfab.fab$b_dns = strlen(defspec); } mynam.nam$l_esa = esa; mynam.nam$b_ess = sizeof esa; mynam.nam$l_rsa = outbuf; mynam.nam$b_rss = NAM$C_MAXRSS; retsts = sys$parse(&myfab,0,0); if (!(retsts & 1)) { mynam.nam$b_nop |= NAM$M_SYNCHK; if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { retsts = sys$parse(&myfab,0,0); if (retsts & 1) goto expanded; } mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ if (out) Safefree(out); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else if (retsts == RMS$_DEV) set_errno(ENODEV); else if (retsts == RMS$_DIR) set_errno(ENOTDIR); else set_errno(EVMSERR); return NULL; } retsts = sys$search(&myfab,0,0); if (!(retsts & 1) && retsts != RMS$_FNF) { mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ if (out) Safefree(out); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else set_errno(EVMSERR); return NULL; } /* If the input filespec contained any lowercase characters, * downcase the result for compatibility with Unix-minded code. */ expanded: for (out = myfab.fab$l_fna; *out; out++) if (islower(*out)) { haslower = 1; break; } if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } else { out = esa; speclen = mynam.nam$b_esl; } /* Trim off null fields added by $PARSE * If type > 1 char, must have been specified in original or default spec * (not true for version; $SEARCH may have added version of existing file). */ trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER); trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && (mynam.nam$l_ver - mynam.nam$l_type == 1); if (trimver || trimtype) { if (defspec && *defspec) { char defesa[NAM$C_MAXRSS]; struct FAB deffab = cc$rms_fab; struct NAM defnam = cc$rms_nam; deffab.fab$l_nam = &defnam; deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns; defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa; defnam.nam$b_nop = NAM$M_SYNCHK; if (sys$parse(&deffab,0,0) & 1) { if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); } } if (trimver) speclen = mynam.nam$l_ver - out; if (trimtype) { /* If we didn't already trim version, copy down */ if (speclen > mynam.nam$l_ver - out) memcpy(mynam.nam$l_type, mynam.nam$l_ver, speclen - (mynam.nam$l_ver - out)); speclen -= mynam.nam$l_ver - mynam.nam$l_type; } } /* If we just had a directory spec on input, $PARSE "helpfully" * adds an empty name and type for us */ if (mynam.nam$l_name == mynam.nam$l_type && mynam.nam$l_ver == mynam.nam$l_type + 1 && !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) speclen = mynam.nam$l_name - out; out[speclen] = '\0'; if (haslower) __mystrtolower(out); /* Have we been working with an expanded, but not resultant, spec? */ /* Also, convert back to Unix syntax if necessary. */ if (!mynam.nam$b_rsl) { if (isunix) { if (do_tounixspec(esa,outbuf,0) == NULL) return NULL; } else strcpy(outbuf,esa); } else if (isunix) { if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL; strcpy(outbuf,tmpfspec); } mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0; myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */ return outbuf; } /*}}}*/ /* External entry points */ char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt) { return do_rmsexpand(spec,buf,0,def,opt); } char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt) { return do_rmsexpand(spec,buf,1,def,opt); } /* ** The following routines are provided to make life easier when ** converting among VMS-style and Unix-style directory specifications. ** All will take input specifications in either VMS or Unix syntax. On ** failure, all return NULL. If successful, the routines listed below ** return a pointer to a buffer containing the appropriately ** reformatted spec (and, therefore, subsequent calls to that routine ** will clobber the result), while the routines of the same names with ** a _ts suffix appended will return a pointer to a mallocd string ** containing the appropriately reformatted spec. ** In all cases, only explicit syntax is altered; no check is made that ** the resulting string is valid or that the directory in question ** actually exists. ** ** fileify_dirspec() - convert a directory spec into the name of the ** directory file (i.e. what you can stat() to see if it's a dir). ** The style (VMS or Unix) of the result is the same as the style ** of the parameter passed in. ** pathify_dirspec() - convert a directory spec into a path (i.e. ** what you prepend to a filename to indicate what directory it's in). ** The style (VMS or Unix) of the result is the same as the style ** of the parameter passed in. ** tounixpath() - convert a directory spec into a Unix-style path. ** tovmspath() - convert a directory spec into a VMS-style path. ** tounixspec() - convert any file spec into a Unix-style file spec. ** tovmsspec() - convert any file spec into a VMS-style spec. ** ** Copyright 1996 by Charles Bailey ** Permission is given to distribute this code as part of the Perl ** standard distribution under the terms of the GNU General Public ** License or the Perl Artistic License. Copies of each may be ** found in the Perl standard distribution. */ /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/ static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) { static char __fileify_retbuf[NAM$C_MAXRSS+1]; 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]; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; } dirlen = strlen(dir); while (dirlen && dir[dirlen-1] == '/') --dirlen; if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */ strcpy(trndir,"/sys$disk/000000"); dir = trndir; dirlen = 16; } if (dirlen > NAM$C_MAXRSS) { set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL; } if (!strpbrk(dir+1,"/]>:")) { strcpy(trndir,*dir == '/' ? dir + 1: dir); while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ; dir = trndir; dirlen = strlen(dir); } else { strncpy(trndir,dir,dirlen); trndir[dirlen] = '\0'; dir = trndir; } /* If we were handed a rooted logical name or spec, treat it like a * simple directory, so that * $ Define myroot dev:[dir.] * ... do_fileify_dirspec("myroot",buf,1) ... * does something useful. */ 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. */ if (*(cp1+1)) hasfilename = 1; /* Similarly, we can just back up a level if we've got multiple levels of explicit directories in a VMS spec which ends with directories. */ else { for (cp2 = cp1; cp2 > dir; cp2--) { if (*cp2 == '.') { *cp2 = *cp1; *cp1 = '\0'; hasfilename = 1; break; } if (*cp2 == '[' || *cp2 == '<') break; } } } if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */ if (dir[0] == '.') { if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0')) return do_fileify_dirspec("[]",buf,ts); else if (dir[1] == '.' && (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0'))) return do_fileify_dirspec("[-]",buf,ts); } if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } else if ((cp1 = strstr(dir,"/.")) != NULL) { /* If we have "/." or "/..", VMSify it and let the VMS code * below expand it, rather than repeating the code to handle * relative components of a filespec here */ do { if (*(cp1+2) == '.') cp1++; if (*(cp1+2) == '/' || *(cp1+2) == '\0') { if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; if (strchr(vmsdir,'/') != NULL) { /* If do_tovmsspec() returned it, it must have VMS syntax * delimiters in it, so it's a mixed VMS/Unix spec. We take * the time to check this here only so we avoid a recursion * loop; otherwise, gigo. */ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL; } if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; return do_tounixspec(trndir,buf,ts); } cp1++; } while ((cp1 = strstr(cp1,"/.")) != NULL); lastdir = strrchr(dir,'/'); } else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) { /* Ditto for specs that end in an MFD -- let the VMS code * figure out whether it's a real device or a rooted logical. */ dir[dirlen] = '/'; dir[dirlen+1] = '\0'; if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; return do_tounixspec(trndir,buf,ts); } else { if ( !(lastdir = cp1 = strrchr(dir,'/')) && !(lastdir = cp1 = strrchr(dir,']')) && !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir; if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */ int ver; char *cp3; if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ !*(cp2+3) || toupper(*(cp2+3)) != 'R' || (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && (ver || *cp3)))))) { set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; } dirlen = cp2 - dir; } } /* If we lead off with a device or rooted logical, add the MFD if we're specifying a top-level directory. */ if (lastdir && *dir == '/') { addmfd = 1; for (cp1 = lastdir - 1; cp1 > dir; cp1--) { if (*cp1 == '/') { addmfd = 0; break; } } } retlen = dirlen + (addmfd ? 13 : 6); if (buf) retspec = buf; else if (ts) New(1309,retspec,retlen+1,char); else retspec = __fileify_retbuf; if (addmfd) { dirlen = lastdir - dir; memcpy(retspec,dir,dirlen); strcpy(&retspec[dirlen],"/000000"); strcpy(&retspec[dirlen+7],lastdir); } else { memcpy(retspec,dir,dirlen); retspec[dirlen] = '\0'; } /* We've picked up everything up to the directory file name. Now just add the type and version, and we're set. */ strcat(retspec,".dir;1"); return retspec; } else { /* VMS-style directory spec */ char esa[NAM$C_MAXRSS+1], term, *cp; unsigned long int sts, cmplen, haslower = 0; struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; dirfab.fab$b_fns = strlen(dir); dirfab.fab$l_fna = dir; dirfab.fab$l_nam = &dirnam; dirfab.fab$l_dna = ".DIR;1"; dirfab.fab$b_dns = 6; dirnam.nam$b_ess = NAM$C_MAXRSS; dirnam.nam$l_esa = esa; for (cp = dir; *cp; cp++) if (islower(*cp)) { haslower = 1; break; } if (!((sts = sys$parse(&dirfab))&1)) { if (dirfab.fab$l_sts == RMS$_DIR) { dirnam.nam$b_nop |= NAM$M_SYNCHK; sts = sys$parse(&dirfab) & 1; } if (!sts) { set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } } else { savnam = dirnam; if (sys$search(&dirfab)&1) { /* Does the file really exist? */ /* Yes; fake the fnb bits so we'll check type below */ dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER; } else { /* No; just work with potential name */ if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam; else { set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); return NULL; } } } if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) { cp1 = strchr(esa,']'); if (!cp1) cp1 = strchr(esa,'>'); if (cp1) { /* Should always be true */ dirnam.nam$b_esl -= cp1 - esa - 1; memcpy(esa,cp1 + 1,dirnam.nam$b_esl); } } if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ /* Yep; check version while we're at it, if it's there. */ cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { /* Something other than .DIR[;1]. Bzzt. */ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; } } esa[dirnam.nam$b_esl] = '\0'; if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) { /* They provided at least the name; we added the type, if necessary, */ if (buf) retspec = buf; /* in sys$parse() */ else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char); else retspec = __fileify_retbuf; strcpy(retspec,esa); dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); return retspec; } if ((cp1 = strstr(esa,".][000000]")) != NULL) { for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2; *cp1 = '\0'; dirnam.nam$b_esl -= 9; } if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); if (cp1 == NULL) { /* should never happen */ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); return NULL; } term = *cp1; *cp1 = '\0'; retlen = strlen(esa); if ((cp1 = strrchr(esa,'.')) != NULL) { /* There's more than one directory in the path. Just roll back. */ *cp1 = term; if (buf) retspec = buf; else if (ts) New(1311,retspec,retlen+7,char); else retspec = __fileify_retbuf; strcpy(retspec,esa); } else { if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) { /* Go back and expand rooted logical name */ dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL; if (!(sys$parse(&dirfab) & 1)) { dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */ if (buf) retspec = buf; else if (ts) New(1312,retspec,retlen+16,char); else retspec = __fileify_retbuf; cp1 = strstr(esa,"]["); dirlen = cp1 - esa; memcpy(retspec,esa,dirlen); if (!strncmp(cp1+2,"000000]",7)) { retspec[dirlen-1] = '\0'; for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; if (*cp1 == '.') *cp1 = ']'; else { memmove(cp1+8,cp1+1,retspec+dirlen-cp1); memcpy(cp1+1,"000000]",7); } } else { memcpy(retspec+dirlen,cp1+2,retlen-dirlen); retspec[retlen] = '\0'; /* Convert last '.' to ']' */ for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ; if (*cp1 == '.') *cp1 = ']'; else { memmove(cp1+8,cp1+1,retspec+dirlen-cp1); memcpy(cp1+1,"000000]",7); } } } else { /* This is a top-level dir. Add the MFD to the path. */ if (buf) retspec = buf; else if (ts) New(1312,retspec,retlen+16,char); else retspec = __fileify_retbuf; cp1 = esa; cp2 = retspec; while (*cp1 != ':') *(cp2++) = *(cp1++); strcpy(cp2,":[000000]"); cp1 += 2; strcpy(cp2+9,cp1); } } dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); /* We've set up the string up through the filename. Add the type and version, and we're done. */ strcat(retspec,".DIR;1"); /* $PARSE may have upcased filespec, so convert output to lower * case if input contained any lowercase characters. */ if (haslower) __mystrtolower(retspec); return retspec; } } /* end of do_fileify_dirspec() */ /*}}}*/ /* External entry points */ char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf) { return do_fileify_dirspec(dir,buf,0); } char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf) { return do_fileify_dirspec(dir,buf,1); } /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts) { static char __pathify_retbuf[NAM$C_MAXRSS+1]; unsigned long int retlen; char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1]; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; } if (*dir) strcpy(trndir,dir); else getcwd(trndir,sizeof trndir - 1); while (!strpbrk(trndir,"/]:>") && !no_translate_barewords && my_trnlnm(trndir,trndir,0)) { STRLEN trnlen = strlen(trndir); /* Trap simple rooted lnms, and return lnm:[000000] */ if (!strcmp(trndir+trnlen-2,".]")) { if (buf) retpath = buf; else if (ts) New(1318,retpath,strlen(dir)+10,char); else retpath = __pathify_retbuf; strcpy(retpath,dir); strcat(retpath,":[000000]"); return retpath; } } dir = trndir; if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */ if (*dir == '.' && (*(dir+1) == '\0' || (*(dir+1) == '.' && *(dir+2) == '\0'))) retlen = 2 + (*(dir+1) != '\0'); else { if ( !(cp1 = strrchr(dir,'/')) && !(cp1 = strrchr(dir,']')) && !(cp1 = strrchr(dir,'>')) ) cp1 = dir; if ((cp2 = strchr(cp1,'.')) != NULL && (*(cp2-1) != '/' || /* Trailing '.', '..', */ !(*(cp2+1) == '\0' || /* or '...' are dirs. */ (*(cp2+1) == '.' && *(cp2+2) == '\0') || (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) { int ver; char *cp3; if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ !*(cp2+3) || toupper(*(cp2+3)) != 'R' || (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && (ver || *cp3)))))) { set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; } retlen = cp2 - dir + 1; } else { /* No file type present. Treat the filename as a directory. */ retlen = strlen(dir) + 1; } } if (buf) retpath = buf; else if (ts) New(1313,retpath,retlen+1,char); else retpath = __pathify_retbuf; strncpy(retpath,dir,retlen-1); if (retpath[retlen-2] != '/') { /* If the path doesn't already end */ retpath[retlen-1] = '/'; /* with '/', add it. */ retpath[retlen] = '\0'; } else retpath[retlen-1] = '\0'; } else { /* VMS-style directory spec */ char esa[NAM$C_MAXRSS+1], *cp; unsigned long int sts, cmplen, haslower; struct FAB dirfab = cc$rms_fab; struct NAM savnam, dirnam = cc$rms_nam; /* If we've got an explicit filename, we can just shuffle the string. */ if ( ( (cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) { if ((cp2 = strchr(cp1,'.')) != NULL) { int ver; char *cp3; if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */ !*(cp2+3) || toupper(*(cp2+3)) != 'R' || (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') || (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 && (ver || *cp3)))))) { set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; } } else { /* No file type, so just draw name into directory part */ for (cp2 = cp1; *cp2; cp2++) ; } *cp2 = *cp1; *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */ *cp1 = '.'; /* We've now got a VMS 'path'; fall through */ } dirfab.fab$b_fns = strlen(dir); dirfab.fab$l_fna = dir; if (dir[dirfab.fab$b_fns-1] == ']' || dir[dirfab.fab$b_fns-1] == '>' || dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */ if (buf) retpath = buf; else if (ts) New(1314,retpath,strlen(dir)+1,char); else retpath = __pathify_retbuf; strcpy(retpath,dir); return retpath; } dirfab.fab$l_dna = ".DIR;1"; dirfab.fab$b_dns = 6; dirfab.fab$l_nam = &dirnam; dirnam.nam$b_ess = (unsigned char) sizeof esa - 1; dirnam.nam$l_esa = esa; for (cp = dir; *cp; cp++) if (islower(*cp)) { haslower = 1; break; } if (!(sts = (sys$parse(&dirfab)&1))) { if (dirfab.fab$l_sts == RMS$_DIR) { dirnam.nam$b_nop |= NAM$M_SYNCHK; sts = sys$parse(&dirfab) & 1; } if (!sts) { set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } } else { savnam = dirnam; if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ if (dirfab.fab$l_sts != RMS$_FNF) { dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } dirnam = savnam; /* No; just work with potential name */ } } if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */ /* Yep; check version while we're at it, if it's there. */ cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4; if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) { /* Something other than .DIR[;1]. Bzzt. */ dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; } } /* OK, the type was fine. Now pull any file name into the directory path. */ if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']'; else { cp1 = strrchr(esa,'>'); *dirnam.nam$l_type = '>'; } *cp1 = '.'; *(dirnam.nam$l_type + 1) = '\0'; retlen = dirnam.nam$l_type - esa + 2; if (buf) retpath = buf; else if (ts) New(1314,retpath,retlen,char); else retpath = __pathify_retbuf; strcpy(retpath,esa); dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL; dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0); /* $PARSE may have upcased filespec, so convert output to lower * case if input contained any lowercase characters. */ if (haslower) __mystrtolower(retpath); } return retpath; } /* end of do_pathify_dirspec() */ /*}}}*/ /* External entry points */ char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf) { return do_pathify_dirspec(dir,buf,0); } char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf) { return do_pathify_dirspec(dir,buf,1); } /*{{{ char *tounixspec[_ts](char *path, char *buf)*/ static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts) { 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; if (spec == NULL) return NULL; if (strlen(spec) > NAM$C_MAXRSS) return NULL; if (buf) rslt = buf; else if (ts) { retlen = strlen(spec); cp1 = strchr(spec,'['); if (!cp1) cp1 = strchr(spec,'<'); if (cp1) { for (cp1++; *cp1; cp1++) { if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */ if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.') { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */ } } New(1315,rslt,retlen+2+2*expand,char); } else rslt = __tounixspec_retbuf; if (strchr(spec,'/') != NULL) { strcpy(rslt,spec); return rslt; } cp1 = rslt; cp2 = spec; dirend = strrchr(spec,']'); if (dirend == NULL) dirend = strrchr(spec,'>'); if (dirend == NULL) dirend = strchr(spec,':'); if (dirend == NULL) { strcpy(rslt,spec); return rslt; } if (*cp2 != '[' && *cp2 != '<') { *(cp1++) = '/'; } else { /* the VMS spec begins with directories */ cp2++; if (*cp2 == ']' || *cp2 == '>') { *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0'; return rslt; } else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */ if (getcwd(tmp,sizeof tmp,1) == NULL) { if (ts) Safefree(rslt); return NULL; } do { cp3 = tmp; while (*cp3 != ':' && *cp3) cp3++; *(cp3++) = '\0'; if (strchr(cp3,']') != NULL) break; } while (vmstrnenv(tmp,tmp,0,fildev,0)); if (ts && !buf && ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) { retlen = devlen + dirlen; Renew(rslt,retlen+1+2*expand,char); cp1 = rslt; } cp3 = tmp; *(cp1++) = '/'; while (*cp3) { *(cp1++) = *(cp3++); if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */ } *(cp1++) = '/'; } else if ( *cp2 == '.') { if (*(cp2+1) == '.' && *(cp2+2) == '.') { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; cp2 += 3; } else cp2++; } } for (; cp2 <= dirend; cp2++) { if (*cp2 == ':') { *(cp1++) = '/'; if (*(cp2+1) == '[') cp2++; } else if (*cp2 == ']' || *cp2 == '>') { if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */ } else if (*cp2 == '.') { *(cp1++) = '/'; if (*(cp2+1) == ']' || *(cp2+1) == '>') { while (*(cp2+1) == ']' || *(cp2+1) == '>' || *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' || *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7; } else if ( *(cp2+1) == '.' && *(cp2+2) == '.') { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/'; cp2 += 2; } } else if (*cp2 == '-') { if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') { while (*cp2 == '-') { cp2++; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; } if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ if (ts) Safefree(rslt); /* filespecs like */ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */ return NULL; } } else *(cp1++) = *cp2; } else *(cp1++) = *cp2; } while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; return rslt; } /* end of do_tounixspec() */ /*}}}*/ /* External entry points */ char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); } char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); } /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) { static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; char *rslt, *dirend; register char *cp1, *cp2; unsigned long int infront = 0, hasdir = 1; if (path == NULL) return NULL; if (buf) rslt = buf; else if (ts) New(1316,rslt,strlen(path)+9,char); else rslt = __tovmsspec_retbuf; if (strpbrk(path,"]:>") || (dirend = strrchr(path,'/')) == NULL) { if (path[0] == '.') { if (path[1] == '\0') strcpy(rslt,"[]"); else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]"); else strcpy(rslt,path); /* probably garbage */ } else strcpy(rslt,path); return rslt; } if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */ if (!*(dirend+2)) dirend +=2; if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; } cp1 = rslt; cp2 = path; if (*cp2 == '/') { char trndev[NAM$C_MAXRSS+1]; int islnm, rooted; STRLEN trnend; while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ if (!*(cp2+1)) { if (!buf & ts) Renew(rslt,18,char); strcpy(rslt,"sys$disk:[000000]"); return rslt; } while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; *cp1 = '\0'; islnm = my_trnlnm(rslt,trndev,0); trnend = islnm ? strlen(trndev) - 1 : 0; islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0; rooted = islnm ? (trndev[trnend-1] == '.') : 0; /* If the first element of the path is a logical name, determine * whether it has to be translated so we can add more directories. */ if (!islnm || rooted) { *(cp1++) = ':'; *(cp1++) = '['; if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0'; else cp2++; } else { if (cp2 != dirend) { if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char); strcpy(rslt,trndev); cp1 = rslt + trnend; *(cp1++) = '.'; cp2++; } else { *(cp1++) = ':'; hasdir = 0; } } } else { *(cp1++) = '['; if (*cp2 == '.') { if (*(cp2+1) == '/' || *(cp2+1) == '\0') { cp2 += 2; /* skip over "./" - it's redundant */ *(cp1++) = '.'; /* but it does indicate a relative dirspec */ } else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { *(cp1++) = '-'; /* "../" --> "-" */ cp2 += 3; } else if (*(cp2+1) == '.' && *(cp2+2) == '.' && (*(cp2+3) == '/' || *(cp2+3) == '\0')) { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */ cp2 += 4; } if (cp2 > dirend) cp2 = dirend; } else *(cp1++) = '.'; } for (; cp2 < dirend; cp2++) { if (*cp2 == '/') { if (*(cp2-1) == '/') continue; if (*(cp1-1) != '.') *(cp1++) = '.'; infront = 0; } else if (!infront && *cp2 == '.') { if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; } else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */ else if (*(cp1-2) == '[') *(cp1-1) = '-'; else { /* back up over previous directory name */ cp1--; while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--; if (*(cp1-1) == '[') { memcpy(cp1,"000000.",7); cp1 += 7; } } cp2 += 2; if (cp2 == dirend) break; } else if ( *(cp2+1) == '.' && *(cp2+2) == '.' && (*(cp2+3) == '/' || *(cp2+3) == '\0') ) { if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */ *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */ if (!*(cp2+3)) { *(cp1++) = '.'; /* Simulate trailing '/' */ cp2 += 2; /* for loop will incr this to == dirend */ } else cp2 += 3; /* Trailing '/' was there, so skip it, too */ } else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ } else { if (!infront && *(cp1-1) == '-') *(cp1++) = '.'; if (*cp2 == '.') *(cp1++) = '_'; else *(cp1++) = *cp2; infront = 1; } } if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */ if (hasdir) *(cp1++) = ']'; if (*cp2) cp2++; /* check in case we ended with trailing '..' */ while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; return rslt; } /* end of do_tovmsspec() */ /*}}}*/ /* External entry points */ char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); } char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); } /*{{{ char *tovmspath[_ts](char *path, char *buf)*/ static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) { static char __tovmspath_retbuf[NAM$C_MAXRSS+1]; int vmslen; char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp; if (path == NULL) return NULL; if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL; if (buf) return buf; else if (ts) { vmslen = strlen(vmsified); New(1317,cp,vmslen+1,char); memcpy(cp,vmsified,vmslen); cp[vmslen] = '\0'; return cp; } else { strcpy(__tovmspath_retbuf,vmsified); return __tovmspath_retbuf; } } /* end of do_tovmspath() */ /*}}}*/ /* External entry points */ char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); } char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); } /*{{{ char *tounixpath[_ts](char *path, char *buf)*/ static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) { static char __tounixpath_retbuf[NAM$C_MAXRSS+1]; int unixlen; char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp; if (path == NULL) return NULL; if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL; if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL; if (buf) return buf; else if (ts) { unixlen = strlen(unixified); New(1317,cp,unixlen+1,char); memcpy(cp,unixified,unixlen); cp[unixlen] = '\0'; return cp; } else { strcpy(__tounixpath_retbuf,unixified); return __tounixpath_retbuf; } } /* end of do_tounixpath() */ /*}}}*/ /* External entry points */ char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); } char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); } /* * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com) * ***************************************************************************** * * * Copyright (C) 1989-1994 by * * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 * * * * Permission is hereby granted for the reproduction of this software, * * on condition that this copyright notice is included in the reproduction, * * and that such reproduction is not for purposes of profit or material * * gain. * * * * 27-Aug-1994 Modified for inclusion in perl5 * * by Charles Bailey bailey@newman.upenn.edu * ***************************************************************************** */ /* * getredirection() is intended to aid in porting C programs * to VMS (Vax-11 C). The native VMS environment does not support * '>' and '<' I/O redirection, or command line wild card expansion, * or a command line pipe mechanism using the '|' AND background * command execution '&'. All of these capabilities are provided to any * C program which calls this procedure as the first thing in the * main program. * The piping mechanism will probably work with almost any 'filter' type * of program. With suitable modification, it may useful for other * portability problems as well. * * Author: Mark Pizzolato mark@infocomm.com */ struct list_item { struct list_item *next; char *value; }; static void add_item(struct list_item **head, struct list_item **tail, char *value, int *count); static void mp_expand_wild_cards(pTHX_ char *item, struct list_item **head, struct list_item **tail, int *count); static int background_process(int argc, char **argv); static void pipe_and_fork(char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ static void mp_getredirection(pTHX_ int *ac, char ***av) /* * Process vms redirection arg's. Exit if any error is seen. * If getredirection() processes an argument, it is erased * from the vector. getredirection() returns a new argc and argv value. * In the event that a background command is requested (by a trailing "&"), * this routine creates a background subprocess, and simply exits the program. * * Warning: do not try to simplify the code for vms. The code * presupposes that getredirection() is called before any data is * read from stdin or written to stdout. * * Normal usage is as follows: * * main(argc, argv) * int argc; * char *argv[]; * { * getredirection(&argc, &argv); * } */ { int argc = *ac; /* Argument Count */ char **argv = *av; /* Argument Vector */ char *ap; /* Argument pointer */ int j; /* argv[] index */ int item_count = 0; /* Count of Items in List */ struct list_item *list_head = 0; /* First Item in List */ struct list_item *list_tail; /* Last Item in List */ char *in = NULL; /* Input File Name */ char *out = NULL; /* Output File Name */ char *outmode = "w"; /* Mode to Open Output File */ char *err = NULL; /* Error File Name */ char *errmode = "w"; /* Mode to Open Error File */ int cmargc = 0; /* Piped Command Arg Count */ char **cmargv = NULL;/* Piped Command Arg Vector */ /* * First handle the case where the last thing on the line ends with * a '&'. This indicates the desire for the command to be run in a * subprocess, so we satisfy that desire. */ ap = argv[argc-1]; if (0 == strcmp("&", ap)) exit(background_process(--argc, argv)); if (*ap && '&' == ap[strlen(ap)-1]) { ap[strlen(ap)-1] = '\0'; exit(background_process(argc, argv)); } /* * Now we handle the general redirection cases that involve '>', '>>', * '<', and pipes '|'. */ for (j = 0; j < argc; ++j) { if (0 == strcmp("<", argv[j])) { if (j+1 >= argc) { PerlIO_printf(Perl_debug_log,"No input file after < on command line"); exit(LIB$_WRONUMARG); } in = argv[++j]; continue; } if ('<' == *(ap = argv[j])) { in = 1 + ap; continue; } if (0 == strcmp(">", ap)) { if (j+1 >= argc) { PerlIO_printf(Perl_debug_log,"No output file after > on command line"); exit(LIB$_WRONUMARG); } out = argv[++j]; continue; } if ('>' == *ap) { if ('>' == ap[1]) { outmode = "a"; if ('\0' == ap[2]) out = argv[++j]; else out = 2 + ap; } else out = 1 + ap; if (j >= argc) { PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line"); exit(LIB$_WRONUMARG); } continue; } if (('2' == *ap) && ('>' == ap[1])) { if ('>' == ap[2]) { errmode = "a"; if ('\0' == ap[3]) err = argv[++j]; else err = 3 + ap; } else if ('\0' == ap[2]) err = argv[++j]; else err = 2 + ap; if (j >= argc) { PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line"); exit(LIB$_WRONUMARG); } continue; } if (0 == strcmp("|", argv[j])) { if (j+1 >= argc) { PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line"); exit(LIB$_WRONUMARG); } cmargc = argc-(j+1); cmargv = &argv[j+1]; argc = j; continue; } if ('|' == *(ap = argv[j])) { ++argv[j]; cmargc = argc-j; cmargv = &argv[j]; argc = j; continue; } expand_wild_cards(ap, &list_head, &list_tail, &item_count); } /* * Allocate and fill in the new argument vector, Some Unix's terminate * the list with an extra null pointer. */ New(1302, argv, item_count+1, char *); *av = argv; for (j = 0; j < item_count; ++j, list_head = list_head->next) argv[j] = list_head->value; *ac = item_count; if (cmargv != NULL) { if (out != NULL) { PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line"); exit(LIB$_INVARGORD); } pipe_and_fork(cmargv); } /* Check for input from a pipe (mailbox) */ if (in == NULL && 1 == isapipe(0)) { char mbxname[L_tmpnam]; long int bufsize; long int dvi_item = DVI$_DEVBUFSIZ; $DESCRIPTOR(mbxnam, ""); $DESCRIPTOR(mbxdevnam, ""); /* Input from a pipe, reopen it in binary mode to disable */ /* carriage control processing. */ PerlIO_getname(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); mbxdevnam.dsc$a_pointer = mbxname; mbxdevnam.dsc$w_length = sizeof(mbxname); dvi_item = DVI$_DEVNAM; lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length); mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0'; set_errno(0); set_vaxc_errno(1); freopen(mbxname, "rb", stdin); if (errno != 0) { PerlIO_printf(Perl_debug_log,"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); 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); exit(vaxc$errno); } if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out); if (err != NULL) { if (strcmp(err,"&1") == 0) { dup2(fileno(stdout), fileno(Perl_debug_log)); Perl_vmssetuserlnm("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); exit(vaxc$errno); } fclose(tmperr); if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2")) { exit(vaxc$errno); } Perl_vmssetuserlnm("SYS$ERROR",err); } } #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "Arglist:\n"); for (j = 0; j < *ac; ++j) PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); #endif /* Clear errors we may have hit expanding wildcards, so they don't show up in Perl's $! later */ set_errno(0); set_vaxc_errno(1); } /* end of getredirection() */ /*}}}*/ static void add_item(struct list_item **head, struct list_item **tail, char *value, int *count) { if (*head == 0) { New(1303,*head,1,struct list_item); *tail = *head; } else { New(1304,(*tail)->next,1,struct list_item); *tail = (*tail)->next; } (*tail)->value = value; ++(*count); } static void mp_expand_wild_cards(pTHX_ char *item, struct list_item **head, struct list_item **tail, int *count) { int expcount = 0; unsigned long int context = 0; int isunix = 0; char *had_version; char *had_device; int had_directory; char *devdir,*cp; char vmsspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(filespec, ""); $DESCRIPTOR(defaultspec, "SYS$DISK:[]"); $DESCRIPTOR(resultspec, ""); unsigned long int zero = 0, sts; for (cp = item; *cp; cp++) { if (*cp == '*' || *cp == '%' || isspace(*cp)) break; if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break; } if (!*cp || isspace(*cp)) { 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; if ((isunix = (int) strchr(item,'/')) != (int) NULL) filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0); if (!isunix || !filespec.dsc$a_pointer) filespec.dsc$a_pointer = item; filespec.dsc$w_length = strlen(filespec.dsc$a_pointer); /* * Only return version specs, if the caller specified a version */ had_version = strchr(item, ';'); /* * Only return device and directory specs, if the caller specifed either. */ had_device = strchr(item, ':'); had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<')); while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context, &defaultspec, 0, 0, &zero)))) { char *string; char *c; New(1305,string,resultspec.dsc$w_length+1,char); strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length); string[resultspec.dsc$w_length] = '\0'; if (NULL == had_version) *((char *)strrchr(string, ';')) = '\0'; if ((!had_directory) && (had_device == NULL)) { if (NULL == (devdir = strrchr(string, ']'))) devdir = strrchr(string, '>'); strcpy(string, devdir + 1); } /* * Be consistent with what the C RTL has already done to the rest of * the argv items and lowercase all of these names. */ for (c = string; *c; ++c) if (isupper(*c)) *c = tolower(*c); if (isunix) trim_unixpath(string,item,1); add_item(head, tail, string, count); ++expcount; } if (sts != RMS$_NMF) { set_vaxc_errno(sts); 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$_FNM: case RMS$_SYN: set_errno(EINVAL); break; case RMS$_PRV: set_errno(EACCES); break; default: _ckvmssts_noperl(sts); } } if (expcount == 0) add_item(head, tail, item, count); _ckvmssts_noperl(lib$sfree1_dd(&resultspec)); _ckvmssts_noperl(lib$find_file_end(&context)); } static int child_st[2];/* Event Flag set when child process completes */ static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */ static unsigned long int exit_handler(int *status) { short iosb[4]; if (0 == child_st[0]) { #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n"); #endif fflush(stdout); /* Have to flush pipe for binary data to */ /* terminate properly -- */ sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0); sys$dassgn(child_chan); fclose(stdout); sys$synch(0, child_st); } return(1); } static void sig_child(int chan) { #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "Child Completion AST\n"); #endif if (child_st[0] == 0) child_st[0] = 1; } static struct exit_control_block exit_block = { 0, exit_handler, 1, &exit_block.exit_status, 0 }; static void pipe_and_fork(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, "\""); } cmddsc.dsc$a_pointer = subcmd; cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer); create_mbx(&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); } } static int background_process(int argc, char **argv) { char command[2048] = "$"; $DESCRIPTOR(value, ""); static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND"); static $DESCRIPTOR(null, "NLA0:"); static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID"); char pidstring[80]; $DESCRIPTOR(pidstr, ""); int pid; unsigned long int flags = 17, one = 1, retsts; strcat(command, argv[0]); while (--argc) { strcat(command, " \""); strcat(command, *(++argv)); strcat(command, "\""); } value.dsc$a_pointer = command; value.dsc$w_length = strlen(value.dsc$a_pointer); _ckvmssts_noperl(lib$set_symbol(&cmd, &value)); retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid); if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */ _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid)); } else { _ckvmssts_noperl(retsts); } #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "%s\n", command); #endif sprintf(pidstring, "%08X", pid); PerlIO_printf(Perl_debug_log, "%s\n", pidstring); pidstr.dsc$a_pointer = pidstring; pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer); lib$set_symbol(&pidsymbol, &pidstr); return(SS$_NORMAL); } /*}}}*/ /***** End of code taken from Mark Pizzolato's argproc.c package *****/ /* OS-specific initialization at image activation (not thread startup) */ /* Older VAXC header files lack these constants */ #ifndef JPI$_RIGHTS_SIZE # define JPI$_RIGHTS_SIZE 817 #endif #ifndef KGB$M_SUBSYSTEM # define KGB$M_SUBSYSTEM 0x8 #endif /*{{{void vms_image_init(int *, char ***)*/ void vms_image_init(int *argcp, char ***argvp) { char eqv[LNM$C_NAMLENGTH+1] = ""; unsigned int len, tabct = 8, tabidx = 0; unsigned long int *mask, iosb[2], i, rlst[128], rsz; 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; 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]); 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. */ will_taint = TRUE; break; } } /* Rights identifiers might trigger tainting as well. */ if (!will_taint && (rlen || rsz)) { while (rlen < rsz) { /* We didn't get all the identifiers on the first pass. Allocate a * buffer much larger than $GETJPI wants (rsz is size in bytes that * were needed to hold all identifiers at time of last call; we'll * allocate that many unsigned long ints), and go back and get 'em. * If it gave us less than it wanted to despite ample buffer space, * something's broken. Is your system missing a system identifier? */ if (rsz <= jpilist[1].buflen) { /* Perl_croak accvios when used this early in startup. */ fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s", rsz, (unsigned long) jpilist[1].buflen, "Check your rights database for corruption.\n"); exit(SS$_ABORT); } 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]); } mask = jpilist[1].bufadr; /* Check attribute flags for each identifier (2nd longword); protected