3 * VMS-specific routines for perl5
5 * Last revised: 09-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu
21 #include <lib$routines.h>
39 unsigned short int buflen;
40 unsigned short int itmcode;
42 unsigned short int *retlen;
46 my_trnlnm(char *lnm, char *eqv)
48 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
49 unsigned short int eqvlen;
50 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
51 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
52 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
53 struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen},
56 if (!eqv) eqv = __my_trnlnm_eqv;
57 lnmlst[0].bufadr = (void *)eqv;
58 lnmdsc.dsc$a_pointer = lnm;
59 lnmdsc.dsc$w_length = strlen(lnm);
60 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
61 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch;
62 else if (retsts & 1) {
66 _ckvmssts(retsts); /* Must be an error */
67 return Nullch; /* Not reached, assuming _ckvmssts() bails out */
71 * Translate a logical name. Substitute for CRTL getenv() to avoid
72 * memory leak, and to keep my_getenv() and my_setenv() in the same
73 * domain (mostly - my_getenv() need not return a translation from
74 * the process logical name table)
76 * Note: Uses static buffer -- not thread-safe!
78 /*{{{ char *my_getenv(char *lnm)*/
82 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
83 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
85 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
87 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
88 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
89 return __my_getenv_eqv;
91 else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) {
92 return __my_getenv_eqv;
95 unsigned long int retsts;
96 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
97 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
98 DSC$K_CLASS_S, __my_getenv_eqv};
99 symdsc.dsc$w_length = cp1 - lnm;
100 symdsc.dsc$a_pointer = uplnm;
101 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
102 if (retsts == LIB$_INVSYMNAM) return Nullch;
103 if (retsts != LIB$_NOSUCHSYM) {
104 /* We want to return only logical names or CRTL Unix emulations */
105 if (retsts & 1) return Nullch;
108 else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
112 } /* end of my_getenv() */
115 /*{{{ void my_setenv(char *lnm, char *eqv)*/
117 my_setenv(char *lnm,char *eqv)
118 /* Define a supervisor-mode logical name in the process table.
119 * In the future we'll add tables, attribs, and acmodes,
120 * probably through a different call.
123 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
124 unsigned long int retsts, usermode = PSL$C_USER;
125 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
126 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
127 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
129 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
130 lnmdsc.dsc$w_length = cp1 - lnm;
132 if (!eqv || !*eqv) { /* we're deleting a logical name */
133 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
134 if (retsts == SS$_IVLOGNAM) return;
135 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
137 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
138 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
142 eqvdsc.dsc$w_length = strlen(eqv);
143 eqvdsc.dsc$a_pointer = eqv;
145 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
148 } /* end of my_setenv() */
151 static char *do_fileify_dirspec(char *, char *, int);
152 static char *do_tovmsspec(char *, char *, int);
154 /*{{{int do_rmdir(char *name)*/
158 char dirfile[NAM$C_MAXRSS+1];
162 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
163 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
164 else retval = kill_file(dirfile);
167 } /* end of do_rmdir */
171 * Delete any file to which user has control access, regardless of whether
172 * delete access is explicitly allowed.
173 * Limitations: User must have write access to parent directory.
174 * Does not block signals or ASTs; if interrupted in midstream
175 * may leave file with an altered ACL.
178 /*{{{int kill_file(char *name)*/
180 kill_file(char *name)
182 char vmsname[NAM$C_MAXRSS+1];
183 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
184 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
185 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
187 unsigned char myace$b_length;
188 unsigned char myace$b_type;
189 unsigned short int myace$w_flags;
190 unsigned long int myace$l_access;
191 unsigned long int myace$l_ident;
192 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
193 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
194 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
196 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
197 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
198 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
199 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
200 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
201 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
203 if (!remove(name)) return 0; /* Can we just get rid of it? */
205 /* No, so we get our own UIC to use as a rights identifier,
206 * and the insert an ACE at the head of the ACL which allows us
207 * to delete the file.
209 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
210 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
211 fildsc.dsc$w_length = strlen(vmsname);
212 fildsc.dsc$a_pointer = vmsname;
214 newace.myace$l_ident = oldace.myace$l_ident;
215 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
217 set_vaxc_errno(aclsts);
220 /* Grab any existing ACEs with this identifier in case we fail */
221 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
222 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY) {
223 /* Add the new ACE . . . */
224 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
226 if ((rmsts = remove(name))) {
227 /* We blew it - dir with files in it, no write priv for
228 * parent directory, etc. Put things back the way they were. */
229 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
232 addlst[0].bufadr = &oldace;
233 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
241 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
242 if (aclsts & 1) aclsts = fndsts;
246 set_vaxc_errno(aclsts);
252 } /* end of kill_file() */
255 /* my_utime - update modification time of a file
256 * calling sequence is identical to POSIX utime(), but under
257 * VMS only the modification time is changed; ODS-2 does not
258 * maintain access times. Restrictions differ from the POSIX
259 * definition in that the time can be changed as long as the
260 * caller has permission to execute the necessary IO$_MODIFY $QIO;
261 * no separate checks are made to insure that the caller is the
262 * owner of the file or has special privs enabled.
263 * Code here is based on Joe Meadows' FILE utility.
266 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
267 * to VMS epoch (01-JAN-1858 00:00:00.00)
268 * in 100 ns intervals.
270 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
272 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
273 int my_utime(char *file, struct utimbuf *utimes)
276 long int bintime[2], len = 2, lowbit, unixtime,
277 secscale = 10000000; /* seconds --> 100 ns intervals */
278 unsigned long int chan, iosb[2], retsts;
279 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
280 struct FAB myfab = cc$rms_fab;
281 struct NAM mynam = cc$rms_nam;
282 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
284 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
285 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
286 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
288 if (file == NULL || *file == '\0') {
290 set_vaxc_errno(LIB$_INVARG);
293 if (tovmsspec(file,vmsspec) == NULL) return -1;
295 if (utimes != NULL) {
296 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
297 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
298 * Since time_t is unsigned long int, and lib$emul takes a signed long int
299 * as input, we force the sign bit to be clear by shifting unixtime right
300 * one bit, then multiplying by an extra factor of 2 in lib$emul().
302 lowbit = (utimes->modtime & 1) ? secscale : 0;
303 unixtime = (long int) utimes->modtime;
304 unixtime >> 1; secscale << 1;
305 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
308 set_vaxc_errno(retsts);
311 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
314 set_vaxc_errno(retsts);
319 /* Just get the current time in VMS format directly */
320 retsts = sys$gettim(bintime);
323 set_vaxc_errno(retsts);
328 myfab.fab$l_fna = vmsspec;
329 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
330 myfab.fab$l_nam = &mynam;
331 mynam.nam$l_esa = esa;
332 mynam.nam$b_ess = (unsigned char) sizeof esa;
333 mynam.nam$l_rsa = rsa;
334 mynam.nam$b_rss = (unsigned char) sizeof rsa;
336 /* Look for the file to be affected, letting RMS parse the file
337 * specification for us as well. I have set errno using only
338 * values documented in the utime() man page for VMS POSIX.
340 retsts = sys$parse(&myfab,0,0);
342 set_vaxc_errno(retsts);
343 if (retsts == RMS$_PRV) set_errno(EACCES);
344 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
345 else set_errno(EVMSERR);
348 retsts = sys$search(&myfab,0,0);
350 set_vaxc_errno(retsts);
351 if (retsts == RMS$_PRV) set_errno(EACCES);
352 else if (retsts == RMS$_FNF) set_errno(ENOENT);
353 else set_errno(EVMSERR);
357 devdsc.dsc$w_length = mynam.nam$b_dev;
358 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
360 retsts = sys$assign(&devdsc,&chan,0,0);
362 set_vaxc_errno(retsts);
363 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
364 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
365 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
366 else set_errno(EVMSERR);
370 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
371 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
373 memset((void *) &myfib, 0, sizeof myfib);
375 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
376 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
377 /* This prevents the revision time of the file being reset to the current
378 * time as a reqult of our IO$_MODIFY $QIO. */
379 myfib.fib$l_acctl = FIB$M_NORECORD;
381 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
382 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
383 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
385 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
386 if (retsts & 1) retsts = iosb[0];
388 set_vaxc_errno(retsts);
389 if (retsts == SS$_NOPRIV) set_errno(EACCES);
390 else set_errno(EVMSERR);
395 } /* end of my_utime() */
399 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
401 static unsigned long int mbxbufsiz;
402 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
406 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
407 * preprocessor consant BUFSIZ from stdio.h as the size of the
410 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
411 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
413 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
415 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
416 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
418 } /* end of create_mbx() */
420 /*{{{ my_popen and my_pclose*/
423 struct pipe_details *next;
424 FILE *fp; /* stdio file pointer to pipe mailbox */
425 int pid; /* PID of subprocess */
426 int mode; /* == 'r' if pipe open for reading */
427 int done; /* subprocess has completed */
428 unsigned long int completion; /* termination status of subprocess */
431 struct exit_control_block
433 struct exit_control_block *flink;
434 unsigned long int (*exit_routine)();
435 unsigned long int arg_count;
436 unsigned long int *status_address;
437 unsigned long int exit_status;
440 static struct pipe_details *open_pipes = NULL;
441 static $DESCRIPTOR(nl_desc, "NL:");
442 static int waitpid_asleep = 0;
444 static unsigned long int
447 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
449 while (open_pipes != NULL) {
450 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
451 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
454 if (!open_pipes->done) /* We tried to be nice . . . */
455 _ckvmssts(sys$delprc(&open_pipes->pid,0));
456 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
461 static struct exit_control_block pipe_exitblock =
462 {(struct exit_control_block *) 0,
463 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
467 popen_completion_ast(struct pipe_details *thispipe)
469 thispipe->done = TRUE;
470 if (waitpid_asleep) {
476 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
478 my_popen(char *cmd, char *mode)
480 static int handler_set_up = FALSE;
482 unsigned short int chan;
483 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
484 struct pipe_details *info;
485 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
486 DSC$K_CLASS_S, mbxname},
487 cmddsc = {0, DSC$K_DTYPE_T,
491 New(7001,info,1,struct pipe_details);
494 create_mbx(&chan,&namdsc);
496 /* open a FILE* onto it */
497 info->fp=fopen(mbxname, mode);
499 /* give up other channel onto it */
500 _ckvmssts(sys$dassgn(chan));
505 cmddsc.dsc$w_length=strlen(cmd);
506 cmddsc.dsc$a_pointer=cmd;
513 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
514 0 /* name */, &info->pid, &info->completion,
515 0, popen_completion_ast,info,0,0,0));
518 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
519 0 /* name */, &info->pid, &info->completion,
520 0, popen_completion_ast,info,0,0,0));
523 if (!handler_set_up) {
524 _ckvmssts(sys$dclexh(&pipe_exitblock));
525 handler_set_up = TRUE;
527 info->next=open_pipes; /* prepend to list */
534 /*{{{ I32 my_pclose(FILE *fp)*/
535 I32 my_pclose(FILE *fp)
537 struct pipe_details *info, *last = NULL;
538 unsigned long int retsts;
540 for (info = open_pipes; info != NULL; last = info, info = info->next)
541 if (info->fp == fp) break;
544 /* get here => no such pipe open */
545 croak("No such pipe open");
547 if (info->done) retsts = info->completion;
548 else waitpid(info->pid,(int *) &retsts,0);
552 /* remove from list of open pipes */
553 if (last) last->next = info->next;
554 else open_pipes = info->next;
559 } /* end of my_pclose() */
561 /* sort-of waitpid; use only with popen() */
562 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
564 waitpid(unsigned long int pid, int *statusp, int flags)
566 struct pipe_details *info;
568 for (info = open_pipes; info != NULL; info = info->next)
569 if (info->pid == pid) break;
571 if (info != NULL) { /* we know about this child */
572 while (!info->done) {
577 *statusp = info->completion;
580 else { /* we haven't heard of this child */
581 $DESCRIPTOR(intdsc,"0 00:00:01");
582 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
583 unsigned long int interval[2],sts;
586 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
587 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
588 if (ownerpid != mypid)
589 warn("pid %d not a child",pid);
592 _ckvmssts(sys$bintim(&intdsc,interval));
593 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
594 _ckvmssts(sys$schdwk(0,0,interval,0));
595 _ckvmssts(sys$hiber());
599 /* There's no easy way to find the termination status a child we're
600 * not aware of beforehand. If we're really interested in the future,
601 * we can go looking for a termination mailbox, or chase after the
602 * accounting record for the process.
608 } /* end of waitpid() */
613 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
615 my_gconvert(double val, int ndig, int trail, char *buf)
617 static char __gcvtbuf[DBL_DIG+1];
620 loc = buf ? buf : __gcvtbuf;
622 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
623 return gcvt(val,ndig,loc);
626 loc[0] = '0'; loc[1] = '\0';
634 ** The following routines are provided to make life easier when
635 ** converting among VMS-style and Unix-style directory specifications.
636 ** All will take input specifications in either VMS or Unix syntax. On
637 ** failure, all return NULL. If successful, the routines listed below
638 ** return a pointer to a buffer containing the appropriately
639 ** reformatted spec (and, therefore, subsequent calls to that routine
640 ** will clobber the result), while the routines of the same names with
641 ** a _ts suffix appended will return a pointer to a mallocd string
642 ** containing the appropriately reformatted spec.
643 ** In all cases, only explicit syntax is altered; no check is made that
644 ** the resulting string is valid or that the directory in question
647 ** fileify_dirspec() - convert a directory spec into the name of the
648 ** directory file (i.e. what you can stat() to see if it's a dir).
649 ** The style (VMS or Unix) of the result is the same as the style
650 ** of the parameter passed in.
651 ** pathify_dirspec() - convert a directory spec into a path (i.e.
652 ** what you prepend to a filename to indicate what directory it's in).
653 ** The style (VMS or Unix) of the result is the same as the style
654 ** of the parameter passed in.
655 ** tounixpath() - convert a directory spec into a Unix-style path.
656 ** tovmspath() - convert a directory spec into a VMS-style path.
657 ** tounixspec() - convert any file spec into a Unix-style file spec.
658 ** tovmsspec() - convert any file spec into a VMS-style spec.
661 static char *do_tounixspec(char *, char *, int);
663 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
664 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
666 static char __fileify_retbuf[NAM$C_MAXRSS+1];
667 unsigned long int dirlen, retlen, addmfd = 0;
668 char *retspec, *cp1, *cp2, *lastdir;
669 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
671 if (dir == NULL) return NULL;
673 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
676 dirlen = strlen(dir);
677 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
679 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
680 return do_fileify_dirspec("[]",buf,ts);
681 else if (dir[1] == '.' &&
682 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
683 return do_fileify_dirspec("[-]",buf,ts);
685 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
686 dirlen -= 1; /* to last element */
687 lastdir = strrchr(dir,'/');
689 else if (strstr(trndir,"..") != NULL) {
690 /* If we have a relative path, let do_tovmsspec figure it out,
691 * rather than repeating the code here */
692 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
693 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
694 return do_tounixspec(trndir,buf,ts);
697 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
698 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
699 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
700 toupper(*(cp2+2)) == 'I' &&
701 toupper(*(cp2+3)) == 'R') {
702 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
703 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
704 set_errno(ENOTDIR); /* Bzzt. */
705 set_vaxc_errno(RMS$_DIR);
711 else { /* There's a type, and it's not .dir. Bzzt. */
713 set_vaxc_errno(RMS$_DIR);
718 /* If we lead off with a device or rooted logical, add the MFD
719 if we're specifying a top-level directory. */
720 if (lastdir && *dir == '/') {
722 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
729 retlen = dirlen + addmfd ? 13 : 6;
730 if (buf) retspec = buf;
731 else if (ts) New(7009,retspec,retlen+6,char);
732 else retspec = __fileify_retbuf;
734 dirlen = lastdir - dir;
735 memcpy(retspec,dir,dirlen);
736 strcpy(&retspec[dirlen],"/000000");
737 strcpy(&retspec[dirlen+7],lastdir);
740 memcpy(retspec,dir,dirlen);
741 retspec[dirlen] = '\0';
743 /* We've picked up everything up to the directory file name.
744 Now just add the type and version, and we're set. */
745 strcat(retspec,".dir;1");
748 else { /* VMS-style directory spec */
749 char esa[NAM$C_MAXRSS+1], term;
750 unsigned long int cmplen, hasdev, hasdir, hastype, hasver;
751 struct FAB dirfab = cc$rms_fab;
752 struct NAM savnam, dirnam = cc$rms_nam;
754 dirfab.fab$b_fns = strlen(dir);
755 dirfab.fab$l_fna = dir;
756 dirfab.fab$l_nam = &dirnam;
757 dirfab.fab$l_dna = ".DIR;1";
758 dirfab.fab$b_dns = 6;
759 dirnam.nam$b_ess = NAM$C_MAXRSS;
760 dirnam.nam$l_esa = esa;
761 if (!(sys$parse(&dirfab)&1)) {
763 set_vaxc_errno(dirfab.fab$l_sts);
767 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
768 /* Yes; fake the fnb bits so we'll check type below */
769 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
772 if (dirfab.fab$l_sts != RMS$_FNF) {
774 set_vaxc_errno(dirfab.fab$l_sts);
777 dirnam = savnam; /* No; just work with potential name */
779 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
780 cp1 = strchr(esa,']');
781 if (!cp1) cp1 = strchr(esa,'>');
782 if (cp1) { /* Should always be true */
783 dirnam.nam$b_esl -= cp1 - esa - 1;
784 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
787 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
788 /* Yep; check version while we're at it, if it's there. */
789 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
790 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
791 /* Something other than .DIR[;1]. Bzzt. */
793 set_vaxc_errno(RMS$_DIR);
797 esa[dirnam.nam$b_esl] = '\0';
798 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
799 /* They provided at least the name; we added the type, if necessary, */
800 if (buf) retspec = buf; /* in sys$parse() */
801 else if (ts) New(7011,retspec,dirnam.nam$b_esl,char);
802 else retspec = __fileify_retbuf;
806 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
807 if (cp1 == NULL) return NULL; /* should never happen */
810 retlen = strlen(esa);
811 if ((cp1 = strrchr(esa,'.')) != NULL) {
812 /* There's more than one directory in the path. Just roll back. */
814 if (buf) retspec = buf;
815 else if (ts) New(7011,retspec,retlen+6,char);
816 else retspec = __fileify_retbuf;
820 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
821 /* Go back and expand rooted logical name */
822 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
823 if (!(sys$parse(&dirfab) & 1)) {
825 set_vaxc_errno(dirfab.fab$l_sts);
828 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
829 if (buf) retspec = buf;
830 else if (ts) New(7012,retspec,retlen+7,char);
831 else retspec = __fileify_retbuf;
832 cp1 = strstr(esa,"][");
834 memcpy(retspec,esa,dirlen);
835 if (!strncmp(cp1+2,"000000]",7)) {
836 retspec[dirlen-1] = '\0';
837 for (cp1 = retspec+dirlen-1; *cp1 != '.'; cp1--) ;
841 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
842 retspec[retlen] = '\0';
843 /* Convert last '.' to ']' */
844 for (cp1 = retspec+retlen-1; *cp1 != '.'; cp1--) ;
848 else { /* This is a top-level dir. Add the MFD to the path. */
849 if (buf) retspec = buf;
850 else if (ts) New(7012,retspec,retlen+14,char);
851 else retspec = __fileify_retbuf;
854 while (*cp1 != ':') *(cp2++) = *(cp1++);
855 strcpy(cp2,":[000000]");
860 /* We've set up the string up through the filename. Add the
861 type and version, and we're done. */
862 strcat(retspec,".DIR;1");
865 } /* end of do_fileify_dirspec() */
867 /* External entry points */
868 char *fileify_dirspec(char *dir, char *buf)
869 { return do_fileify_dirspec(dir,buf,0); }
870 char *fileify_dirspec_ts(char *dir, char *buf)
871 { return do_fileify_dirspec(dir,buf,1); }
873 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
874 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
876 static char __pathify_retbuf[NAM$C_MAXRSS+1];
877 unsigned long int retlen;
878 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
880 if (dir == NULL) return NULL;
883 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
886 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
887 if (*dir == '.' && (*(dir+1) == '\0' ||
888 (*(dir+1) == '.' && *(dir+2) == '\0')))
889 retlen = 2 + (*(dir+1) != '\0');
891 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
892 if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
893 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
894 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
895 toupper(*(cp2+3)) == 'R') {
896 retlen = cp2 - dir + 1;
898 else { /* Some other file type. Bzzt. */
900 set_vaxc_errno(RMS$_DIR);
904 else { /* No file type present. Treat the filename as a directory. */
905 retlen = strlen(dir) + 1;
908 if (buf) retpath = buf;
909 else if (ts) New(7013,retpath,retlen,char);
910 else retpath = __pathify_retbuf;
911 strncpy(retpath,dir,retlen-1);
912 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
913 retpath[retlen-1] = '/'; /* with '/', add it. */
914 retpath[retlen] = '\0';
916 else retpath[retlen-1] = '\0';
918 else { /* VMS-style directory spec */
919 char esa[NAM$C_MAXRSS+1];
920 unsigned long int cmplen;
921 struct FAB dirfab = cc$rms_fab;
922 struct NAM savnam, dirnam = cc$rms_nam;
924 dirfab.fab$b_fns = strlen(dir);
925 dirfab.fab$l_fna = dir;
926 if (dir[dirfab.fab$b_fns-1] == ']' ||
927 dir[dirfab.fab$b_fns-1] == '>' ||
928 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
929 if (buf) retpath = buf;
930 else if (ts) New(7014,retpath,strlen(dir),char);
931 else retpath = __pathify_retbuf;
935 dirfab.fab$l_dna = ".DIR;1";
936 dirfab.fab$b_dns = 6;
937 dirfab.fab$l_nam = &dirnam;
938 dirnam.nam$b_ess = (unsigned char) sizeof esa;
939 dirnam.nam$l_esa = esa;
940 if (!(sys$parse(&dirfab)&1)) {
942 set_vaxc_errno(dirfab.fab$l_sts);
946 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
947 if (dirfab.fab$l_sts != RMS$_FNF) {
949 set_vaxc_errno(dirfab.fab$l_sts);
952 dirnam = savnam; /* No; just work with potential name */
955 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
956 /* Yep; check version while we're at it, if it's there. */
957 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
958 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
959 /* Something other than .DIR[;1]. Bzzt. */
961 set_vaxc_errno(RMS$_DIR);
965 /* OK, the type was fine. Now pull any file name into the
967 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
969 cp1 = strrchr(esa,'>');
970 *dirnam.nam$l_type = '>';
973 *(dirnam.nam$l_type + 1) = '\0';
974 retlen = dirnam.nam$l_type - esa + 2;
975 if (buf) retpath = buf;
976 else if (ts) New(7014,retpath,retlen,char);
977 else retpath = __pathify_retbuf;
982 } /* end of do_pathify_dirspec() */
984 /* External entry points */
985 char *pathify_dirspec(char *dir, char *buf)
986 { return do_pathify_dirspec(dir,buf,0); }
987 char *pathify_dirspec_ts(char *dir, char *buf)
988 { return do_pathify_dirspec(dir,buf,1); }
990 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
991 static char *do_tounixspec(char *spec, char *buf, int ts)
993 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
994 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
997 if (spec == NULL) return NULL;
999 else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
1000 else rslt = __tounixspec_retbuf;
1001 if (strchr(spec,'/') != NULL) {
1008 dirend = strrchr(spec,']');
1009 if (dirend == NULL) dirend = strrchr(spec,'>');
1010 if (dirend == NULL) dirend = strchr(spec,':');
1011 if (dirend == NULL) {
1018 else { /* the VMS spec begins with directories */
1021 while (*cp2 == '-') {
1022 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1025 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1026 if (ts) Safefree(rslt); /* filespecs like */
1027 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1032 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1034 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1035 if (ts) Safefree(rslt);
1040 while (*cp3 != ':' && *cp3) cp3++;
1042 if (strchr(cp3,']') != NULL) break;
1043 } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1045 while (*cp3) *(cp1++) = *(cp3++);
1047 if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
1048 if (ts) Safefree(rslt);
1050 set_errno(RMS$_SYN);
1056 for (; cp2 <= dirend; cp2++) {
1059 if (*(cp2+1) == '[') cp2++;
1061 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1062 else if (*cp2 == '.') {
1064 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1065 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1067 else if (*cp2 == '-') {
1068 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1069 while (*cp2 == '-') {
1071 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1073 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1074 if (ts) Safefree(rslt); /* filespecs like */
1075 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1080 else *(cp1++) = *cp2;
1082 else *(cp1++) = *cp2;
1084 while (*cp2) *(cp1++) = *(cp2++);
1089 } /* end of do_tounixspec() */
1091 /* External entry points */
1092 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1093 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1095 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1096 static char *do_tovmsspec(char *path, char *buf, int ts) {
1097 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1098 register char *rslt, *dirend, *cp1, *cp2;
1099 register unsigned long int infront = 0;
1101 if (path == NULL) return NULL;
1102 if (buf) rslt = buf;
1103 else if (ts) New(7016,rslt,strlen(path)+1,char);
1104 else rslt = __tovmsspec_retbuf;
1105 if (strpbrk(path,"]:>") ||
1106 (dirend = strrchr(path,'/')) == NULL) {
1107 if (path[0] == '.') {
1108 if (path[1] == '\0') strcpy(rslt,"[]");
1109 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1110 else strcpy(rslt,path); /* probably garbage */
1112 else strcpy(rslt,path);
1115 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1116 if (!*(dirend+2)) dirend +=2;
1117 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1122 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1125 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1131 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1132 cp2 += 2; /* skip over "./" - it's redundant */
1133 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1135 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1136 *(cp1++) = '-'; /* "../" --> "-" */
1139 if (cp2 > dirend) cp2 = dirend;
1141 else *(cp1++) = '.';
1143 for (; cp2 < dirend; cp2++) {
1145 if (*(cp1-1) != '.') *(cp1++) = '.';
1148 else if (!infront && *cp2 == '.') {
1149 if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1150 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1151 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1152 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1153 else { /* back up over previous directory name */
1155 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1158 if (cp2 == dirend) {
1159 if (*(cp1-1) == '.') cp1--;
1163 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1166 if (*(cp1-1) == '-') *(cp1++) = '.';
1167 if (*cp2 == '/') *(cp1++) = '.';
1168 else if (*cp2 == '.') *(cp1++) = '_';
1169 else *(cp1++) = *cp2;
1173 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1175 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1176 while (*cp2) *(cp1++) = *(cp2++);
1181 } /* end of do_tovmsspec() */
1183 /* External entry points */
1184 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1185 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1187 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1188 static char *do_tovmspath(char *path, char *buf, int ts) {
1189 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1191 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1193 if (path == NULL) return NULL;
1194 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1195 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1196 if (buf) return buf;
1198 vmslen = strlen(vmsified);
1199 New(7017,cp,vmslen,char);
1200 memcpy(cp,vmsified,vmslen);
1205 strcpy(__tovmspath_retbuf,vmsified);
1206 return __tovmspath_retbuf;
1209 } /* end of do_tovmspath() */
1211 /* External entry points */
1212 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1213 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1216 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1217 static char *do_tounixpath(char *path, char *buf, int ts) {
1218 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1220 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1222 if (path == NULL) return NULL;
1223 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1224 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1225 if (buf) return buf;
1227 unixlen = strlen(unixified);
1228 New(7017,cp,unixlen,char);
1229 memcpy(cp,unixified,unixlen);
1234 strcpy(__tounixpath_retbuf,unixified);
1235 return __tounixpath_retbuf;
1238 } /* end of do_tounixpath() */
1240 /* External entry points */
1241 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1242 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1245 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1247 *****************************************************************************
1249 * Copyright (C) 1989-1994 by *
1250 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1252 * Permission is hereby granted for the reproduction of this software, *
1253 * on condition that this copyright notice is included in the reproduction, *
1254 * and that such reproduction is not for purposes of profit or material *
1257 * 27-Aug-1994 Modified for inclusion in perl5 *
1258 * by Charles Bailey bailey@genetics.upenn.edu *
1259 *****************************************************************************
1263 * getredirection() is intended to aid in porting C programs
1264 * to VMS (Vax-11 C). The native VMS environment does not support
1265 * '>' and '<' I/O redirection, or command line wild card expansion,
1266 * or a command line pipe mechanism using the '|' AND background
1267 * command execution '&'. All of these capabilities are provided to any
1268 * C program which calls this procedure as the first thing in the
1270 * The piping mechanism will probably work with almost any 'filter' type
1271 * of program. With suitable modification, it may useful for other
1272 * portability problems as well.
1274 * Author: Mark Pizzolato mark@infocomm.com
1278 struct list_item *next;
1282 static void add_item(struct list_item **head,
1283 struct list_item **tail,
1287 static void expand_wild_cards(char *item,
1288 struct list_item **head,
1289 struct list_item **tail,
1292 static int background_process(int argc, char **argv);
1294 static void pipe_and_fork(char **cmargv);
1296 /*{{{ void getredirection(int *ac, char ***av)*/
1298 getredirection(int *ac, char ***av)
1300 * Process vms redirection arg's. Exit if any error is seen.
1301 * If getredirection() processes an argument, it is erased
1302 * from the vector. getredirection() returns a new argc and argv value.
1303 * In the event that a background command is requested (by a trailing "&"),
1304 * this routine creates a background subprocess, and simply exits the program.
1306 * Warning: do not try to simplify the code for vms. The code
1307 * presupposes that getredirection() is called before any data is
1308 * read from stdin or written to stdout.
1310 * Normal usage is as follows:
1316 * getredirection(&argc, &argv);
1320 int argc = *ac; /* Argument Count */
1321 char **argv = *av; /* Argument Vector */
1322 char *ap; /* Argument pointer */
1323 int j; /* argv[] index */
1324 int item_count = 0; /* Count of Items in List */
1325 struct list_item *list_head = 0; /* First Item in List */
1326 struct list_item *list_tail; /* Last Item in List */
1327 char *in = NULL; /* Input File Name */
1328 char *out = NULL; /* Output File Name */
1329 char *outmode = "w"; /* Mode to Open Output File */
1330 char *err = NULL; /* Error File Name */
1331 char *errmode = "w"; /* Mode to Open Error File */
1332 int cmargc = 0; /* Piped Command Arg Count */
1333 char **cmargv = NULL;/* Piped Command Arg Vector */
1336 * First handle the case where the last thing on the line ends with
1337 * a '&'. This indicates the desire for the command to be run in a
1338 * subprocess, so we satisfy that desire.
1341 if (0 == strcmp("&", ap))
1342 exit(background_process(--argc, argv));
1343 if ('&' == ap[strlen(ap)-1])
1345 ap[strlen(ap)-1] = '\0';
1346 exit(background_process(argc, argv));
1349 * Now we handle the general redirection cases that involve '>', '>>',
1350 * '<', and pipes '|'.
1352 for (j = 0; j < argc; ++j)
1354 if (0 == strcmp("<", argv[j]))
1358 fprintf(stderr,"No input file after < on command line");
1359 exit(LIB$_WRONUMARG);
1364 if ('<' == *(ap = argv[j]))
1369 if (0 == strcmp(">", ap))
1373 fprintf(stderr,"No output file after > on command line");
1374 exit(LIB$_WRONUMARG);
1393 fprintf(stderr,"No output file after > or >> on command line");
1394 exit(LIB$_WRONUMARG);
1398 if (('2' == *ap) && ('>' == ap[1]))
1415 fprintf(stderr,"No output file after 2> or 2>> on command line");
1416 exit(LIB$_WRONUMARG);
1420 if (0 == strcmp("|", argv[j]))
1424 fprintf(stderr,"No command into which to pipe on command line");
1425 exit(LIB$_WRONUMARG);
1427 cmargc = argc-(j+1);
1428 cmargv = &argv[j+1];
1432 if ('|' == *(ap = argv[j]))
1440 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1443 * Allocate and fill in the new argument vector, Some Unix's terminate
1444 * the list with an extra null pointer.
1446 New(7002, argv, item_count+1, char *);
1448 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1449 argv[j] = list_head->value;
1455 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1456 exit(LIB$_INVARGORD);
1458 pipe_and_fork(cmargv);
1461 /* Check for input from a pipe (mailbox) */
1463 if (1 == isapipe(0))
1465 char mbxname[L_tmpnam];
1467 long int dvi_item = DVI$_DEVBUFSIZ;
1468 $DESCRIPTOR(mbxnam, "");
1469 $DESCRIPTOR(mbxdevnam, "");
1471 /* Input from a pipe, reopen it in binary mode to disable */
1472 /* carriage control processing. */
1476 fprintf(stderr,"'|' and '<' may not both be specified on command line");
1477 exit(LIB$_INVARGORD);
1479 fgetname(stdin, mbxname,1);
1480 mbxnam.dsc$a_pointer = mbxname;
1481 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1482 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1483 mbxdevnam.dsc$a_pointer = mbxname;
1484 mbxdevnam.dsc$w_length = sizeof(mbxname);
1485 dvi_item = DVI$_DEVNAM;
1486 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1487 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1490 freopen(mbxname, "rb", stdin);
1493 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1497 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1499 fprintf(stderr,"Can't open input file %s as stdin",in);
1502 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1504 fprintf(stderr,"Can't open output file %s as stdout",out);
1509 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1511 fprintf(stderr,"Can't open error file %s as stderr",err);
1515 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1520 #ifdef ARGPROC_DEBUG
1521 fprintf(stderr, "Arglist:\n");
1522 for (j = 0; j < *ac; ++j)
1523 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1525 } /* end of getredirection() */
1528 static void add_item(struct list_item **head,
1529 struct list_item **tail,
1535 New(7003,*head,1,struct list_item);
1539 New(7004,(*tail)->next,1,struct list_item);
1540 *tail = (*tail)->next;
1542 (*tail)->value = value;
1546 static void expand_wild_cards(char *item,
1547 struct list_item **head,
1548 struct list_item **tail,
1552 unsigned long int context = 0;
1559 char vmsspec[NAM$C_MAXRSS+1];
1560 $DESCRIPTOR(filespec, "");
1561 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1562 $DESCRIPTOR(resultspec, "");
1563 unsigned long int zero = 0;
1565 if (strcspn(item, "*%") == strlen(item))
1567 add_item(head, tail, item, count);
1570 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1571 resultspec.dsc$b_class = DSC$K_CLASS_D;
1572 resultspec.dsc$a_pointer = NULL;
1573 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1574 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1575 if (!isunix || !filespec.dsc$a_pointer)
1576 filespec.dsc$a_pointer = item;
1577 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1579 * Only return version specs, if the caller specified a version
1581 had_version = strchr(item, ';');
1583 * Only return device and directory specs, if the caller specifed either.
1585 had_device = strchr(item, ':');
1586 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1588 while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1589 &defaultspec, 0, &status_value, &zero)))
1594 New(7005,string,resultspec.dsc$w_length+1,char);
1595 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1596 string[resultspec.dsc$w_length] = '\0';
1597 if (NULL == had_version)
1598 *((char *)strrchr(string, ';')) = '\0';
1599 if ((!had_directory) && (had_device == NULL))
1601 if (NULL == (devdir = strrchr(string, ']')))
1602 devdir = strrchr(string, '>');
1603 strcpy(string, devdir + 1);
1606 * Be consistent with what the C RTL has already done to the rest of
1607 * the argv items and lowercase all of these names.
1609 for (c = string; *c; ++c)
1612 if (isunix) trim_unixpath(item,string);
1613 add_item(head, tail, string, count);
1617 add_item(head, tail, item, count);
1618 lib$sfree1_dd(&resultspec);
1619 lib$find_file_end(&context);
1622 static int child_st[2];/* Event Flag set when child process completes */
1624 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
1626 static unsigned long int exit_handler(int *status)
1630 if (0 == child_st[0])
1632 #ifdef ARGPROC_DEBUG
1633 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1635 fflush(stdout); /* Have to flush pipe for binary data to */
1636 /* terminate properly -- <tp@mccall.com> */
1637 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1638 sys$dassgn(child_chan);
1640 sys$synch(0, child_st);
1645 static void sig_child(int chan)
1647 #ifdef ARGPROC_DEBUG
1648 fprintf(stderr, "Child Completion AST\n");
1650 if (child_st[0] == 0)
1654 static struct exit_control_block exit_block =
1659 &exit_block.exit_status,
1663 static void pipe_and_fork(char **cmargv)
1666 $DESCRIPTOR(cmddsc, "");
1667 static char mbxname[64];
1668 $DESCRIPTOR(mbxdsc, mbxname);
1670 unsigned long int zero = 0, one = 1;
1672 strcpy(subcmd, cmargv[0]);
1673 for (j = 1; NULL != cmargv[j]; ++j)
1675 strcat(subcmd, " \"");
1676 strcat(subcmd, cmargv[j]);
1677 strcat(subcmd, "\"");
1679 cmddsc.dsc$a_pointer = subcmd;
1680 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1682 create_mbx(&child_chan,&mbxdsc);
1683 #ifdef ARGPROC_DEBUG
1684 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1685 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1687 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1688 0, &pid, child_st, &zero, sig_child,
1690 #ifdef ARGPROC_DEBUG
1691 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1693 sys$dclexh(&exit_block);
1694 if (NULL == freopen(mbxname, "wb", stdout))
1696 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1700 static int background_process(int argc, char **argv)
1702 char command[2048] = "$";
1703 $DESCRIPTOR(value, "");
1704 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1705 static $DESCRIPTOR(null, "NLA0:");
1706 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1708 $DESCRIPTOR(pidstr, "");
1710 unsigned long int flags = 17, one = 1, retsts;
1712 strcat(command, argv[0]);
1715 strcat(command, " \"");
1716 strcat(command, *(++argv));
1717 strcat(command, "\"");
1719 value.dsc$a_pointer = command;
1720 value.dsc$w_length = strlen(value.dsc$a_pointer);
1721 _ckvmssts(lib$set_symbol(&cmd, &value));
1722 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1723 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1724 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1729 #ifdef ARGPROC_DEBUG
1730 fprintf(stderr, "%s\n", command);
1732 sprintf(pidstring, "%08X", pid);
1733 fprintf(stderr, "%s\n", pidstring);
1734 pidstr.dsc$a_pointer = pidstring;
1735 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1736 lib$set_symbol(&pidsymbol, &pidstr);
1740 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1743 * Trim Unix-style prefix off filespec, so it looks like what a shell
1744 * glob expansion would return (i.e. from specified prefix on, not
1745 * full path). Note that returned filespec is Unix-style, regardless
1746 * of whether input filespec was VMS-style or Unix-style.
1748 * Returns !=0 on success, 0 on failure.
1750 /*{{{int trim_unixpath(char *template, char *fspec)*/
1752 trim_unixpath(char *template, char *fspec)
1754 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1755 register int tmplen;
1757 if (strpbrk(fspec,"]>:") != NULL) {
1758 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1759 else base = unixified;
1762 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
1764 /* Find prefix to template consisting of path elements without wildcards */
1765 if ((cp1 = strpbrk(template,"*%?")) == NULL)
1766 for (cp1 = template; *cp1; cp1++) ;
1767 else while (cp1 >= template && *cp1 != '/') cp1--;
1768 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
1769 tmplen = cp1 - template;
1771 /* Try to find template prefix on filespec */
1772 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
1773 for (; cp2 - base > tmplen; base++) {
1774 if (*base != '/') continue;
1775 if (!memcmp(base + 1,template,tmplen)) break;
1777 if (cp2 - base == tmplen) return 0; /* Not there - not good */
1778 base++; /* Move past leading '/' */
1779 /* Copy down remaining portion of filespec, including trailing NUL */
1780 memmove(fspec,base,cp2 - base + 1);
1783 } /* end of trim_unixpath() */
1788 * VMS readdir() routines.
1789 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1790 * This code has no copyright.
1792 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
1793 * Minor modifications to original routines.
1796 /* Number of elements in vms_versions array */
1797 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
1800 * Open a directory, return a handle for later use.
1802 /*{{{ DIR *opendir(char*name) */
1807 char dir[NAM$C_MAXRSS+1];
1809 /* Get memory for the handle, and the pattern. */
1811 if (do_tovmspath(name,dir,0) == NULL) {
1812 Safefree((char *)dd);
1815 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1817 /* Fill in the fields; mainly playing with the descriptor. */
1818 (void)sprintf(dd->pattern, "%s*.*",dir);
1821 dd->vms_wantversions = 0;
1822 dd->pat.dsc$a_pointer = dd->pattern;
1823 dd->pat.dsc$w_length = strlen(dd->pattern);
1824 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1825 dd->pat.dsc$b_class = DSC$K_CLASS_S;
1828 } /* end of opendir() */
1832 * Set the flag to indicate we want versions or not.
1834 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1836 vmsreaddirversions(DIR *dd, int flag)
1838 dd->vms_wantversions = flag;
1843 * Free up an opened directory.
1845 /*{{{ void closedir(DIR *dd)*/
1849 (void)lib$find_file_end(&dd->context);
1850 Safefree(dd->pattern);
1851 Safefree((char *)dd);
1856 * Collect all the version numbers for the current file.
1862 struct dsc$descriptor_s pat;
1863 struct dsc$descriptor_s res;
1865 char *p, *text, buff[sizeof dd->entry.d_name];
1867 unsigned long context, tmpsts;
1869 /* Convenient shorthand. */
1872 /* Add the version wildcard, ignoring the "*.*" put on before */
1873 i = strlen(dd->pattern);
1874 New(7008,text,i + e->d_namlen + 3,char);
1875 (void)strcpy(text, dd->pattern);
1876 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1878 /* Set up the pattern descriptor. */
1879 pat.dsc$a_pointer = text;
1880 pat.dsc$w_length = i + e->d_namlen - 1;
1881 pat.dsc$b_dtype = DSC$K_DTYPE_T;
1882 pat.dsc$b_class = DSC$K_CLASS_S;
1884 /* Set up result descriptor. */
1885 res.dsc$a_pointer = buff;
1886 res.dsc$w_length = sizeof buff - 2;
1887 res.dsc$b_dtype = DSC$K_DTYPE_T;
1888 res.dsc$b_class = DSC$K_CLASS_S;
1890 /* Read files, collecting versions. */
1891 for (context = 0, e->vms_verscount = 0;
1892 e->vms_verscount < VERSIZE(e);
1893 e->vms_verscount++) {
1894 tmpsts = lib$find_file(&pat, &res, &context);
1895 if (tmpsts == RMS$_NMF || context == 0) break;
1897 buff[sizeof buff - 1] = '\0';
1898 if ((p = strchr(buff, ';')))
1899 e->vms_versions[e->vms_verscount] = atoi(p + 1);
1901 e->vms_versions[e->vms_verscount] = -1;
1904 _ckvmssts(lib$find_file_end(&context));
1907 } /* end of collectversions() */
1910 * Read the next entry from the directory.
1912 /*{{{ struct dirent *readdir(DIR *dd)*/
1916 struct dsc$descriptor_s res;
1917 char *p, buff[sizeof dd->entry.d_name];
1918 unsigned long int tmpsts;
1920 /* Set up result descriptor, and get next file. */
1921 res.dsc$a_pointer = buff;
1922 res.dsc$w_length = sizeof buff - 2;
1923 res.dsc$b_dtype = DSC$K_DTYPE_T;
1924 res.dsc$b_class = DSC$K_CLASS_S;
1926 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
1927 if ( tmpsts == RMS$_NMF || tmpsts == RMS$_FNF ||
1928 dd->context == 0) return NULL; /* None left. */
1930 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
1931 buff[sizeof buff - 1] = '\0';
1932 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
1935 /* Skip any directory component and just copy the name. */
1936 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
1937 else (void)strcpy(dd->entry.d_name, buff);
1939 /* Clobber the version. */
1940 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
1942 dd->entry.d_namlen = strlen(dd->entry.d_name);
1943 dd->entry.vms_verscount = 0;
1944 if (dd->vms_wantversions) collectversions(dd);
1947 } /* end of readdir() */
1951 * Return something that can be used in a seekdir later.
1953 /*{{{ long telldir(DIR *dd)*/
1962 * Return to a spot where we used to be. Brute force.
1964 /*{{{ void seekdir(DIR *dd,long count)*/
1966 seekdir(DIR *dd, long count)
1968 int vms_wantversions;
1970 /* If we haven't done anything yet... */
1974 /* Remember some state, and clear it. */
1975 vms_wantversions = dd->vms_wantversions;
1976 dd->vms_wantversions = 0;
1977 _ckvmssts(lib$find_file_end(&dd->context));
1980 /* The increment is in readdir(). */
1981 for (dd->count = 0; dd->count < count; )
1984 dd->vms_wantversions = vms_wantversions;
1986 } /* end of seekdir() */
1989 /* VMS subprocess management
1991 * my_vfork() - just a vfork(), after setting a flag to record that
1992 * the current script is trying a Unix-style fork/exec.
1994 * vms_do_aexec() and vms_do_exec() are called in response to the
1995 * perl 'exec' function. If this follows a vfork call, then they
1996 * call out the the regular perl routines in doio.c which do an
1997 * execvp (for those who really want to try this under VMS).
1998 * Otherwise, they do exactly what the perl docs say exec should
1999 * do - terminate the current script and invoke a new command
2000 * (See below for notes on command syntax.)
2002 * do_aspawn() and do_spawn() implement the VMS side of the perl
2003 * 'system' function.
2005 * Note on command arguments to perl 'exec' and 'system': When handled
2006 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2007 * are concatenated to form a DCL command string. If the first arg
2008 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2009 * the the command string is hrnded off to DCL directly. Otherwise,
2010 * the first token of the command is taken as the filespec of an image
2011 * to run. The filespec is expanded using a default type of '.EXE' and
2012 * the process defaults for device, directory, etc., and the resultant
2013 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2014 * the command string as parameters. This is perhaps a bit compicated,
2015 * but I hope it will form a happy medium between what VMS folks expect
2016 * from lib$spawn and what Unix folks expect from exec.
2019 static int vfork_called;
2021 /*{{{int my_vfork()*/
2031 setup_argstr(SV *really, SV **mark, SV **sp, char **argstr)
2034 register size_t cmdlen = 0;
2039 tmps = SvPV(really,rlen);
2040 if (really && *tmps) {
2045 for (idx++; idx <= sp; idx++) {
2047 junk = SvPVx(*idx,rlen);
2048 cmdlen += rlen ? rlen + 1 : 0;
2051 New(401,*argstr,cmdlen, char);
2054 strcpy(*argstr,tmps);
2057 else **argstr = '\0';
2058 while (++mark <= sp) {
2060 strcat(*argstr," ");
2061 strcat(*argstr,SvPVx(*mark,na));
2065 } /* end of setup_argstr() */
2067 static unsigned long int
2068 setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img)
2070 char resspec[NAM$C_MAXRSS+1];
2071 $DESCRIPTOR(defdsc,".EXE");
2072 $DESCRIPTOR(resdsc,resspec);
2073 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2074 unsigned long int cxt = 0, flags = 1, retsts;
2075 register char *s, *rest, *cp;
2076 register int isdcl = 0;
2079 while (*s && isspace(*s)) s++;
2081 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2082 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2083 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2084 if (*cp == ':' || *cp == '[' || *cp == '<') {
2092 if (isdcl) { /* It's a DCL command, just do it. */
2093 cmddsc->dsc$a_pointer = cmd;
2094 cmddsc->dsc$w_length = strlen(cmd);
2096 else { /* assume first token is an image spec */
2098 while (*s && !isspace(*s)) s++;
2100 imgdsc.dsc$a_pointer = cmd;
2101 imgdsc.dsc$w_length = s - cmd;
2102 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2103 if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2106 _ckvmssts(lib$find_file_end(&cxt));
2108 while (*s && !isspace(*s)) s++;
2110 New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char);
2111 strcpy(Cmd,"$ MCR ");
2112 strcat(Cmd,resspec);
2113 if (rest) strcat(Cmd,rest);
2114 cmddsc->dsc$a_pointer = Cmd;
2115 cmddsc->dsc$w_length = strlen(Cmd);
2120 } /* end of setup_cmddsc() */
2122 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2124 vms_do_aexec(SV *really,SV **mark,SV **sp)
2128 if (vfork_called) { /* this follows a vfork - act Unixish */
2130 if (vfork_called < 0) {
2131 warn("Internal inconsistency in tracking vforks");
2134 else return do_aexec(really,mark,sp);
2137 /* no vfork - act VMSish */
2138 setup_argstr(really,mark,sp,Argv);
2139 return vms_do_exec(*Argv);
2143 } /* end of vms_do_aexec() */
2146 /* {{{bool vms_do_exec(char *cmd) */
2148 vms_do_exec(char *cmd)
2151 if (vfork_called) { /* this follows a vfork - act Unixish */
2153 if (vfork_called < 0) {
2154 warn("Internal inconsistency in tracking vforks");
2157 else return do_exec(cmd);
2160 { /* no vfork - act VMSish */
2161 struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2162 unsigned long int retsts;
2164 if ((retsts = setup_cmddsc(cmd,&cmddsc,1)) & 1)
2165 retsts = lib$do_command(&cmddsc);
2168 set_vaxc_errno(retsts);
2170 warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
2176 } /* end of vms_do_exec() */
2179 unsigned long int do_spawn(char *);
2181 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2183 do_aspawn(SV *really,SV **mark,SV **sp)
2187 setup_argstr(really,mark,sp,Argv);
2188 return do_spawn(*Argv);
2192 } /* end of do_aspawn() */
2195 /* {{{unsigned long int do_spawn(char *cmd) */
2199 struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2200 unsigned long int substs;
2202 if (!cmd || !*cmd) {
2203 _ckvmssts(lib$spawn(0,0,0,0,0,&substs,0,0,0,0,0));
2205 else if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) {
2206 _ckvmssts(lib$spawn(&cmddsc,0,0,0,0,&substs,0,0,0,0,0));
2211 set_vaxc_errno(substs);
2213 warn("Can't exec \"%s\": %s",
2214 (cmd && *cmd) ? cmddsc.dsc$a_pointer : "", Strerror(errno));
2218 } /* end of do_spawn() */
2222 * A simple fwrite replacement which outputs itmsz*nitm chars without
2223 * introducing record boundaries every itmsz chars.
2225 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2227 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2229 register char *cp, *end;
2231 end = (char *)src + itmsz * nitm;
2233 while ((char *)src <= end) {
2234 for (cp = src; cp <= end; cp++) if (!*cp) break;
2235 if (fputs(src,dest) == EOF) return EOF;
2237 if (fputc('\0',dest) == EOF) return EOF;
2243 } /* end of my_fwrite() */
2247 * Here are replacements for the following Unix routines in the VMS environment:
2248 * getpwuid Get information for a particular UIC or UID
2249 * getpwnam Get information for a named user
2250 * getpwent Get information for each user in the rights database
2251 * setpwent Reset search to the start of the rights database
2252 * endpwent Finish searching for users in the rights database
2254 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2255 * (defined in pwd.h), which contains the following fields:-
2257 * char *pw_name; Username (in lower case)
2258 * char *pw_passwd; Hashed password
2259 * unsigned int pw_uid; UIC
2260 * unsigned int pw_gid; UIC group number
2261 * char *pw_unixdir; Default device/directory (VMS-style)
2262 * char *pw_gecos; Owner name
2263 * char *pw_dir; Default device/directory (Unix-style)
2264 * char *pw_shell; Default CLI name (eg. DCL)
2266 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2268 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2269 * not the UIC member number (eg. what's returned by getuid()),
2270 * getpwuid() can accept either as input (if uid is specified, the caller's
2271 * UIC group is used), though it won't recognise gid=0.
2273 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2274 * information about other users in your group or in other groups, respectively.
2275 * If the required privilege is not available, then these routines fill only
2276 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2279 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2282 /* sizes of various UAF record fields */
2283 #define UAI$S_USERNAME 12
2284 #define UAI$S_IDENT 31
2285 #define UAI$S_OWNER 31
2286 #define UAI$S_DEFDEV 31
2287 #define UAI$S_DEFDIR 63
2288 #define UAI$S_DEFCLI 31
2291 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2292 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2293 (uic).uic$v_group != UIC$K_WILD_GROUP)
2295 static const char __empty[]= "";
2296 static const struct passwd __passwd_empty=
2297 {(char *) __empty, (char *) __empty, 0, 0,
2298 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2299 static int contxt= 0;
2300 static struct passwd __pwdcache;
2301 static char __pw_namecache[UAI$S_IDENT+1];
2303 static char *_mystrtolower(char *str)
2305 if (str) for (; *str; ++str) *str= tolower(*str);
2310 * This routine does most of the work extracting the user information.
2312 static int fillpasswd (const char *name, struct passwd *pwd)
2315 unsigned char length;
2316 char pw_gecos[UAI$S_OWNER+1];
2318 static union uicdef uic;
2320 unsigned char length;
2321 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2324 unsigned char length;
2325 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2328 unsigned char length;
2329 char pw_shell[UAI$S_DEFCLI+1];
2331 static char pw_passwd[UAI$S_PWD+1];
2333 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2334 struct dsc$descriptor_s name_desc;
2337 static const struct itmlst_3 itmlst[]= {
2338 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2339 {sizeof(uic), UAI$_UIC, &uic, &luic},
2340 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2341 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2342 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2343 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2344 {0, 0, NULL, NULL}};
2346 name_desc.dsc$w_length= strlen(name);
2347 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2348 name_desc.dsc$b_class= DSC$K_CLASS_S;
2349 name_desc.dsc$a_pointer= (char *) name;
2351 /* Note that sys$getuai returns many fields as counted strings. */
2352 status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2353 if (!(status&1)) return status;
2355 if ((int) owner.length < lowner) lowner= (int) owner.length;
2356 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2357 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2358 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2359 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2360 owner.pw_gecos[lowner]= '\0';
2361 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2362 defcli.pw_shell[ldefcli]= '\0';
2363 if (valid_uic(uic)) {
2364 pwd->pw_uid= uic.uic$l_uic;
2365 pwd->pw_gid= uic.uic$v_group;
2368 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2369 pwd->pw_passwd= pw_passwd;
2370 pwd->pw_gecos= owner.pw_gecos;
2371 pwd->pw_dir= defdev.pw_dir;
2372 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2373 pwd->pw_shell= defcli.pw_shell;
2374 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2376 ldir= strlen(pwd->pw_unixdir) - 1;
2377 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2380 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2381 _mystrtolower(pwd->pw_unixdir);
2386 * Get information for a named user.
2388 /*{{{struct passwd *getpwnam(char *name)*/
2389 struct passwd *my_getpwnam(char *name)
2391 struct dsc$descriptor_s name_desc;
2393 unsigned long int status, stat;
2395 __pwdcache = __passwd_empty;
2396 if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV
2397 || status == SS$_NOGRPPRV || status == RMS$_RNF) {
2398 /* We still may be able to determine pw_uid and pw_gid */
2399 name_desc.dsc$w_length= strlen(name);
2400 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2401 name_desc.dsc$b_class= DSC$K_CLASS_S;
2402 name_desc.dsc$a_pointer= (char *) name;
2403 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2404 __pwdcache.pw_uid= uic.uic$l_uic;
2405 __pwdcache.pw_gid= uic.uic$v_group;
2407 else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL;
2408 else { _ckvmssts(stat); }
2410 else { _ckvmssts(status); }
2411 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2412 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2413 __pwdcache.pw_name= __pw_namecache;
2415 } /* end of my_getpwnam() */
2419 * Get information for a particular UIC or UID.
2420 * Called by my_getpwent with uid=-1 to list all users.
2422 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2423 struct passwd *my_getpwuid(Uid_t uid)
2425 const $DESCRIPTOR(name_desc,__pw_namecache);
2426 unsigned short lname;
2428 unsigned long int status;
2430 if (uid == (unsigned int) -1) {
2432 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2433 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2437 else { _ckvmssts(status); }
2438 } while (!valid_uic (uic));
2442 if (!uic.uic$v_group) uic.uic$v_group= getgid();
2444 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2445 else status = SS$_IVIDENT;
2448 __pw_namecache[lname]= '\0';
2449 _mystrtolower(__pw_namecache);
2451 __pwdcache = __passwd_empty;
2452 __pwdcache.pw_name = __pw_namecache;
2454 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2455 The identifier's value is usually the UIC, but it doesn't have to be,
2456 so if we can, we let fillpasswd update this. */
2457 __pwdcache.pw_uid = uic.uic$l_uic;
2458 __pwdcache.pw_gid = uic.uic$v_group;
2460 status = fillpasswd(__pw_namecache, &__pwdcache);
2461 if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV &&
2462 status != RMS$_RNF) { _ckvmssts(status); }
2465 } /* end of my_getpwuid() */
2469 * Get information for next user.
2471 /*{{{struct passwd *my_getpwent()*/
2472 struct passwd *my_getpwent()
2474 return (my_getpwuid((unsigned int) -1));
2479 * Finish searching rights database for users.
2481 /*{{{void my_endpwent()*/
2485 _ckvmssts(sys$finish_rdb(&contxt));
2492 * flex_stat, flex_fstat
2493 * basic stat, but gets it right when asked to stat
2494 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2497 /* encode_dev packs a VMS device name string into an integer to allow
2498 * simple comparisons. This can be used, for example, to check whether two
2499 * files are located on the same device, by comparing their encoded device
2500 * names. Even a string comparison would not do, because stat() reuses the
2501 * device name buffer for each call; so without encode_dev, it would be
2502 * necessary to save the buffer and use strcmp (this would mean a number of
2503 * changes to the standard Perl code, to say nothing of what a Perl script
2506 * The device lock id, if it exists, should be unique (unless perhaps compared
2507 * with lock ids transferred from other nodes). We have a lock id if the disk is
2508 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2509 * device names. Thus we use the lock id in preference, and only if that isn't
2510 * available, do we try to pack the device name into an integer (flagged by
2511 * the sign bit (LOCKID_MASK) being set).
2513 * Note that encode_dev cann guarantee an 1-to-1 correspondence twixt device
2514 * name and its encoded form, but it seems very unlikely that we will find
2515 * two files on different disks that share the same encoded device names,
2516 * and even more remote that they will share the same file id (if the test
2517 * is to check for the same file).
2519 * A better method might be to use sys$device_scan on the first call, and to
2520 * search for the device, returning an index into the cached array.
2521 * The number returned would be more intelligable.
2522 * This is probably not worth it, and anyway would take quite a bit longer
2523 * on the first call.
2525 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2526 static dev_t encode_dev (const char *dev)
2529 unsigned long int f;
2534 if (!dev || !dev[0]) return 0;
2538 struct dsc$descriptor_s dev_desc;
2539 unsigned long int status, lockid, item = DVI$_LOCKID;
2541 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2542 can try that first. */
2543 dev_desc.dsc$w_length = strlen (dev);
2544 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2545 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2546 dev_desc.dsc$a_pointer = (char *) dev;
2547 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2548 if (lockid) return (lockid & ~LOCKID_MASK);
2552 /* Otherwise we try to encode the device name */
2556 for (q = dev + strlen(dev); q--; q >= dev) {
2559 else if (isalpha (toupper (*q)))
2560 c= toupper (*q) - 'A' + (char)10;
2562 continue; /* Skip '$'s */
2564 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2566 enc += f * (unsigned long int) c;
2568 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2570 } /* end of encode_dev() */
2572 static char namecache[NAM$C_MAXRSS+1];
2575 is_null_device(name)
2578 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2579 The underscore prefix, controller letter, and unit number are
2580 independently optional; for our purposes, the colon punctuation
2581 is not. The colon can be trailed by optional directory and/or
2582 filename, but two consecutive colons indicates a nodename rather
2583 than a device. [pr] */
2584 if (*name == '_') ++name;
2585 if (tolower(*name++) != 'n') return 0;
2586 if (tolower(*name++) != 'l') return 0;
2587 if (tolower(*name) == 'a') ++name;
2588 if (*name == '0') ++name;
2589 return (*name++ == ':') && (*name != ':');
2592 /* Do the permissions allow some operation? Assumes statcache already set. */
2593 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2594 * subset of the applicable information.
2596 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2598 cando(I32 bit, I32 effective, struct stat *statbufp)
2600 if (statbufp == &statcache)
2601 return cando_by_name(bit,effective,namecache);
2603 char fname[NAM$C_MAXRSS+1];
2604 unsigned long int retsts;
2605 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2606 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2608 /* If the struct mystat is stale, we're OOL; stat() overwrites the
2609 device name on successive calls */
2610 devdsc.dsc$a_pointer = statbufp->st_devnam;
2611 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2612 namdsc.dsc$a_pointer = fname;
2613 namdsc.dsc$w_length = sizeof fname - 1;
2615 retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc,
2616 &namdsc.dsc$w_length,0,0);
2618 fname[namdsc.dsc$w_length] = '\0';
2619 return cando_by_name(bit,effective,fname);
2621 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2622 warn("Can't get filespec - stale stat buffer?\n");
2626 return FALSE; /* Should never get to here */
2631 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2633 cando_by_name(I32 bit, I32 effective, char *fname)
2635 static char usrname[L_cuserid];
2636 static struct dsc$descriptor_s usrdsc =
2637 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2639 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2640 unsigned short int retlen;
2641 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2642 union prvdef curprv;
2643 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2644 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2645 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2648 if (!fname || !*fname) return FALSE;
2649 if (!usrdsc.dsc$w_length) {
2651 usrdsc.dsc$w_length = strlen(usrname);
2653 namdsc.dsc$w_length = strlen(fname);
2654 namdsc.dsc$a_pointer = fname;
2659 access = ARM$M_EXECUTE;
2664 access = ARM$M_READ;
2669 access = ARM$M_WRITE;
2674 access = ARM$M_DELETE;
2680 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
2681 if (retsts == SS$_NOPRIV || retsts == RMS$_FNF ||
2682 retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
2683 if (retsts == SS$_NORMAL) {
2684 if (!privused) return TRUE;
2685 /* We can get access, but only by using privs. Do we have the
2686 necessary privs currently enabled? */
2687 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
2688 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
2689 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv
2690 && !curprv.prv$v_bypass) return FALSE;
2691 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv
2692 && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
2693 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
2698 return FALSE; /* Should never get here */
2700 } /* end of cando_by_name() */
2704 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
2706 flex_fstat(int fd, struct stat *statbuf)
2708 char fspec[NAM$C_MAXRSS+1];
2710 if (!getname(fd,fspec,1)) return -1;
2711 return flex_stat(fspec,statbuf);
2713 } /* end of flex_fstat() */
2716 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
2718 flex_stat(char *fspec, struct stat *statbufp)
2720 char fileified[NAM$C_MAXRSS+1];
2721 int retval,myretval;
2725 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
2726 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2727 memset(statbufp,0,sizeof *statbufp);
2728 statbufp->st_dev = encode_dev("_NLA0:");
2729 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
2730 statbufp->st_uid = 0x00010001;
2731 statbufp->st_gid = 0x0001;
2732 time((time_t *)&statbufp->st_mtime);
2733 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
2737 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
2738 * 'struct stat' elsewhere in Perl would use our struct. We go back
2739 * to the system version here, since we're actually calling their
2744 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
2746 myretval = stat(fileified,(stat_t *) &tmpbuf);
2748 retval = stat(fspec,(stat_t *) statbufp);
2754 else if (!retval) { /* Dir with same name. Substitute it. */
2755 statbufp->st_mode &= ~S_IFDIR;
2756 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
2757 strcpy(namecache,fileified);
2760 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
2763 } /* end of flex_stat() */
2766 /*** The following glue provides 'hooks' to make some of the routines
2767 * from this file available from Perl. These routines are sufficiently
2768 * basic, and are required sufficiently early in the build process,
2769 * that's it's nice to have them available to miniperl as well as the
2770 * full Perl, so they're set up here instead of in an extension. The
2771 * Perl code which handles importation of these names into a given
2772 * package lives in [.VMS]Filespec.pm in @INC.
2776 vmsify_fromperl(CV *cv)
2781 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
2782 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
2783 ST(0) = sv_newmortal();
2784 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
2789 unixify_fromperl(CV *cv)
2794 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
2795 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
2796 ST(0) = sv_newmortal();
2797 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
2802 fileify_fromperl(CV *cv)
2807 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
2808 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
2809 ST(0) = sv_newmortal();
2810 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
2815 pathify_fromperl(CV *cv)
2820 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
2821 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
2822 ST(0) = sv_newmortal();
2823 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
2828 vmspath_fromperl(CV *cv)
2833 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
2834 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
2835 ST(0) = sv_newmortal();
2836 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
2841 unixpath_fromperl(CV *cv)
2846 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
2847 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
2848 ST(0) = sv_newmortal();
2849 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
2854 candelete_fromperl(CV *cv)
2857 char vmsspec[NAM$C_MAXRSS+1];
2859 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
2860 if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf))
2862 else ST(0) = &sv_no;
2869 char* file = __FILE__;
2871 newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
2872 newXS("VMS::Filespec::unixify",unixify_fromperl,file);
2873 newXS("VMS::Filespec::pathify",pathify_fromperl,file);
2874 newXS("VMS::Filespec::fileify",fileify_fromperl,file);
2875 newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
2876 newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
2877 newXS("VMS::Filespec::candelete",candelete_fromperl,file);