3 * VMS-specific routines for perl5
5 * Last revised: 5-Jun-1995 by Charles Bailey bailey@genetics.upenn.edu
22 #include <lib$routines.h>
40 unsigned short int buflen;
41 unsigned short int itmcode;
43 unsigned short int *retlen;
47 my_trnlnm(char *lnm, char *eqv)
49 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
50 unsigned short int eqvlen;
51 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
52 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
53 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
54 struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen},
57 if (!eqv) eqv = __my_trnlnm_eqv;
58 lnmlst[0].bufadr = (void *)eqv;
59 lnmdsc.dsc$a_pointer = lnm;
60 lnmdsc.dsc$w_length = strlen(lnm);
61 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
62 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch;
63 else if (retsts & 1) {
67 _ckvmssts(retsts); /* Must be an error */
68 return Nullch; /* Not reached, assuming _ckvmssts() bails out */
72 * Translate a logical name. Substitute for CRTL getenv() to avoid
73 * memory leak, and to keep my_getenv() and my_setenv() in the same
74 * domain (mostly - my_getenv() need not return a translation from
75 * the process logical name table)
77 * Note: Uses static buffer -- not thread-safe!
79 /*{{{ char *my_getenv(char *lnm)*/
83 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
84 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
86 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
88 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
89 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
90 return __my_getenv_eqv;
92 else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) {
93 return __my_getenv_eqv;
96 unsigned long int retsts;
97 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
98 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
99 DSC$K_CLASS_S, __my_getenv_eqv};
100 symdsc.dsc$w_length = cp1 - lnm;
101 symdsc.dsc$a_pointer = uplnm;
102 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
103 if (retsts == LIB$_INVSYMNAM) return Nullch;
104 if (retsts != LIB$_NOSUCHSYM) {
105 /* We want to return only logical names or CRTL Unix emulations */
106 if (retsts & 1) return Nullch;
109 else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
113 } /* end of my_getenv() */
116 /*{{{ void my_setenv(char *lnm, char *eqv)*/
118 my_setenv(char *lnm,char *eqv)
119 /* Define a supervisor-mode logical name in the process table.
120 * In the future we'll add tables, attribs, and acmodes,
121 * probably through a different call.
124 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
125 unsigned long int retsts, usermode = PSL$C_USER;
126 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
127 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
128 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
130 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
131 lnmdsc.dsc$w_length = cp1 - lnm;
133 if (!eqv || !*eqv) { /* we're deleting a logical name */
134 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
135 if (retsts == SS$_IVLOGNAM) return;
136 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
138 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
139 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
143 eqvdsc.dsc$w_length = strlen(eqv);
144 eqvdsc.dsc$a_pointer = eqv;
146 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
149 } /* end of my_setenv() */
152 static char *do_fileify_dirspec(char *, char *, int);
153 static char *do_tovmsspec(char *, char *, int);
155 /*{{{int do_rmdir(char *name)*/
159 char dirfile[NAM$C_MAXRSS+1];
163 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
164 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
165 else retval = kill_file(dirfile);
168 } /* end of do_rmdir */
172 * Delete any file to which user has control access, regardless of whether
173 * delete access is explicitly allowed.
174 * Limitations: User must have write access to parent directory.
175 * Does not block signals or ASTs; if interrupted in midstream
176 * may leave file with an altered ACL.
179 /*{{{int kill_file(char *name)*/
181 kill_file(char *name)
183 char vmsname[NAM$C_MAXRSS+1];
184 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
185 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
186 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
188 unsigned char myace$b_length;
189 unsigned char myace$b_type;
190 unsigned short int myace$w_flags;
191 unsigned long int myace$l_access;
192 unsigned long int myace$l_ident;
193 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
194 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
195 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
197 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
198 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
199 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
200 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
201 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
202 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
204 if (!remove(name)) return 0; /* Can we just get rid of it? */
206 /* No, so we get our own UIC to use as a rights identifier,
207 * and the insert an ACE at the head of the ACL which allows us
208 * to delete the file.
210 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
211 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
212 fildsc.dsc$w_length = strlen(vmsname);
213 fildsc.dsc$a_pointer = vmsname;
215 newace.myace$l_ident = oldace.myace$l_ident;
216 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
218 set_vaxc_errno(aclsts);
221 /* Grab any existing ACEs with this identifier in case we fail */
222 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
223 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY) {
224 /* Add the new ACE . . . */
225 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
227 if ((rmsts = remove(name))) {
228 /* We blew it - dir with files in it, no write priv for
229 * parent directory, etc. Put things back the way they were. */
230 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
233 addlst[0].bufadr = &oldace;
234 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
242 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
243 if (aclsts & 1) aclsts = fndsts;
247 set_vaxc_errno(aclsts);
253 } /* end of kill_file() */
256 /* my_utime - update modification time of a file
257 * calling sequence is identical to POSIX utime(), but under
258 * VMS only the modification time is changed; ODS-2 does not
259 * maintain access times. Restrictions differ from the POSIX
260 * definition in that the time can be changed as long as the
261 * caller has permission to execute the necessary IO$_MODIFY $QIO;
262 * no separate checks are made to insure that the caller is the
263 * owner of the file or has special privs enabled.
264 * Code here is based on Joe Meadows' FILE utility.
267 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
268 * to VMS epoch (01-JAN-1858 00:00:00.00)
269 * in 100 ns intervals.
271 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
273 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
274 int my_utime(char *file, struct utimbuf *utimes)
277 long int bintime[2], len = 2, lowbit, unixtime,
278 secscale = 10000000; /* seconds --> 100 ns intervals */
279 unsigned long int chan, iosb[2], retsts;
280 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
281 struct FAB myfab = cc$rms_fab;
282 struct NAM mynam = cc$rms_nam;
283 #if defined (__DECC) && defined (__VAX)
284 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
285 * at least through VMS V6.1, which causes a type-conversion warning.
287 # pragma message save
288 # pragma message disable cvtdiftypes
290 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
292 #if defined (__DECC) && defined (__VAX)
293 /* This should be right after the declaration of myatr, but due
294 * to a bug in VAX DEC C, this takes effect a statement early.
296 # pragma message restore
298 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
299 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
300 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
302 if (file == NULL || *file == '\0') {
304 set_vaxc_errno(LIB$_INVARG);
307 if (tovmsspec(file,vmsspec) == NULL) return -1;
309 if (utimes != NULL) {
310 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
311 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
312 * Since time_t is unsigned long int, and lib$emul takes a signed long int
313 * as input, we force the sign bit to be clear by shifting unixtime right
314 * one bit, then multiplying by an extra factor of 2 in lib$emul().
316 lowbit = (utimes->modtime & 1) ? secscale : 0;
317 unixtime = (long int) utimes->modtime;
318 unixtime >> 1; secscale << 1;
319 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
322 set_vaxc_errno(retsts);
325 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
328 set_vaxc_errno(retsts);
333 /* Just get the current time in VMS format directly */
334 retsts = sys$gettim(bintime);
337 set_vaxc_errno(retsts);
342 myfab.fab$l_fna = vmsspec;
343 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
344 myfab.fab$l_nam = &mynam;
345 mynam.nam$l_esa = esa;
346 mynam.nam$b_ess = (unsigned char) sizeof esa;
347 mynam.nam$l_rsa = rsa;
348 mynam.nam$b_rss = (unsigned char) sizeof rsa;
350 /* Look for the file to be affected, letting RMS parse the file
351 * specification for us as well. I have set errno using only
352 * values documented in the utime() man page for VMS POSIX.
354 retsts = sys$parse(&myfab,0,0);
356 set_vaxc_errno(retsts);
357 if (retsts == RMS$_PRV) set_errno(EACCES);
358 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
359 else set_errno(EVMSERR);
362 retsts = sys$search(&myfab,0,0);
364 set_vaxc_errno(retsts);
365 if (retsts == RMS$_PRV) set_errno(EACCES);
366 else if (retsts == RMS$_FNF) set_errno(ENOENT);
367 else set_errno(EVMSERR);
371 devdsc.dsc$w_length = mynam.nam$b_dev;
372 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
374 retsts = sys$assign(&devdsc,&chan,0,0);
376 set_vaxc_errno(retsts);
377 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
378 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
379 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
380 else set_errno(EVMSERR);
384 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
385 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
387 memset((void *) &myfib, 0, sizeof myfib);
389 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
390 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
391 /* This prevents the revision time of the file being reset to the current
392 * time as a reqult of our IO$_MODIFY $QIO. */
393 myfib.fib$l_acctl = FIB$M_NORECORD;
395 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
396 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
397 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
399 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
400 if (retsts & 1) retsts = iosb[0];
402 set_vaxc_errno(retsts);
403 if (retsts == SS$_NOPRIV) set_errno(EACCES);
404 else set_errno(EVMSERR);
409 } /* end of my_utime() */
413 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
415 static unsigned long int mbxbufsiz;
416 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
420 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
421 * preprocessor consant BUFSIZ from stdio.h as the size of the
424 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
425 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
427 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
429 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
430 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
432 } /* end of create_mbx() */
434 /*{{{ my_popen and my_pclose*/
437 struct pipe_details *next;
438 FILE *fp; /* stdio file pointer to pipe mailbox */
439 int pid; /* PID of subprocess */
440 int mode; /* == 'r' if pipe open for reading */
441 int done; /* subprocess has completed */
442 unsigned long int completion; /* termination status of subprocess */
445 struct exit_control_block
447 struct exit_control_block *flink;
448 unsigned long int (*exit_routine)();
449 unsigned long int arg_count;
450 unsigned long int *status_address;
451 unsigned long int exit_status;
454 static struct pipe_details *open_pipes = NULL;
455 static $DESCRIPTOR(nl_desc, "NL:");
456 static int waitpid_asleep = 0;
458 static unsigned long int
461 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
463 while (open_pipes != NULL) {
464 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
465 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
468 if (!open_pipes->done) /* We tried to be nice . . . */
469 _ckvmssts(sys$delprc(&open_pipes->pid,0));
470 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
475 static struct exit_control_block pipe_exitblock =
476 {(struct exit_control_block *) 0,
477 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
481 popen_completion_ast(struct pipe_details *thispipe)
483 thispipe->done = TRUE;
484 if (waitpid_asleep) {
490 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
492 my_popen(char *cmd, char *mode)
494 static int handler_set_up = FALSE;
496 unsigned short int chan;
497 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
498 struct pipe_details *info;
499 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
500 DSC$K_CLASS_S, mbxname},
501 cmddsc = {0, DSC$K_DTYPE_T,
505 New(7001,info,1,struct pipe_details);
508 create_mbx(&chan,&namdsc);
510 /* open a FILE* onto it */
511 info->fp=fopen(mbxname, mode);
513 /* give up other channel onto it */
514 _ckvmssts(sys$dassgn(chan));
519 cmddsc.dsc$w_length=strlen(cmd);
520 cmddsc.dsc$a_pointer=cmd;
527 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
528 0 /* name */, &info->pid, &info->completion,
529 0, popen_completion_ast,info,0,0,0));
532 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
533 0 /* name */, &info->pid, &info->completion,
534 0, popen_completion_ast,info,0,0,0));
537 if (!handler_set_up) {
538 _ckvmssts(sys$dclexh(&pipe_exitblock));
539 handler_set_up = TRUE;
541 info->next=open_pipes; /* prepend to list */
548 /*{{{ I32 my_pclose(FILE *fp)*/
549 I32 my_pclose(FILE *fp)
551 struct pipe_details *info, *last = NULL;
552 unsigned long int retsts;
554 for (info = open_pipes; info != NULL; last = info, info = info->next)
555 if (info->fp == fp) break;
558 /* get here => no such pipe open */
559 croak("No such pipe open");
561 if (info->done) retsts = info->completion;
562 else waitpid(info->pid,(int *) &retsts,0);
566 /* remove from list of open pipes */
567 if (last) last->next = info->next;
568 else open_pipes = info->next;
573 } /* end of my_pclose() */
575 /* sort-of waitpid; use only with popen() */
576 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
578 waitpid(unsigned long int pid, int *statusp, int flags)
580 struct pipe_details *info;
582 for (info = open_pipes; info != NULL; info = info->next)
583 if (info->pid == pid) break;
585 if (info != NULL) { /* we know about this child */
586 while (!info->done) {
591 *statusp = info->completion;
594 else { /* we haven't heard of this child */
595 $DESCRIPTOR(intdsc,"0 00:00:01");
596 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
597 unsigned long int interval[2],sts;
600 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
601 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
602 if (ownerpid != mypid)
603 warn("pid %d not a child",pid);
606 _ckvmssts(sys$bintim(&intdsc,interval));
607 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
608 _ckvmssts(sys$schdwk(0,0,interval,0));
609 _ckvmssts(sys$hiber());
613 /* There's no easy way to find the termination status a child we're
614 * not aware of beforehand. If we're really interested in the future,
615 * we can go looking for a termination mailbox, or chase after the
616 * accounting record for the process.
622 } /* end of waitpid() */
627 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
629 my_gconvert(double val, int ndig, int trail, char *buf)
631 static char __gcvtbuf[DBL_DIG+1];
634 loc = buf ? buf : __gcvtbuf;
636 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
637 return gcvt(val,ndig,loc);
640 loc[0] = '0'; loc[1] = '\0';
648 ** The following routines are provided to make life easier when
649 ** converting among VMS-style and Unix-style directory specifications.
650 ** All will take input specifications in either VMS or Unix syntax. On
651 ** failure, all return NULL. If successful, the routines listed below
652 ** return a pointer to a buffer containing the appropriately
653 ** reformatted spec (and, therefore, subsequent calls to that routine
654 ** will clobber the result), while the routines of the same names with
655 ** a _ts suffix appended will return a pointer to a mallocd string
656 ** containing the appropriately reformatted spec.
657 ** In all cases, only explicit syntax is altered; no check is made that
658 ** the resulting string is valid or that the directory in question
661 ** fileify_dirspec() - convert a directory spec into the name of the
662 ** directory file (i.e. what you can stat() to see if it's a dir).
663 ** The style (VMS or Unix) of the result is the same as the style
664 ** of the parameter passed in.
665 ** pathify_dirspec() - convert a directory spec into a path (i.e.
666 ** what you prepend to a filename to indicate what directory it's in).
667 ** The style (VMS or Unix) of the result is the same as the style
668 ** of the parameter passed in.
669 ** tounixpath() - convert a directory spec into a Unix-style path.
670 ** tovmspath() - convert a directory spec into a VMS-style path.
671 ** tounixspec() - convert any file spec into a Unix-style file spec.
672 ** tovmsspec() - convert any file spec into a VMS-style spec.
675 static char *do_tounixspec(char *, char *, int);
677 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
678 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
680 static char __fileify_retbuf[NAM$C_MAXRSS+1];
681 unsigned long int dirlen, retlen, addmfd = 0;
682 char *retspec, *cp1, *cp2, *lastdir;
683 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
685 if (dir == NULL) return NULL;
687 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
690 dirlen = strlen(dir);
691 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
693 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
694 return do_fileify_dirspec("[]",buf,ts);
695 else if (dir[1] == '.' &&
696 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
697 return do_fileify_dirspec("[-]",buf,ts);
699 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
700 dirlen -= 1; /* to last element */
701 lastdir = strrchr(dir,'/');
703 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
705 if (*(cp1+2) == '.') cp1++;
706 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
711 } while ((cp1 = strstr(cp1,"/.")) != NULL);
712 /* If we have a relative path, VMSify it and let the VMS code
713 * below expand it, rather than repeating the code here */
715 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
716 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
717 return do_tounixspec(trndir,buf,ts);
721 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
722 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
723 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
724 toupper(*(cp2+2)) == 'I' &&
725 toupper(*(cp2+3)) == 'R') {
726 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
727 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
728 set_errno(ENOTDIR); /* Bzzt. */
729 set_vaxc_errno(RMS$_DIR);
735 else { /* There's a type, and it's not .dir. Bzzt. */
737 set_vaxc_errno(RMS$_DIR);
742 /* If we lead off with a device or rooted logical, add the MFD
743 if we're specifying a top-level directory. */
744 if (lastdir && *dir == '/') {
746 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
753 retlen = dirlen + (addmfd ? 13 : 6);
754 if (buf) retspec = buf;
755 else if (ts) New(7009,retspec,retlen+6,char);
756 else retspec = __fileify_retbuf;
758 dirlen = lastdir - dir;
759 memcpy(retspec,dir,dirlen);
760 strcpy(&retspec[dirlen],"/000000");
761 strcpy(&retspec[dirlen+7],lastdir);
764 memcpy(retspec,dir,dirlen);
765 retspec[dirlen] = '\0';
767 /* We've picked up everything up to the directory file name.
768 Now just add the type and version, and we're set. */
769 strcat(retspec,".dir;1");
772 else { /* VMS-style directory spec */
773 char esa[NAM$C_MAXRSS+1], term;
774 unsigned long int cmplen, hasdev, hasdir, hastype, hasver;
775 struct FAB dirfab = cc$rms_fab;
776 struct NAM savnam, dirnam = cc$rms_nam;
778 dirfab.fab$b_fns = strlen(dir);
779 dirfab.fab$l_fna = dir;
780 dirfab.fab$l_nam = &dirnam;
781 dirfab.fab$l_dna = ".DIR;1";
782 dirfab.fab$b_dns = 6;
783 dirnam.nam$b_ess = NAM$C_MAXRSS;
784 dirnam.nam$l_esa = esa;
785 if (!(sys$parse(&dirfab)&1)) {
787 set_vaxc_errno(dirfab.fab$l_sts);
791 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
792 /* Yes; fake the fnb bits so we'll check type below */
793 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
796 if (dirfab.fab$l_sts != RMS$_FNF) {
798 set_vaxc_errno(dirfab.fab$l_sts);
801 dirnam = savnam; /* No; just work with potential name */
803 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
804 cp1 = strchr(esa,']');
805 if (!cp1) cp1 = strchr(esa,'>');
806 if (cp1) { /* Should always be true */
807 dirnam.nam$b_esl -= cp1 - esa - 1;
808 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
811 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
812 /* Yep; check version while we're at it, if it's there. */
813 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
814 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
815 /* Something other than .DIR[;1]. Bzzt. */
817 set_vaxc_errno(RMS$_DIR);
821 esa[dirnam.nam$b_esl] = '\0';
822 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
823 /* They provided at least the name; we added the type, if necessary, */
824 if (buf) retspec = buf; /* in sys$parse() */
825 else if (ts) New(7011,retspec,dirnam.nam$b_esl,char);
826 else retspec = __fileify_retbuf;
830 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
831 if (cp1 == NULL) return NULL; /* should never happen */
834 retlen = strlen(esa);
835 if ((cp1 = strrchr(esa,'.')) != NULL) {
836 /* There's more than one directory in the path. Just roll back. */
838 if (buf) retspec = buf;
839 else if (ts) New(7011,retspec,retlen+6,char);
840 else retspec = __fileify_retbuf;
844 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
845 /* Go back and expand rooted logical name */
846 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
847 if (!(sys$parse(&dirfab) & 1)) {
849 set_vaxc_errno(dirfab.fab$l_sts);
852 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
853 if (buf) retspec = buf;
854 else if (ts) New(7012,retspec,retlen+14,char);
855 else retspec = __fileify_retbuf;
856 cp1 = strstr(esa,"][");
858 memcpy(retspec,esa,dirlen);
859 if (!strncmp(cp1+2,"000000]",7)) {
860 retspec[dirlen-1] = '\0';
861 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
862 if (*cp1 == '.') *cp1 = ']';
864 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
865 memcpy(cp1+1,"000000]",7);
869 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
870 retspec[retlen] = '\0';
871 /* Convert last '.' to ']' */
872 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
873 if (*cp1 == '.') *cp1 = ']';
875 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
876 memcpy(cp1+1,"000000]",7);
880 else { /* This is a top-level dir. Add the MFD to the path. */
881 if (buf) retspec = buf;
882 else if (ts) New(7012,retspec,retlen+14,char);
883 else retspec = __fileify_retbuf;
886 while (*cp1 != ':') *(cp2++) = *(cp1++);
887 strcpy(cp2,":[000000]");
892 /* We've set up the string up through the filename. Add the
893 type and version, and we're done. */
894 strcat(retspec,".DIR;1");
897 } /* end of do_fileify_dirspec() */
899 /* External entry points */
900 char *fileify_dirspec(char *dir, char *buf)
901 { return do_fileify_dirspec(dir,buf,0); }
902 char *fileify_dirspec_ts(char *dir, char *buf)
903 { return do_fileify_dirspec(dir,buf,1); }
905 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
906 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
908 static char __pathify_retbuf[NAM$C_MAXRSS+1];
909 unsigned long int retlen;
910 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
912 if (dir == NULL) return NULL;
915 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
918 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
919 if (*dir == '.' && (*(dir+1) == '\0' ||
920 (*(dir+1) == '.' && *(dir+2) == '\0')))
921 retlen = 2 + (*(dir+1) != '\0');
923 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
924 if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
925 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
926 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
927 toupper(*(cp2+3)) == 'R') {
928 retlen = cp2 - dir + 1;
930 else { /* Some other file type. Bzzt. */
932 set_vaxc_errno(RMS$_DIR);
936 else { /* No file type present. Treat the filename as a directory. */
937 retlen = strlen(dir) + 1;
940 if (buf) retpath = buf;
941 else if (ts) New(7013,retpath,retlen,char);
942 else retpath = __pathify_retbuf;
943 strncpy(retpath,dir,retlen-1);
944 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
945 retpath[retlen-1] = '/'; /* with '/', add it. */
946 retpath[retlen] = '\0';
948 else retpath[retlen-1] = '\0';
950 else { /* VMS-style directory spec */
951 char esa[NAM$C_MAXRSS+1];
952 unsigned long int cmplen;
953 struct FAB dirfab = cc$rms_fab;
954 struct NAM savnam, dirnam = cc$rms_nam;
956 dirfab.fab$b_fns = strlen(dir);
957 dirfab.fab$l_fna = dir;
958 if (dir[dirfab.fab$b_fns-1] == ']' ||
959 dir[dirfab.fab$b_fns-1] == '>' ||
960 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
961 if (buf) retpath = buf;
962 else if (ts) New(7014,retpath,strlen(dir),char);
963 else retpath = __pathify_retbuf;
967 dirfab.fab$l_dna = ".DIR;1";
968 dirfab.fab$b_dns = 6;
969 dirfab.fab$l_nam = &dirnam;
970 dirnam.nam$b_ess = (unsigned char) sizeof esa;
971 dirnam.nam$l_esa = esa;
972 if (!(sys$parse(&dirfab)&1)) {
974 set_vaxc_errno(dirfab.fab$l_sts);
978 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
979 if (dirfab.fab$l_sts != RMS$_FNF) {
981 set_vaxc_errno(dirfab.fab$l_sts);
984 dirnam = savnam; /* No; just work with potential name */
987 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
988 /* Yep; check version while we're at it, if it's there. */
989 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
990 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
991 /* Something other than .DIR[;1]. Bzzt. */
993 set_vaxc_errno(RMS$_DIR);
997 /* OK, the type was fine. Now pull any file name into the
999 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1001 cp1 = strrchr(esa,'>');
1002 *dirnam.nam$l_type = '>';
1005 *(dirnam.nam$l_type + 1) = '\0';
1006 retlen = dirnam.nam$l_type - esa + 2;
1007 if (buf) retpath = buf;
1008 else if (ts) New(7014,retpath,retlen,char);
1009 else retpath = __pathify_retbuf;
1010 strcpy(retpath,esa);
1014 } /* end of do_pathify_dirspec() */
1016 /* External entry points */
1017 char *pathify_dirspec(char *dir, char *buf)
1018 { return do_pathify_dirspec(dir,buf,0); }
1019 char *pathify_dirspec_ts(char *dir, char *buf)
1020 { return do_pathify_dirspec(dir,buf,1); }
1022 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1023 static char *do_tounixspec(char *spec, char *buf, int ts)
1025 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1026 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1029 if (spec == NULL) return NULL;
1030 if (buf) rslt = buf;
1031 else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
1032 else rslt = __tounixspec_retbuf;
1033 if (strchr(spec,'/') != NULL) {
1040 dirend = strrchr(spec,']');
1041 if (dirend == NULL) dirend = strrchr(spec,'>');
1042 if (dirend == NULL) dirend = strchr(spec,':');
1043 if (dirend == NULL) {
1050 else { /* the VMS spec begins with directories */
1053 while (*cp2 == '-') {
1054 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1057 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1058 if (ts) Safefree(rslt); /* filespecs like */
1059 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1064 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1066 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1067 if (ts) Safefree(rslt);
1072 while (*cp3 != ':' && *cp3) cp3++;
1074 if (strchr(cp3,']') != NULL) break;
1075 } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1077 while (*cp3) *(cp1++) = *(cp3++);
1079 if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
1080 if (ts) Safefree(rslt);
1082 set_errno(RMS$_SYN);
1088 for (; cp2 <= dirend; cp2++) {
1091 if (*(cp2+1) == '[') cp2++;
1093 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1094 else if (*cp2 == '.') {
1096 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1097 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1099 else if (*cp2 == '-') {
1100 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1101 while (*cp2 == '-') {
1103 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1105 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1106 if (ts) Safefree(rslt); /* filespecs like */
1107 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1112 else *(cp1++) = *cp2;
1114 else *(cp1++) = *cp2;
1116 while (*cp2) *(cp1++) = *(cp2++);
1121 } /* end of do_tounixspec() */
1123 /* External entry points */
1124 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1125 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1127 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1128 static char *do_tovmsspec(char *path, char *buf, int ts) {
1129 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1130 register char *rslt, *dirend, *cp1, *cp2;
1131 register unsigned long int infront = 0;
1133 if (path == NULL) return NULL;
1134 if (buf) rslt = buf;
1135 else if (ts) New(7016,rslt,strlen(path)+3,char);
1136 else rslt = __tovmsspec_retbuf;
1137 if (strpbrk(path,"]:>") ||
1138 (dirend = strrchr(path,'/')) == NULL) {
1139 if (path[0] == '.') {
1140 if (path[1] == '\0') strcpy(rslt,"[]");
1141 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1142 else strcpy(rslt,path); /* probably garbage */
1144 else strcpy(rslt,path);
1147 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1148 if (!*(dirend+2)) dirend +=2;
1149 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1154 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1157 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1163 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1164 cp2 += 2; /* skip over "./" - it's redundant */
1165 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1167 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1168 *(cp1++) = '-'; /* "../" --> "-" */
1171 if (cp2 > dirend) cp2 = dirend;
1173 else *(cp1++) = '.';
1175 for (; cp2 < dirend; cp2++) {
1177 if (*(cp1-1) != '.') *(cp1++) = '.';
1180 else if (!infront && *cp2 == '.') {
1181 if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1182 else if (*(cp2+1) == '\0') { cp2++; break; }
1183 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1184 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1185 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1186 else { /* back up over previous directory name */
1188 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1189 if (*(cp1-1) == '[') {
1190 memcpy(cp1,"000000.",7);
1195 if (cp2 == dirend) {
1196 if (*(cp1-1) == '.') cp1--;
1200 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1203 if (*(cp1-1) == '-') *(cp1++) = '.';
1204 if (*cp2 == '/') *(cp1++) = '.';
1205 else if (*cp2 == '.') *(cp1++) = '_';
1206 else *(cp1++) = *cp2;
1210 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1212 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1213 while (*cp2) *(cp1++) = *(cp2++);
1218 } /* end of do_tovmsspec() */
1220 /* External entry points */
1221 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1222 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1224 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1225 static char *do_tovmspath(char *path, char *buf, int ts) {
1226 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1228 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1230 if (path == NULL) return NULL;
1231 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1232 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1233 if (buf) return buf;
1235 vmslen = strlen(vmsified);
1236 New(7017,cp,vmslen,char);
1237 memcpy(cp,vmsified,vmslen);
1242 strcpy(__tovmspath_retbuf,vmsified);
1243 return __tovmspath_retbuf;
1246 } /* end of do_tovmspath() */
1248 /* External entry points */
1249 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1250 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1253 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1254 static char *do_tounixpath(char *path, char *buf, int ts) {
1255 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1257 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1259 if (path == NULL) return NULL;
1260 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1261 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1262 if (buf) return buf;
1264 unixlen = strlen(unixified);
1265 New(7017,cp,unixlen,char);
1266 memcpy(cp,unixified,unixlen);
1271 strcpy(__tounixpath_retbuf,unixified);
1272 return __tounixpath_retbuf;
1275 } /* end of do_tounixpath() */
1277 /* External entry points */
1278 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1279 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1282 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1284 *****************************************************************************
1286 * Copyright (C) 1989-1994 by *
1287 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1289 * Permission is hereby granted for the reproduction of this software, *
1290 * on condition that this copyright notice is included in the reproduction, *
1291 * and that such reproduction is not for purposes of profit or material *
1294 * 27-Aug-1994 Modified for inclusion in perl5 *
1295 * by Charles Bailey bailey@genetics.upenn.edu *
1296 *****************************************************************************
1300 * getredirection() is intended to aid in porting C programs
1301 * to VMS (Vax-11 C). The native VMS environment does not support
1302 * '>' and '<' I/O redirection, or command line wild card expansion,
1303 * or a command line pipe mechanism using the '|' AND background
1304 * command execution '&'. All of these capabilities are provided to any
1305 * C program which calls this procedure as the first thing in the
1307 * The piping mechanism will probably work with almost any 'filter' type
1308 * of program. With suitable modification, it may useful for other
1309 * portability problems as well.
1311 * Author: Mark Pizzolato mark@infocomm.com
1315 struct list_item *next;
1319 static void add_item(struct list_item **head,
1320 struct list_item **tail,
1324 static void expand_wild_cards(char *item,
1325 struct list_item **head,
1326 struct list_item **tail,
1329 static int background_process(int argc, char **argv);
1331 static void pipe_and_fork(char **cmargv);
1333 /*{{{ void getredirection(int *ac, char ***av)*/
1335 getredirection(int *ac, char ***av)
1337 * Process vms redirection arg's. Exit if any error is seen.
1338 * If getredirection() processes an argument, it is erased
1339 * from the vector. getredirection() returns a new argc and argv value.
1340 * In the event that a background command is requested (by a trailing "&"),
1341 * this routine creates a background subprocess, and simply exits the program.
1343 * Warning: do not try to simplify the code for vms. The code
1344 * presupposes that getredirection() is called before any data is
1345 * read from stdin or written to stdout.
1347 * Normal usage is as follows:
1353 * getredirection(&argc, &argv);
1357 int argc = *ac; /* Argument Count */
1358 char **argv = *av; /* Argument Vector */
1359 char *ap; /* Argument pointer */
1360 int j; /* argv[] index */
1361 int item_count = 0; /* Count of Items in List */
1362 struct list_item *list_head = 0; /* First Item in List */
1363 struct list_item *list_tail; /* Last Item in List */
1364 char *in = NULL; /* Input File Name */
1365 char *out = NULL; /* Output File Name */
1366 char *outmode = "w"; /* Mode to Open Output File */
1367 char *err = NULL; /* Error File Name */
1368 char *errmode = "w"; /* Mode to Open Error File */
1369 int cmargc = 0; /* Piped Command Arg Count */
1370 char **cmargv = NULL;/* Piped Command Arg Vector */
1373 * First handle the case where the last thing on the line ends with
1374 * a '&'. This indicates the desire for the command to be run in a
1375 * subprocess, so we satisfy that desire.
1378 if (0 == strcmp("&", ap))
1379 exit(background_process(--argc, argv));
1380 if ('&' == ap[strlen(ap)-1])
1382 ap[strlen(ap)-1] = '\0';
1383 exit(background_process(argc, argv));
1386 * Now we handle the general redirection cases that involve '>', '>>',
1387 * '<', and pipes '|'.
1389 for (j = 0; j < argc; ++j)
1391 if (0 == strcmp("<", argv[j]))
1395 fprintf(stderr,"No input file after < on command line");
1396 exit(LIB$_WRONUMARG);
1401 if ('<' == *(ap = argv[j]))
1406 if (0 == strcmp(">", ap))
1410 fprintf(stderr,"No output file after > on command line");
1411 exit(LIB$_WRONUMARG);
1430 fprintf(stderr,"No output file after > or >> on command line");
1431 exit(LIB$_WRONUMARG);
1435 if (('2' == *ap) && ('>' == ap[1]))
1452 fprintf(stderr,"No output file after 2> or 2>> on command line");
1453 exit(LIB$_WRONUMARG);
1457 if (0 == strcmp("|", argv[j]))
1461 fprintf(stderr,"No command into which to pipe on command line");
1462 exit(LIB$_WRONUMARG);
1464 cmargc = argc-(j+1);
1465 cmargv = &argv[j+1];
1469 if ('|' == *(ap = argv[j]))
1477 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1480 * Allocate and fill in the new argument vector, Some Unix's terminate
1481 * the list with an extra null pointer.
1483 New(7002, argv, item_count+1, char *);
1485 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1486 argv[j] = list_head->value;
1492 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1493 exit(LIB$_INVARGORD);
1495 pipe_and_fork(cmargv);
1498 /* Check for input from a pipe (mailbox) */
1500 if (1 == isapipe(0))
1502 char mbxname[L_tmpnam];
1504 long int dvi_item = DVI$_DEVBUFSIZ;
1505 $DESCRIPTOR(mbxnam, "");
1506 $DESCRIPTOR(mbxdevnam, "");
1508 /* Input from a pipe, reopen it in binary mode to disable */
1509 /* carriage control processing. */
1513 fprintf(stderr,"'|' and '<' may not both be specified on command line");
1514 exit(LIB$_INVARGORD);
1516 fgetname(stdin, mbxname,1);
1517 mbxnam.dsc$a_pointer = mbxname;
1518 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1519 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1520 mbxdevnam.dsc$a_pointer = mbxname;
1521 mbxdevnam.dsc$w_length = sizeof(mbxname);
1522 dvi_item = DVI$_DEVNAM;
1523 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1524 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1527 freopen(mbxname, "rb", stdin);
1530 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1534 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1536 fprintf(stderr,"Can't open input file %s as stdin",in);
1539 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1541 fprintf(stderr,"Can't open output file %s as stdout",out);
1546 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1548 fprintf(stderr,"Can't open error file %s as stderr",err);
1552 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1557 #ifdef ARGPROC_DEBUG
1558 fprintf(stderr, "Arglist:\n");
1559 for (j = 0; j < *ac; ++j)
1560 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1562 } /* end of getredirection() */
1565 static void add_item(struct list_item **head,
1566 struct list_item **tail,
1572 New(7003,*head,1,struct list_item);
1576 New(7004,(*tail)->next,1,struct list_item);
1577 *tail = (*tail)->next;
1579 (*tail)->value = value;
1583 static void expand_wild_cards(char *item,
1584 struct list_item **head,
1585 struct list_item **tail,
1589 unsigned long int context = 0;
1596 char vmsspec[NAM$C_MAXRSS+1];
1597 $DESCRIPTOR(filespec, "");
1598 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1599 $DESCRIPTOR(resultspec, "");
1600 unsigned long int zero = 0;
1602 if (strcspn(item, "*%") == strlen(item))
1604 add_item(head, tail, item, count);
1607 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1608 resultspec.dsc$b_class = DSC$K_CLASS_D;
1609 resultspec.dsc$a_pointer = NULL;
1610 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1611 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1612 if (!isunix || !filespec.dsc$a_pointer)
1613 filespec.dsc$a_pointer = item;
1614 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1616 * Only return version specs, if the caller specified a version
1618 had_version = strchr(item, ';');
1620 * Only return device and directory specs, if the caller specifed either.
1622 had_device = strchr(item, ':');
1623 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1625 while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1626 &defaultspec, 0, &status_value, &zero)))
1631 New(7005,string,resultspec.dsc$w_length+1,char);
1632 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1633 string[resultspec.dsc$w_length] = '\0';
1634 if (NULL == had_version)
1635 *((char *)strrchr(string, ';')) = '\0';
1636 if ((!had_directory) && (had_device == NULL))
1638 if (NULL == (devdir = strrchr(string, ']')))
1639 devdir = strrchr(string, '>');
1640 strcpy(string, devdir + 1);
1643 * Be consistent with what the C RTL has already done to the rest of
1644 * the argv items and lowercase all of these names.
1646 for (c = string; *c; ++c)
1649 if (isunix) trim_unixpath(item,string);
1650 add_item(head, tail, string, count);
1654 add_item(head, tail, item, count);
1655 lib$sfree1_dd(&resultspec);
1656 lib$find_file_end(&context);
1659 static int child_st[2];/* Event Flag set when child process completes */
1661 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
1663 static unsigned long int exit_handler(int *status)
1667 if (0 == child_st[0])
1669 #ifdef ARGPROC_DEBUG
1670 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1672 fflush(stdout); /* Have to flush pipe for binary data to */
1673 /* terminate properly -- <tp@mccall.com> */
1674 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1675 sys$dassgn(child_chan);
1677 sys$synch(0, child_st);
1682 static void sig_child(int chan)
1684 #ifdef ARGPROC_DEBUG
1685 fprintf(stderr, "Child Completion AST\n");
1687 if (child_st[0] == 0)
1691 static struct exit_control_block exit_block =
1696 &exit_block.exit_status,
1700 static void pipe_and_fork(char **cmargv)
1703 $DESCRIPTOR(cmddsc, "");
1704 static char mbxname[64];
1705 $DESCRIPTOR(mbxdsc, mbxname);
1707 unsigned long int zero = 0, one = 1;
1709 strcpy(subcmd, cmargv[0]);
1710 for (j = 1; NULL != cmargv[j]; ++j)
1712 strcat(subcmd, " \"");
1713 strcat(subcmd, cmargv[j]);
1714 strcat(subcmd, "\"");
1716 cmddsc.dsc$a_pointer = subcmd;
1717 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1719 create_mbx(&child_chan,&mbxdsc);
1720 #ifdef ARGPROC_DEBUG
1721 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1722 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1724 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1725 0, &pid, child_st, &zero, sig_child,
1727 #ifdef ARGPROC_DEBUG
1728 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1730 sys$dclexh(&exit_block);
1731 if (NULL == freopen(mbxname, "wb", stdout))
1733 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1737 static int background_process(int argc, char **argv)
1739 char command[2048] = "$";
1740 $DESCRIPTOR(value, "");
1741 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1742 static $DESCRIPTOR(null, "NLA0:");
1743 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1745 $DESCRIPTOR(pidstr, "");
1747 unsigned long int flags = 17, one = 1, retsts;
1749 strcat(command, argv[0]);
1752 strcat(command, " \"");
1753 strcat(command, *(++argv));
1754 strcat(command, "\"");
1756 value.dsc$a_pointer = command;
1757 value.dsc$w_length = strlen(value.dsc$a_pointer);
1758 _ckvmssts(lib$set_symbol(&cmd, &value));
1759 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1760 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1761 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1766 #ifdef ARGPROC_DEBUG
1767 fprintf(stderr, "%s\n", command);
1769 sprintf(pidstring, "%08X", pid);
1770 fprintf(stderr, "%s\n", pidstring);
1771 pidstr.dsc$a_pointer = pidstring;
1772 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1773 lib$set_symbol(&pidsymbol, &pidstr);
1777 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1780 * Trim Unix-style prefix off filespec, so it looks like what a shell
1781 * glob expansion would return (i.e. from specified prefix on, not
1782 * full path). Note that returned filespec is Unix-style, regardless
1783 * of whether input filespec was VMS-style or Unix-style.
1785 * Returns !=0 on success, 0 on failure.
1787 /*{{{int trim_unixpath(char *template, char *fspec)*/
1789 trim_unixpath(char *template, char *fspec)
1791 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1792 register int tmplen;
1794 if (strpbrk(fspec,"]>:") != NULL) {
1795 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1796 else base = unixified;
1799 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
1801 /* Find prefix to template consisting of path elements without wildcards */
1802 if ((cp1 = strpbrk(template,"*%?")) == NULL)
1803 for (cp1 = template; *cp1; cp1++) ;
1804 else while (cp1 >= template && *cp1 != '/') cp1--;
1805 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
1806 tmplen = cp1 - template;
1808 /* Try to find template prefix on filespec */
1809 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
1810 for (; cp2 - base > tmplen; base++) {
1811 if (*base != '/') continue;
1812 if (!memcmp(base + 1,template,tmplen)) break;
1814 if (cp2 - base == tmplen) return 0; /* Not there - not good */
1815 base++; /* Move past leading '/' */
1816 /* Copy down remaining portion of filespec, including trailing NUL */
1817 memmove(fspec,base,cp2 - base + 1);
1820 } /* end of trim_unixpath() */
1825 * VMS readdir() routines.
1826 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1827 * This code has no copyright.
1829 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
1830 * Minor modifications to original routines.
1833 /* Number of elements in vms_versions array */
1834 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
1837 * Open a directory, return a handle for later use.
1839 /*{{{ DIR *opendir(char*name) */
1844 char dir[NAM$C_MAXRSS+1];
1846 /* Get memory for the handle, and the pattern. */
1848 if (do_tovmspath(name,dir,0) == NULL) {
1849 Safefree((char *)dd);
1852 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1854 /* Fill in the fields; mainly playing with the descriptor. */
1855 (void)sprintf(dd->pattern, "%s*.*",dir);
1858 dd->vms_wantversions = 0;
1859 dd->pat.dsc$a_pointer = dd->pattern;
1860 dd->pat.dsc$w_length = strlen(dd->pattern);
1861 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1862 dd->pat.dsc$b_class = DSC$K_CLASS_S;
1865 } /* end of opendir() */
1869 * Set the flag to indicate we want versions or not.
1871 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1873 vmsreaddirversions(DIR *dd, int flag)
1875 dd->vms_wantversions = flag;
1880 * Free up an opened directory.
1882 /*{{{ void closedir(DIR *dd)*/
1886 (void)lib$find_file_end(&dd->context);
1887 Safefree(dd->pattern);
1888 Safefree((char *)dd);
1893 * Collect all the version numbers for the current file.
1899 struct dsc$descriptor_s pat;
1900 struct dsc$descriptor_s res;
1902 char *p, *text, buff[sizeof dd->entry.d_name];
1904 unsigned long context, tmpsts;
1906 /* Convenient shorthand. */
1909 /* Add the version wildcard, ignoring the "*.*" put on before */
1910 i = strlen(dd->pattern);
1911 New(7008,text,i + e->d_namlen + 3,char);
1912 (void)strcpy(text, dd->pattern);
1913 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1915 /* Set up the pattern descriptor. */
1916 pat.dsc$a_pointer = text;
1917 pat.dsc$w_length = i + e->d_namlen - 1;
1918 pat.dsc$b_dtype = DSC$K_DTYPE_T;
1919 pat.dsc$b_class = DSC$K_CLASS_S;
1921 /* Set up result descriptor. */
1922 res.dsc$a_pointer = buff;
1923 res.dsc$w_length = sizeof buff - 2;
1924 res.dsc$b_dtype = DSC$K_DTYPE_T;
1925 res.dsc$b_class = DSC$K_CLASS_S;
1927 /* Read files, collecting versions. */
1928 for (context = 0, e->vms_verscount = 0;
1929 e->vms_verscount < VERSIZE(e);
1930 e->vms_verscount++) {
1931 tmpsts = lib$find_file(&pat, &res, &context);
1932 if (tmpsts == RMS$_NMF || context == 0) break;
1934 buff[sizeof buff - 1] = '\0';
1935 if ((p = strchr(buff, ';')))
1936 e->vms_versions[e->vms_verscount] = atoi(p + 1);
1938 e->vms_versions[e->vms_verscount] = -1;
1941 _ckvmssts(lib$find_file_end(&context));
1944 } /* end of collectversions() */
1947 * Read the next entry from the directory.
1949 /*{{{ struct dirent *readdir(DIR *dd)*/
1953 struct dsc$descriptor_s res;
1954 char *p, buff[sizeof dd->entry.d_name];
1955 unsigned long int tmpsts;
1957 /* Set up result descriptor, and get next file. */
1958 res.dsc$a_pointer = buff;
1959 res.dsc$w_length = sizeof buff - 2;
1960 res.dsc$b_dtype = DSC$K_DTYPE_T;
1961 res.dsc$b_class = DSC$K_CLASS_S;
1962 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
1963 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
1964 if (!(tmpsts & 1)) {
1965 set_vaxc_errno(tmpsts);
1985 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
1986 buff[sizeof buff - 1] = '\0';
1987 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
1990 /* Skip any directory component and just copy the name. */
1991 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
1992 else (void)strcpy(dd->entry.d_name, buff);
1994 /* Clobber the version. */
1995 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
1997 dd->entry.d_namlen = strlen(dd->entry.d_name);
1998 dd->entry.vms_verscount = 0;
1999 if (dd->vms_wantversions) collectversions(dd);
2002 } /* end of readdir() */
2006 * Return something that can be used in a seekdir later.
2008 /*{{{ long telldir(DIR *dd)*/
2017 * Return to a spot where we used to be. Brute force.
2019 /*{{{ void seekdir(DIR *dd,long count)*/
2021 seekdir(DIR *dd, long count)
2023 int vms_wantversions;
2025 /* If we haven't done anything yet... */
2029 /* Remember some state, and clear it. */
2030 vms_wantversions = dd->vms_wantversions;
2031 dd->vms_wantversions = 0;
2032 _ckvmssts(lib$find_file_end(&dd->context));
2035 /* The increment is in readdir(). */
2036 for (dd->count = 0; dd->count < count; )
2039 dd->vms_wantversions = vms_wantversions;
2041 } /* end of seekdir() */
2044 /* VMS subprocess management
2046 * my_vfork() - just a vfork(), after setting a flag to record that
2047 * the current script is trying a Unix-style fork/exec.
2049 * vms_do_aexec() and vms_do_exec() are called in response to the
2050 * perl 'exec' function. If this follows a vfork call, then they
2051 * call out the the regular perl routines in doio.c which do an
2052 * execvp (for those who really want to try this under VMS).
2053 * Otherwise, they do exactly what the perl docs say exec should
2054 * do - terminate the current script and invoke a new command
2055 * (See below for notes on command syntax.)
2057 * do_aspawn() and do_spawn() implement the VMS side of the perl
2058 * 'system' function.
2060 * Note on command arguments to perl 'exec' and 'system': When handled
2061 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2062 * are concatenated to form a DCL command string. If the first arg
2063 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2064 * the the command string is hrnded off to DCL directly. Otherwise,
2065 * the first token of the command is taken as the filespec of an image
2066 * to run. The filespec is expanded using a default type of '.EXE' and
2067 * the process defaults for device, directory, etc., and the resultant
2068 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2069 * the command string as parameters. This is perhaps a bit compicated,
2070 * but I hope it will form a happy medium between what VMS folks expect
2071 * from lib$spawn and what Unix folks expect from exec.
2074 static int vfork_called;
2076 /*{{{int my_vfork()*/
2086 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2094 if (VMScmd.dsc$a_pointer) {
2095 Safefree(VMScmd.dsc$a_pointer);
2096 VMScmd.dsc$w_length = 0;
2097 VMScmd.dsc$a_pointer = Nullch;
2102 setup_argstr(SV *really, SV **mark, SV **sp)
2104 char *junk, *tmps = Nullch;
2105 register size_t cmdlen = 0;
2111 tmps = SvPV(really,rlen);
2118 for (idx++; idx <= sp; idx++) {
2120 junk = SvPVx(*idx,rlen);
2121 cmdlen += rlen ? rlen + 1 : 0;
2124 New(401,Cmd,cmdlen,char);
2126 if (tmps && *tmps) {
2131 while (++mark <= sp) {
2134 strcat(Cmd,SvPVx(*mark,na));
2139 } /* end of setup_argstr() */
2142 static unsigned long int
2143 setup_cmddsc(char *cmd, int check_img)
2145 char resspec[NAM$C_MAXRSS+1];
2146 $DESCRIPTOR(defdsc,".EXE");
2147 $DESCRIPTOR(resdsc,resspec);
2148 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2149 unsigned long int cxt = 0, flags = 1, retsts;
2150 register char *s, *rest, *cp;
2151 register int isdcl = 0;
2154 while (*s && isspace(*s)) s++;
2156 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2157 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2158 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2159 if (*cp == ':' || *cp == '[' || *cp == '<') {
2167 if (isdcl) { /* It's a DCL command, just do it. */
2168 VMScmd.dsc$a_pointer = cmd;
2169 VMScmd.dsc$w_length = strlen(cmd);
2170 if (cmd == Cmd) Cmd = Nullch; /* clear Cmd so vms_execfree isok */
2172 else { /* assume first token is an image spec */
2174 while (*s && !isspace(*s)) s++;
2176 imgdsc.dsc$a_pointer = cmd;
2177 imgdsc.dsc$w_length = s - cmd;
2178 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2179 if (!(retsts & 1)) {
2180 /* just hand off status values likely to be due to user error */
2181 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2182 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2183 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2184 else { _ckvmssts(retsts); }
2187 _ckvmssts(lib$find_file_end(&cxt));
2189 while (*s && !isspace(*s)) s++;
2191 New(402,VMScmd.dsc$a_pointer,6 + s - resspec + (rest ? strlen(rest) : 0),char);
2192 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2193 strcat(VMScmd.dsc$a_pointer,resspec);
2194 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2195 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2200 } /* end of setup_cmddsc() */
2202 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2204 vms_do_aexec(SV *really,SV **mark,SV **sp)
2207 if (vfork_called) { /* this follows a vfork - act Unixish */
2209 if (vfork_called < 0) {
2210 warn("Internal inconsistency in tracking vforks");
2213 else return do_aexec(really,mark,sp);
2215 /* no vfork - act VMSish */
2216 return vms_do_exec(setup_argstr(really,mark,sp));
2221 } /* end of vms_do_aexec() */
2224 /* {{{bool vms_do_exec(char *cmd) */
2226 vms_do_exec(char *cmd)
2229 if (vfork_called) { /* this follows a vfork - act Unixish */
2231 if (vfork_called < 0) {
2232 warn("Internal inconsistency in tracking vforks");
2235 else return do_exec(cmd);
2238 { /* no vfork - act VMSish */
2239 unsigned long int retsts;
2241 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2242 retsts = lib$do_command(&VMScmd);
2245 set_vaxc_errno(retsts);
2247 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2253 } /* end of vms_do_exec() */
2256 unsigned long int do_spawn(char *);
2258 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2260 do_aspawn(SV *really,SV **mark,SV **sp)
2262 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2265 } /* end of do_aspawn() */
2268 /* {{{unsigned long int do_spawn(char *cmd) */
2272 unsigned long int substs, hadcmd = 1;
2274 if (!cmd || !*cmd) {
2276 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2278 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2279 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2284 set_vaxc_errno(substs);
2286 warn("Can't exec \"%s\": %s",
2287 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2292 } /* end of do_spawn() */
2296 * A simple fwrite replacement which outputs itmsz*nitm chars without
2297 * introducing record boundaries every itmsz chars.
2299 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2301 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2303 register char *cp, *end;
2305 end = (char *)src + itmsz * nitm;
2307 while ((char *)src <= end) {
2308 for (cp = src; cp <= end; cp++) if (!*cp) break;
2309 if (fputs(src,dest) == EOF) return EOF;
2311 if (fputc('\0',dest) == EOF) return EOF;
2317 } /* end of my_fwrite() */
2321 * Here are replacements for the following Unix routines in the VMS environment:
2322 * getpwuid Get information for a particular UIC or UID
2323 * getpwnam Get information for a named user
2324 * getpwent Get information for each user in the rights database
2325 * setpwent Reset search to the start of the rights database
2326 * endpwent Finish searching for users in the rights database
2328 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2329 * (defined in pwd.h), which contains the following fields:-
2331 * char *pw_name; Username (in lower case)
2332 * char *pw_passwd; Hashed password
2333 * unsigned int pw_uid; UIC
2334 * unsigned int pw_gid; UIC group number
2335 * char *pw_unixdir; Default device/directory (VMS-style)
2336 * char *pw_gecos; Owner name
2337 * char *pw_dir; Default device/directory (Unix-style)
2338 * char *pw_shell; Default CLI name (eg. DCL)
2340 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2342 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2343 * not the UIC member number (eg. what's returned by getuid()),
2344 * getpwuid() can accept either as input (if uid is specified, the caller's
2345 * UIC group is used), though it won't recognise gid=0.
2347 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2348 * information about other users in your group or in other groups, respectively.
2349 * If the required privilege is not available, then these routines fill only
2350 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2353 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2356 /* sizes of various UAF record fields */
2357 #define UAI$S_USERNAME 12
2358 #define UAI$S_IDENT 31
2359 #define UAI$S_OWNER 31
2360 #define UAI$S_DEFDEV 31
2361 #define UAI$S_DEFDIR 63
2362 #define UAI$S_DEFCLI 31
2365 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2366 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2367 (uic).uic$v_group != UIC$K_WILD_GROUP)
2369 static char __empty[]= "";
2370 static struct passwd __passwd_empty=
2371 {(char *) __empty, (char *) __empty, 0, 0,
2372 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2373 static int contxt= 0;
2374 static struct passwd __pwdcache;
2375 static char __pw_namecache[UAI$S_IDENT+1];
2377 static char *_mystrtolower(char *str)
2379 if (str) for (; *str; ++str) *str= tolower(*str);
2384 * This routine does most of the work extracting the user information.
2386 static int fillpasswd (const char *name, struct passwd *pwd)
2389 unsigned char length;
2390 char pw_gecos[UAI$S_OWNER+1];
2392 static union uicdef uic;
2394 unsigned char length;
2395 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2398 unsigned char length;
2399 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2402 unsigned char length;
2403 char pw_shell[UAI$S_DEFCLI+1];
2405 static char pw_passwd[UAI$S_PWD+1];
2407 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2408 struct dsc$descriptor_s name_desc;
2411 static struct itmlst_3 itmlst[]= {
2412 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2413 {sizeof(uic), UAI$_UIC, &uic, &luic},
2414 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2415 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2416 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2417 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2418 {0, 0, NULL, NULL}};
2420 name_desc.dsc$w_length= strlen(name);
2421 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2422 name_desc.dsc$b_class= DSC$K_CLASS_S;
2423 name_desc.dsc$a_pointer= (char *) name;
2425 /* Note that sys$getuai returns many fields as counted strings. */
2426 status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2427 if (!(status&1)) return status;
2429 if ((int) owner.length < lowner) lowner= (int) owner.length;
2430 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2431 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2432 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2433 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2434 owner.pw_gecos[lowner]= '\0';
2435 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2436 defcli.pw_shell[ldefcli]= '\0';
2437 if (valid_uic(uic)) {
2438 pwd->pw_uid= uic.uic$l_uic;
2439 pwd->pw_gid= uic.uic$v_group;
2442 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2443 pwd->pw_passwd= pw_passwd;
2444 pwd->pw_gecos= owner.pw_gecos;
2445 pwd->pw_dir= defdev.pw_dir;
2446 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2447 pwd->pw_shell= defcli.pw_shell;
2448 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2450 ldir= strlen(pwd->pw_unixdir) - 1;
2451 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2454 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2455 _mystrtolower(pwd->pw_unixdir);
2460 * Get information for a named user.
2462 /*{{{struct passwd *getpwnam(char *name)*/
2463 struct passwd *my_getpwnam(char *name)
2465 struct dsc$descriptor_s name_desc;
2467 unsigned long int status, stat;
2469 __pwdcache = __passwd_empty;
2470 if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV
2471 || status == SS$_NOGRPPRV || status == RMS$_RNF) {
2472 /* We still may be able to determine pw_uid and pw_gid */
2473 name_desc.dsc$w_length= strlen(name);
2474 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2475 name_desc.dsc$b_class= DSC$K_CLASS_S;
2476 name_desc.dsc$a_pointer= (char *) name;
2477 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2478 __pwdcache.pw_uid= uic.uic$l_uic;
2479 __pwdcache.pw_gid= uic.uic$v_group;
2481 else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL;
2482 else { _ckvmssts(stat); }
2484 else { _ckvmssts(status); }
2485 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2486 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2487 __pwdcache.pw_name= __pw_namecache;
2489 } /* end of my_getpwnam() */
2493 * Get information for a particular UIC or UID.
2494 * Called by my_getpwent with uid=-1 to list all users.
2496 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2497 struct passwd *my_getpwuid(Uid_t uid)
2499 const $DESCRIPTOR(name_desc,__pw_namecache);
2500 unsigned short lname;
2502 unsigned long int status;
2504 if (uid == (unsigned int) -1) {
2506 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2507 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2511 else { _ckvmssts(status); }
2512 } while (!valid_uic (uic));
2516 if (!uic.uic$v_group) uic.uic$v_group= getgid();
2518 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2519 else status = SS$_IVIDENT;
2522 __pw_namecache[lname]= '\0';
2523 _mystrtolower(__pw_namecache);
2525 __pwdcache = __passwd_empty;
2526 __pwdcache.pw_name = __pw_namecache;
2528 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2529 The identifier's value is usually the UIC, but it doesn't have to be,
2530 so if we can, we let fillpasswd update this. */
2531 __pwdcache.pw_uid = uic.uic$l_uic;
2532 __pwdcache.pw_gid = uic.uic$v_group;
2534 status = fillpasswd(__pw_namecache, &__pwdcache);
2535 if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV &&
2536 status != RMS$_RNF) { _ckvmssts(status); }
2539 } /* end of my_getpwuid() */
2543 * Get information for next user.
2545 /*{{{struct passwd *my_getpwent()*/
2546 struct passwd *my_getpwent()
2548 return (my_getpwuid((unsigned int) -1));
2553 * Finish searching rights database for users.
2555 /*{{{void my_endpwent()*/
2559 _ckvmssts(sys$finish_rdb(&contxt));
2566 * flex_stat, flex_fstat
2567 * basic stat, but gets it right when asked to stat
2568 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2571 /* encode_dev packs a VMS device name string into an integer to allow
2572 * simple comparisons. This can be used, for example, to check whether two
2573 * files are located on the same device, by comparing their encoded device
2574 * names. Even a string comparison would not do, because stat() reuses the
2575 * device name buffer for each call; so without encode_dev, it would be
2576 * necessary to save the buffer and use strcmp (this would mean a number of
2577 * changes to the standard Perl code, to say nothing of what a Perl script
2580 * The device lock id, if it exists, should be unique (unless perhaps compared
2581 * with lock ids transferred from other nodes). We have a lock id if the disk is
2582 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2583 * device names. Thus we use the lock id in preference, and only if that isn't
2584 * available, do we try to pack the device name into an integer (flagged by
2585 * the sign bit (LOCKID_MASK) being set).
2587 * Note that encode_dev cann guarantee an 1-to-1 correspondence twixt device
2588 * name and its encoded form, but it seems very unlikely that we will find
2589 * two files on different disks that share the same encoded device names,
2590 * and even more remote that they will share the same file id (if the test
2591 * is to check for the same file).
2593 * A better method might be to use sys$device_scan on the first call, and to
2594 * search for the device, returning an index into the cached array.
2595 * The number returned would be more intelligable.
2596 * This is probably not worth it, and anyway would take quite a bit longer
2597 * on the first call.
2599 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2600 static dev_t encode_dev (const char *dev)
2603 unsigned long int f;
2608 if (!dev || !dev[0]) return 0;
2612 struct dsc$descriptor_s dev_desc;
2613 unsigned long int status, lockid, item = DVI$_LOCKID;
2615 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2616 can try that first. */
2617 dev_desc.dsc$w_length = strlen (dev);
2618 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2619 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2620 dev_desc.dsc$a_pointer = (char *) dev;
2621 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2622 if (lockid) return (lockid & ~LOCKID_MASK);
2626 /* Otherwise we try to encode the device name */
2630 for (q = dev + strlen(dev); q--; q >= dev) {
2633 else if (isalpha (toupper (*q)))
2634 c= toupper (*q) - 'A' + (char)10;
2636 continue; /* Skip '$'s */
2638 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2640 enc += f * (unsigned long int) c;
2642 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2644 } /* end of encode_dev() */
2646 static char namecache[NAM$C_MAXRSS+1];
2649 is_null_device(name)
2652 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2653 The underscore prefix, controller letter, and unit number are
2654 independently optional; for our purposes, the colon punctuation
2655 is not. The colon can be trailed by optional directory and/or
2656 filename, but two consecutive colons indicates a nodename rather
2657 than a device. [pr] */
2658 if (*name == '_') ++name;
2659 if (tolower(*name++) != 'n') return 0;
2660 if (tolower(*name++) != 'l') return 0;
2661 if (tolower(*name) == 'a') ++name;
2662 if (*name == '0') ++name;
2663 return (*name++ == ':') && (*name != ':');
2666 /* Do the permissions allow some operation? Assumes statcache already set. */
2667 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2668 * subset of the applicable information.
2670 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2672 cando(I32 bit, I32 effective, struct stat *statbufp)
2674 if (statbufp == &statcache)
2675 return cando_by_name(bit,effective,namecache);
2677 char fname[NAM$C_MAXRSS+1];
2678 unsigned long int retsts;
2679 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2680 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2682 /* If the struct mystat is stale, we're OOL; stat() overwrites the
2683 device name on successive calls */
2684 devdsc.dsc$a_pointer = statbufp->st_devnam;
2685 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2686 namdsc.dsc$a_pointer = fname;
2687 namdsc.dsc$w_length = sizeof fname - 1;
2689 retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc,
2690 &namdsc.dsc$w_length,0,0);
2692 fname[namdsc.dsc$w_length] = '\0';
2693 return cando_by_name(bit,effective,fname);
2695 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2696 warn("Can't get filespec - stale stat buffer?\n");
2700 return FALSE; /* Should never get to here */
2705 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2707 cando_by_name(I32 bit, I32 effective, char *fname)
2709 static char usrname[L_cuserid];
2710 static struct dsc$descriptor_s usrdsc =
2711 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2713 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2714 unsigned short int retlen;
2715 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2716 union prvdef curprv;
2717 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2718 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2719 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2722 if (!fname || !*fname) return FALSE;
2723 if (!usrdsc.dsc$w_length) {
2725 usrdsc.dsc$w_length = strlen(usrname);
2727 namdsc.dsc$w_length = strlen(fname);
2728 namdsc.dsc$a_pointer = fname;
2733 access = ARM$M_EXECUTE;
2738 access = ARM$M_READ;
2743 access = ARM$M_WRITE;
2748 access = ARM$M_DELETE;
2754 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
2755 if (retsts == SS$_NOPRIV || retsts == RMS$_FNF ||
2756 retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
2757 if (retsts == SS$_NORMAL) {
2758 if (!privused) return TRUE;
2759 /* We can get access, but only by using privs. Do we have the
2760 necessary privs currently enabled? */
2761 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
2762 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
2763 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv
2764 && !curprv.prv$v_bypass) return FALSE;
2765 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv
2766 && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
2767 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
2772 return FALSE; /* Should never get here */
2774 } /* end of cando_by_name() */
2778 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
2780 flex_fstat(int fd, struct stat *statbuf)
2782 char fspec[NAM$C_MAXRSS+1];
2784 if (!getname(fd,fspec,1)) return -1;
2785 return flex_stat(fspec,statbuf);
2787 } /* end of flex_fstat() */
2790 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
2792 flex_stat(char *fspec, struct stat *statbufp)
2794 char fileified[NAM$C_MAXRSS+1];
2795 int retval,myretval;
2799 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
2800 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
2801 memset(statbufp,0,sizeof *statbufp);
2802 statbufp->st_dev = encode_dev("_NLA0:");
2803 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
2804 statbufp->st_uid = 0x00010001;
2805 statbufp->st_gid = 0x0001;
2806 time((time_t *)&statbufp->st_mtime);
2807 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
2811 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
2812 * 'struct stat' elsewhere in Perl would use our struct. We go back
2813 * to the system version here, since we're actually calling their
2818 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
2820 myretval = stat(fileified,(stat_t *) &tmpbuf);
2822 retval = stat(fspec,(stat_t *) statbufp);
2828 else if (!retval) { /* Dir with same name. Substitute it. */
2829 statbufp->st_mode &= ~S_IFDIR;
2830 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
2831 strcpy(namecache,fileified);
2834 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
2837 } /* end of flex_stat() */
2840 /*** The following glue provides 'hooks' to make some of the routines
2841 * from this file available from Perl. These routines are sufficiently
2842 * basic, and are required sufficiently early in the build process,
2843 * that's it's nice to have them available to miniperl as well as the
2844 * full Perl, so they're set up here instead of in an extension. The
2845 * Perl code which handles importation of these names into a given
2846 * package lives in [.VMS]Filespec.pm in @INC.
2850 vmsify_fromperl(CV *cv)
2855 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
2856 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
2857 ST(0) = sv_newmortal();
2858 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
2863 unixify_fromperl(CV *cv)
2868 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
2869 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
2870 ST(0) = sv_newmortal();
2871 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
2876 fileify_fromperl(CV *cv)
2881 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
2882 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
2883 ST(0) = sv_newmortal();
2884 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
2889 pathify_fromperl(CV *cv)
2894 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
2895 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
2896 ST(0) = sv_newmortal();
2897 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
2902 vmspath_fromperl(CV *cv)
2907 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
2908 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
2909 ST(0) = sv_newmortal();
2910 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
2915 unixpath_fromperl(CV *cv)
2920 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
2921 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
2922 ST(0) = sv_newmortal();
2923 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
2928 candelete_fromperl(CV *cv)
2931 char vmsspec[NAM$C_MAXRSS+1];
2933 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
2934 if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf))
2936 else ST(0) = &sv_no;
2943 char* file = __FILE__;
2945 newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
2946 newXS("VMS::Filespec::unixify",unixify_fromperl,file);
2947 newXS("VMS::Filespec::pathify",pathify_fromperl,file);
2948 newXS("VMS::Filespec::fileify",fileify_fromperl,file);
2949 newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
2950 newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
2951 newXS("VMS::Filespec::candelete",candelete_fromperl,file);