/* VMS-specific routines for perl5 * * Last revised: 09-Oct-1994 */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include "EXTERN.h" #include "perl.h" struct itmlst_3 { unsigned short int buflen; unsigned short int itmcode; void *bufadr; unsigned long int retlen; }; static unsigned long int sts; #define _cksts(call) \ if (!(sts=(call))&1) { \ errno = EVMSERR; vaxc$errno = sts; \ croak("fatal error at %s, line %d",__FILE__,__LINE__); \ } else { 1; } /* my_getenv * Translate a logical name. Substitute for CRTL getenv() to avoid * memory leak, and to keep my_getenv() and my_setenv() in the same * domain (mostly - my_getenv() need not return a translation from * the process logical name table) * * Note: Uses static buffer -- not thread-safe! */ /*{{{ char *my_getenv(char *lnm)*/ char * my_getenv(char *lnm) { static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; unsigned short int eqvlen; unsigned long int retsts, attr = LNM$M_CASE_BLIND; $DESCRIPTOR(sysdiskdsc,"SYS$DISK"); $DESCRIPTOR(tabdsc,"LNM$FILE_DEV"); struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm}, eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T, DSC$K_CLASS_S, __my_getenv_eqv}; struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING, __my_getenv_eqv, &eqvlen, 0, 0, 0, 0}; for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1); *cp2 = '\0'; lnmdsc.dsc$w_length = cp1 - lnm; if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) { _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst)); eqvdsc.dsc$a_pointer += eqvlen; eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1; _cksts(sys$setddir(0,&eqvlen,&eqvdsc)); eqvdsc.dsc$a_pointer[eqvlen] = '\0'; return __my_getenv_eqv; } else { retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst); if (retsts != SS$_NOLOGNAM) { if (retsts & 1) { __my_getenv_eqv[eqvlen] = '\0'; return __my_getenv_eqv; } _cksts(retsts); } else { retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0); if (retsts != LIB$_NOSUCHSYM) { /* We want to return only logical names or CRTL Unix emulations */ if (retsts & 1) return Nullch; _cksts(retsts); } else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */ } } return NULL; } /* end of my_getenv() */ /*}}}*/ /*{{{ void my_setenv(char *lnm, char *eqv)*/ void my_setenv(char *lnm,char *eqv) /* Define a supervisor-mode logical name in the process table. * In the future we'll add tables, attribs, and acmodes, * probably through a different call. */ { char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2; unsigned long int retsts, usermode = PSL$C_USER; $DESCRIPTOR(tabdsc,"LNM$PROCESS"); 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}; for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1); lnmdsc.dsc$w_length = cp1 - lnm; if (!eqv || !*eqv) { /* we're deleting a logical name */ retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */ if (retsts != SS$_NOLOGNAM) _cksts(retsts); if (!(retsts & 1)) { retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */ if (retsts != SS$_NOLOGNAM) _cksts(retsts); } } else { eqvdsc.dsc$w_length = strlen(eqv); eqvdsc.dsc$a_pointer = eqv; _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0)); } } /* end of my_setenv() */ /*}}}*/ static char *do_fileify_dirspec(char *, char *, int); static char *do_tovmsspec(char *, char *, int); /*{{{int do_rmdir(char *name)*/ int do_rmdir(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]; unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE; unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1; struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; struct myacedef { unsigned char ace$b_length; unsigned char ace$b_type; unsigned short int ace$w_flags; unsigned long int ace$l_access; unsigned long int ace$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}; if (!remove(name)) return 0; /* Can we just get rid of it? */ /* 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. */ _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0)); if (do_tovmsspec(name,vmsname,0) == NULL) return -1; fildsc.dsc$w_length = strlen(vmsname); fildsc.dsc$a_pointer = vmsname; cxt = 0; newace.ace$l_ident = oldace.ace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { errno = EVMSERR; 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) { /* 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: if (rmsts) { fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0); if (aclsts & 1) aclsts = fndsts; } if (!(aclsts & 1)) { errno = EVMSERR; vaxc$errno = aclsts; return -1; } return rmsts; } /* end of kill_file() */ /*}}}*/ static void create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) { static unsigned long int mbxbufsiz; long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; if (!mbxbufsiz) { /* * Get the SYSGEN parameter MAXBUF, and the smaller of it and the * preprocessor consant BUFSIZ from stdio.h as the size of the * 'pipe' mailbox. */ _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ; } _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); _cksts(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*/ struct pipe_details { struct pipe_details *next; FILE *fp; int pid; unsigned long int completion; }; static struct pipe_details *open_pipes = NULL; static $DESCRIPTOR(nl_desc, "NL:"); static int waitpid_asleep = 0; static void popen_completion_ast(unsigned long int unused) { if (waitpid_asleep) { waitpid_asleep = 0; sys$wake(0,0); } } /*{{{ FILE *my_popen(char *cmd, char *mode)*/ FILE * my_popen(char *cmd, char *mode) { char mbxname[64]; unsigned short int chan; unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */ struct pipe_details *info; struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbxname}, cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; New(7001,info,1,struct pipe_details); info->completion=0; /* I assume this will remain 0 until terminates */ /* create mailbox */ create_mbx(&chan,&namdsc); /* open a FILE* onto it */ info->fp=fopen(mbxname, mode); /* give up other channel onto it */ _cksts(sys$dassgn(chan)); if (!info->fp) return Nullfp; cmddsc.dsc$w_length=strlen(cmd); cmddsc.dsc$a_pointer=cmd; if (strcmp(mode,"r")==0) { _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags, 0 /* name */, &info->pid, &info->completion, 0, popen_completion_ast,0,0,0,0)); } else { _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, 0 /* name */, &info->pid, &info->completion)); } info->next=open_pipes; /* prepend to list */ open_pipes=info; return info->fp; } /*}}}*/ /*{{{ I32 my_pclose(FILE *fp)*/ I32 my_pclose(FILE *fp) { struct pipe_details *info, *last = NULL; unsigned long int abort = SS$_TIMEOUT, retsts; for (info = open_pipes; info != NULL; last = info, info = info->next) if (info->fp == fp) break; if (info == NULL) /* get here => no such pipe open */ croak("my_pclose() - no such pipe open ???"); if (!info->completion) { /* Tap them gently on the shoulder . . .*/ _cksts(sys$forcex(&info->pid,0,&abort)); sleep(1); } if (!info->completion) /* We tried to be nice . . . */ _cksts(sys$delprc(&info->pid)); fclose(info->fp); /* remove from list of open pipes */ if (last) last->next = info->next; else open_pipes = info->next; retsts = info->completion; Safefree(info); return retsts; } /* end of my_pclose() */ #ifndef HAS_WAITPID /* sort-of waitpid; use only with popen() */ /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/ unsigned long int waitpid(unsigned long int pid, int *statusp, int flags) { struct pipe_details *info; unsigned long int abort = SS$_TIMEOUT; for (info = open_pipes; info != NULL; info = info->next) if (info->pid == pid) break; if (info != NULL) { /* we know about this child */ while (!info->completion) { waitpid_asleep = 1; sys$hiber(); } *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]; _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); if (ownerpid != mypid) croak("pid %d not a child",pid); _cksts(sys$bintim(&intdsc,interval)); while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) { _cksts(sys$schdwk(0,0,interval,0)); _cksts(sys$hiber()); } _cksts(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() */ #endif /*}}}*/ /*}}}*/ /*}}}*/ /*{{{ 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; if (val) { if (!buf && ndig > DBL_DIG) ndig = DBL_DIG; return gcvt(val,ndig,loc); } else { loc[0] = '0'; loc[1] = '\0'; return loc; } } /*}}}*/ /* ** 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 static 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. */ /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/ static char *do_fileify_dirspec(char *dir,char *buf,int ts) { static char __fileify_retbuf[NAM$C_MAXRSS+1]; unsigned long int dirlen, retlen, addmfd = 0; char *retspec, *cp1, *cp2, *lastdir; if (dir == NULL) return NULL; dirlen = strlen(dir); if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } else { if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir; if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */ if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */ toupper(*(cp2+2)) == 'I' && toupper(*(cp2+3)) == 'R') { if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) { if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */ errno = ENOTDIR; /* Bzzt. */ return NULL; } } dirlen = cp2 - dir; } else { /* There's a type, and it's not .dir. Bzzt. */ errno = ENOTDIR; return NULL; } } /* 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(7009,retspec,retlen+6,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; unsigned long int sts, cmplen; 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; dirnam.nam$b_ess = NAM$C_MAXRSS; dirnam.nam$l_esa = esa; dirnam.nam$b_nop = NAM$M_SYNCHK; if (!(sys$parse(&dirfab)&1)) { errno = EVMSERR; vaxc$errno = dirfab.fab$l_sts; return NULL; } 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 { if (dirfab.fab$l_sts != RMS$_FNF) { errno = EVMSERR; 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. */ errno = ENOTDIR; return NULL; } else { /* Ok, it was .DIR[;1]; copy over everything up to the */ retlen = dirnam.nam$l_type - esa; /* file name. */ if (buf) retspec = buf; else if (ts) New(7010,retspec,retlen+6,char); else retspec = __fileify_retbuf; strncpy(retspec,esa,retlen); retspec[retlen] = '\0'; } } else { /* They didn't explicitly specify the directory file. Ignore any file names in the input, pull off the last element of the directory path, and make it the file name. If you want to pay attention to filenames without .dir in the input, just use ".DIR;1" as a default filespec for the $PARSE */ esa[dirnam.nam$b_esl] = '\0'; if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>'); if (cp1 == NULL) return NULL; /* should never happen */ 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(7011,retspec,retlen+6,char); else retspec = __fileify_retbuf; strcpy(retspec,esa); } else { /* This is a top-level dir. Add the MFD to the path. */ if (buf) retspec = buf; else if (ts) New(7012,retspec,retlen+14,char); else retspec = __fileify_retbuf; cp1 = esa; cp2 = retspec; while (*cp1 != ':') *(cp2++) = *(cp1++); strcpy(cp2,":[000000]"); cp1 += 2; strcpy(cp2+9,cp1); } } /* Again, we've set up the string up through the filename. Add the type and version, and we're done. */ strcat(retspec,".DIR;1"); return retspec; } } /* end of do_fileify_dirspec() */ /*}}}*/ /* External entry points */ char *fileify_dirspec(char *dir, char *buf) { return do_fileify_dirspec(dir,buf,0); } char *fileify_dirspec_ts(char *dir, char *buf) { return do_fileify_dirspec(dir,buf,1); } /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ static char *do_pathify_dirspec(char *dir,char *buf, int ts) { static char __pathify_retbuf[NAM$C_MAXRSS+1]; unsigned long int retlen; char *retpath, *cp1, *cp2; if (dir == NULL) return NULL; if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ if (!(cp1 = strrchr(dir,'/'))) cp1 = dir; if (cp2 = strchr(cp1,'.')) { if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */ toupper(*(cp2+2)) == 'I' && /* Trim it off. */ toupper(*(cp2+3)) == 'R') { retlen = cp2 - dir + 1; } else { /* Some other file type. Bzzt. */ errno = ENOTDIR; return NULL; } } else { /* No file type present. Treat the filename as a directory. */ retlen = strlen(dir) + 1; } if (buf) retpath = buf; else if (ts) New(7013,retpath,retlen,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]; unsigned long int sts, cmplen; 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; dirnam.nam$b_ess = sizeof esa; dirnam.nam$l_esa = esa; dirnam.nam$b_nop = NAM$M_SYNCHK; if (!(sys$parse(&dirfab)&1)) { errno = EVMSERR; vaxc$errno = dirfab.fab$l_sts; return NULL; } 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 { if (dirfab.fab$l_sts != RMS$_FNF) { errno = EVMSERR; 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. */ errno = ENOTDIR; 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; } else { /* There wasn't a type on the input, so ignore any file names as well. If you want to pay attention to filenames without .dir in the input, just use ".DIR;1" as a default filespec for the $PARSE and set retlen thus retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl); */ retlen = dirnam.nam$l_name - esa; esa[retlen] = '\0'; } if (buf) retpath = buf; else if (ts) New(7014,retpath,retlen,char); else retpath = __pathify_retbuf; strcpy(retpath,esa); } return retpath; } /* end of do_pathify_dirspec() */ /*}}}*/ /* External entry points */ char *pathify_dirspec(char *dir, char *buf) { return do_pathify_dirspec(dir,buf,0); } char *pathify_dirspec_ts(char *dir, char *buf) { return do_pathify_dirspec(dir,buf,1); } /*{{{ char *tounixspec[_ts](char *path, char *buf)*/ static char *do_tounixspec(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; if (spec == NULL || *spec == '\0') return NULL; if (buf) rslt = buf; else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,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 != '[') { *(cp1++) = '/'; } else { /* the VMS spec begins with directories */ cp2++; if (*cp2 == '-') { while (*cp2 == '-') { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; cp2++; } if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ if (ts) Safefree(rslt); /* filespecs like */ errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */ return NULL; } cp2++; } else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */ *(cp1++) = '/'; 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 (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3)); cp3 = tmp; while (*cp3) *(cp1++) = *(cp3++); *(cp1++) = '/'; if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) { if (ts) Safefree(rslt); errno = ERANGE; return NULL; } } else cp2++; } for (; cp2 <= dirend; cp2++) { if (*cp2 == ':') { *(cp1++) = '/'; if (*(cp2+1) == '[') cp2++; } else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/'; else if (*cp2 == '.') { *(cp1++) = '/'; while (*(cp2+1) == ']' || *(cp2+1) == '>' || *(cp2+1) == '[' || *(cp2+1) == '<') cp2++; } 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 */ errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */ return NULL; } cp2++; } else *(cp1++) = *cp2; } else *(cp1++) = *cp2; } while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; return rslt; } /* end of do_tounixspec() */ /*}}}*/ /* External entry points */ char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); } char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); } /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ static char *do_tovmsspec(char *path, char *buf, int ts) { static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; char *rslt, *dirend, *cp1, *cp2; if (path == NULL || *path == '\0') return NULL; if (buf) rslt = buf; else if (ts) New(7016,rslt,strlen(path)+1,char); else rslt = __tovmsspec_retbuf; if (strchr(path,']') != NULL || strchr(path,'>') != NULL || (dirend = strrchr(path,'/')) == NULL) { strcpy(rslt,path); return rslt; } cp1 = rslt; cp2 = path; if (*cp2 == '/') { while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; *(cp1++) = ':'; *(cp1++) = '['; cp2++; } else { *(cp1++) = '['; *(cp1++) = '.'; } for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2; *(cp1++) = ']'; cp2++; while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; return rslt; } /* end of do_tovmsspec() */ /*}}}*/ /* External entry points */ char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); } char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); } /*{{{ char *tovmspath[_ts](char *path, char *buf)*/ static char *do_tovmspath(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 || *path == '\0') 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(7017,cp,vmslen,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 *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); } char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); } /*{{{ char *tounixpath[_ts](char *path, char *buf)*/ static char *do_tounixpath(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 || *path == '\0') 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(7017,cp,unixlen,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 *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); } char *tounixpath_ts(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@genetics.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 expand_wild_cards(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)*/ void getredirection(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 */ stat_t statbuf; /* fstat buffer */ /* * 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[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) { errno = EINVAL; croak("No input file"); } in = argv[++j]; continue; } if ('<' == *(ap = argv[j])) { in = 1 + ap; continue; } if (0 == strcmp(">", ap)) { if (j+1 >= argc) { errno = EINVAL; croak("No input file"); } 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) { errno = EINVAL; croak("No output file"); } 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 = 1 + ap; if (j >= argc) { errno = EINVAL; croak("No error file"); } continue; } if (0 == strcmp("|", argv[j])) { if (j+1 >= argc) { errno = EPIPE; croak("No command into which to pipe"); } 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(7002, 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) { errno = EINVAL; croak("'|' and '>' may not both be specified on command line"); } pipe_and_fork(cmargv); } /* Check for input from a pipe (mailbox) */ if (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. */ if (in != NULL) { errno = EINVAL; croak("'|' and '<' may not both be specified on command line"); } fgetname(stdin, mbxname); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); 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'; errno = 0; freopen(mbxname, "rb", stdin); if (errno != 0) { croak("Error reopening pipe (name: %s) in binary mode",mbxname); } } if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) { croak("Can't open input file %s",in); } if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) { croak("Can't open output file %s",out); } if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2"))) { croak("Can't open error file %s",err); } #ifdef ARGPROC_DEBUG fprintf(stderr, "Arglist:\n"); for (j = 0; j < *ac; ++j) fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]); #endif } /* end of getredirection() */ /*}}}*/ static void add_item(struct list_item **head, struct list_item **tail, char *value, int *count) { if (*head == 0) { New(7003,*head,1,struct list_item); *tail = *head; } else { New(7004,(*tail)->next,1,struct list_item); *tail = (*tail)->next; } (*tail)->value = value; ++(*count); } static void expand_wild_cards(char *item, struct list_item **head, struct list_item **tail, int *count) { int expcount = 0; int context = 0; int isunix = 0; int status; int status_value; char *had_version; char *had_device; int had_directory; char *devdir; char vmsspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(filespec, ""); $DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;"); $DESCRIPTOR(resultspec, ""); unsigned long int zero = 0; if (strcspn(item, "*%") == strlen(item)) { 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 = strchr(item,'/')) 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&lib$find_file(&filespec, &resultspec, &context, &defaultspec, 0, &status_value, &zero))) { char *string; char *c; New(7005,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(item,string); add_item(head, tail, string, count); ++expcount; } if (expcount == 0) add_item(head, tail, item, count); lib$sfree1_dd(&resultspec); lib$find_file_end(&context); } static int child_st[2];/* Event Flag set when child process completes */ static short child_chan;/* I/O Channel for Pipe Mailbox */ static exit_handler(int *status) { short iosb[4]; if (0 == child_st[0]) { #ifdef ARGPROC_DEBUG fprintf(stderr, "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 fprintf(stderr, "Child Completion AST\n"); #endif if (child_st[0] == 0) child_st[0] = 1; } static struct exit_control_block { struct exit_control_block *flink; int (*exit_routine)(); int arg_count; int *status_address; int exit_status; } 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); short iosb[4]; int status; int pid, j; short dvi_item = DVI$_DEVNAM; 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 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer); fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer); #endif if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one, 0, &pid, child_st, &zero, sig_child, &child_chan)))) { errno = EVMSERR; croak("Can't spawn subprocess"); } #ifdef ARGPROC_DEBUG fprintf(stderr, "Subprocess's Pid = %08X\n", pid); #endif sys$dclexh(&exit_block); if (NULL == freopen(mbxname, "wb", stdout)) { croak("Can't open pipe mailbox for output"); } } 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; 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); if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value)))) { errno = EVMSERR; croak("Can't create symbol for subprocess command"); } if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) && (vaxc$errno != 0x38250)) { errno = EVMSERR; croak("Can't spawn subprocess"); } if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */ if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid)))) { errno = EVMSERR; croak("Can't spawn subprocess"); } #ifdef ARGPROC_DEBUG fprintf(stderr, "%s\n", command); #endif sprintf(pidstring, "%08X", pid); fprintf(stderr, "%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 *****/ /* * flex_stat, flex_fstat * basic stat, but gets it right when asked to stat * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3) */ static char namecache[NAM$C_MAXRSS+1]; static int is_null_device(name) const char *name; { /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:". The underscore prefix, controller letter, and unit number are independently optional; for our purposes, the colon punctuation is not. The colon can be trailed by optional directory and/or filename, but two consecutive colons indicates a nodename rather than a device. [pr] */ if (*name == '_') ++name; if (tolower(*name++) != 'n') return 0; if (tolower(*name++) != 'l') return 0; if (tolower(*name) == 'a') ++name; if (*name == '0') ++name; return (*name++ == ':') && (*name != ':'); } /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/ int flex_fstat(int fd, struct stat *statbuf) { char fspec[NAM$C_MAXRSS+1]; if (!getname(fd,fspec)) return -1; return flex_stat(fspec,statbuf); } /* end of flex_fstat() */ /*}}}*/ /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/ flex_stat(char *fspec, struct stat *statbufp) { char fileified[NAM$C_MAXRSS+1]; int retval,myretval; struct stat tmpbuf; if (statbufp == &statcache) strcpy(namecache,fspec); if (is_null_device(fspec)) { /* Fake a stat() for the null device */ memset(statbufp,0,sizeof *statbufp); statbufp->st_dev = "_NLA0:"; statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; statbufp->st_uid = 0x00010001; statbufp->st_gid = 0x0001; time(&statbufp->st_mtime); statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; return 0; } if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1; else { myretval = stat(fileified,&tmpbuf); } retval = stat(fspec,statbufp); if (!myretval) { if (retval == -1) { *statbufp = tmpbuf; retval = 0; } else if (!retval) { /* Dir with same name. Substitute it. */ statbufp->st_mode &= ~S_IFDIR; statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR; strcpy(namecache,fileified); } } return retval; } /* end of flex_stat() */ /*}}}*/ /* trim_unixpath() * Trim Unix-style prefix off filespec, so it looks like what a shell * glob expansion would return (i.e. from specified prefix on, not * full path). Note that returned filespec is Unix-style, regardless * of whether input filespec was VMS-style or Unix-style. * * Returns !=0 on success, 0 on failure. */ /*{{{int trim_unixpath(char *template, char *fspec)*/ int trim_unixpath(char *template, char *fspec) { char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2; register int tmplen; if (strpbrk(fspec,"]>:") != NULL) { if (do_tounixspec(fspec,unixified,0) == NULL) return 0; else base = unixified; } else base = fspec; for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */ /* Find prefix to template consisting of path elements without wildcards */ if ((cp1 = strpbrk(template,"*%?")) == NULL) for (cp1 = template; *cp1; cp1++) ; else while (cp1 >= template && *cp1 != '/') cp1--; if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */ tmplen = cp1 - template; /* Try to find template prefix on filespec */ if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */ for (; cp2 - base > tmplen; base++) { if (*base != '/') continue; if (!memcmp(base + 1,template,tmplen)) break; } if (cp2 - base == tmplen) return 0; /* Not there - not good */ base++; /* Move past leading '/' */ /* Copy down remaining portion of filespec, including trailing NUL */ memmove(fspec,base,cp2 - base + 1); return 1; } /* end of trim_unixpath() */ /*}}}*/ /* Do the permissions allow some operation? Assumes statcache already set. */ /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a * subset of the applicable information. */ /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/ I32 cando(I32 bit, I32 effective, struct stat *statbufp) { unsigned long int objtyp = ACL$C_FILE, access, retsts; unsigned short int retlen; struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache}; static char usrname[L_cuserid]; static struct dsc$descriptor_s usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen, 0, 0, 0, 0}; if (!usrdsc.dsc$w_length) { cuserid(usrname); usrdsc.dsc$w_length = strlen(usrname); } namdsc.dsc$w_length = strlen(namecache); switch (bit) { case S_IXUSR: case S_IXGRP: case S_IXOTH: access = ARM$M_EXECUTE; break; case S_IRUSR: case S_IRGRP: case S_IROTH: access = ARM$M_READ; break; case S_IWUSR: case S_IWGRP: case S_IWOTH: access = ARM$M_READ; break; default: return FALSE; } retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); if (retsts == SS$_NORMAL) return TRUE; if (retsts == SS$_NOPRIV) return FALSE; _cksts(retsts); return FALSE; /* Should never get here */ } /* end of cando() */ /*}}}*/ /* * VMS readdir() routines. * Written by Rich $alz, in August, 1990. * This code has no copyright. * * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu * Minor modifications to original routines. */ /* Number of elements in vms_versions array */ #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0]) /* * Open a directory, return a handle for later use. */ /*{{{ DIR *opendir(char*name) */ DIR * opendir(char *name) { DIR *dd; char dir[NAM$C_MAXRSS+1]; /* Get memory for the handle, and the pattern. */ New(7006,dd,1,DIR); if (do_tovmspath(name,dir,0) == NULL) { Safefree((char *)dd); return(NULL); } New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char); /* Fill in the fields; mainly playing with the descriptor. */ (void)sprintf(dd->pattern, "%s*.*",dir); dd->context = 0; dd->count = 0; dd->vms_wantversions = 0; dd->pat.dsc$a_pointer = dd->pattern; dd->pat.dsc$w_length = strlen(dd->pattern); dd->pat.dsc$b_dtype = DSC$K_DTYPE_T; dd->pat.dsc$b_class = DSC$K_CLASS_S; return dd; } /* end of opendir() */ /*}}}*/ /* * Set the flag to indicate we want versions or not. */ /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/ void vmsreaddirversions(DIR *dd, int flag) { dd->vms_wantversions = flag; } /*}}}*/ /* * Free up an opened directory. */ /*{{{ void closedir(DIR *dd)*/ void closedir(DIR *dd) { (void)lib$find_file_end(&dd->context); Safefree(dd->pattern); Safefree((char *)dd); } /*}}}*/ /* * Collect all the version numbers for the current file. */ static void collectversions(dd) DIR *dd; { struct dsc$descriptor_s pat; struct dsc$descriptor_s res; struct dirent *e; char *p, *text, buff[sizeof dd->entry.d_name]; int i; unsigned long context, tmpsts; /* Convenient shorthand. */ e = &dd->entry; /* Add the version wildcard, ignoring the "*.*" put on before */ i = strlen(dd->pattern); New(7008,text,i + e->d_namlen + 3,char); (void)strcpy(text, dd->pattern); (void)sprintf(&text[i - 3], "%s;*", e->d_name); /* Set up the pattern descriptor. */ pat.dsc$a_pointer = text; pat.dsc$w_length = i + e->d_namlen - 1; pat.dsc$b_dtype = DSC$K_DTYPE_T; pat.dsc$b_class = DSC$K_CLASS_S; /* Set up result descriptor. */ res.dsc$a_pointer = buff; res.dsc$w_length = sizeof buff - 2; res.dsc$b_dtype = DSC$K_DTYPE_T; res.dsc$b_class = DSC$K_CLASS_S; /* Read files, collecting versions. */ for (context = 0, e->vms_verscount = 0; e->vms_verscount < VERSIZE(e); e->vms_verscount++) { tmpsts = lib$find_file(&pat, &res, &context); if (tmpsts == RMS$_NMF || context == 0) break; _cksts(tmpsts); buff[sizeof buff - 1] = '\0'; if (p = strchr(buff, ';')) e->vms_versions[e->vms_verscount] = atoi(p + 1); else e->vms_versions[e->vms_verscount] = -1; } _cksts(lib$find_file_end(&context)); Safefree(text); } /* end of collectversions() */ /* * Read the next entry from the directory. */ /*{{{ struct dirent *readdir(DIR *dd)*/ struct dirent * readdir(DIR *dd) { struct dsc$descriptor_s res; char *p, buff[sizeof dd->entry.d_name]; int i; unsigned long int tmpsts; /* Set up result descriptor, and get next file. */ res.dsc$a_pointer = buff; res.dsc$w_length = sizeof buff - 2; res.dsc$b_dtype = DSC$K_DTYPE_T; res.dsc$b_class = DSC$K_CLASS_S; dd->count++; tmpsts = lib$find_file(&dd->pat, &res, &dd->context); if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */ /* Force the buffer to end with a NUL, and downcase name to match C convention. */ buff[sizeof buff - 1] = '\0'; for (p = buff; !isspace(*p); p++) *p = _tolower(*p); *p = '\0'; /* Skip any directory component and just copy the name. */ if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1); else (void)strcpy(dd->entry.d_name, buff); /* Clobber the version. */ if (p = strchr(dd->entry.d_name, ';')) *p = '\0'; dd->entry.d_namlen = strlen(dd->entry.d_name); dd->entry.vms_verscount = 0; if (dd->vms_wantversions) collectversions(dd); return &dd->entry; } /* end of readdir() */ /*}}}*/ /* * Return something that can be used in a seekdir later. */ /*{{{ long telldir(DIR *dd)*/ long telldir(DIR *dd) { return dd->count; } /*}}}*/ /* * Return to a spot where we used to be. Brute force. */ /*{{{ void seekdir(DIR *dd,long count)*/ void seekdir(DIR *dd, long count) { int vms_wantversions; unsigned long int tmpsts; /* If we haven't done anything yet... */ if (dd->count == 0) return; /* Remember some state, and clear it. */ vms_wantversions = dd->vms_wantversions; dd->vms_wantversions = 0; _cksts(lib$find_file_end(&dd->context)); dd->context = 0; /* The increment is in readdir(). */ for (dd->count = 0; dd->count < count; ) (void)readdir(dd); dd->vms_wantversions = vms_wantversions; } /* end of seekdir() */ /*}}}*/ /* VMS subprocess management * * my_vfork() - just a vfork(), after setting a flag to record that * the current script is trying a Unix-style fork/exec. * * vms_do_aexec() and vms_do_exec() are called in response to the * perl 'exec' function. If this follows a vfork call, then they * call out the the regular perl routines in doio.c which do an * execvp (for those who really want to try this under VMS). * Otherwise, they do exactly what the perl docs say exec should * do - terminate the current script and invoke a new command * (See below for notes on command syntax.) * * do_aspawn() and do_spawn() implement the VMS side of the perl * 'system' function. * * Note on command arguments to perl 'exec' and 'system': When handled * in 'VMSish fashion' (i.e. not after a call to vfork) The args * are concatenated to form a DCL command string. If the first arg * begins with '$' (i.e. the perl script had "\$ Type" or some such), * the the command string is hrnded off to DCL directly. Otherwise, * the first token of the command is taken as the filespec of an image * to run. The filespec is expanded using a default type of '.EXE' and * the process defaults for device, directory, etc., and the resultant * filespec is invoked using the DCL verb 'MCR', and passed the rest of * the command string as parameters. This is perhaps a bit compicated, * but I hope it will form a happy medium between what VMS folks expect * from lib$spawn and what Unix folks expect from exec. */ static int vfork_called; /*{{{int my_vfork()*/ int my_vfork() { vfork_called = 1; return vfork(); } /*}}}*/ static void setup_argstr(SV *really, SV **mark, SV **sp, char **argstr) { char *tmps, *junk; register size_t cmdlen = 0; size_t rlen; register SV **idx; idx = mark; if (really && *(tmps = SvPV(really,rlen))) { cmdlen += rlen + 1; idx++; } for (idx++; idx <= sp; idx++) { if (*idx) { junk = SvPVx(*idx,rlen); cmdlen += rlen ? rlen + 1 : 0; } } New(401,*argstr,cmdlen, char); if (*tmps) { strcpy(*argstr,tmps); mark++; } else **argstr = '\0'; while (++mark <= sp) { if (*mark) { strcat(*argstr," "); strcat(*argstr,SvPVx(*mark,na)); } } } /* end of setup_argstr() */ static unsigned long int setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) { char resspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(defdsc,".EXE"); $DESCRIPTOR(resdsc,resspec); struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; unsigned long int cxt = 0, flags = 1, retsts; register char *s, *rest, *cp; register int isdcl = 0; s = cmd; while (*s && isspace(*s)) s++; if (check_img) { if (*s == '$') { /* Check whether this is a DCL command: leading $ and */ isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */ for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) { if (*cp == ':' || *cp == '[' || *cp == '<') { isdcl = 0; break; } } } } else isdcl = 1; if (isdcl) { /* It's a DCL command, just do it. */ cmddsc->dsc$a_pointer = cmd; cmddsc->dsc$w_length = strlen(cmd); } else { /* assume first token is an image spec */ cmd = s; while (*s && !isspace(*s)) s++; rest = *s ? s : 0; imgdsc.dsc$a_pointer = cmd; imgdsc.dsc$w_length = s - cmd; retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags); if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts; else { _cksts(retsts); _cksts(lib$find_file_end(&cxt)); s = resspec; while (*s && !isspace(*s)) s++; *s = '\0'; New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char); strcpy(Cmd,"$ MCR "); strcat(Cmd,resspec); if (rest) strcat(Cmd,rest); cmddsc->dsc$a_pointer = Cmd; cmddsc->dsc$w_length = strlen(Cmd); } } return SS$_NORMAL; } /* end of setup_cmddsc() */ /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */ bool vms_do_aexec(SV *really,SV **mark,SV **sp) { if (sp > mark) { if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called = 0; do_aexec(really,mark,sp); } else { /* no vfork - act VMSish */ setup_argstr(really,mark,sp,&Argv); return vms_do_exec(Argv); } } return FALSE; } /* end of vms_do_aexec() */ /*}}}*/ /* {{{bool vms_do_exec(char *cmd) */ bool vms_do_exec(char *cmd) { if (vfork_called) { /* this follows a vfork - act Unixish */ vfork_called = 0; do_exec(cmd); } else { /* no vfork - act VMSish */ struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1) vaxc$errno = lib$do_command(&cmddsc); errno = EVMSERR; if (dowarn) warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); do_execfree(); } return FALSE; } /* end of vms_do_exec() */ /*}}}*/ unsigned long int do_spawn(char *); /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) { if (sp > mark) { setup_argstr(really,mark,sp,&Argv); return do_spawn(Argv); } return SS$_ABORT; } /* end of do_aspawn() */ /*}}}*/ /* {{{unsigned long int do_spawn(char *cmd) */ unsigned long int do_spawn(char *cmd) { struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; unsigned long int substs; if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0)); if (!(substs&1)) { vaxc$errno = substs; errno = EVMSERR; if (dowarn) warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); } return substs; } /* end of do_spawn() */ /*}}}*/ /* * A simple fwrite replacement which outputs itmsz*nitm chars without * introducing record boundaries every itmsz chars. */ /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) { register char *cp, *end; end = (char *)src + itmsz * nitm; while ((char *)src <= end) { for (cp = src; cp <= end; cp++) if (!*cp) break; if (fputs(src,dest) == EOF) return EOF; if (cp < end) if (fputc('\0',dest) == EOF) return EOF; src = cp + 1; } return 1; } /* end of my_fwrite() */ /*}}}*/ #ifndef VMS_DO_SOCKETS /***** The following two routines are temporary, and should be removed, * along with the corresponding #defines in vmsish.h, when TCP/IP support * has been added to the VMS port of perl5. (The temporary hacks are * here now sho that pack can handle type N elements.) * - C. Bailey 16-Aug-1994 *****/ /*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/ unsigned short int tmp_shortflip(unsigned short int val) { return val << 8 | val >> 8; } /*}}}*/ /*{{{ unsigned long int tmp_longflip(unsigned long int val)*/ unsigned long int tmp_longflip(unsigned long int val) { unsigned long int scratch = val; unsigned char savbyte, *tmp; tmp = (unsigned char *) &scratch; savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte; savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte; return scratch; } /*}}}*/ #endif