3 * VMS-specific routines for perl5
5 * Last revised: 15-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
14 #include <climsgdef.h>
23 #include <lib$routines.h>
32 #include <str$routines.h>
37 /* Older versions of ssdef.h don't have these */
38 #ifndef SS$_INVFILFOROP
39 # define SS$_INVFILFOROP 3930
41 #ifndef SS$_NOSUCHOBJECT
42 # define SS$_NOSUCHOBJECT 2696
45 /* Don't replace system definitions of vfork, getenv, and stat,
46 * code below needs to get to the underlying CRTL routines. */
47 #define DONT_MASK_RTL_CALLS
52 /* gcc's header files don't #define direct access macros
53 * corresponding to VAXC's variant structs */
55 # define uic$v_format uic$r_uic_form.uic$v_format
56 # define uic$v_group uic$r_uic_form.uic$v_group
57 # define uic$v_member uic$r_uic_form.uic$v_member
58 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
59 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
60 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
61 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
66 unsigned short int buflen;
67 unsigned short int itmcode;
69 unsigned short int *retlen;
72 static char *__mystrtolower(char *str)
74 if (str) for (; *str; ++str) *str= tolower(*str);
79 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
81 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
82 unsigned short int eqvlen;
83 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
84 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
85 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
86 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
87 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
90 if (!lnm || idx > LNM$_MAX_INDEX) {
91 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
93 if (!eqv) eqv = __my_trnlnm_eqv;
94 lnmlst[1].bufadr = (void *)eqv;
95 lnmdsc.dsc$a_pointer = lnm;
96 lnmdsc.dsc$w_length = strlen(lnm);
97 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
98 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
99 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
101 else if (retsts & 1) {
105 _ckvmssts(retsts); /* Must be an error */
106 return 0; /* Not reached, assuming _ckvmssts() bails out */
108 } /* end of my_trnlnm */
111 * Translate a logical name. Substitute for CRTL getenv() to avoid
112 * memory leak, and to keep my_getenv() and my_setenv() in the same
113 * domain (mostly - my_getenv() need not return a translation from
114 * the process logical name table)
116 * Note: Uses static buffer -- not thread-safe!
118 /*{{{ char *my_getenv(char *lnm)*/
122 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
123 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
124 unsigned long int idx = 0;
127 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
129 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
130 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
131 return __my_getenv_eqv;
134 if ((cp2 = strchr(uplnm,';')) != NULL) {
136 idx = strtoul(cp2+1,NULL,0);
138 trnsuccess = my_trnlnm(uplnm,__my_getenv_eqv,idx);
139 /* If we had a translation index, we're only interested in lnms */
140 if (!trnsuccess && cp2 != NULL) return Nullch;
141 if (trnsuccess) return __my_getenv_eqv;
143 unsigned long int retsts;
144 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
146 DSC$K_CLASS_S, __my_getenv_eqv};
147 symdsc.dsc$w_length = cp1 - lnm;
148 symdsc.dsc$a_pointer = uplnm;
149 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
150 if (retsts == LIB$_INVSYMNAM) return Nullch;
151 if (retsts != LIB$_NOSUCHSYM) {
152 /* We want to return only logical names or CRTL Unix emulations */
153 if (retsts & 1) return Nullch;
156 /* Try for CRTL emulation of a Unix/POSIX name */
157 else return getenv(uplnm);
162 } /* end of my_getenv() */
165 static FILE *safe_popen(char *, char *);
167 /*{{{ void prime_env_iter() */
170 /* Fill the %ENV associative array with all logical names we can
171 * find, in preparation for iterating over it.
174 static int primed = 0; /* XXX Not thread-safe!!! */
175 HV *envhv = GvHVn(envgv);
177 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
179 SV *oldrs, *linesv, *eqvsv;
182 /* Perform a dummy fetch as an lval to insure that the hash table is
183 * set up. Otherwise, the hv_store() will turn into a nullop */
184 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
185 /* Also, set up the four "special" keys that the CRTL defines,
186 * whether or not underlying logical names exist. */
187 (void) hv_fetch(envhv,"HOME",4,TRUE);
188 (void) hv_fetch(envhv,"TERM",4,TRUE);
189 (void) hv_fetch(envhv,"PATH",4,TRUE);
190 (void) hv_fetch(envhv,"USER",4,TRUE);
192 /* Now, go get the logical names */
193 if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp)
194 _ckvmssts(vaxc$errno);
195 /* We use Perl's sv_gets to read from the pipe, since safe_popen is
196 * tied to Perl's I/O layer, so it may not return a simple FILE * */
198 rs = newSVpv("\n",1);
199 linesv = newSVpv("",0);
201 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
203 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
207 while (*start != '"' && *start != '=' && *start) start++;
208 if (*start != '"') continue;
209 for (end = ++start; *end && *end != '"'; end++) ;
210 if (*end) *end = '\0';
212 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
213 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
215 warn("Ill-formed logical name |%s| in prime_env_iter",start);
218 else _ckvmssts(vaxc$errno);
221 eqvsv = newSVpv(eqv,eqvlen);
222 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
225 } /* end of prime_env_iter */
229 /*{{{ void my_setenv(char *lnm, char *eqv)*/
231 my_setenv(char *lnm,char *eqv)
232 /* Define a supervisor-mode logical name in the process table.
233 * In the future we'll add tables, attribs, and acmodes,
234 * probably through a different call.
237 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
238 unsigned long int retsts, usermode = PSL$C_USER;
239 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
240 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
241 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
243 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
244 lnmdsc.dsc$w_length = cp1 - lnm;
246 if (!eqv || !*eqv) { /* we're deleting a logical name */
247 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
248 if (retsts == SS$_IVLOGNAM) return;
249 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
251 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
252 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
256 eqvdsc.dsc$w_length = strlen(eqv);
257 eqvdsc.dsc$a_pointer = eqv;
259 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
262 } /* end of my_setenv() */
266 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
267 /* my_crypt - VMS password hashing
268 * my_crypt() provides an interface compatible with the Unix crypt()
269 * C library function, and uses sys$hash_password() to perform VMS
270 * password hashing. The quadword hashed password value is returned
271 * as a NUL-terminated 8 character string. my_crypt() does not change
272 * the case of its string arguments; in order to match the behavior
273 * of LOGINOUT et al., alphabetic characters in both arguments must
274 * be upcased by the caller.
277 my_crypt(const char *textpasswd, const char *usrname)
279 # ifndef UAI$C_PREFERRED_ALGORITHM
280 # define UAI$C_PREFERRED_ALGORITHM 127
282 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
283 unsigned short int salt = 0;
284 unsigned long int sts;
286 unsigned short int dsc$w_length;
287 unsigned char dsc$b_type;
288 unsigned char dsc$b_class;
289 const char * dsc$a_pointer;
290 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
291 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
292 struct itmlst_3 uailst[3] = {
293 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
294 { sizeof salt, UAI$_SALT, &salt, 0},
295 { 0, 0, NULL, NULL}};
298 usrdsc.dsc$w_length = strlen(usrname);
299 usrdsc.dsc$a_pointer = usrname;
300 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
307 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
313 if (sts != RMS$_RNF) return NULL;
316 txtdsc.dsc$w_length = strlen(textpasswd);
317 txtdsc.dsc$a_pointer = textpasswd;
318 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
319 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
322 return (char *) hash;
324 } /* end of my_crypt() */
328 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
329 static char *do_fileify_dirspec(char *, char *, int);
330 static char *do_tovmsspec(char *, char *, int);
332 /*{{{int do_rmdir(char *name)*/
336 char dirfile[NAM$C_MAXRSS+1];
340 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
341 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
342 else retval = kill_file(dirfile);
345 } /* end of do_rmdir */
349 * Delete any file to which user has control access, regardless of whether
350 * delete access is explicitly allowed.
351 * Limitations: User must have write access to parent directory.
352 * Does not block signals or ASTs; if interrupted in midstream
353 * may leave file with an altered ACL.
356 /*{{{int kill_file(char *name)*/
358 kill_file(char *name)
360 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
361 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
362 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
363 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
365 unsigned char myace$b_length;
366 unsigned char myace$b_type;
367 unsigned short int myace$w_flags;
368 unsigned long int myace$l_access;
369 unsigned long int myace$l_ident;
370 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
371 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
372 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
374 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
375 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
376 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
377 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
378 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
379 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
381 /* Expand the input spec using RMS, since the CRTL remove() and
382 * system services won't do this by themselves, so we may miss
383 * a file "hiding" behind a logical name or search list. */
384 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
385 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
386 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
387 /* If not, can changing protections help? */
388 if (vaxc$errno != RMS$_PRV) return -1;
390 /* No, so we get our own UIC to use as a rights identifier,
391 * and the insert an ACE at the head of the ACL which allows us
392 * to delete the file.
394 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
395 fildsc.dsc$w_length = strlen(rspec);
396 fildsc.dsc$a_pointer = rspec;
398 newace.myace$l_ident = oldace.myace$l_ident;
399 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
404 case SS$_NOSUCHOBJECT:
405 set_errno(ENOENT); break;
407 set_errno(ENODEV); break;
409 case SS$_INVFILFOROP:
410 set_errno(EINVAL); break;
412 set_errno(EACCES); break;
416 set_vaxc_errno(aclsts);
419 /* Grab any existing ACEs with this identifier in case we fail */
420 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
421 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
422 || fndsts == SS$_NOMOREACE ) {
423 /* Add the new ACE . . . */
424 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
426 if ((rmsts = remove(name))) {
427 /* We blew it - dir with files in it, no write priv for
428 * parent directory, etc. Put things back the way they were. */
429 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
432 addlst[0].bufadr = &oldace;
433 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
440 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
441 /* We just deleted it, so of course it's not there. Some versions of
442 * VMS seem to return success on the unlock operation anyhow (after all
443 * the unlock is successful), but others don't.
445 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
446 if (aclsts & 1) aclsts = fndsts;
449 set_vaxc_errno(aclsts);
455 } /* end of kill_file() */
459 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
461 static unsigned long int mbxbufsiz;
462 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
466 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
467 * preprocessor consant BUFSIZ from stdio.h as the size of the
470 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
471 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
473 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
475 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
476 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
478 } /* end of create_mbx() */
480 /*{{{ my_popen and my_pclose*/
483 struct pipe_details *next;
484 PerlIO *fp; /* stdio file pointer to pipe mailbox */
485 int pid; /* PID of subprocess */
486 int mode; /* == 'r' if pipe open for reading */
487 int done; /* subprocess has completed */
488 unsigned long int completion; /* termination status of subprocess */
491 struct exit_control_block
493 struct exit_control_block *flink;
494 unsigned long int (*exit_routine)();
495 unsigned long int arg_count;
496 unsigned long int *status_address;
497 unsigned long int exit_status;
500 static struct pipe_details *open_pipes = NULL;
501 static $DESCRIPTOR(nl_desc, "NL:");
502 static int waitpid_asleep = 0;
504 static unsigned long int
507 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
510 while (open_pipes != NULL) {
511 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
512 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
515 if (!open_pipes->done) /* We tried to be nice . . . */
516 _ckvmssts(sys$delprc(&open_pipes->pid,0));
517 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
518 else if (!(sts & 1)) retsts = sts;
523 static struct exit_control_block pipe_exitblock =
524 {(struct exit_control_block *) 0,
525 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
529 popen_completion_ast(struct pipe_details *thispipe)
531 thispipe->done = TRUE;
532 if (waitpid_asleep) {
539 safe_popen(char *cmd, char *mode)
541 static int handler_set_up = FALSE;
543 unsigned short int chan;
544 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
545 struct pipe_details *info;
546 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
547 DSC$K_CLASS_S, mbxname},
548 cmddsc = {0, DSC$K_DTYPE_T,
552 cmddsc.dsc$w_length=strlen(cmd);
553 cmddsc.dsc$a_pointer=cmd;
554 if (cmddsc.dsc$w_length > 255) {
555 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
559 New(7001,info,1,struct pipe_details);
562 create_mbx(&chan,&namdsc);
564 /* open a FILE* onto it */
565 info->fp = PerlIO_open(mbxname, mode);
567 /* give up other channel onto it */
568 _ckvmssts(sys$dassgn(chan));
578 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
579 0 /* name */, &info->pid, &info->completion,
580 0, popen_completion_ast,info,0,0,0));
583 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
584 0 /* name */, &info->pid, &info->completion,
585 0, popen_completion_ast,info,0,0,0));
588 if (!handler_set_up) {
589 _ckvmssts(sys$dclexh(&pipe_exitblock));
590 handler_set_up = TRUE;
592 info->next=open_pipes; /* prepend to list */
595 forkprocess = info->pid;
597 } /* end of safe_popen */
600 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
602 my_popen(char *cmd, char *mode)
605 TAINT_PROPER("popen");
606 return safe_popen(cmd,mode);
611 /*{{{ I32 my_pclose(FILE *fp)*/
612 I32 my_pclose(FILE *fp)
614 struct pipe_details *info, *last = NULL;
615 unsigned long int retsts;
617 for (info = open_pipes; info != NULL; last = info, info = info->next)
618 if (info->fp == fp) break;
620 if (info == NULL) { /* no such pipe open */
621 set_errno(ECHILD); /* quoth POSIX */
622 set_vaxc_errno(SS$_NONEXPR);
626 /* If we were writing to a subprocess, insure that someone reading from
627 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
628 * produce an EOF record in the mailbox. */
629 if (info->mode != 'r') {
630 char devnam[NAM$C_MAXRSS+1], *cp;
631 unsigned long int chan, iosb[2], retsts, retsts2;
632 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
634 if (fgetname(info->fp,devnam)) {
635 /* It oughta be a mailbox, so fgetname should give just the device
636 * name, but just in case . . . */
637 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
638 devdsc.dsc$w_length = strlen(devnam);
639 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
640 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
641 if (retsts & 1) retsts = iosb[0];
642 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
643 if (retsts & 1) retsts = retsts2;
646 else _ckvmssts(vaxc$errno); /* Should never happen */
648 PerlIO_close(info->fp);
650 if (info->done) retsts = info->completion;
651 else waitpid(info->pid,(int *) &retsts,0);
653 /* remove from list of open pipes */
654 if (last) last->next = info->next;
655 else open_pipes = info->next;
660 } /* end of my_pclose() */
662 /* sort-of waitpid; use only with popen() */
663 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
665 my_waitpid(Pid_t pid, int *statusp, int flags)
667 struct pipe_details *info;
669 for (info = open_pipes; info != NULL; info = info->next)
670 if (info->pid == pid) break;
672 if (info != NULL) { /* we know about this child */
673 while (!info->done) {
678 *statusp = info->completion;
681 else { /* we haven't heard of this child */
682 $DESCRIPTOR(intdsc,"0 00:00:01");
683 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
684 unsigned long int interval[2],sts;
687 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
688 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
689 if (ownerpid != mypid)
690 warn("pid %d not a child",pid);
693 _ckvmssts(sys$bintim(&intdsc,interval));
694 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
695 _ckvmssts(sys$schdwk(0,0,interval,0));
696 _ckvmssts(sys$hiber());
700 /* There's no easy way to find the termination status a child we're
701 * not aware of beforehand. If we're really interested in the future,
702 * we can go looking for a termination mailbox, or chase after the
703 * accounting record for the process.
709 } /* end of waitpid() */
714 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
716 my_gconvert(double val, int ndig, int trail, char *buf)
718 static char __gcvtbuf[DBL_DIG+1];
721 loc = buf ? buf : __gcvtbuf;
723 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
725 sprintf(loc,"%.*g",ndig,val);
731 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
732 return gcvt(val,ndig,loc);
735 loc[0] = '0'; loc[1] = '\0';
743 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
744 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
745 * to expand file specification. Allows for a single default file
746 * specification and a simple mask of options. If outbuf is non-NULL,
747 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
748 * the resultant file specification is placed. If outbuf is NULL, the
749 * resultant file specification is placed into a static buffer.
750 * The third argument, if non-NULL, is taken to be a default file
751 * specification string. The fourth argument is unused at present.
752 * rmesexpand() returns the address of the resultant string if
753 * successful, and NULL on error.
756 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
758 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
759 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
760 struct FAB myfab = cc$rms_fab;
761 struct NAM mynam = cc$rms_nam;
763 unsigned long int retsts, haslower = 0;
765 if (!filespec || !*filespec) {
766 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
770 if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
771 else outbuf = __rmsexpand_retbuf;
774 myfab.fab$l_fna = filespec;
775 myfab.fab$b_fns = strlen(filespec);
776 myfab.fab$l_nam = &mynam;
778 if (defspec && *defspec) {
779 myfab.fab$l_dna = defspec;
780 myfab.fab$b_dns = strlen(defspec);
783 mynam.nam$l_esa = esa;
784 mynam.nam$b_ess = sizeof esa;
785 mynam.nam$l_rsa = outbuf;
786 mynam.nam$b_rss = NAM$C_MAXRSS;
788 retsts = sys$parse(&myfab,0,0);
790 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
791 retsts == RMS$_DEV || retsts == RMS$_DEV) {
792 mynam.nam$b_nop |= NAM$M_SYNCHK;
793 retsts = sys$parse(&myfab,0,0);
794 if (retsts & 1) goto expanded;
796 if (out) Safefree(out);
797 set_vaxc_errno(retsts);
798 if (retsts == RMS$_PRV) set_errno(EACCES);
799 else if (retsts == RMS$_DEV) set_errno(ENODEV);
800 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
801 else set_errno(EVMSERR);
804 retsts = sys$search(&myfab,0,0);
805 if (!(retsts & 1) && retsts != RMS$_FNF) {
806 if (out) Safefree(out);
807 set_vaxc_errno(retsts);
808 if (retsts == RMS$_PRV) set_errno(EACCES);
809 else set_errno(EVMSERR);
813 /* If the input filespec contained any lowercase characters,
814 * downcase the result for compatibility with Unix-minded code. */
816 for (out = myfab.fab$l_fna; *out; out++)
817 if (islower(*out)) { haslower = 1; break; }
818 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
819 else { out = esa; speclen = mynam.nam$b_esl; }
820 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
821 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
822 speclen = mynam.nam$l_ver - out;
823 /* If we just had a directory spec on input, $PARSE "helpfully"
824 * adds an empty name and type for us */
825 if (mynam.nam$l_name == mynam.nam$l_type &&
826 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
827 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
828 speclen = mynam.nam$l_name - out;
830 if (haslower) __mystrtolower(out);
832 /* Have we been working with an expanded, but not resultant, spec? */
833 if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
837 /* External entry points */
838 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
839 { return do_rmsexpand(spec,buf,0,def,opt); }
840 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
841 { return do_rmsexpand(spec,buf,1,def,opt); }
845 ** The following routines are provided to make life easier when
846 ** converting among VMS-style and Unix-style directory specifications.
847 ** All will take input specifications in either VMS or Unix syntax. On
848 ** failure, all return NULL. If successful, the routines listed below
849 ** return a pointer to a buffer containing the appropriately
850 ** reformatted spec (and, therefore, subsequent calls to that routine
851 ** will clobber the result), while the routines of the same names with
852 ** a _ts suffix appended will return a pointer to a mallocd string
853 ** containing the appropriately reformatted spec.
854 ** In all cases, only explicit syntax is altered; no check is made that
855 ** the resulting string is valid or that the directory in question
858 ** fileify_dirspec() - convert a directory spec into the name of the
859 ** directory file (i.e. what you can stat() to see if it's a dir).
860 ** The style (VMS or Unix) of the result is the same as the style
861 ** of the parameter passed in.
862 ** pathify_dirspec() - convert a directory spec into a path (i.e.
863 ** what you prepend to a filename to indicate what directory it's in).
864 ** The style (VMS or Unix) of the result is the same as the style
865 ** of the parameter passed in.
866 ** tounixpath() - convert a directory spec into a Unix-style path.
867 ** tovmspath() - convert a directory spec into a VMS-style path.
868 ** tounixspec() - convert any file spec into a Unix-style file spec.
869 ** tovmsspec() - convert any file spec into a VMS-style spec.
871 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
872 ** Permission is given to distribute this code as part of the Perl
873 ** standard distribution under the terms of the GNU General Public
874 ** License or the Perl Artistic License. Copies of each may be
875 ** found in the Perl standard distribution.
878 static char *do_tounixspec(char *, char *, int);
880 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
881 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
883 static char __fileify_retbuf[NAM$C_MAXRSS+1];
884 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
885 char *retspec, *cp1, *cp2, *lastdir;
886 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
889 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
891 dirlen = strlen(dir);
892 if (dir[dirlen-1] == '/') --dirlen;
895 set_vaxc_errno(RMS$_DIR);
898 if (!strpbrk(dir+1,"/]>:")) {
899 strcpy(trndir,*dir == '/' ? dir + 1: dir);
900 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
902 dirlen = strlen(dir);
905 strncpy(trndir,dir,dirlen);
906 trndir[dirlen] = '\0';
909 /* If we were handed a rooted logical name or spec, treat it like a
910 * simple directory, so that
911 * $ Define myroot dev:[dir.]
912 * ... do_fileify_dirspec("myroot",buf,1) ...
913 * does something useful.
915 if (!strcmp(dir+dirlen-2,".]")) {
916 dir[--dirlen] = '\0';
920 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
921 /* If we've got an explicit filename, we can just shuffle the string. */
922 if (*(cp1+1)) hasfilename = 1;
923 /* Similarly, we can just back up a level if we've got multiple levels
924 of explicit directories in a VMS spec which ends with directories. */
926 for (cp2 = cp1; cp2 > dir; cp2--) {
928 *cp2 = *cp1; *cp1 = '\0';
932 if (*cp2 == '[' || *cp2 == '<') break;
937 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
939 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
940 return do_fileify_dirspec("[]",buf,ts);
941 else if (dir[1] == '.' &&
942 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
943 return do_fileify_dirspec("[-]",buf,ts);
945 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
946 dirlen -= 1; /* to last element */
947 lastdir = strrchr(dir,'/');
949 else if ((cp1 = strstr(dir,"/.")) != NULL) {
950 /* If we have "/." or "/..", VMSify it and let the VMS code
951 * below expand it, rather than repeating the code to handle
952 * relative components of a filespec here */
954 if (*(cp1+2) == '.') cp1++;
955 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
956 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
957 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
958 return do_tounixspec(trndir,buf,ts);
961 } while ((cp1 = strstr(cp1,"/.")) != NULL);
964 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
965 !(lastdir = cp1 = strrchr(dir,']')) &&
966 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
967 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
969 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
970 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
971 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
972 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
973 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
976 set_vaxc_errno(RMS$_DIR);
982 /* If we lead off with a device or rooted logical, add the MFD
983 if we're specifying a top-level directory. */
984 if (lastdir && *dir == '/') {
986 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
993 retlen = dirlen + (addmfd ? 13 : 6);
994 if (buf) retspec = buf;
995 else if (ts) New(7009,retspec,retlen+1,char);
996 else retspec = __fileify_retbuf;
998 dirlen = lastdir - dir;
999 memcpy(retspec,dir,dirlen);
1000 strcpy(&retspec[dirlen],"/000000");
1001 strcpy(&retspec[dirlen+7],lastdir);
1004 memcpy(retspec,dir,dirlen);
1005 retspec[dirlen] = '\0';
1007 /* We've picked up everything up to the directory file name.
1008 Now just add the type and version, and we're set. */
1009 strcat(retspec,".dir;1");
1012 else { /* VMS-style directory spec */
1013 char esa[NAM$C_MAXRSS+1], term, *cp;
1014 unsigned long int sts, cmplen, haslower = 0;
1015 struct FAB dirfab = cc$rms_fab;
1016 struct NAM savnam, dirnam = cc$rms_nam;
1018 dirfab.fab$b_fns = strlen(dir);
1019 dirfab.fab$l_fna = dir;
1020 dirfab.fab$l_nam = &dirnam;
1021 dirfab.fab$l_dna = ".DIR;1";
1022 dirfab.fab$b_dns = 6;
1023 dirnam.nam$b_ess = NAM$C_MAXRSS;
1024 dirnam.nam$l_esa = esa;
1026 for (cp = dir; *cp; cp++)
1027 if (islower(*cp)) { haslower = 1; break; }
1028 if (!((sts = sys$parse(&dirfab))&1)) {
1029 if (dirfab.fab$l_sts == RMS$_DIR) {
1030 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1031 sts = sys$parse(&dirfab) & 1;
1035 set_vaxc_errno(dirfab.fab$l_sts);
1041 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1042 /* Yes; fake the fnb bits so we'll check type below */
1043 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1046 if (dirfab.fab$l_sts != RMS$_FNF) {
1048 set_vaxc_errno(dirfab.fab$l_sts);
1051 dirnam = savnam; /* No; just work with potential name */
1054 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1055 cp1 = strchr(esa,']');
1056 if (!cp1) cp1 = strchr(esa,'>');
1057 if (cp1) { /* Should always be true */
1058 dirnam.nam$b_esl -= cp1 - esa - 1;
1059 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1062 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1063 /* Yep; check version while we're at it, if it's there. */
1064 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1065 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1066 /* Something other than .DIR[;1]. Bzzt. */
1068 set_vaxc_errno(RMS$_DIR);
1072 esa[dirnam.nam$b_esl] = '\0';
1073 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1074 /* They provided at least the name; we added the type, if necessary, */
1075 if (buf) retspec = buf; /* in sys$parse() */
1076 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1077 else retspec = __fileify_retbuf;
1078 strcpy(retspec,esa);
1081 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1082 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1084 dirnam.nam$b_esl -= 9;
1086 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1087 if (cp1 == NULL) return NULL; /* should never happen */
1090 retlen = strlen(esa);
1091 if ((cp1 = strrchr(esa,'.')) != NULL) {
1092 /* There's more than one directory in the path. Just roll back. */
1094 if (buf) retspec = buf;
1095 else if (ts) New(7011,retspec,retlen+7,char);
1096 else retspec = __fileify_retbuf;
1097 strcpy(retspec,esa);
1100 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1101 /* Go back and expand rooted logical name */
1102 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1103 if (!(sys$parse(&dirfab) & 1)) {
1105 set_vaxc_errno(dirfab.fab$l_sts);
1108 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1109 if (buf) retspec = buf;
1110 else if (ts) New(7012,retspec,retlen+16,char);
1111 else retspec = __fileify_retbuf;
1112 cp1 = strstr(esa,"][");
1114 memcpy(retspec,esa,dirlen);
1115 if (!strncmp(cp1+2,"000000]",7)) {
1116 retspec[dirlen-1] = '\0';
1117 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1118 if (*cp1 == '.') *cp1 = ']';
1120 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1121 memcpy(cp1+1,"000000]",7);
1125 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1126 retspec[retlen] = '\0';
1127 /* Convert last '.' to ']' */
1128 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1129 if (*cp1 == '.') *cp1 = ']';
1131 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1132 memcpy(cp1+1,"000000]",7);
1136 else { /* This is a top-level dir. Add the MFD to the path. */
1137 if (buf) retspec = buf;
1138 else if (ts) New(7012,retspec,retlen+16,char);
1139 else retspec = __fileify_retbuf;
1142 while (*cp1 != ':') *(cp2++) = *(cp1++);
1143 strcpy(cp2,":[000000]");
1148 /* We've set up the string up through the filename. Add the
1149 type and version, and we're done. */
1150 strcat(retspec,".DIR;1");
1152 /* $PARSE may have upcased filespec, so convert output to lower
1153 * case if input contained any lowercase characters. */
1154 if (haslower) __mystrtolower(retspec);
1157 } /* end of do_fileify_dirspec() */
1159 /* External entry points */
1160 char *fileify_dirspec(char *dir, char *buf)
1161 { return do_fileify_dirspec(dir,buf,0); }
1162 char *fileify_dirspec_ts(char *dir, char *buf)
1163 { return do_fileify_dirspec(dir,buf,1); }
1165 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1166 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1168 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1169 unsigned long int retlen;
1170 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1172 if (!dir || !*dir) {
1173 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1176 if (*dir) strcpy(trndir,dir);
1177 else getcwd(trndir,sizeof trndir - 1);
1179 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1180 STRLEN trnlen = strlen(trndir);
1182 /* Trap simple rooted lnms, and return lnm:[000000] */
1183 if (!strcmp(trndir+trnlen-2,".]")) {
1184 if (buf) retpath = buf;
1185 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1186 else retpath = __pathify_retbuf;
1187 strcpy(retpath,dir);
1188 strcat(retpath,":[000000]");
1194 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1195 if (*dir == '.' && (*(dir+1) == '\0' ||
1196 (*(dir+1) == '.' && *(dir+2) == '\0')))
1197 retlen = 2 + (*(dir+1) != '\0');
1199 if ( !(cp1 = strrchr(dir,'/')) &&
1200 !(cp1 = strrchr(dir,']')) &&
1201 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1202 if ((cp2 = strchr(cp1,'.')) != NULL &&
1203 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1204 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1205 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1206 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1208 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1209 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1210 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1211 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1212 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1213 (ver || *cp3)))))) {
1215 set_vaxc_errno(RMS$_DIR);
1218 retlen = cp2 - dir + 1;
1220 else { /* No file type present. Treat the filename as a directory. */
1221 retlen = strlen(dir) + 1;
1224 if (buf) retpath = buf;
1225 else if (ts) New(7013,retpath,retlen+1,char);
1226 else retpath = __pathify_retbuf;
1227 strncpy(retpath,dir,retlen-1);
1228 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1229 retpath[retlen-1] = '/'; /* with '/', add it. */
1230 retpath[retlen] = '\0';
1232 else retpath[retlen-1] = '\0';
1234 else { /* VMS-style directory spec */
1235 char esa[NAM$C_MAXRSS+1], *cp;
1236 unsigned long int sts, cmplen, haslower;
1237 struct FAB dirfab = cc$rms_fab;
1238 struct NAM savnam, dirnam = cc$rms_nam;
1240 /* If we've got an explicit filename, we can just shuffle the string. */
1241 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1242 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1243 if ((cp2 = strchr(cp1,'.')) != NULL) {
1245 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1246 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1247 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1248 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1249 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1250 (ver || *cp3)))))) {
1252 set_vaxc_errno(RMS$_DIR);
1256 else { /* No file type, so just draw name into directory part */
1257 for (cp2 = cp1; *cp2; cp2++) ;
1260 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1262 /* We've now got a VMS 'path'; fall through */
1264 dirfab.fab$b_fns = strlen(dir);
1265 dirfab.fab$l_fna = dir;
1266 if (dir[dirfab.fab$b_fns-1] == ']' ||
1267 dir[dirfab.fab$b_fns-1] == '>' ||
1268 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1269 if (buf) retpath = buf;
1270 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1271 else retpath = __pathify_retbuf;
1272 strcpy(retpath,dir);
1275 dirfab.fab$l_dna = ".DIR;1";
1276 dirfab.fab$b_dns = 6;
1277 dirfab.fab$l_nam = &dirnam;
1278 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1279 dirnam.nam$l_esa = esa;
1281 for (cp = dir; *cp; cp++)
1282 if (islower(*cp)) { haslower = 1; break; }
1284 if (!(sts = (sys$parse(&dirfab)&1))) {
1285 if (dirfab.fab$l_sts == RMS$_DIR) {
1286 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1287 sts = sys$parse(&dirfab) & 1;
1291 set_vaxc_errno(dirfab.fab$l_sts);
1297 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1298 if (dirfab.fab$l_sts != RMS$_FNF) {
1300 set_vaxc_errno(dirfab.fab$l_sts);
1303 dirnam = savnam; /* No; just work with potential name */
1306 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1307 /* Yep; check version while we're at it, if it's there. */
1308 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1309 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1310 /* Something other than .DIR[;1]. Bzzt. */
1312 set_vaxc_errno(RMS$_DIR);
1316 /* OK, the type was fine. Now pull any file name into the
1318 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1320 cp1 = strrchr(esa,'>');
1321 *dirnam.nam$l_type = '>';
1324 *(dirnam.nam$l_type + 1) = '\0';
1325 retlen = dirnam.nam$l_type - esa + 2;
1326 if (buf) retpath = buf;
1327 else if (ts) New(7014,retpath,retlen,char);
1328 else retpath = __pathify_retbuf;
1329 strcpy(retpath,esa);
1330 /* $PARSE may have upcased filespec, so convert output to lower
1331 * case if input contained any lowercase characters. */
1332 if (haslower) __mystrtolower(retpath);
1336 } /* end of do_pathify_dirspec() */
1338 /* External entry points */
1339 char *pathify_dirspec(char *dir, char *buf)
1340 { return do_pathify_dirspec(dir,buf,0); }
1341 char *pathify_dirspec_ts(char *dir, char *buf)
1342 { return do_pathify_dirspec(dir,buf,1); }
1344 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1345 static char *do_tounixspec(char *spec, char *buf, int ts)
1347 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1348 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1349 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1351 if (spec == NULL) return NULL;
1352 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1353 if (buf) rslt = buf;
1355 retlen = strlen(spec);
1356 cp1 = strchr(spec,'[');
1357 if (!cp1) cp1 = strchr(spec,'<');
1359 for (cp1++; *cp1; cp1++) {
1360 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1361 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1362 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1365 New(7015,rslt,retlen+2+2*expand,char);
1367 else rslt = __tounixspec_retbuf;
1368 if (strchr(spec,'/') != NULL) {
1375 dirend = strrchr(spec,']');
1376 if (dirend == NULL) dirend = strrchr(spec,'>');
1377 if (dirend == NULL) dirend = strchr(spec,':');
1378 if (dirend == NULL) {
1382 if (*cp2 != '[' && *cp2 != '<') {
1385 else { /* the VMS spec begins with directories */
1387 if (*cp2 == ']' || *cp2 == '>') {
1388 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1391 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1392 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1393 if (ts) Safefree(rslt);
1398 while (*cp3 != ':' && *cp3) cp3++;
1400 if (strchr(cp3,']') != NULL) break;
1401 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1403 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1404 retlen = devlen + dirlen;
1405 Renew(rslt,retlen+1+2*expand,char);
1411 *(cp1++) = *(cp3++);
1412 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1416 else if ( *cp2 == '.') {
1417 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1418 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1424 for (; cp2 <= dirend; cp2++) {
1427 if (*(cp2+1) == '[') cp2++;
1429 else if (*cp2 == ']' || *cp2 == '>') {
1430 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1432 else if (*cp2 == '.') {
1434 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1435 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1436 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1437 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1438 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1440 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1441 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1445 else if (*cp2 == '-') {
1446 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1447 while (*cp2 == '-') {
1449 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1451 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1452 if (ts) Safefree(rslt); /* filespecs like */
1453 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1457 else *(cp1++) = *cp2;
1459 else *(cp1++) = *cp2;
1461 while (*cp2) *(cp1++) = *(cp2++);
1466 } /* end of do_tounixspec() */
1468 /* External entry points */
1469 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1470 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1472 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1473 static char *do_tovmsspec(char *path, char *buf, int ts) {
1474 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1475 char *rslt, *dirend;
1476 register char *cp1, *cp2;
1477 unsigned long int infront = 0, hasdir = 1;
1479 if (path == NULL) return NULL;
1480 if (buf) rslt = buf;
1481 else if (ts) New(7016,rslt,strlen(path)+9,char);
1482 else rslt = __tovmsspec_retbuf;
1483 if (strpbrk(path,"]:>") ||
1484 (dirend = strrchr(path,'/')) == NULL) {
1485 if (path[0] == '.') {
1486 if (path[1] == '\0') strcpy(rslt,"[]");
1487 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1488 else strcpy(rslt,path); /* probably garbage */
1490 else strcpy(rslt,path);
1493 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1494 if (!*(dirend+2)) dirend +=2;
1495 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1496 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1501 char trndev[NAM$C_MAXRSS+1];
1505 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1506 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1508 islnm = my_trnlnm(rslt,trndev,0);
1509 trnend = islnm ? strlen(trndev) - 1 : 0;
1510 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1511 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1512 /* If the first element of the path is a logical name, determine
1513 * whether it has to be translated so we can add more directories. */
1514 if (!islnm || rooted) {
1517 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1521 if (cp2 != dirend) {
1522 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1523 strcpy(rslt,trndev);
1524 cp1 = rslt + trnend;
1537 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1538 cp2 += 2; /* skip over "./" - it's redundant */
1539 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1541 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1542 *(cp1++) = '-'; /* "../" --> "-" */
1545 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1546 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1547 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1548 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1551 if (cp2 > dirend) cp2 = dirend;
1553 else *(cp1++) = '.';
1555 for (; cp2 < dirend; cp2++) {
1557 if (*(cp2-1) == '/') continue;
1558 if (*(cp1-1) != '.') *(cp1++) = '.';
1561 else if (!infront && *cp2 == '.') {
1562 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1563 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1564 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1565 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1566 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1567 else { /* back up over previous directory name */
1569 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1570 if (*(cp1-1) == '[') {
1571 memcpy(cp1,"000000.",7);
1576 if (cp2 == dirend) break;
1578 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1579 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1580 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1581 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1583 *(cp1++) = '.'; /* Simulate trailing '/' */
1584 cp2 += 2; /* for loop will incr this to == dirend */
1586 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1588 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1591 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1592 if (*cp2 == '.') *(cp1++) = '_';
1593 else *(cp1++) = *cp2;
1597 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1598 if (hasdir) *(cp1++) = ']';
1599 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1600 while (*cp2) *(cp1++) = *(cp2++);
1605 } /* end of do_tovmsspec() */
1607 /* External entry points */
1608 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1609 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1611 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1612 static char *do_tovmspath(char *path, char *buf, int ts) {
1613 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1615 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1617 if (path == NULL) return NULL;
1618 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1619 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1620 if (buf) return buf;
1622 vmslen = strlen(vmsified);
1623 New(7017,cp,vmslen+1,char);
1624 memcpy(cp,vmsified,vmslen);
1629 strcpy(__tovmspath_retbuf,vmsified);
1630 return __tovmspath_retbuf;
1633 } /* end of do_tovmspath() */
1635 /* External entry points */
1636 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1637 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1640 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1641 static char *do_tounixpath(char *path, char *buf, int ts) {
1642 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1644 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1646 if (path == NULL) return NULL;
1647 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1648 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1649 if (buf) return buf;
1651 unixlen = strlen(unixified);
1652 New(7017,cp,unixlen+1,char);
1653 memcpy(cp,unixified,unixlen);
1658 strcpy(__tounixpath_retbuf,unixified);
1659 return __tounixpath_retbuf;
1662 } /* end of do_tounixpath() */
1664 /* External entry points */
1665 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1666 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1669 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1671 *****************************************************************************
1673 * Copyright (C) 1989-1994 by *
1674 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1676 * Permission is hereby granted for the reproduction of this software, *
1677 * on condition that this copyright notice is included in the reproduction, *
1678 * and that such reproduction is not for purposes of profit or material *
1681 * 27-Aug-1994 Modified for inclusion in perl5 *
1682 * by Charles Bailey bailey@genetics.upenn.edu *
1683 *****************************************************************************
1687 * getredirection() is intended to aid in porting C programs
1688 * to VMS (Vax-11 C). The native VMS environment does not support
1689 * '>' and '<' I/O redirection, or command line wild card expansion,
1690 * or a command line pipe mechanism using the '|' AND background
1691 * command execution '&'. All of these capabilities are provided to any
1692 * C program which calls this procedure as the first thing in the
1694 * The piping mechanism will probably work with almost any 'filter' type
1695 * of program. With suitable modification, it may useful for other
1696 * portability problems as well.
1698 * Author: Mark Pizzolato mark@infocomm.com
1702 struct list_item *next;
1706 static void add_item(struct list_item **head,
1707 struct list_item **tail,
1711 static void expand_wild_cards(char *item,
1712 struct list_item **head,
1713 struct list_item **tail,
1716 static int background_process(int argc, char **argv);
1718 static void pipe_and_fork(char **cmargv);
1720 /*{{{ void getredirection(int *ac, char ***av)*/
1722 getredirection(int *ac, char ***av)
1724 * Process vms redirection arg's. Exit if any error is seen.
1725 * If getredirection() processes an argument, it is erased
1726 * from the vector. getredirection() returns a new argc and argv value.
1727 * In the event that a background command is requested (by a trailing "&"),
1728 * this routine creates a background subprocess, and simply exits the program.
1730 * Warning: do not try to simplify the code for vms. The code
1731 * presupposes that getredirection() is called before any data is
1732 * read from stdin or written to stdout.
1734 * Normal usage is as follows:
1740 * getredirection(&argc, &argv);
1744 int argc = *ac; /* Argument Count */
1745 char **argv = *av; /* Argument Vector */
1746 char *ap; /* Argument pointer */
1747 int j; /* argv[] index */
1748 int item_count = 0; /* Count of Items in List */
1749 struct list_item *list_head = 0; /* First Item in List */
1750 struct list_item *list_tail; /* Last Item in List */
1751 char *in = NULL; /* Input File Name */
1752 char *out = NULL; /* Output File Name */
1753 char *outmode = "w"; /* Mode to Open Output File */
1754 char *err = NULL; /* Error File Name */
1755 char *errmode = "w"; /* Mode to Open Error File */
1756 int cmargc = 0; /* Piped Command Arg Count */
1757 char **cmargv = NULL;/* Piped Command Arg Vector */
1760 * First handle the case where the last thing on the line ends with
1761 * a '&'. This indicates the desire for the command to be run in a
1762 * subprocess, so we satisfy that desire.
1765 if (0 == strcmp("&", ap))
1766 exit(background_process(--argc, argv));
1767 if (*ap && '&' == ap[strlen(ap)-1])
1769 ap[strlen(ap)-1] = '\0';
1770 exit(background_process(argc, argv));
1773 * Now we handle the general redirection cases that involve '>', '>>',
1774 * '<', and pipes '|'.
1776 for (j = 0; j < argc; ++j)
1778 if (0 == strcmp("<", argv[j]))
1782 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1783 exit(LIB$_WRONUMARG);
1788 if ('<' == *(ap = argv[j]))
1793 if (0 == strcmp(">", ap))
1797 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1798 exit(LIB$_WRONUMARG);
1817 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1818 exit(LIB$_WRONUMARG);
1822 if (('2' == *ap) && ('>' == ap[1]))
1839 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1840 exit(LIB$_WRONUMARG);
1844 if (0 == strcmp("|", argv[j]))
1848 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1849 exit(LIB$_WRONUMARG);
1851 cmargc = argc-(j+1);
1852 cmargv = &argv[j+1];
1856 if ('|' == *(ap = argv[j]))
1864 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1867 * Allocate and fill in the new argument vector, Some Unix's terminate
1868 * the list with an extra null pointer.
1870 New(7002, argv, item_count+1, char *);
1872 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1873 argv[j] = list_head->value;
1879 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1880 exit(LIB$_INVARGORD);
1882 pipe_and_fork(cmargv);
1885 /* Check for input from a pipe (mailbox) */
1887 if (in == NULL && 1 == isapipe(0))
1889 char mbxname[L_tmpnam];
1891 long int dvi_item = DVI$_DEVBUFSIZ;
1892 $DESCRIPTOR(mbxnam, "");
1893 $DESCRIPTOR(mbxdevnam, "");
1895 /* Input from a pipe, reopen it in binary mode to disable */
1896 /* carriage control processing. */
1898 PerlIO_getname(stdin, mbxname);
1899 mbxnam.dsc$a_pointer = mbxname;
1900 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1901 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1902 mbxdevnam.dsc$a_pointer = mbxname;
1903 mbxdevnam.dsc$w_length = sizeof(mbxname);
1904 dvi_item = DVI$_DEVNAM;
1905 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1906 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1909 freopen(mbxname, "rb", stdin);
1912 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1916 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1918 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1921 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1923 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
1928 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1930 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
1934 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1939 #ifdef ARGPROC_DEBUG
1940 PerlIO_printf(Perl_debug_log, "Arglist:\n");
1941 for (j = 0; j < *ac; ++j)
1942 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1944 /* Clear errors we may have hit expanding wildcards, so they don't
1945 show up in Perl's $! later */
1946 set_errno(0); set_vaxc_errno(1);
1947 } /* end of getredirection() */
1950 static void add_item(struct list_item **head,
1951 struct list_item **tail,
1957 New(7003,*head,1,struct list_item);
1961 New(7004,(*tail)->next,1,struct list_item);
1962 *tail = (*tail)->next;
1964 (*tail)->value = value;
1968 static void expand_wild_cards(char *item,
1969 struct list_item **head,
1970 struct list_item **tail,
1974 unsigned long int context = 0;
1980 char vmsspec[NAM$C_MAXRSS+1];
1981 $DESCRIPTOR(filespec, "");
1982 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1983 $DESCRIPTOR(resultspec, "");
1984 unsigned long int zero = 0, sts;
1986 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
1988 add_item(head, tail, item, count);
1991 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1992 resultspec.dsc$b_class = DSC$K_CLASS_D;
1993 resultspec.dsc$a_pointer = NULL;
1994 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1995 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1996 if (!isunix || !filespec.dsc$a_pointer)
1997 filespec.dsc$a_pointer = item;
1998 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2000 * Only return version specs, if the caller specified a version
2002 had_version = strchr(item, ';');
2004 * Only return device and directory specs, if the caller specifed either.
2006 had_device = strchr(item, ':');
2007 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2009 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2010 &defaultspec, 0, 0, &zero))))
2015 New(7005,string,resultspec.dsc$w_length+1,char);
2016 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2017 string[resultspec.dsc$w_length] = '\0';
2018 if (NULL == had_version)
2019 *((char *)strrchr(string, ';')) = '\0';
2020 if ((!had_directory) && (had_device == NULL))
2022 if (NULL == (devdir = strrchr(string, ']')))
2023 devdir = strrchr(string, '>');
2024 strcpy(string, devdir + 1);
2027 * Be consistent with what the C RTL has already done to the rest of
2028 * the argv items and lowercase all of these names.
2030 for (c = string; *c; ++c)
2033 if (isunix) trim_unixpath(string,item,1);
2034 add_item(head, tail, string, count);
2037 if (sts != RMS$_NMF)
2039 set_vaxc_errno(sts);
2045 set_errno(ENOENT); break;
2047 set_errno(ENODEV); break;
2050 set_errno(EINVAL); break;
2052 set_errno(EACCES); break;
2054 _ckvmssts_noperl(sts);
2058 add_item(head, tail, item, count);
2059 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2060 _ckvmssts_noperl(lib$find_file_end(&context));
2063 static int child_st[2];/* Event Flag set when child process completes */
2065 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2067 static unsigned long int exit_handler(int *status)
2071 if (0 == child_st[0])
2073 #ifdef ARGPROC_DEBUG
2074 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2076 fflush(stdout); /* Have to flush pipe for binary data to */
2077 /* terminate properly -- <tp@mccall.com> */
2078 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2079 sys$dassgn(child_chan);
2081 sys$synch(0, child_st);
2086 static void sig_child(int chan)
2088 #ifdef ARGPROC_DEBUG
2089 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2091 if (child_st[0] == 0)
2095 static struct exit_control_block exit_block =
2100 &exit_block.exit_status,
2104 static void pipe_and_fork(char **cmargv)
2107 $DESCRIPTOR(cmddsc, "");
2108 static char mbxname[64];
2109 $DESCRIPTOR(mbxdsc, mbxname);
2111 unsigned long int zero = 0, one = 1;
2113 strcpy(subcmd, cmargv[0]);
2114 for (j = 1; NULL != cmargv[j]; ++j)
2116 strcat(subcmd, " \"");
2117 strcat(subcmd, cmargv[j]);
2118 strcat(subcmd, "\"");
2120 cmddsc.dsc$a_pointer = subcmd;
2121 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2123 create_mbx(&child_chan,&mbxdsc);
2124 #ifdef ARGPROC_DEBUG
2125 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2126 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2128 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2129 0, &pid, child_st, &zero, sig_child,
2131 #ifdef ARGPROC_DEBUG
2132 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2134 sys$dclexh(&exit_block);
2135 if (NULL == freopen(mbxname, "wb", stdout))
2137 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2141 static int background_process(int argc, char **argv)
2143 char command[2048] = "$";
2144 $DESCRIPTOR(value, "");
2145 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2146 static $DESCRIPTOR(null, "NLA0:");
2147 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2149 $DESCRIPTOR(pidstr, "");
2151 unsigned long int flags = 17, one = 1, retsts;
2153 strcat(command, argv[0]);
2156 strcat(command, " \"");
2157 strcat(command, *(++argv));
2158 strcat(command, "\"");
2160 value.dsc$a_pointer = command;
2161 value.dsc$w_length = strlen(value.dsc$a_pointer);
2162 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2163 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2164 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2165 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2168 _ckvmssts_noperl(retsts);
2170 #ifdef ARGPROC_DEBUG
2171 PerlIO_printf(Perl_debug_log, "%s\n", command);
2173 sprintf(pidstring, "%08X", pid);
2174 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2175 pidstr.dsc$a_pointer = pidstring;
2176 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2177 lib$set_symbol(&pidsymbol, &pidstr);
2181 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2184 * Trim Unix-style prefix off filespec, so it looks like what a shell
2185 * glob expansion would return (i.e. from specified prefix on, not
2186 * full path). Note that returned filespec is Unix-style, regardless
2187 * of whether input filespec was VMS-style or Unix-style.
2189 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2190 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2191 * vector of options; at present, only bit 0 is used, and if set tells
2192 * trim unixpath to try the current default directory as a prefix when
2193 * presented with a possibly ambiguous ... wildcard.
2195 * Returns !=0 on success, with trimmed filespec replacing contents of
2196 * fspec, and 0 on failure, with contents of fpsec unchanged.
2198 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2200 trim_unixpath(char *fspec, char *wildspec, int opts)
2202 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2203 *template, *base, *end, *cp1, *cp2;
2204 register int tmplen, reslen = 0, dirs = 0;
2206 if (!wildspec || !fspec) return 0;
2207 if (strpbrk(wildspec,"]>:") != NULL) {
2208 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2209 else template = unixwild;
2211 else template = wildspec;
2212 if (strpbrk(fspec,"]>:") != NULL) {
2213 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2214 else base = unixified;
2215 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2216 * check to see that final result fits into (isn't longer than) fspec */
2217 reslen = strlen(fspec);
2221 /* No prefix or absolute path on wildcard, so nothing to remove */
2222 if (!*template || *template == '/') {
2223 if (base == fspec) return 1;
2224 tmplen = strlen(unixified);
2225 if (tmplen > reslen) return 0; /* not enough space */
2226 /* Copy unixified resultant, including trailing NUL */
2227 memmove(fspec,unixified,tmplen+1);
2231 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2232 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2233 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2234 for (cp1 = end ;cp1 >= base; cp1--)
2235 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2237 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2241 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2242 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2243 int ells = 1, totells, segdirs, match;
2244 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2245 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2247 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2249 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2250 if (ellipsis == template && opts & 1) {
2251 /* Template begins with an ellipsis. Since we can't tell how many
2252 * directory names at the front of the resultant to keep for an
2253 * arbitrary starting point, we arbitrarily choose the current
2254 * default directory as a starting point. If it's there as a prefix,
2255 * clip it off. If not, fall through and act as if the leading
2256 * ellipsis weren't there (i.e. return shortest possible path that
2257 * could match template).
2259 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2260 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2261 if (_tolower(*cp1) != _tolower(*cp2)) break;
2262 segdirs = dirs - totells; /* Min # of dirs we must have left */
2263 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2264 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2265 memcpy(fspec,cp2+1,end - cp2);
2269 /* First off, back up over constant elements at end of path */
2271 for (front = end ; front >= base; front--)
2272 if (*front == '/' && !dirs--) { front++; break; }
2274 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2275 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2276 if (cp1 != '\0') return 0; /* Path too long. */
2278 *cp2 = '\0'; /* Pick up with memcpy later */
2279 lcfront = lcres + (front - base);
2280 /* Now skip over each ellipsis and try to match the path in front of it. */
2282 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2283 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2284 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2285 if (cp1 < template) break; /* template started with an ellipsis */
2286 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2287 ellipsis = cp1; continue;
2289 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2291 for (segdirs = 0, cp2 = tpl;
2292 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2294 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2295 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2296 if (*cp2 == '/') segdirs++;
2298 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2299 /* Back up at least as many dirs as in template before matching */
2300 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2301 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2302 for (match = 0; cp1 > lcres;) {
2303 resdsc.dsc$a_pointer = cp1;
2304 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2306 if (match == 1) lcfront = cp1;
2308 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2310 if (!match) return 0; /* Can't find prefix ??? */
2311 if (match > 1 && opts & 1) {
2312 /* This ... wildcard could cover more than one set of dirs (i.e.
2313 * a set of similar dir names is repeated). If the template
2314 * contains more than 1 ..., upstream elements could resolve the
2315 * ambiguity, but it's not worth a full backtracking setup here.
2316 * As a quick heuristic, clip off the current default directory
2317 * if it's present to find the trimmed spec, else use the
2318 * shortest string that this ... could cover.
2320 char def[NAM$C_MAXRSS+1], *st;
2322 if (getcwd(def, sizeof def,0) == NULL) return 0;
2323 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2324 if (_tolower(*cp1) != _tolower(*cp2)) break;
2325 segdirs = dirs - totells; /* Min # of dirs we must have left */
2326 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2327 if (*cp1 == '\0' && *cp2 == '/') {
2328 memcpy(fspec,cp2+1,end - cp2);
2331 /* Nope -- stick with lcfront from above and keep going. */
2334 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2339 } /* end of trim_unixpath() */
2344 * VMS readdir() routines.
2345 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2347 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2348 * Minor modifications to original routines.
2351 /* Number of elements in vms_versions array */
2352 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2355 * Open a directory, return a handle for later use.
2357 /*{{{ DIR *opendir(char*name) */
2362 char dir[NAM$C_MAXRSS+1];
2364 /* Get memory for the handle, and the pattern. */
2366 if (do_tovmspath(name,dir,0) == NULL) {
2367 Safefree((char *)dd);
2370 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2372 /* Fill in the fields; mainly playing with the descriptor. */
2373 (void)sprintf(dd->pattern, "%s*.*",dir);
2376 dd->vms_wantversions = 0;
2377 dd->pat.dsc$a_pointer = dd->pattern;
2378 dd->pat.dsc$w_length = strlen(dd->pattern);
2379 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2380 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2383 } /* end of opendir() */
2387 * Set the flag to indicate we want versions or not.
2389 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2391 vmsreaddirversions(DIR *dd, int flag)
2393 dd->vms_wantversions = flag;
2398 * Free up an opened directory.
2400 /*{{{ void closedir(DIR *dd)*/
2404 (void)lib$find_file_end(&dd->context);
2405 Safefree(dd->pattern);
2406 Safefree((char *)dd);
2411 * Collect all the version numbers for the current file.
2417 struct dsc$descriptor_s pat;
2418 struct dsc$descriptor_s res;
2420 char *p, *text, buff[sizeof dd->entry.d_name];
2422 unsigned long context, tmpsts;
2424 /* Convenient shorthand. */
2427 /* Add the version wildcard, ignoring the "*.*" put on before */
2428 i = strlen(dd->pattern);
2429 New(7008,text,i + e->d_namlen + 3,char);
2430 (void)strcpy(text, dd->pattern);
2431 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2433 /* Set up the pattern descriptor. */
2434 pat.dsc$a_pointer = text;
2435 pat.dsc$w_length = i + e->d_namlen - 1;
2436 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2437 pat.dsc$b_class = DSC$K_CLASS_S;
2439 /* Set up result descriptor. */
2440 res.dsc$a_pointer = buff;
2441 res.dsc$w_length = sizeof buff - 2;
2442 res.dsc$b_dtype = DSC$K_DTYPE_T;
2443 res.dsc$b_class = DSC$K_CLASS_S;
2445 /* Read files, collecting versions. */
2446 for (context = 0, e->vms_verscount = 0;
2447 e->vms_verscount < VERSIZE(e);
2448 e->vms_verscount++) {
2449 tmpsts = lib$find_file(&pat, &res, &context);
2450 if (tmpsts == RMS$_NMF || context == 0) break;
2452 buff[sizeof buff - 1] = '\0';
2453 if ((p = strchr(buff, ';')))
2454 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2456 e->vms_versions[e->vms_verscount] = -1;
2459 _ckvmssts(lib$find_file_end(&context));
2462 } /* end of collectversions() */
2465 * Read the next entry from the directory.
2467 /*{{{ struct dirent *readdir(DIR *dd)*/
2471 struct dsc$descriptor_s res;
2472 char *p, buff[sizeof dd->entry.d_name];
2473 unsigned long int tmpsts;
2475 /* Set up result descriptor, and get next file. */
2476 res.dsc$a_pointer = buff;
2477 res.dsc$w_length = sizeof buff - 2;
2478 res.dsc$b_dtype = DSC$K_DTYPE_T;
2479 res.dsc$b_class = DSC$K_CLASS_S;
2480 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2481 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2482 if (!(tmpsts & 1)) {
2483 set_vaxc_errno(tmpsts);
2486 set_errno(EACCES); break;
2488 set_errno(ENODEV); break;
2491 set_errno(ENOENT); break;
2498 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2499 buff[sizeof buff - 1] = '\0';
2500 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2503 /* Skip any directory component and just copy the name. */
2504 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2505 else (void)strcpy(dd->entry.d_name, buff);
2507 /* Clobber the version. */
2508 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2510 dd->entry.d_namlen = strlen(dd->entry.d_name);
2511 dd->entry.vms_verscount = 0;
2512 if (dd->vms_wantversions) collectversions(dd);
2515 } /* end of readdir() */
2519 * Return something that can be used in a seekdir later.
2521 /*{{{ long telldir(DIR *dd)*/
2530 * Return to a spot where we used to be. Brute force.
2532 /*{{{ void seekdir(DIR *dd,long count)*/
2534 seekdir(DIR *dd, long count)
2536 int vms_wantversions;
2538 /* If we haven't done anything yet... */
2542 /* Remember some state, and clear it. */
2543 vms_wantversions = dd->vms_wantversions;
2544 dd->vms_wantversions = 0;
2545 _ckvmssts(lib$find_file_end(&dd->context));
2548 /* The increment is in readdir(). */
2549 for (dd->count = 0; dd->count < count; )
2552 dd->vms_wantversions = vms_wantversions;
2554 } /* end of seekdir() */
2557 /* VMS subprocess management
2559 * my_vfork() - just a vfork(), after setting a flag to record that
2560 * the current script is trying a Unix-style fork/exec.
2562 * vms_do_aexec() and vms_do_exec() are called in response to the
2563 * perl 'exec' function. If this follows a vfork call, then they
2564 * call out the the regular perl routines in doio.c which do an
2565 * execvp (for those who really want to try this under VMS).
2566 * Otherwise, they do exactly what the perl docs say exec should
2567 * do - terminate the current script and invoke a new command
2568 * (See below for notes on command syntax.)
2570 * do_aspawn() and do_spawn() implement the VMS side of the perl
2571 * 'system' function.
2573 * Note on command arguments to perl 'exec' and 'system': When handled
2574 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2575 * are concatenated to form a DCL command string. If the first arg
2576 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2577 * the the command string is hrnded off to DCL directly. Otherwise,
2578 * the first token of the command is taken as the filespec of an image
2579 * to run. The filespec is expanded using a default type of '.EXE' and
2580 * the process defaults for device, directory, etc., and the resultant
2581 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2582 * the command string as parameters. This is perhaps a bit compicated,
2583 * but I hope it will form a happy medium between what VMS folks expect
2584 * from lib$spawn and what Unix folks expect from exec.
2587 static int vfork_called;
2589 /*{{{int my_vfork()*/
2599 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2607 if (VMScmd.dsc$a_pointer) {
2608 Safefree(VMScmd.dsc$a_pointer);
2609 VMScmd.dsc$w_length = 0;
2610 VMScmd.dsc$a_pointer = Nullch;
2615 setup_argstr(SV *really, SV **mark, SV **sp)
2617 char *junk, *tmps = Nullch;
2618 register size_t cmdlen = 0;
2624 tmps = SvPV(really,rlen);
2631 for (idx++; idx <= sp; idx++) {
2633 junk = SvPVx(*idx,rlen);
2634 cmdlen += rlen ? rlen + 1 : 0;
2637 New(401,Cmd,cmdlen+1,char);
2639 if (tmps && *tmps) {
2644 while (++mark <= sp) {
2647 strcat(Cmd,SvPVx(*mark,na));
2652 } /* end of setup_argstr() */
2655 static unsigned long int
2656 setup_cmddsc(char *cmd, int check_img)
2658 char resspec[NAM$C_MAXRSS+1];
2659 $DESCRIPTOR(defdsc,".EXE");
2660 $DESCRIPTOR(resdsc,resspec);
2661 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2662 unsigned long int cxt = 0, flags = 1, retsts;
2663 register char *s, *rest, *cp;
2664 register int isdcl = 0;
2667 while (*s && isspace(*s)) s++;
2669 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2670 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2671 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2672 if (*cp == ':' || *cp == '[' || *cp == '<') {
2680 if (isdcl) { /* It's a DCL command, just do it. */
2681 VMScmd.dsc$w_length = strlen(cmd);
2683 VMScmd.dsc$a_pointer = Cmd;
2684 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2686 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2688 else { /* assume first token is an image spec */
2690 while (*s && !isspace(*s)) s++;
2692 imgdsc.dsc$a_pointer = cmd;
2693 imgdsc.dsc$w_length = s - cmd;
2694 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2695 if (!(retsts & 1)) {
2696 /* just hand off status values likely to be due to user error */
2697 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2698 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2699 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2700 else { _ckvmssts(retsts); }
2703 _ckvmssts(lib$find_file_end(&cxt));
2705 while (*s && !isspace(*s)) s++;
2707 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2708 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2709 strcat(VMScmd.dsc$a_pointer,resspec);
2710 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2711 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2715 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2717 } /* end of setup_cmddsc() */
2720 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2722 vms_do_aexec(SV *really,SV **mark,SV **sp)
2725 if (vfork_called) { /* this follows a vfork - act Unixish */
2727 if (vfork_called < 0) {
2728 warn("Internal inconsistency in tracking vforks");
2731 else return do_aexec(really,mark,sp);
2733 /* no vfork - act VMSish */
2734 return vms_do_exec(setup_argstr(really,mark,sp));
2739 } /* end of vms_do_aexec() */
2742 /* {{{bool vms_do_exec(char *cmd) */
2744 vms_do_exec(char *cmd)
2747 if (vfork_called) { /* this follows a vfork - act Unixish */
2749 if (vfork_called < 0) {
2750 warn("Internal inconsistency in tracking vforks");
2753 else return do_exec(cmd);
2756 { /* no vfork - act VMSish */
2757 unsigned long int retsts;
2760 TAINT_PROPER("exec");
2761 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2762 retsts = lib$do_command(&VMScmd);
2765 set_vaxc_errno(retsts);
2767 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2773 } /* end of vms_do_exec() */
2776 unsigned long int do_spawn(char *);
2778 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2780 do_aspawn(SV *really,SV **mark,SV **sp)
2782 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2785 } /* end of do_aspawn() */
2788 /* {{{unsigned long int do_spawn(char *cmd) */
2792 unsigned long int substs, hadcmd = 1;
2795 TAINT_PROPER("spawn");
2796 if (!cmd || !*cmd) {
2798 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2800 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2801 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2806 set_vaxc_errno(substs);
2808 warn("Can't spawn \"%s\": %s",
2809 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2814 } /* end of do_spawn() */
2818 * A simple fwrite replacement which outputs itmsz*nitm chars without
2819 * introducing record boundaries every itmsz chars.
2821 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2823 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2825 register char *cp, *end;
2827 end = (char *)src + itmsz * nitm;
2829 while ((char *)src <= end) {
2830 for (cp = src; cp <= end; cp++) if (!*cp) break;
2831 if (fputs(src,dest) == EOF) return EOF;
2833 if (fputc('\0',dest) == EOF) return EOF;
2839 } /* end of my_fwrite() */
2843 * Here are replacements for the following Unix routines in the VMS environment:
2844 * getpwuid Get information for a particular UIC or UID
2845 * getpwnam Get information for a named user
2846 * getpwent Get information for each user in the rights database
2847 * setpwent Reset search to the start of the rights database
2848 * endpwent Finish searching for users in the rights database
2850 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2851 * (defined in pwd.h), which contains the following fields:-
2853 * char *pw_name; Username (in lower case)
2854 * char *pw_passwd; Hashed password
2855 * unsigned int pw_uid; UIC
2856 * unsigned int pw_gid; UIC group number
2857 * char *pw_unixdir; Default device/directory (VMS-style)
2858 * char *pw_gecos; Owner name
2859 * char *pw_dir; Default device/directory (Unix-style)
2860 * char *pw_shell; Default CLI name (eg. DCL)
2862 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2864 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2865 * not the UIC member number (eg. what's returned by getuid()),
2866 * getpwuid() can accept either as input (if uid is specified, the caller's
2867 * UIC group is used), though it won't recognise gid=0.
2869 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2870 * information about other users in your group or in other groups, respectively.
2871 * If the required privilege is not available, then these routines fill only
2872 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2875 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2878 /* sizes of various UAF record fields */
2879 #define UAI$S_USERNAME 12
2880 #define UAI$S_IDENT 31
2881 #define UAI$S_OWNER 31
2882 #define UAI$S_DEFDEV 31
2883 #define UAI$S_DEFDIR 63
2884 #define UAI$S_DEFCLI 31
2887 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2888 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2889 (uic).uic$v_group != UIC$K_WILD_GROUP)
2891 static char __empty[]= "";
2892 static struct passwd __passwd_empty=
2893 {(char *) __empty, (char *) __empty, 0, 0,
2894 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2895 static int contxt= 0;
2896 static struct passwd __pwdcache;
2897 static char __pw_namecache[UAI$S_IDENT+1];
2900 * This routine does most of the work extracting the user information.
2902 static int fillpasswd (const char *name, struct passwd *pwd)
2905 unsigned char length;
2906 char pw_gecos[UAI$S_OWNER+1];
2908 static union uicdef uic;
2910 unsigned char length;
2911 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2914 unsigned char length;
2915 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2918 unsigned char length;
2919 char pw_shell[UAI$S_DEFCLI+1];
2921 static char pw_passwd[UAI$S_PWD+1];
2923 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2924 struct dsc$descriptor_s name_desc;
2925 unsigned long int sts;
2927 static struct itmlst_3 itmlst[]= {
2928 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2929 {sizeof(uic), UAI$_UIC, &uic, &luic},
2930 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2931 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2932 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2933 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2934 {0, 0, NULL, NULL}};
2936 name_desc.dsc$w_length= strlen(name);
2937 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2938 name_desc.dsc$b_class= DSC$K_CLASS_S;
2939 name_desc.dsc$a_pointer= (char *) name;
2941 /* Note that sys$getuai returns many fields as counted strings. */
2942 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2943 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2944 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2946 else { _ckvmssts(sts); }
2947 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2949 if ((int) owner.length < lowner) lowner= (int) owner.length;
2950 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2951 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2952 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2953 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2954 owner.pw_gecos[lowner]= '\0';
2955 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2956 defcli.pw_shell[ldefcli]= '\0';
2957 if (valid_uic(uic)) {
2958 pwd->pw_uid= uic.uic$l_uic;
2959 pwd->pw_gid= uic.uic$v_group;
2962 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2963 pwd->pw_passwd= pw_passwd;
2964 pwd->pw_gecos= owner.pw_gecos;
2965 pwd->pw_dir= defdev.pw_dir;
2966 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2967 pwd->pw_shell= defcli.pw_shell;
2968 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2970 ldir= strlen(pwd->pw_unixdir) - 1;
2971 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2974 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2975 __mystrtolower(pwd->pw_unixdir);
2980 * Get information for a named user.
2982 /*{{{struct passwd *getpwnam(char *name)*/
2983 struct passwd *my_getpwnam(char *name)
2985 struct dsc$descriptor_s name_desc;
2987 unsigned long int status, sts;
2989 __pwdcache = __passwd_empty;
2990 if (!fillpasswd(name, &__pwdcache)) {
2991 /* We still may be able to determine pw_uid and pw_gid */
2992 name_desc.dsc$w_length= strlen(name);
2993 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2994 name_desc.dsc$b_class= DSC$K_CLASS_S;
2995 name_desc.dsc$a_pointer= (char *) name;
2996 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2997 __pwdcache.pw_uid= uic.uic$l_uic;
2998 __pwdcache.pw_gid= uic.uic$v_group;
3001 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3002 set_vaxc_errno(sts);
3003 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3006 else { _ckvmssts(sts); }
3009 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3010 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3011 __pwdcache.pw_name= __pw_namecache;
3013 } /* end of my_getpwnam() */
3017 * Get information for a particular UIC or UID.
3018 * Called by my_getpwent with uid=-1 to list all users.
3020 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3021 struct passwd *my_getpwuid(Uid_t uid)
3023 const $DESCRIPTOR(name_desc,__pw_namecache);
3024 unsigned short lname;
3026 unsigned long int status;
3028 if (uid == (unsigned int) -1) {
3030 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3031 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3032 set_vaxc_errno(status);
3033 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3037 else { _ckvmssts(status); }
3038 } while (!valid_uic (uic));
3042 if (!uic.uic$v_group)
3043 uic.uic$v_group= getgid();
3045 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3046 else status = SS$_IVIDENT;
3047 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3048 status == RMS$_PRV) {
3049 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3052 else { _ckvmssts(status); }
3054 __pw_namecache[lname]= '\0';
3055 __mystrtolower(__pw_namecache);
3057 __pwdcache = __passwd_empty;
3058 __pwdcache.pw_name = __pw_namecache;
3060 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3061 The identifier's value is usually the UIC, but it doesn't have to be,
3062 so if we can, we let fillpasswd update this. */
3063 __pwdcache.pw_uid = uic.uic$l_uic;
3064 __pwdcache.pw_gid = uic.uic$v_group;
3066 fillpasswd(__pw_namecache, &__pwdcache);
3069 } /* end of my_getpwuid() */
3073 * Get information for next user.
3075 /*{{{struct passwd *my_getpwent()*/
3076 struct passwd *my_getpwent()
3078 return (my_getpwuid((unsigned int) -1));
3083 * Finish searching rights database for users.
3085 /*{{{void my_endpwent()*/
3089 _ckvmssts(sys$finish_rdb(&contxt));
3096 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3097 * my_utime(), and flex_stat(), all of which operate on UTC unless
3098 * VMSISH_TIMES is true.
3100 /* method used to handle UTC conversions:
3101 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3103 static int gmtime_emulation_type;
3104 /* number of secs to add to UTC POSIX-style time to get local time */
3105 static long int utc_offset_secs;
3107 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3108 * in vmsish.h. #undef them here so we can call the CRTL routines
3115 /* my_time(), my_localtime(), my_gmtime()
3116 * By default traffic in UTC time values, suing CRTL gmtime() or
3117 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3118 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3119 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3122 /*{{{time_t my_time(time_t *timep)*/
3123 time_t my_time(time_t *timep)
3127 if (gmtime_emulation_type == 0) {
3129 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3131 gmtime_emulation_type++;
3132 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3135 gmtime_emulation_type++;
3136 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3137 gmtime_emulation_type++;
3138 warn("no UTC offset information; assuming local time is UTC");
3140 else { utc_offset_secs = atol(off); }
3142 else { /* We've got a working gmtime() */
3143 struct tm gmt, local;
3146 tm_p = localtime(&base);
3148 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3149 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3150 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3151 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3160 when != -1) when -= utc_offset_secs;
3161 if (timep != NULL) *timep = when;
3164 } /* end of my_time() */
3168 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3170 my_gmtime(const time_t *timep)
3175 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3179 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3181 /* CRTL localtime() wants local time as input, so does no tz correction */
3182 return localtime(&when);
3184 } /* end of my_gmtime() */
3188 /*{{{struct tm *my_localtime(const time_t *timep)*/
3190 my_localtime(const time_t *timep)
3194 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3198 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3200 /* CRTL localtime() wants local time as input, so does no tz correction */
3201 return localtime(&when);
3203 } /* end of my_localtime() */
3206 /* Reset definitions for later calls */
3207 #define gmtime(t) my_gmtime(t)
3208 #define localtime(t) my_localtime(t)
3209 #define time(t) my_time(t)
3212 /* my_utime - update modification time of a file
3213 * calling sequence is identical to POSIX utime(), but under
3214 * VMS only the modification time is changed; ODS-2 does not
3215 * maintain access times. Restrictions differ from the POSIX
3216 * definition in that the time can be changed as long as the
3217 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3218 * no separate checks are made to insure that the caller is the
3219 * owner of the file or has special privs enabled.
3220 * Code here is based on Joe Meadows' FILE utility.
3223 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3224 * to VMS epoch (01-JAN-1858 00:00:00.00)
3225 * in 100 ns intervals.
3227 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3229 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3230 int my_utime(char *file, struct utimbuf *utimes)
3233 long int bintime[2], len = 2, lowbit, unixtime,
3234 secscale = 10000000; /* seconds --> 100 ns intervals */
3235 unsigned long int chan, iosb[2], retsts;
3236 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3237 struct FAB myfab = cc$rms_fab;
3238 struct NAM mynam = cc$rms_nam;
3239 #if defined (__DECC) && defined (__VAX)
3240 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3241 * at least through VMS V6.1, which causes a type-conversion warning.
3243 # pragma message save
3244 # pragma message disable cvtdiftypes
3246 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3247 struct fibdef myfib;
3248 #if defined (__DECC) && defined (__VAX)
3249 /* This should be right after the declaration of myatr, but due
3250 * to a bug in VAX DEC C, this takes effect a statement early.
3252 # pragma message restore
3254 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3255 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3256 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3258 if (file == NULL || *file == '\0') {
3260 set_vaxc_errno(LIB$_INVARG);
3263 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3265 if (utimes != NULL) {
3266 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3267 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3268 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3269 * as input, we force the sign bit to be clear by shifting unixtime right
3270 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3272 lowbit = (utimes->modtime & 1) ? secscale : 0;
3273 unixtime = (long int) utimes->modtime;
3275 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3276 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3277 unixtime += utc_offset_secs;
3280 unixtime >> 1; secscale << 1;
3281 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3282 if (!(retsts & 1)) {
3284 set_vaxc_errno(retsts);
3287 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3288 if (!(retsts & 1)) {
3290 set_vaxc_errno(retsts);
3295 /* Just get the current time in VMS format directly */
3296 retsts = sys$gettim(bintime);
3297 if (!(retsts & 1)) {
3299 set_vaxc_errno(retsts);
3304 myfab.fab$l_fna = vmsspec;
3305 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3306 myfab.fab$l_nam = &mynam;
3307 mynam.nam$l_esa = esa;
3308 mynam.nam$b_ess = (unsigned char) sizeof esa;
3309 mynam.nam$l_rsa = rsa;
3310 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3312 /* Look for the file to be affected, letting RMS parse the file
3313 * specification for us as well. I have set errno using only
3314 * values documented in the utime() man page for VMS POSIX.
3316 retsts = sys$parse(&myfab,0,0);
3317 if (!(retsts & 1)) {
3318 set_vaxc_errno(retsts);
3319 if (retsts == RMS$_PRV) set_errno(EACCES);
3320 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3321 else set_errno(EVMSERR);
3324 retsts = sys$search(&myfab,0,0);
3325 if (!(retsts & 1)) {
3326 set_vaxc_errno(retsts);
3327 if (retsts == RMS$_PRV) set_errno(EACCES);
3328 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3329 else set_errno(EVMSERR);
3333 devdsc.dsc$w_length = mynam.nam$b_dev;
3334 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3336 retsts = sys$assign(&devdsc,&chan,0,0);
3337 if (!(retsts & 1)) {
3338 set_vaxc_errno(retsts);
3339 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3340 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3341 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3342 else set_errno(EVMSERR);
3346 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3347 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3349 memset((void *) &myfib, 0, sizeof myfib);
3351 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3352 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3353 /* This prevents the revision time of the file being reset to the current
3354 * time as a result of our IO$_MODIFY $QIO. */
3355 myfib.fib$l_acctl = FIB$M_NORECORD;
3357 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3358 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3359 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3361 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3362 _ckvmssts(sys$dassgn(chan));
3363 if (retsts & 1) retsts = iosb[0];
3364 if (!(retsts & 1)) {
3365 set_vaxc_errno(retsts);
3366 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3367 else set_errno(EVMSERR);
3372 } /* end of my_utime() */
3376 * flex_stat, flex_fstat
3377 * basic stat, but gets it right when asked to stat
3378 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3381 /* encode_dev packs a VMS device name string into an integer to allow
3382 * simple comparisons. This can be used, for example, to check whether two
3383 * files are located on the same device, by comparing their encoded device
3384 * names. Even a string comparison would not do, because stat() reuses the
3385 * device name buffer for each call; so without encode_dev, it would be
3386 * necessary to save the buffer and use strcmp (this would mean a number of
3387 * changes to the standard Perl code, to say nothing of what a Perl script
3390 * The device lock id, if it exists, should be unique (unless perhaps compared
3391 * with lock ids transferred from other nodes). We have a lock id if the disk is
3392 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3393 * device names. Thus we use the lock id in preference, and only if that isn't
3394 * available, do we try to pack the device name into an integer (flagged by
3395 * the sign bit (LOCKID_MASK) being set).
3397 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3398 * name and its encoded form, but it seems very unlikely that we will find
3399 * two files on different disks that share the same encoded device names,
3400 * and even more remote that they will share the same file id (if the test
3401 * is to check for the same file).
3403 * A better method might be to use sys$device_scan on the first call, and to
3404 * search for the device, returning an index into the cached array.
3405 * The number returned would be more intelligable.
3406 * This is probably not worth it, and anyway would take quite a bit longer
3407 * on the first call.
3409 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3410 static mydev_t encode_dev (const char *dev)
3413 unsigned long int f;
3418 if (!dev || !dev[0]) return 0;
3422 struct dsc$descriptor_s dev_desc;
3423 unsigned long int status, lockid, item = DVI$_LOCKID;
3425 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3426 can try that first. */
3427 dev_desc.dsc$w_length = strlen (dev);
3428 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3429 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3430 dev_desc.dsc$a_pointer = (char *) dev;
3431 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3432 if (lockid) return (lockid & ~LOCKID_MASK);
3436 /* Otherwise we try to encode the device name */
3440 for (q = dev + strlen(dev); q--; q >= dev) {
3443 else if (isalpha (toupper (*q)))
3444 c= toupper (*q) - 'A' + (char)10;
3446 continue; /* Skip '$'s */
3448 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3450 enc += f * (unsigned long int) c;
3452 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3454 } /* end of encode_dev() */
3456 static char namecache[NAM$C_MAXRSS+1];
3459 is_null_device(name)
3462 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3463 The underscore prefix, controller letter, and unit number are
3464 independently optional; for our purposes, the colon punctuation
3465 is not. The colon can be trailed by optional directory and/or
3466 filename, but two consecutive colons indicates a nodename rather
3467 than a device. [pr] */
3468 if (*name == '_') ++name;
3469 if (tolower(*name++) != 'n') return 0;
3470 if (tolower(*name++) != 'l') return 0;
3471 if (tolower(*name) == 'a') ++name;
3472 if (*name == '0') ++name;
3473 return (*name++ == ':') && (*name != ':');
3476 /* Do the permissions allow some operation? Assumes statcache already set. */
3477 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3478 * subset of the applicable information. (We have to stick with struct
3479 * stat instead of struct mystat in the prototype since we have to match
3480 * the one in proto.h.)
3482 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3484 cando(I32 bit, I32 effective, struct stat *statbufp)
3486 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3488 char fname[NAM$C_MAXRSS+1];
3489 unsigned long int retsts;
3490 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3491 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3493 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3494 device name on successive calls */
3495 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3496 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3497 namdsc.dsc$a_pointer = fname;
3498 namdsc.dsc$w_length = sizeof fname - 1;
3500 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3501 &namdsc,&namdsc.dsc$w_length,0,0);
3503 fname[namdsc.dsc$w_length] = '\0';
3504 return cando_by_name(bit,effective,fname);
3506 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3507 warn("Can't get filespec - stale stat buffer?\n");
3511 return FALSE; /* Should never get to here */
3513 } /* end of cando() */
3517 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3519 cando_by_name(I32 bit, I32 effective, char *fname)
3521 static char usrname[L_cuserid];
3522 static struct dsc$descriptor_s usrdsc =
3523 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3524 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3525 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3526 unsigned short int retlen;
3527 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3528 union prvdef curprv;
3529 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3530 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3531 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3534 if (!fname || !*fname) return FALSE;
3535 /* Make sure we expand logical names, since sys$check_access doesn't */
3536 if (!strpbrk(fname,"/]>:")) {
3537 strcpy(fileified,fname);
3538 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3541 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3542 retlen = namdsc.dsc$w_length = strlen(vmsname);
3543 namdsc.dsc$a_pointer = vmsname;
3544 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3545 vmsname[retlen-1] == ':') {
3546 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3547 namdsc.dsc$w_length = strlen(fileified);
3548 namdsc.dsc$a_pointer = fileified;
3551 if (!usrdsc.dsc$w_length) {
3553 usrdsc.dsc$w_length = strlen(usrname);
3560 access = ARM$M_EXECUTE;
3565 access = ARM$M_READ;
3570 access = ARM$M_WRITE;
3575 access = ARM$M_DELETE;
3581 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3582 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3583 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3584 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3585 set_vaxc_errno(retsts);
3586 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3587 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3588 else set_errno(ENOENT);
3591 if (retsts == SS$_NORMAL) {
3592 if (!privused) return TRUE;
3593 /* We can get access, but only by using privs. Do we have the
3594 necessary privs currently enabled? */
3595 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3596 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3597 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3598 !curprv.prv$v_bypass) return FALSE;
3599 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3600 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3601 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3606 return FALSE; /* Should never get here */
3608 } /* end of cando_by_name() */
3612 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3614 flex_fstat(int fd, struct mystat *statbufp)
3616 if (!fstat(fd,(stat_t *) statbufp)) {
3617 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3618 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3620 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3624 if (!gmtime_emulation_type) (void)time(NULL);
3625 statbufp->st_mtime -= utc_offset_secs;
3626 statbufp->st_atime -= utc_offset_secs;
3627 statbufp->st_ctime -= utc_offset_secs;
3633 } /* end of flex_fstat() */
3636 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3638 flex_stat(char *fspec, struct mystat *statbufp)
3640 char fileified[NAM$C_MAXRSS+1];
3643 if (statbufp == (struct mystat *) &statcache)
3644 do_tovmsspec(fspec,namecache,0);
3645 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3646 memset(statbufp,0,sizeof *statbufp);
3647 statbufp->st_dev = encode_dev("_NLA0:");
3648 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3649 statbufp->st_uid = 0x00010001;
3650 statbufp->st_gid = 0x0001;
3651 time((time_t *)&statbufp->st_mtime);
3652 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3656 /* Try for a directory name first. If fspec contains a filename without
3657 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3658 * and sea:[wine.dark]water. exist, we prefer the directory here.
3659 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3660 * not sea:[wine.dark]., if the latter exists. If the intended target is
3661 * the file with null type, specify this by calling flex_stat() with
3662 * a '.' at the end of fspec.
3664 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3665 retval = stat(fileified,(stat_t *) statbufp);
3666 if (!retval && statbufp == (struct mystat *) &statcache)
3667 strcpy(namecache,fileified);
3669 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3671 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3673 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3677 if (!gmtime_emulation_type) (void)time(NULL);
3678 statbufp->st_mtime -= utc_offset_secs;
3679 statbufp->st_atime -= utc_offset_secs;
3680 statbufp->st_ctime -= utc_offset_secs;
3685 } /* end of flex_stat() */
3688 /* Insures that no carriage-control translation will be done on a file. */
3689 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3691 my_binmode(FILE *fp, char iotype)
3693 char filespec[NAM$C_MAXRSS], *acmode;
3696 if (!fgetname(fp,filespec)) return NULL;
3697 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3699 case '<': case 'r': acmode = "rb"; break;
3701 /* use 'a' instead of 'w' to avoid creating new file;
3702 fsetpos below will take care of restoring file position */
3703 case 'a': acmode = "ab"; break;
3704 case '+': case '|': case 's': acmode = "rb+"; break;
3705 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3707 warn("Unrecognized iotype %c in my_binmode",iotype);
3710 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3711 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3713 } /* end of my_binmode() */
3717 /*{{{char *my_getlogin()*/
3718 /* VMS cuserid == Unix getlogin, except calling sequence */
3722 static char user[L_cuserid];
3723 return cuserid(user);
3728 /* rmscopy - copy a file using VMS RMS routines
3730 * Copies contents and attributes of spec_in to spec_out, except owner
3731 * and protection information. Name and type of spec_in are used as
3732 * defaults for spec_out. The third parameter specifies whether rmscopy()
3733 * should try to propagate timestamps from the input file to the output file.
3734 * If it is less than 0, no timestamps are preserved. If it is 0, then
3735 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3736 * propagated to the output file at creation iff the output file specification
3737 * did not contain an explicit name or type, and the revision date is always
3738 * updated at the end of the copy operation. If it is greater than 0, then
3739 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3740 * other than the revision date should be propagated, and bit 1 indicates
3741 * that the revision date should be propagated.
3743 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3745 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3746 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3747 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3748 * as part of the Perl standard distribution under the terms of the
3749 * GNU General Public License or the Perl Artistic License. Copies
3750 * of each may be found in the Perl standard distribution.
3752 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3754 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3756 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3757 rsa[NAM$C_MAXRSS], ubf[32256];
3758 unsigned long int i, sts, sts2;
3759 struct FAB fab_in, fab_out;
3760 struct RAB rab_in, rab_out;
3762 struct XABDAT xabdat;
3763 struct XABFHC xabfhc;
3764 struct XABRDT xabrdt;
3765 struct XABSUM xabsum;
3767 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3768 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3769 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3773 fab_in = cc$rms_fab;
3774 fab_in.fab$l_fna = vmsin;
3775 fab_in.fab$b_fns = strlen(vmsin);
3776 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3777 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3778 fab_in.fab$l_fop = FAB$M_SQO;
3779 fab_in.fab$l_nam = &nam;
3780 fab_in.fab$l_xab = (void *) &xabdat;
3783 nam.nam$l_rsa = rsa;
3784 nam.nam$b_rss = sizeof(rsa);
3785 nam.nam$l_esa = esa;
3786 nam.nam$b_ess = sizeof (esa);
3787 nam.nam$b_esl = nam.nam$b_rsl = 0;
3789 xabdat = cc$rms_xabdat; /* To get creation date */
3790 xabdat.xab$l_nxt = (void *) &xabfhc;
3792 xabfhc = cc$rms_xabfhc; /* To get record length */
3793 xabfhc.xab$l_nxt = (void *) &xabsum;
3795 xabsum = cc$rms_xabsum; /* To get key and area information */
3797 if (!((sts = sys$open(&fab_in)) & 1)) {
3798 set_vaxc_errno(sts);
3802 set_errno(ENOENT); break;
3804 set_errno(ENODEV); break;
3806 set_errno(EINVAL); break;
3808 set_errno(EACCES); break;
3816 fab_out.fab$w_ifi = 0;
3817 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3818 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3819 fab_out.fab$l_fop = FAB$M_SQO;
3820 fab_out.fab$l_fna = vmsout;
3821 fab_out.fab$b_fns = strlen(vmsout);
3822 fab_out.fab$l_dna = nam.nam$l_name;
3823 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3825 if (preserve_dates == 0) { /* Act like DCL COPY */
3826 nam.nam$b_nop = NAM$M_SYNCHK;
3827 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3828 if (!((sts = sys$parse(&fab_out)) & 1)) {
3829 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3830 set_vaxc_errno(sts);
3833 fab_out.fab$l_xab = (void *) &xabdat;
3834 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3836 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3837 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3838 preserve_dates =0; /* bitmask from this point forward */
3840 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3841 if (!((sts = sys$create(&fab_out)) & 1)) {
3842 set_vaxc_errno(sts);
3845 set_errno(ENOENT); break;
3847 set_errno(ENODEV); break;
3849 set_errno(EINVAL); break;
3851 set_errno(EACCES); break;
3857 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3858 if (preserve_dates & 2) {
3859 /* sys$close() will process xabrdt, not xabdat */
3860 xabrdt = cc$rms_xabrdt;
3862 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3864 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3865 * is unsigned long[2], while DECC & VAXC use a struct */
3866 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3868 fab_out.fab$l_xab = (void *) &xabrdt;
3871 rab_in = cc$rms_rab;
3872 rab_in.rab$l_fab = &fab_in;
3873 rab_in.rab$l_rop = RAB$M_BIO;
3874 rab_in.rab$l_ubf = ubf;
3875 rab_in.rab$w_usz = sizeof ubf;
3876 if (!((sts = sys$connect(&rab_in)) & 1)) {
3877 sys$close(&fab_in); sys$close(&fab_out);
3878 set_errno(EVMSERR); set_vaxc_errno(sts);
3882 rab_out = cc$rms_rab;
3883 rab_out.rab$l_fab = &fab_out;
3884 rab_out.rab$l_rbf = ubf;
3885 if (!((sts = sys$connect(&rab_out)) & 1)) {
3886 sys$close(&fab_in); sys$close(&fab_out);
3887 set_errno(EVMSERR); set_vaxc_errno(sts);
3891 while ((sts = sys$read(&rab_in))) { /* always true */
3892 if (sts == RMS$_EOF) break;
3893 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3894 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3895 sys$close(&fab_in); sys$close(&fab_out);
3896 set_errno(EVMSERR); set_vaxc_errno(sts);
3901 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3902 sys$close(&fab_in); sys$close(&fab_out);
3903 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3905 set_errno(EVMSERR); set_vaxc_errno(sts);
3911 } /* end of rmscopy() */
3915 /*** The following glue provides 'hooks' to make some of the routines
3916 * from this file available from Perl. These routines are sufficiently
3917 * basic, and are required sufficiently early in the build process,
3918 * that's it's nice to have them available to miniperl as well as the
3919 * full Perl, so they're set up here instead of in an extension. The
3920 * Perl code which handles importation of these names into a given
3921 * package lives in [.VMS]Filespec.pm in @INC.
3925 rmsexpand_fromperl(CV *cv)
3928 char *fspec, *defspec = NULL, *rslt;
3930 if (!items || items > 2)
3931 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3932 fspec = SvPV(ST(0),na);
3933 if (!fspec || !*fspec) XSRETURN_UNDEF;
3934 if (items == 2) defspec = SvPV(ST(1),na);
3936 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3937 ST(0) = sv_newmortal();
3938 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3943 vmsify_fromperl(CV *cv)
3948 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3949 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3950 ST(0) = sv_newmortal();
3951 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3956 unixify_fromperl(CV *cv)
3961 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3962 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3963 ST(0) = sv_newmortal();
3964 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3969 fileify_fromperl(CV *cv)
3974 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3975 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3976 ST(0) = sv_newmortal();
3977 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3982 pathify_fromperl(CV *cv)
3987 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3988 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3989 ST(0) = sv_newmortal();
3990 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3995 vmspath_fromperl(CV *cv)
4000 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4001 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4002 ST(0) = sv_newmortal();
4003 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4008 unixpath_fromperl(CV *cv)
4013 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4014 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4015 ST(0) = sv_newmortal();
4016 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4021 candelete_fromperl(CV *cv)
4024 char fspec[NAM$C_MAXRSS+1], *fsp;
4028 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4030 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4031 if (SvTYPE(mysv) == SVt_PVGV) {
4032 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4033 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4040 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4041 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4047 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
4052 rmscopy_fromperl(CV *cv)
4055 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4057 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4058 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4059 unsigned long int sts;
4063 if (items < 2 || items > 3)
4064 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4066 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4067 if (SvTYPE(mysv) == SVt_PVGV) {
4068 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4069 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4076 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4077 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4082 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4083 if (SvTYPE(mysv) == SVt_PVGV) {
4084 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4085 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4092 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4093 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4098 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4100 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
4107 char* file = __FILE__;
4109 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4110 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4111 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4112 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4113 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4114 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4115 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4116 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4117 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);