diff options
Diffstat (limited to 'vms/vms.c')
| -rw-r--r-- | vms/vms.c | 1732 |
1 files changed, 1259 insertions, 473 deletions
@@ -1,14 +1,18 @@ -/* VMS-specific routines for perl5 +/* vms.c * - * Last revised: 09-Oct-1994 + * VMS-specific routines for perl5 + * + * Last revised: 09-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu */ #include <acedef.h> #include <acldef.h> #include <armdef.h> +#include <atrdef.h> #include <chpdef.h> #include <descrip.h> #include <dvidef.h> +#include <fibdef.h> #include <float.h> #include <fscndef.h> #include <iodef.h> @@ -16,6 +20,7 @@ #include <libdef.h> #include <lib$routines.h> #include <lnmdef.h> +#include <prvdef.h> #include <psldef.h> #include <rms.h> #include <shrdef.h> @@ -23,25 +28,44 @@ #include <starlet.h> #include <stsdef.h> #include <syidef.h> - +#include <uaidef.h> +#include <uicdef.h> #include "EXTERN.h" #include "perl.h" +#include "XSUB.h" struct itmlst_3 { unsigned short int buflen; unsigned short int itmcode; void *bufadr; - unsigned long int retlen; + unsigned short 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; } +static char * +my_trnlnm(char *lnm, char *eqv) +{ + static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1]; + unsigned short int eqvlen; + unsigned long int retsts, attr = LNM$M_CASE_BLIND; + $DESCRIPTOR(tabdsc,"LNM$FILE_DEV"); + struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}; + struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen}, + {0, 0, 0, 0}}; + + if (!eqv) eqv = __my_trnlnm_eqv; + lnmlst[0].bufadr = (void *)eqv; + lnmdsc.dsc$a_pointer = lnm; + lnmdsc.dsc$w_length = strlen(lnm); + retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst); + if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch; + else if (retsts & 1) { + eqv[eqvlen] = '\0'; + return eqv; + } + _ckvmssts(retsts); /* Must be an error */ + return Nullch; /* Not reached, assuming _ckvmssts() bails out */ +} /* my_getenv * Translate a logical name. Substitute for CRTL getenv() to avoid @@ -57,47 +81,33 @@ 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'; + if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) { + getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv); + return __my_getenv_eqv; + } + else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) { 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 */ + unsigned long int retsts; + struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0}, + valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T, + DSC$K_CLASS_S, __my_getenv_eqv}; + symdsc.dsc$w_length = cp1 - lnm; + symdsc.dsc$a_pointer = uplnm; + retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0); + if (retsts == LIB$_INVSYMNAM) return Nullch; + if (retsts != LIB$_NOSUCHSYM) { + /* We want to return only logical names or CRTL Unix emulations */ + if (retsts & 1) return Nullch; + _ckvmssts(retsts); } + else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */ } - return NULL; + return Nullch; } /* end of my_getenv() */ /*}}}*/ @@ -121,17 +131,18 @@ my_setenv(char *lnm,char *eqv) 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 == SS$_IVLOGNAM) return; + if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts); if (!(retsts & 1)) { retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */ - if (retsts != SS$_NOLOGNAM) _cksts(retsts); + if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts); } } else { eqvdsc.dsc$w_length = strlen(eqv); eqvdsc.dsc$a_pointer = eqv; - _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0)); + _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0)); } } /* end of my_setenv() */ @@ -146,7 +157,7 @@ do_rmdir(char *name) { char dirfile[NAM$C_MAXRSS+1]; int retval; - stat_t st; + struct stat st; if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1; if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; @@ -170,24 +181,24 @@ 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; + unsigned long int 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; + 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}; + 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? */ @@ -195,15 +206,15 @@ kill_file(char *name) * 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)); + _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$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; + newace.myace$l_ident = oldace.myace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { - errno = EVMSERR; - vaxc$errno = aclsts; + set_errno(EVMSERR); + set_vaxc_errno(aclsts); return -1; } /* Grab any existing ACEs with this identifier in case we fail */ @@ -212,7 +223,7 @@ kill_file(char *name) /* Add the new ACE . . . */ if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1)) goto yourroom; - if (rmsts = remove(name)) { + 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)) @@ -231,8 +242,8 @@ kill_file(char *name) if (aclsts & 1) aclsts = fndsts; } if (!(aclsts & 1)) { - errno = EVMSERR; - vaxc$errno = aclsts; + set_errno(EVMSERR); + set_vaxc_errno(aclsts); return -1; } @@ -241,6 +252,149 @@ kill_file(char *name) } /* end of kill_file() */ /*}}}*/ +/* my_utime - update modification time of a file + * calling sequence is identical to POSIX utime(), but under + * VMS only the modification time is changed; ODS-2 does not + * maintain access times. Restrictions differ from the POSIX + * definition in that the time can be changed as long as the + * caller has permission to execute the necessary IO$_MODIFY $QIO; + * no separate checks are made to insure that the caller is the + * owner of the file or has special privs enabled. + * Code here is based on Joe Meadows' FILE utility. + */ + +/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00) + * to VMS epoch (01-JAN-1858 00:00:00.00) + * in 100 ns intervals. + */ +static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; + +/*{{{int my_utime(char *path, struct utimbuf *utimes)*/ +int my_utime(char *file, struct utimbuf *utimes) +{ + register int i; + long int bintime[2], len = 2, lowbit, unixtime, + secscale = 10000000; /* seconds --> 100 ns intervals */ + unsigned long int chan, iosb[2], retsts; + char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS]; + struct FAB myfab = cc$rms_fab; + struct NAM mynam = cc$rms_nam; + struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}}; + struct fibdef myfib; + struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, + devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, + fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; + + if (file == NULL || *file == '\0') { + set_errno(ENOENT); + set_vaxc_errno(LIB$_INVARG); + return -1; + } + if (tovmsspec(file,vmsspec) == NULL) return -1; + + if (utimes != NULL) { + /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) + * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00). + * Since time_t is unsigned long int, and lib$emul takes a signed long int + * as input, we force the sign bit to be clear by shifting unixtime right + * one bit, then multiplying by an extra factor of 2 in lib$emul(). + */ + lowbit = (utimes->modtime & 1) ? secscale : 0; + unixtime = (long int) utimes->modtime; + unixtime >> 1; secscale << 1; + retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); + if (!(retsts & 1)) { + set_errno(EVMSERR); + set_vaxc_errno(retsts); + return -1; + } + retsts = lib$addx(bintime,utime_baseadjust,bintime,&len); + if (!(retsts & 1)) { + set_errno(EVMSERR); + set_vaxc_errno(retsts); + return -1; + } + } + else { + /* Just get the current time in VMS format directly */ + retsts = sys$gettim(bintime); + if (!(retsts & 1)) { + set_errno(EVMSERR); + set_vaxc_errno(retsts); + return -1; + } + } + + myfab.fab$l_fna = vmsspec; + myfab.fab$b_fns = (unsigned char) strlen(vmsspec); + myfab.fab$l_nam = &mynam; + mynam.nam$l_esa = esa; + mynam.nam$b_ess = (unsigned char) sizeof esa; + mynam.nam$l_rsa = rsa; + mynam.nam$b_rss = (unsigned char) sizeof rsa; + + /* Look for the file to be affected, letting RMS parse the file + * specification for us as well. I have set errno using only + * values documented in the utime() man page for VMS POSIX. + */ + retsts = sys$parse(&myfab,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else if (retsts == RMS$_DIR) set_errno(ENOTDIR); + else set_errno(EVMSERR); + return -1; + } + retsts = sys$search(&myfab,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == RMS$_PRV) set_errno(EACCES); + else if (retsts == RMS$_FNF) set_errno(ENOENT); + else set_errno(EVMSERR); + return -1; + } + + devdsc.dsc$w_length = mynam.nam$b_dev; + devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev; + + retsts = sys$assign(&devdsc,&chan,0,0); + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR); + else if (retsts == SS$_NOPRIV) set_errno(EACCES); + else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR); + else set_errno(EVMSERR); + return -1; + } + + fnmdsc.dsc$a_pointer = mynam.nam$l_name; + fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver; + + memset((void *) &myfib, 0, sizeof myfib); +#ifdef __DECC + for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; + for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; + /* This prevents the revision time of the file being reset to the current + * time as a reqult of our IO$_MODIFY $QIO. */ + myfib.fib$l_acctl = FIB$M_NORECORD; +#else + for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i]; + for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i]; + myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD; +#endif + retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0); + if (retsts & 1) retsts = iosb[0]; + if (!(retsts & 1)) { + set_vaxc_errno(retsts); + if (retsts == SS$_NOPRIV) set_errno(EACCES); + else set_errno(EVMSERR); + return -1; + } + + return 0; +} /* end of my_utime() */ +/*}}}*/ + static void create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) { @@ -253,12 +407,12 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) * preprocessor consant BUFSIZ from stdio.h as the size of the * 'pipe' mailbox. */ - _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); + _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ; } - _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); + _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); - _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); + _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() */ @@ -267,18 +421,52 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) struct pipe_details { struct pipe_details *next; - FILE *fp; - int pid; - unsigned long int completion; + FILE *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 */ + unsigned long int completion; /* termination status of subprocess */ }; +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; +}; + static struct pipe_details *open_pipes = NULL; static $DESCRIPTOR(nl_desc, "NL:"); static int waitpid_asleep = 0; +static unsigned long int +pipe_exit_routine() +{ + unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts; + + while (open_pipes != NULL) { + if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/ + _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort)); + sleep(1); + } + if (!open_pipes->done) /* We tried to be nice . . . */ + _ckvmssts(sys$delprc(&open_pipes->pid,0)); + if (!((sts = my_pclose(open_pipes->fp))&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 -popen_completion_ast(unsigned long int unused) +popen_completion_ast(struct pipe_details *thispipe) { + thispipe->done = TRUE; if (waitpid_asleep) { waitpid_asleep = 0; sys$wake(0,0); @@ -289,6 +477,7 @@ popen_completion_ast(unsigned long int unused) FILE * my_popen(char *cmd, char *mode) { + static int handler_set_up = FALSE; char mbxname[64]; unsigned short int chan; unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */ @@ -301,8 +490,6 @@ my_popen(char *cmd, char *mode) New(7001,info,1,struct pipe_details); - info->completion=0; /* I assume this will remain 0 until terminates */ - /* create mailbox */ create_mbx(&chan,&namdsc); @@ -310,7 +497,7 @@ my_popen(char *cmd, char *mode) info->fp=fopen(mbxname, mode); /* give up other channel onto it */ - _cksts(sys$dassgn(chan)); + _ckvmssts(sys$dassgn(chan)); if (!info->fp) return Nullfp; @@ -318,16 +505,25 @@ my_popen(char *cmd, char *mode) cmddsc.dsc$w_length=strlen(cmd); cmddsc.dsc$a_pointer=cmd; - if (strcmp(mode,"r")==0) { - _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags, + info->mode = *mode; + info->done = FALSE; + info->completion=0; + + if (*mode == 'r') { + _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags, 0 /* name */, &info->pid, &info->completion, - 0, popen_completion_ast,0,0,0,0)); + 0, popen_completion_ast,info,0,0,0)); } else { - _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, - 0 /* name */, &info->pid, &info->completion)); + _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags, + 0 /* name */, &info->pid, &info->completion, + 0, popen_completion_ast,info,0,0,0)); } + if (!handler_set_up) { + _ckvmssts(sys$dclexh(&pipe_exitblock)); + handler_set_up = TRUE; + } info->next=open_pipes; /* prepend to list */ open_pipes=info; @@ -339,46 +535,41 @@ my_popen(char *cmd, char *mode) I32 my_pclose(FILE *fp) { struct pipe_details *info, *last = NULL; - unsigned long int abort = SS$_TIMEOUT, retsts; + unsigned long int 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 ???"); + croak("No such pipe open"); + + if (info->done) retsts = info->completion; + else waitpid(info->pid,(int *) &retsts,0); - 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) { + while (!info->done) { waitpid_asleep = 1; sys$hiber(); } @@ -389,19 +580,21 @@ waitpid(unsigned long int pid, int *statusp, int flags) 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]; + unsigned long int interval[2],sts; - _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); + if (dowarn) { + _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)); + _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0)); + if (ownerpid != mypid) + warn("pid %d not a child",pid); + } - _cksts(sys$bintim(&intdsc,interval)); + _ckvmssts(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()); + _ckvmssts(sys$schdwk(0,0,interval,0)); + _ckvmssts(sys$hiber()); } - _cksts(sts); + _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, @@ -413,7 +606,6 @@ waitpid(unsigned long int pid, int *statusp, int flags) } } /* end of waitpid() */ -#endif /*}}}*/ /*}}}*/ /*}}}*/ @@ -443,7 +635,7 @@ my_gconvert(double val, int ndig, int trail, char *buf) ** 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 +** 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 @@ -466,21 +658,41 @@ my_gconvert(double val, int ndig, int trail, char *buf) ** tovmsspec() - convert any file spec into a VMS-style spec. */ +static char *do_tounixspec(char *, char *, int); + /*{{{ 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; + char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1]; if (dir == NULL) return NULL; + strcpy(trndir,dir); + while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ; + dir = trndir; dirlen = strlen(dir); if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */ + 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 (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } + else if (strstr(trndir,"..") != NULL) { + /* If we have a relative path, let do_tovmsspec figure it out, + * rather than repeating the code here */ + if (do_tovmsspec(trndir,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,'/'))) cp1 = dir; if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */ @@ -489,42 +701,44 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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. */ + set_errno(ENOTDIR); /* Bzzt. */ + set_vaxc_errno(RMS$_DIR); return NULL; } } dirlen = cp2 - dir; } else { /* There's a type, and it's not .dir. Bzzt. */ - errno = ENOTDIR; + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); 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; - } + } + /* 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'; - } + } + 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. */ @@ -533,19 +747,20 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } else { /* VMS-style directory spec */ char esa[NAM$C_MAXRSS+1], term; - unsigned long int sts, cmplen; + unsigned long int cmplen, hasdev, hasdir, hastype, hasver; 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; - dirnam.nam$b_nop = NAM$M_SYNCHK; if (!(sys$parse(&dirfab)&1)) { - errno = EVMSERR; - vaxc$errno = dirfab.fab$l_sts; + set_errno(EVMSERR); + set_vaxc_errno(dirfab.fab$l_sts); return NULL; } savnam = dirnam; @@ -555,51 +770,82 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } else { if (dirfab.fab$l_sts != RMS$_FNF) { - errno = EVMSERR; - vaxc$errno = dirfab.fab$l_sts; + 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_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. */ - errno = ENOTDIR; + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); 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'; - } + } + 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(7011,retspec,dirnam.nam$b_esl,char); + else retspec = __fileify_retbuf; + strcpy(retspec,esa); + return retspec; + } + 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 { - /* 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 (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)) { + 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(7011,retspec,retlen+6,char); + else if (ts) New(7012,retspec,retlen+7,char); else retspec = __fileify_retbuf; - strcpy(retspec,esa); + 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 = ']'; + } + else { + memcpy(retspec+dirlen,cp1+2,retlen-dirlen); + retspec[retlen] = '\0'; + /* Convert last '.' to ']' */ + for (cp1 = retspec+retlen-1; *cp1 != '.'; cp1--) ; + *cp1 = ']'; + } } - else { /* This is a top-level dir. Add the MFD to the path. */ + 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; @@ -610,8 +856,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) cp1 += 2; strcpy(cp2+9,cp1); } - } - /* Again, we've set up the string up through the filename. Add the + } + /* 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; @@ -629,26 +875,36 @@ 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; + char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1]; if (dir == NULL) return NULL; + strcpy(trndir,dir); + while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ; + dir = trndir; + 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; + if (*dir == '.' && (*(dir+1) == '\0' || + (*(dir+1) == '.' && *(dir+2) == '\0'))) + retlen = 2 + (*(dir+1) != '\0'); + else { + if (!(cp1 = strrchr(dir,'/'))) cp1 = dir; + if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') { + 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. */ + set_errno(ENOTDIR); + set_vaxc_errno(RMS$_DIR); + return NULL; + } } - 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; } } - 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; @@ -661,30 +917,36 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) } else { /* VMS-style directory spec */ char esa[NAM$C_MAXRSS+1]; - unsigned long int sts, cmplen; + unsigned long int 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; + 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(7014,retpath,strlen(dir),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 = sizeof esa; + dirnam.nam$b_ess = (unsigned char) 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; + set_errno(EVMSERR); + set_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 (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */ if (dirfab.fab$l_sts != RMS$_FNF) { - errno = EVMSERR; - vaxc$errno = dirfab.fab$l_sts; + set_errno(EVMSERR); + set_vaxc_errno(dirfab.fab$l_sts); return NULL; } dirnam = savnam; /* No; just work with potential name */ @@ -695,30 +957,21 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) 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; + 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; } + /* OK, the type was fine. Now pull any file name into the + directory path. */ + if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']'; 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'; + 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(7014,retpath,retlen,char); else retpath = __pathify_retbuf; @@ -741,7 +994,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; int devlen, dirlen; - if (spec == NULL || *spec == '\0') return NULL; + if (spec == NULL) return NULL; if (buf) rslt = buf; else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char); else rslt = __tounixspec_retbuf; @@ -771,7 +1024,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) } if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ if (ts) Safefree(rslt); /* filespecs like */ - errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */ + set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */ return NULL; } cp2++; @@ -793,7 +1046,8 @@ static char *do_tounixspec(char *spec, char *buf, int ts) *(cp1++) = '/'; if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) { if (ts) Safefree(rslt); - errno = ERANGE; + set_errno(ERANGE); + set_errno(RMS$_SYN); return NULL; } } @@ -818,7 +1072,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) } if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */ if (ts) Safefree(rslt); /* filespecs like */ - errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */ + set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */ return NULL; } cp2++; @@ -841,32 +1095,84 @@ 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; + register char *rslt, *dirend, *cp1, *cp2; + register unsigned long int infront = 0; - if (path == NULL || *path == '\0') return NULL; + if (path == NULL) 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 || + if (strpbrk(path,"]:>") || (dirend = strrchr(path,'/')) == NULL) { - strcpy(rslt,path); + 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 "/.."? */ + if (!*(dirend+2)) dirend +=2; + if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; + } cp1 = rslt; cp2 = path; if (*cp2 == '/') { while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; *(cp1++) = ':'; *(cp1++) = '['; - cp2++; - } + if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0'; + else cp2++; + } else { *(cp1++) = '['; - *(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; + } + if (cp2 > dirend) cp2 = dirend; + } + else *(cp1++) = '.'; + } + for (; cp2 < dirend; cp2++) { + if (*cp2 == '/') { + if (*(cp1-1) != '.') *(cp1++) = '.'; + infront = 0; + } + else if (!infront && *cp2 == '.') { + 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--; + } + cp2 += 2; + if (cp2 == dirend) { + if (*(cp1-1) == '.') cp1--; + break; + } + } + else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ + } + else { + if (*(cp1-1) == '-') *(cp1++) = '.'; + if (*cp2 == '/') *(cp1++) = '.'; + else if (*cp2 == '.') *(cp1++) = '_'; + else *(cp1++) = *cp2; + infront = 1; + } } - for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2; + if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */ *(cp1++) = ']'; - cp2++; + if (*cp2) cp2++; /* check in case we ended with trailing '..' */ while (*cp2) *(cp1++) = *(cp2++); *cp1 = '\0'; @@ -884,7 +1190,7 @@ static char *do_tovmspath(char *path, char *buf, int ts) { int vmslen; char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp; - if (path == NULL || *path == '\0') return NULL; + 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; @@ -913,7 +1219,7 @@ static char *do_tounixpath(char *path, char *buf, int ts) { int unixlen; char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp; - if (path == NULL || *path == '\0') return NULL; + 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; @@ -1025,7 +1331,6 @@ getredirection(int *ac, char ***av) 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 @@ -1050,8 +1355,8 @@ getredirection(int *ac, char ***av) { if (j+1 >= argc) { - errno = EINVAL; - croak("No input file"); + fprintf(stderr,"No input file after < on command line"); + exit(LIB$_WRONUMARG); } in = argv[++j]; continue; @@ -1065,8 +1370,8 @@ getredirection(int *ac, char ***av) { if (j+1 >= argc) { - errno = EINVAL; - croak("No input file"); + fprintf(stderr,"No output file after > on command line"); + exit(LIB$_WRONUMARG); } out = argv[++j]; continue; @@ -1085,8 +1390,8 @@ getredirection(int *ac, char ***av) out = 1 + ap; if (j >= argc) { - errno = EINVAL; - croak("No output file"); + fprintf(stderr,"No output file after > or >> on command line"); + exit(LIB$_WRONUMARG); } continue; } @@ -1104,11 +1409,11 @@ getredirection(int *ac, char ***av) if ('\0' == ap[2]) err = argv[++j]; else - err = 1 + ap; + err = 2 + ap; if (j >= argc) { - errno = EINVAL; - croak("No error file"); + fprintf(stderr,"No output file after 2> or 2>> on command line"); + exit(LIB$_WRONUMARG); } continue; } @@ -1116,8 +1421,8 @@ getredirection(int *ac, char ***av) { if (j+1 >= argc) { - errno = EPIPE; - croak("No command into which to pipe"); + fprintf(stderr,"No command into which to pipe on command line"); + exit(LIB$_WRONUMARG); } cmargc = argc-(j+1); cmargv = &argv[j+1]; @@ -1147,8 +1452,8 @@ getredirection(int *ac, char ***av) { if (out != NULL) { - errno = EINVAL; - croak("'|' and '>' may not both be specified on command line"); + fprintf(stderr,"'|' and '>' may not both be specified on command line"); + exit(LIB$_INVARGORD); } pipe_and_fork(cmargv); } @@ -1168,10 +1473,10 @@ getredirection(int *ac, char ***av) if (in != NULL) { - errno = EINVAL; - croak("'|' and '<' may not both be specified on command line"); + fprintf(stderr,"'|' and '<' may not both be specified on command line"); + exit(LIB$_INVARGORD); } - fgetname(stdin, mbxname); + fgetname(stdin, mbxname,1); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); @@ -1180,24 +1485,37 @@ getredirection(int *ac, char ***av) 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; + set_errno(0); + set_vaxc_errno(1); freopen(mbxname, "rb", stdin); if (errno != 0) { - croak("Error reopening pipe (name: %s) in binary mode",mbxname); + fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname); + exit(vaxc$errno); } } if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) { - croak("Can't open input file %s",in); + fprintf(stderr,"Can't open input file %s as stdin",in); + exit(vaxc$errno); } if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) { - croak("Can't open output file %s",out); + fprintf(stderr,"Can't open output file %s as stdout",out); + exit(vaxc$errno); } - if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2"))) - { - croak("Can't open error file %s",err); + if (err != NULL) { + FILE *tmperr; + if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) + { + fprintf(stderr,"Can't open error file %s as stderr",err); + exit(vaxc$errno); + } + fclose(tmperr); + if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2")) + { + exit(vaxc$errno); + } } #ifdef ARGPROC_DEBUG fprintf(stderr, "Arglist:\n"); @@ -1231,9 +1549,8 @@ static void expand_wild_cards(char *item, int *count) { int expcount = 0; -int context = 0; +unsigned long int context = 0; int isunix = 0; -int status; int status_value; char *had_version; char *had_device; @@ -1241,7 +1558,7 @@ int had_directory; char *devdir; char vmsspec[NAM$C_MAXRSS+1]; $DESCRIPTOR(filespec, ""); -$DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;"); +$DESCRIPTOR(defaultspec, "SYS$DISK:[]"); $DESCRIPTOR(resultspec, ""); unsigned long int zero = 0; @@ -1253,7 +1570,7 @@ unsigned long int zero = 0; 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,'/')) + 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; @@ -1304,9 +1621,9 @@ unsigned long int zero = 0; static int child_st[2];/* Event Flag set when child process completes */ -static short child_chan;/* I/O Channel for Pipe Mailbox */ +static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */ -static exit_handler(int *status) +static unsigned long int exit_handler(int *status) { short iosb[4]; @@ -1334,14 +1651,7 @@ static void sig_child(int chan) 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 = +static struct exit_control_block exit_block = { 0, exit_handler, @@ -1356,10 +1666,7 @@ static void pipe_and_fork(char **cmargv) $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]); @@ -1377,20 +1684,16 @@ static void pipe_and_fork(char **cmargv) 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, + _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one, 0, &pid, child_st, &zero, sig_child, - &child_chan)))) - { - errno = EVMSERR; - croak("Can't spawn subprocess"); - } + &child_chan)); #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"); + fprintf(stderr,"Can't open output pipe (name %s)",mbxname); } } @@ -1404,7 +1707,7 @@ static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID"); char pidstring[80]; $DESCRIPTOR(pidstr, ""); int pid; -unsigned long int flags = 17, one = 1; +unsigned long int flags = 17, one = 1, retsts; strcat(command, argv[0]); while (--argc) @@ -1415,23 +1718,14 @@ unsigned long int flags = 17, one = 1; } 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"); - } + _ckvmssts(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(lib$spawn(&cmd, &null, 0, &one, 0, &pid)); + } + else { + _ckvmssts(retsts); + } #ifdef ARGPROC_DEBUG fprintf(stderr, "%s\n", command); #endif @@ -1445,84 +1739,6 @@ unsigned long int flags = 17, one = 1; /*}}}*/ /***** 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 @@ -1567,57 +1783,6 @@ trim_unixpath(char *template, char *fspec) } /* 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. @@ -1728,15 +1893,15 @@ collectversions(dd) e->vms_verscount++) { tmpsts = lib$find_file(&pat, &res, &context); if (tmpsts == RMS$_NMF || context == 0) break; - _cksts(tmpsts); + _ckvmssts(tmpsts); buff[sizeof buff - 1] = '\0'; - if (p = strchr(buff, ';')) + 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)); + _ckvmssts(lib$find_file_end(&context)); Safefree(text); } /* end of collectversions() */ @@ -1750,7 +1915,6 @@ 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. */ @@ -1760,7 +1924,8 @@ readdir(DIR *dd) 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. */ + if ( tmpsts == RMS$_NMF || tmpsts == RMS$_FNF || + 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'; @@ -1768,11 +1933,11 @@ readdir(DIR *dd) *p = '\0'; /* Skip any directory component and just copy the name. */ - if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1); + 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'; + if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0'; dd->entry.d_namlen = strlen(dd->entry.d_name); dd->entry.vms_verscount = 0; @@ -1801,7 +1966,6 @@ void seekdir(DIR *dd, long count) { int vms_wantversions; - unsigned long int tmpsts; /* If we haven't done anything yet... */ if (dd->count == 0) @@ -1810,7 +1974,7 @@ seekdir(DIR *dd, long count) /* Remember some state, and clear it. */ vms_wantversions = dd->vms_wantversions; dd->vms_wantversions = 0; - _cksts(lib$find_file_end(&dd->context)); + _ckvmssts(lib$find_file_end(&dd->context)); dd->context = 0; /* The increment is in readdir(). */ @@ -1858,7 +2022,7 @@ static int vfork_called; int my_vfork() { - vfork_called = 1; + vfork_called++; return vfork(); } /*}}}*/ @@ -1872,7 +2036,8 @@ setup_argstr(SV *really, SV **mark, SV **sp, char **argstr) register SV **idx; idx = mark; - if (really && *(tmps = SvPV(really,rlen))) { + tmps = SvPV(really,rlen); + if (really && *tmps) { cmdlen += rlen + 1; idx++; } @@ -1937,8 +2102,8 @@ setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) 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)); + _ckvmssts(retsts); + _ckvmssts(lib$find_file_end(&cxt)); s = resspec; while (*s && !isspace(*s)) s++; *s = '\0'; @@ -1961,13 +2126,17 @@ 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); + vfork_called--; + if (vfork_called < 0) { + warn("Internal inconsistency in tracking vforks"); + vfork_called = 0; + } + else return do_aexec(really,mark,sp); } + + /* no vfork - act VMSish */ + setup_argstr(really,mark,sp,Argv); + return vms_do_exec(*Argv); } return FALSE; @@ -1980,16 +2149,23 @@ vms_do_exec(char *cmd) { if (vfork_called) { /* this follows a vfork - act Unixish */ - vfork_called = 0; - do_exec(cmd); + vfork_called--; + if (vfork_called < 0) { + warn("Internal inconsistency in tracking vforks"); + vfork_called = 0; + } + else return do_exec(cmd); } - else { /* no vfork - act VMSish */ + + { /* no vfork - act VMSish */ struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + unsigned long int retsts; - if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1) - vaxc$errno = lib$do_command(&cmddsc); + if ((retsts = setup_cmddsc(cmd,&cmddsc,1)) & 1) + retsts = lib$do_command(&cmddsc); - errno = EVMSERR; + set_errno(EVMSERR); + set_vaxc_errno(retsts); if (dowarn) warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); do_execfree(); @@ -2008,8 +2184,8 @@ do_aspawn(SV *really,SV **mark,SV **sp) { if (sp > mark) { - setup_argstr(really,mark,sp,&Argv); - return do_spawn(Argv); + setup_argstr(really,mark,sp,Argv); + return do_spawn(*Argv); } return SS$_ABORT; @@ -2023,14 +2199,19 @@ 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 (!cmd || !*cmd) { + _ckvmssts(lib$spawn(0,0,0,0,0,&substs,0,0,0,0,0)); + } + else if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) { + _ckvmssts(lib$spawn(&cmddsc,0,0,0,0,&substs,0,0,0,0,0)); + } if (!(substs&1)) { - vaxc$errno = substs; - errno = EVMSERR; + set_errno(EVMSERR); + set_vaxc_errno(substs); if (dowarn) - warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno)); + warn("Can't exec \"%s\": %s", + (cmd && *cmd) ? cmddsc.dsc$a_pointer : "", Strerror(errno)); } return substs; @@ -2062,34 +2243,639 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) } /* 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) +/* + * Here are replacements for the following Unix routines in the VMS environment: + * getpwuid Get information for a particular UIC or UID + * getpwnam Get information for a named user + * getpwent Get information for each user in the rights database + * setpwent Reset search to the start of the rights database + * endpwent Finish searching for users in the rights database + * + * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure + * (defined in pwd.h), which contains the following fields:- + * struct passwd { + * char *pw_name; Username (in lower case) + * char *pw_passwd; Hashed password + * unsigned int pw_uid; UIC + * unsigned int pw_gid; UIC group number + * char *pw_unixdir; Default device/directory (VMS-style) + * char *pw_gecos; Owner name + * char *pw_dir; Default device/directory (Unix-style) + * char *pw_shell; Default CLI name (eg. DCL) + * }; + * If the specified user does not exist, getpwuid and getpwnam return NULL. + * + * pw_uid is the full UIC (eg. what's returned by stat() in st_uid). + * not the UIC member number (eg. what's returned by getuid()), + * getpwuid() can accept either as input (if uid is specified, the caller's + * UIC group is used), though it won't recognise gid=0. + * + * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return + * information about other users in your group or in other groups, respectively. + * If the required privilege is not available, then these routines fill only + * the pw_name, pw_uid, and pw_gid fields (the others point to an empty + * string). + * + * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995. + */ + +/* sizes of various UAF record fields */ +#define UAI$S_USERNAME 12 +#define UAI$S_IDENT 31 +#define UAI$S_OWNER 31 +#define UAI$S_DEFDEV 31 +#define UAI$S_DEFDIR 63 +#define UAI$S_DEFCLI 31 +#define UAI$S_PWD 8 + +#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \ + (uic).uic$v_member != UIC$K_WILD_MEMBER && \ + (uic).uic$v_group != UIC$K_WILD_GROUP) + +static const char __empty[]= ""; +static const struct passwd __passwd_empty= + {(char *) __empty, (char *) __empty, 0, 0, + (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty}; +static int contxt= 0; +static struct passwd __pwdcache; +static char __pw_namecache[UAI$S_IDENT+1]; + +static char *_mystrtolower(char *str) +{ + if (str) for (; *str; ++str) *str= tolower(*str); + return str; +} + +/* + * This routine does most of the work extracting the user information. + */ +static int fillpasswd (const char *name, struct passwd *pwd) { - return val << 8 | val >> 8; + static struct { + unsigned char length; + char pw_gecos[UAI$S_OWNER+1]; + } owner; + static union uicdef uic; + static struct { + unsigned char length; + char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1]; + } defdev; + static struct { + unsigned char length; + char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1]; + } defdir; + static struct { + unsigned char length; + char pw_shell[UAI$S_DEFCLI+1]; + } defcli; + static char pw_passwd[UAI$S_PWD+1]; + + static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd; + struct dsc$descriptor_s name_desc; + int status; + + static const struct itmlst_3 itmlst[]= { + {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner}, + {sizeof(uic), UAI$_UIC, &uic, &luic}, + {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev}, + {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir}, + {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli}, + {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd}, + {0, 0, NULL, NULL}}; + + name_desc.dsc$w_length= strlen(name); + name_desc.dsc$b_dtype= DSC$K_DTYPE_T; + name_desc.dsc$b_class= DSC$K_CLASS_S; + name_desc.dsc$a_pointer= (char *) name; + +/* Note that sys$getuai returns many fields as counted strings. */ + status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0); + if (!(status&1)) return status; + + if ((int) owner.length < lowner) lowner= (int) owner.length; + if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length; + if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length; + if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length; + memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir); + owner.pw_gecos[lowner]= '\0'; + defdev.pw_dir[ldefdev+ldefdir]= '\0'; + defcli.pw_shell[ldefcli]= '\0'; + if (valid_uic(uic)) { + pwd->pw_uid= uic.uic$l_uic; + pwd->pw_gid= uic.uic$v_group; + } + else + warn("getpwnam returned invalid UIC %#o for user \"%s\""); + pwd->pw_passwd= pw_passwd; + pwd->pw_gecos= owner.pw_gecos; + pwd->pw_dir= defdev.pw_dir; + pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1); + pwd->pw_shell= defcli.pw_shell; + if (pwd->pw_unixdir && pwd->pw_unixdir[0]) { + int ldir; + ldir= strlen(pwd->pw_unixdir) - 1; + if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0'; + } + else + strcpy(pwd->pw_unixdir, pwd->pw_dir); + _mystrtolower(pwd->pw_unixdir); + return status; } + +/* + * Get information for a named user. +*/ +/*{{{struct passwd *getpwnam(char *name)*/ +struct passwd *my_getpwnam(char *name) +{ + struct dsc$descriptor_s name_desc; + union uicdef uic; + unsigned long int status, stat; + + __pwdcache = __passwd_empty; + if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV + || status == SS$_NOGRPPRV || status == RMS$_RNF) { + /* We still may be able to determine pw_uid and pw_gid */ + name_desc.dsc$w_length= strlen(name); + name_desc.dsc$b_dtype= DSC$K_DTYPE_T; + name_desc.dsc$b_class= DSC$K_CLASS_S; + name_desc.dsc$a_pointer= (char *) name; + if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) { + __pwdcache.pw_uid= uic.uic$l_uic; + __pwdcache.pw_gid= uic.uic$v_group; + } + else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL; + else { _ckvmssts(stat); } + } + else { _ckvmssts(status); } + strncpy(__pw_namecache, name, sizeof(__pw_namecache)); + __pw_namecache[sizeof __pw_namecache - 1] = '\0'; + __pwdcache.pw_name= __pw_namecache; + return &__pwdcache; +} /* end of my_getpwnam() */ /*}}}*/ -/*{{{ unsigned long int tmp_longflip(unsigned long int val)*/ -unsigned long int -tmp_longflip(unsigned long int val) +/* + * Get information for a particular UIC or UID. + * Called by my_getpwent with uid=-1 to list all users. +*/ +/*{{{struct passwd *my_getpwuid(Uid_t uid)*/ +struct passwd *my_getpwuid(Uid_t uid) { - unsigned long int scratch = val; - unsigned char savbyte, *tmp; + const $DESCRIPTOR(name_desc,__pw_namecache); + unsigned short lname; + union uicdef uic; + unsigned long int status; + + if (uid == (unsigned int) -1) { + do { + status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt); + if (status == SS$_NOSUCHID || status == RMS$_PRV) { + my_endpwent(); + return NULL; + } + else { _ckvmssts(status); } + } while (!valid_uic (uic)); + } + else { + uic.uic$l_uic= uid; + if (!uic.uic$v_group) uic.uic$v_group= getgid(); + if (valid_uic(uic)) + status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0); + else status = SS$_IVIDENT; + _ckvmssts(status); + } + __pw_namecache[lname]= '\0'; + _mystrtolower(__pw_namecache); + + __pwdcache = __passwd_empty; + __pwdcache.pw_name = __pw_namecache; + +/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege). + The identifier's value is usually the UIC, but it doesn't have to be, + so if we can, we let fillpasswd update this. */ + __pwdcache.pw_uid = uic.uic$l_uic; + __pwdcache.pw_gid = uic.uic$v_group; + + status = fillpasswd(__pw_namecache, &__pwdcache); + if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV && + status != RMS$_RNF) { _ckvmssts(status); } + return &__pwdcache; - tmp = (unsigned char *) &scratch; - savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte; - savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte; +} /* end of my_getpwuid() */ +/*}}}*/ + +/* + * Get information for next user. +*/ +/*{{{struct passwd *my_getpwent()*/ +struct passwd *my_getpwent() +{ + return (my_getpwuid((unsigned int) -1)); +} +/*}}}*/ - return scratch; +/* + * Finish searching rights database for users. +*/ +/*{{{void my_endpwent()*/ +void my_endpwent() +{ + if (contxt) { + _ckvmssts(sys$finish_rdb(&contxt)); + contxt= 0; + } } /*}}}*/ + +/* + * 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) + */ + +/* encode_dev packs a VMS device name string into an integer to allow + * simple comparisons. This can be used, for example, to check whether two + * files are located on the same device, by comparing their encoded device + * names. Even a string comparison would not do, because stat() reuses the + * device name buffer for each call; so without encode_dev, it would be + * necessary to save the buffer and use strcmp (this would mean a number of + * changes to the standard Perl code, to say nothing of what a Perl script + * would have to do. + * + * The device lock id, if it exists, should be unique (unless perhaps compared + * with lock ids transferred from other nodes). We have a lock id if the disk is + * mounted cluster-wide, which is when we tend to get long (host-qualified) + * device names. Thus we use the lock id in preference, and only if that isn't + * available, do we try to pack the device name into an integer (flagged by + * the sign bit (LOCKID_MASK) being set). + * + * Note that encode_dev cann guarantee an 1-to-1 correspondence twixt device + * name and its encoded form, but it seems very unlikely that we will find + * two files on different disks that share the same encoded device names, + * and even more remote that they will share the same file id (if the test + * is to check for the same file). + * + * A better method might be to use sys$device_scan on the first call, and to + * search for the device, returning an index into the cached array. + * The number returned would be more intelligable. + * This is probably not worth it, and anyway would take quite a bit longer + * on the first call. + */ +#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */ +static dev_t encode_dev (const char *dev) +{ + int i; + unsigned long int f; + dev_t enc; + char c; + const char *q; + + if (!dev || !dev[0]) return 0; + +#if LOCKID_MASK + { + struct dsc$descriptor_s dev_desc; + unsigned long int status, lockid, item = DVI$_LOCKID; + + /* For cluster-mounted disks, the disk lock identifier is unique, so we + can try that first. */ + dev_desc.dsc$w_length = strlen (dev); + dev_desc.dsc$b_dtype = DSC$K_DTYPE_T; + dev_desc.dsc$b_class = DSC$K_CLASS_S; + dev_desc.dsc$a_pointer = (char *) dev; + _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0)); + if (lockid) return (lockid & ~LOCKID_MASK); + } #endif + + /* Otherwise we try to encode the device name */ + enc = 0; + f = 1; + i = 0; + for (q = dev + strlen(dev); q--; q >= dev) { + if (isdigit (*q)) + c= (*q) - '0'; + else if (isalpha (toupper (*q))) + c= toupper (*q) - 'A' + (char)10; + else + continue; /* Skip '$'s */ + i++; + if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */ + if (i>1) f *= 36; + enc += f * (unsigned long int) c; + } + return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */ + +} /* end of encode_dev() */ + +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 != ':'); +} + +/* 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) +{ + if (statbufp == &statcache) + return cando_by_name(bit,effective,namecache); + else { + char fname[NAM$C_MAXRSS+1]; + unsigned long int retsts; + struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + + /* If the struct mystat is stale, we're OOL; stat() overwrites the + device name on successive calls */ + devdsc.dsc$a_pointer = statbufp->st_devnam; + devdsc.dsc$w_length = strlen(statbufp->st_devnam); + namdsc.dsc$a_pointer = fname; + namdsc.dsc$w_length = sizeof fname - 1; + + retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc, + &namdsc.dsc$w_length,0,0); + if (retsts & 1) { + fname[namdsc.dsc$w_length] = '\0'; + return cando_by_name(bit,effective,fname); + } + else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) { + warn("Can't get filespec - stale stat buffer?\n"); + return FALSE; + } + _ckvmssts(retsts); + return FALSE; /* Should never get to here */ + } +} +/*}}}*/ + +/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/ +I32 +cando_by_name(I32 bit, I32 effective, char *fname) +{ + static char usrname[L_cuserid]; + static struct dsc$descriptor_s usrdsc = + {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; + + unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2]; + unsigned short int retlen; + struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + union prvdef curprv; + struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen}, + {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}}; + struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen}, + {0,0,0,0}}; + + if (!fname || !*fname) return FALSE; + if (!usrdsc.dsc$w_length) { + cuserid(usrname); + usrdsc.dsc$w_length = strlen(usrname); + } + namdsc.dsc$w_length = strlen(fname); + namdsc.dsc$a_pointer = fname; + 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_WRITE; + break; + case S_IDUSR: + case S_IDGRP: + case S_IDOTH: + access = ARM$M_DELETE; + break; + default: + return FALSE; + } + + retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); + if (retsts == SS$_NOPRIV || retsts == RMS$_FNF || + retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE; + if (retsts == SS$_NORMAL) { + if (!privused) return TRUE; + /* We can get access, but only by using privs. Do we have the + necessary privs currently enabled? */ + _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0)); + if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE; + if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv + && !curprv.prv$v_bypass) return FALSE; + if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv + && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE; + if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE; + return TRUE; + } + _ckvmssts(retsts); + + return FALSE; /* Should never get here */ + +} /* end of cando_by_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,1)) return -1; + return flex_stat(fspec,statbuf); + +} /* end of flex_fstat() */ +/*}}}*/ + +/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/ +int +flex_stat(char *fspec, struct stat *statbufp) +{ + char fileified[NAM$C_MAXRSS+1]; + int retval,myretval; + struct stat tmpbuf; + + + if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0); + if (is_null_device(fspec)) { /* Fake a stat() for the null device */ + memset(statbufp,0,sizeof *statbufp); + statbufp->st_dev = encode_dev("_NLA0:"); + statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; + statbufp->st_uid = 0x00010001; + statbufp->st_gid = 0x0001; + time((time_t *)&statbufp->st_mtime); + statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; + return 0; + } + +/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of + * 'struct stat' elsewhere in Perl would use our struct. We go back + * to the system version here, since we're actually calling their + * stat(). + */ +#undef stat + + if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1; + else { + myretval = stat(fileified,(stat_t *) &tmpbuf); + } + retval = stat(fspec,(stat_t *) 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); + } + } + if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam); + return retval; + +} /* end of flex_stat() */ +/*}}}*/ + +/*** The following glue provides 'hooks' to make some of the routines + * from this file available from Perl. These routines are sufficiently + * basic, and are required sufficiently early in the build process, + * that's it's nice to have them available to miniperl as well as the + * full Perl, so they're set up here instead of in an extension. The + * Perl code which handles importation of these names into a given + * package lives in [.VMS]Filespec.pm in @INC. + */ + +void +vmsify_fromperl(CV *cv) +{ + dXSARGS; + char *vmsified; + + if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)"); + vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1); + ST(0) = sv_newmortal(); + if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified)); + XSRETURN(1); +} + +void +unixify_fromperl(CV *cv) +{ + dXSARGS; + char *unixified; + + if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)"); + unixified = do_tounixspec(SvPV(ST(0),na),NULL,1); + ST(0) = sv_newmortal(); + if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified)); + XSRETURN(1); +} + +void +fileify_fromperl(CV *cv) +{ + dXSARGS; + char *fileified; + + if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)"); + fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1); + ST(0) = sv_newmortal(); + if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified)); + XSRETURN(1); +} + +void +pathify_fromperl(CV *cv) +{ + dXSARGS; + char *pathified; + + if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)"); + pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1); + ST(0) = sv_newmortal(); + if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified)); + XSRETURN(1); +} + +void +vmspath_fromperl(CV *cv) +{ + dXSARGS; + char *vmspath; + + if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)"); + vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1); + ST(0) = sv_newmortal(); + if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath)); + XSRETURN(1); +} + +void +unixpath_fromperl(CV *cv) +{ + dXSARGS; + char *unixpath; + + if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)"); + unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1); + ST(0) = sv_newmortal(); + if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath)); + XSRETURN(1); +} + +void +candelete_fromperl(CV *cv) +{ + dXSARGS; + char vmsspec[NAM$C_MAXRSS+1]; + + if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)"); + if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf)) + ST(0) = &sv_yes; + else ST(0) = &sv_no; + XSRETURN(1); +} + +void +init_os_extras() +{ + char* file = __FILE__; + + newXS("VMS::Filespec::vmsify",vmsify_fromperl,file); + newXS("VMS::Filespec::unixify",unixify_fromperl,file); + newXS("VMS::Filespec::pathify",pathify_fromperl,file); + newXS("VMS::Filespec::fileify",fileify_fromperl,file); + newXS("VMS::Filespec::vmspath",vmspath_fromperl,file); + newXS("VMS::Filespec::unixpath",unixpath_fromperl,file); + newXS("VMS::Filespec::candelete",candelete_fromperl,file); + return; +} + +/* End of vms.c */ |