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 (timep == NULL) {
3176 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3179 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3180 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3184 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3186 /* CRTL localtime() wants local time as input, so does no tz correction */
3187 return localtime(&when);
3189 } /* end of my_gmtime() */
3193 /*{{{struct tm *my_localtime(const time_t *timep)*/
3195 my_localtime(const time_t *timep)
3199 if (timep == NULL) {
3200 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3203 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3204 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3208 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3210 /* CRTL localtime() wants local time as input, so does no tz correction */
3211 return localtime(&when);
3213 } /* end of my_localtime() */
3216 /* Reset definitions for later calls */
3217 #define gmtime(t) my_gmtime(t)
3218 #define localtime(t) my_localtime(t)
3219 #define time(t) my_time(t)
3222 /* my_utime - update modification time of a file
3223 * calling sequence is identical to POSIX utime(), but under
3224 * VMS only the modification time is changed; ODS-2 does not
3225 * maintain access times. Restrictions differ from the POSIX
3226 * definition in that the time can be changed as long as the
3227 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3228 * no separate checks are made to insure that the caller is the
3229 * owner of the file or has special privs enabled.
3230 * Code here is based on Joe Meadows' FILE utility.
3233 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3234 * to VMS epoch (01-JAN-1858 00:00:00.00)
3235 * in 100 ns intervals.
3237 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3239 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3240 int my_utime(char *file, struct utimbuf *utimes)
3243 long int bintime[2], len = 2, lowbit, unixtime,
3244 secscale = 10000000; /* seconds --> 100 ns intervals */
3245 unsigned long int chan, iosb[2], retsts;
3246 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3247 struct FAB myfab = cc$rms_fab;
3248 struct NAM mynam = cc$rms_nam;
3249 #if defined (__DECC) && defined (__VAX)
3250 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3251 * at least through VMS V6.1, which causes a type-conversion warning.
3253 # pragma message save
3254 # pragma message disable cvtdiftypes
3256 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3257 struct fibdef myfib;
3258 #if defined (__DECC) && defined (__VAX)
3259 /* This should be right after the declaration of myatr, but due
3260 * to a bug in VAX DEC C, this takes effect a statement early.
3262 # pragma message restore
3264 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3265 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3266 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3268 if (file == NULL || *file == '\0') {
3270 set_vaxc_errno(LIB$_INVARG);
3273 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3275 if (utimes != NULL) {
3276 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3277 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3278 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3279 * as input, we force the sign bit to be clear by shifting unixtime right
3280 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3282 lowbit = (utimes->modtime & 1) ? secscale : 0;
3283 unixtime = (long int) utimes->modtime;
3285 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3286 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3287 unixtime += utc_offset_secs;
3290 unixtime >> 1; secscale << 1;
3291 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3292 if (!(retsts & 1)) {
3294 set_vaxc_errno(retsts);
3297 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3298 if (!(retsts & 1)) {
3300 set_vaxc_errno(retsts);
3305 /* Just get the current time in VMS format directly */
3306 retsts = sys$gettim(bintime);
3307 if (!(retsts & 1)) {
3309 set_vaxc_errno(retsts);
3314 myfab.fab$l_fna = vmsspec;
3315 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3316 myfab.fab$l_nam = &mynam;
3317 mynam.nam$l_esa = esa;
3318 mynam.nam$b_ess = (unsigned char) sizeof esa;
3319 mynam.nam$l_rsa = rsa;
3320 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3322 /* Look for the file to be affected, letting RMS parse the file
3323 * specification for us as well. I have set errno using only
3324 * values documented in the utime() man page for VMS POSIX.
3326 retsts = sys$parse(&myfab,0,0);
3327 if (!(retsts & 1)) {
3328 set_vaxc_errno(retsts);
3329 if (retsts == RMS$_PRV) set_errno(EACCES);
3330 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3331 else set_errno(EVMSERR);
3334 retsts = sys$search(&myfab,0,0);
3335 if (!(retsts & 1)) {
3336 set_vaxc_errno(retsts);
3337 if (retsts == RMS$_PRV) set_errno(EACCES);
3338 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3339 else set_errno(EVMSERR);
3343 devdsc.dsc$w_length = mynam.nam$b_dev;
3344 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3346 retsts = sys$assign(&devdsc,&chan,0,0);
3347 if (!(retsts & 1)) {
3348 set_vaxc_errno(retsts);
3349 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3350 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3351 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3352 else set_errno(EVMSERR);
3356 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3357 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3359 memset((void *) &myfib, 0, sizeof myfib);
3361 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3362 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3363 /* This prevents the revision time of the file being reset to the current
3364 * time as a result of our IO$_MODIFY $QIO. */
3365 myfib.fib$l_acctl = FIB$M_NORECORD;
3367 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3368 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3369 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3371 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3372 _ckvmssts(sys$dassgn(chan));
3373 if (retsts & 1) retsts = iosb[0];
3374 if (!(retsts & 1)) {
3375 set_vaxc_errno(retsts);
3376 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3377 else set_errno(EVMSERR);
3382 } /* end of my_utime() */
3386 * flex_stat, flex_fstat
3387 * basic stat, but gets it right when asked to stat
3388 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3391 /* encode_dev packs a VMS device name string into an integer to allow
3392 * simple comparisons. This can be used, for example, to check whether two
3393 * files are located on the same device, by comparing their encoded device
3394 * names. Even a string comparison would not do, because stat() reuses the
3395 * device name buffer for each call; so without encode_dev, it would be
3396 * necessary to save the buffer and use strcmp (this would mean a number of
3397 * changes to the standard Perl code, to say nothing of what a Perl script
3400 * The device lock id, if it exists, should be unique (unless perhaps compared
3401 * with lock ids transferred from other nodes). We have a lock id if the disk is
3402 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3403 * device names. Thus we use the lock id in preference, and only if that isn't
3404 * available, do we try to pack the device name into an integer (flagged by
3405 * the sign bit (LOCKID_MASK) being set).
3407 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3408 * name and its encoded form, but it seems very unlikely that we will find
3409 * two files on different disks that share the same encoded device names,
3410 * and even more remote that they will share the same file id (if the test
3411 * is to check for the same file).
3413 * A better method might be to use sys$device_scan on the first call, and to
3414 * search for the device, returning an index into the cached array.
3415 * The number returned would be more intelligable.
3416 * This is probably not worth it, and anyway would take quite a bit longer
3417 * on the first call.
3419 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3420 static mydev_t encode_dev (const char *dev)
3423 unsigned long int f;
3428 if (!dev || !dev[0]) return 0;
3432 struct dsc$descriptor_s dev_desc;
3433 unsigned long int status, lockid, item = DVI$_LOCKID;
3435 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3436 can try that first. */
3437 dev_desc.dsc$w_length = strlen (dev);
3438 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3439 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3440 dev_desc.dsc$a_pointer = (char *) dev;
3441 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3442 if (lockid) return (lockid & ~LOCKID_MASK);
3446 /* Otherwise we try to encode the device name */
3450 for (q = dev + strlen(dev); q--; q >= dev) {
3453 else if (isalpha (toupper (*q)))
3454 c= toupper (*q) - 'A' + (char)10;
3456 continue; /* Skip '$'s */
3458 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3460 enc += f * (unsigned long int) c;
3462 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3464 } /* end of encode_dev() */
3466 static char namecache[NAM$C_MAXRSS+1];
3469 is_null_device(name)
3472 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3473 The underscore prefix, controller letter, and unit number are
3474 independently optional; for our purposes, the colon punctuation
3475 is not. The colon can be trailed by optional directory and/or
3476 filename, but two consecutive colons indicates a nodename rather
3477 than a device. [pr] */
3478 if (*name == '_') ++name;
3479 if (tolower(*name++) != 'n') return 0;
3480 if (tolower(*name++) != 'l') return 0;
3481 if (tolower(*name) == 'a') ++name;
3482 if (*name == '0') ++name;
3483 return (*name++ == ':') && (*name != ':');
3486 /* Do the permissions allow some operation? Assumes statcache already set. */
3487 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3488 * subset of the applicable information. (We have to stick with struct
3489 * stat instead of struct mystat in the prototype since we have to match
3490 * the one in proto.h.)
3492 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3494 cando(I32 bit, I32 effective, struct stat *statbufp)
3496 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3498 char fname[NAM$C_MAXRSS+1];
3499 unsigned long int retsts;
3500 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3501 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3503 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3504 device name on successive calls */
3505 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3506 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3507 namdsc.dsc$a_pointer = fname;
3508 namdsc.dsc$w_length = sizeof fname - 1;
3510 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3511 &namdsc,&namdsc.dsc$w_length,0,0);
3513 fname[namdsc.dsc$w_length] = '\0';
3514 return cando_by_name(bit,effective,fname);
3516 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3517 warn("Can't get filespec - stale stat buffer?\n");
3521 return FALSE; /* Should never get to here */
3523 } /* end of cando() */
3527 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3529 cando_by_name(I32 bit, I32 effective, char *fname)
3531 static char usrname[L_cuserid];
3532 static struct dsc$descriptor_s usrdsc =
3533 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3534 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3535 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3536 unsigned short int retlen;
3537 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3538 union prvdef curprv;
3539 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3540 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3541 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3544 if (!fname || !*fname) return FALSE;
3545 /* Make sure we expand logical names, since sys$check_access doesn't */
3546 if (!strpbrk(fname,"/]>:")) {
3547 strcpy(fileified,fname);
3548 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3551 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3552 retlen = namdsc.dsc$w_length = strlen(vmsname);
3553 namdsc.dsc$a_pointer = vmsname;
3554 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3555 vmsname[retlen-1] == ':') {
3556 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3557 namdsc.dsc$w_length = strlen(fileified);
3558 namdsc.dsc$a_pointer = fileified;
3561 if (!usrdsc.dsc$w_length) {
3563 usrdsc.dsc$w_length = strlen(usrname);
3570 access = ARM$M_EXECUTE;
3575 access = ARM$M_READ;
3580 access = ARM$M_WRITE;
3585 access = ARM$M_DELETE;
3591 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3592 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3593 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3594 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3595 set_vaxc_errno(retsts);
3596 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3597 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3598 else set_errno(ENOENT);
3601 if (retsts == SS$_NORMAL) {
3602 if (!privused) return TRUE;
3603 /* We can get access, but only by using privs. Do we have the
3604 necessary privs currently enabled? */
3605 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3606 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3607 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3608 !curprv.prv$v_bypass) return FALSE;
3609 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3610 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3611 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3616 return FALSE; /* Should never get here */
3618 } /* end of cando_by_name() */
3622 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3624 flex_fstat(int fd, struct mystat *statbufp)
3626 if (!fstat(fd,(stat_t *) statbufp)) {
3627 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3628 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3630 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3634 if (!gmtime_emulation_type) (void)time(NULL);
3635 statbufp->st_mtime -= utc_offset_secs;
3636 statbufp->st_atime -= utc_offset_secs;
3637 statbufp->st_ctime -= utc_offset_secs;
3643 } /* end of flex_fstat() */
3646 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3648 flex_stat(char *fspec, struct mystat *statbufp)
3650 char fileified[NAM$C_MAXRSS+1];
3653 if (statbufp == (struct mystat *) &statcache)
3654 do_tovmsspec(fspec,namecache,0);
3655 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3656 memset(statbufp,0,sizeof *statbufp);
3657 statbufp->st_dev = encode_dev("_NLA0:");
3658 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3659 statbufp->st_uid = 0x00010001;
3660 statbufp->st_gid = 0x0001;
3661 time((time_t *)&statbufp->st_mtime);
3662 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3666 /* Try for a directory name first. If fspec contains a filename without
3667 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3668 * and sea:[wine.dark]water. exist, we prefer the directory here.
3669 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3670 * not sea:[wine.dark]., if the latter exists. If the intended target is
3671 * the file with null type, specify this by calling flex_stat() with
3672 * a '.' at the end of fspec.
3674 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3675 retval = stat(fileified,(stat_t *) statbufp);
3676 if (!retval && statbufp == (struct mystat *) &statcache)
3677 strcpy(namecache,fileified);
3679 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3681 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3683 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3687 if (!gmtime_emulation_type) (void)time(NULL);
3688 statbufp->st_mtime -= utc_offset_secs;
3689 statbufp->st_atime -= utc_offset_secs;
3690 statbufp->st_ctime -= utc_offset_secs;
3695 } /* end of flex_stat() */
3698 /* Insures that no carriage-control translation will be done on a file. */
3699 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3701 my_binmode(FILE *fp, char iotype)
3703 char filespec[NAM$C_MAXRSS], *acmode;
3706 if (!fgetname(fp,filespec)) return NULL;
3707 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3709 case '<': case 'r': acmode = "rb"; break;
3711 /* use 'a' instead of 'w' to avoid creating new file;
3712 fsetpos below will take care of restoring file position */
3713 case 'a': acmode = "ab"; break;
3714 case '+': case '|': case 's': acmode = "rb+"; break;
3715 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3717 warn("Unrecognized iotype %c in my_binmode",iotype);
3720 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3721 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3723 } /* end of my_binmode() */
3727 /*{{{char *my_getlogin()*/
3728 /* VMS cuserid == Unix getlogin, except calling sequence */
3732 static char user[L_cuserid];
3733 return cuserid(user);
3738 /* rmscopy - copy a file using VMS RMS routines
3740 * Copies contents and attributes of spec_in to spec_out, except owner
3741 * and protection information. Name and type of spec_in are used as
3742 * defaults for spec_out. The third parameter specifies whether rmscopy()
3743 * should try to propagate timestamps from the input file to the output file.
3744 * If it is less than 0, no timestamps are preserved. If it is 0, then
3745 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3746 * propagated to the output file at creation iff the output file specification
3747 * did not contain an explicit name or type, and the revision date is always
3748 * updated at the end of the copy operation. If it is greater than 0, then
3749 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3750 * other than the revision date should be propagated, and bit 1 indicates
3751 * that the revision date should be propagated.
3753 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3755 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3756 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3757 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3758 * as part of the Perl standard distribution under the terms of the
3759 * GNU General Public License or the Perl Artistic License. Copies
3760 * of each may be found in the Perl standard distribution.
3762 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3764 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3766 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3767 rsa[NAM$C_MAXRSS], ubf[32256];
3768 unsigned long int i, sts, sts2;
3769 struct FAB fab_in, fab_out;
3770 struct RAB rab_in, rab_out;
3772 struct XABDAT xabdat;
3773 struct XABFHC xabfhc;
3774 struct XABRDT xabrdt;
3775 struct XABSUM xabsum;
3777 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3778 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3779 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3783 fab_in = cc$rms_fab;
3784 fab_in.fab$l_fna = vmsin;
3785 fab_in.fab$b_fns = strlen(vmsin);
3786 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3787 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3788 fab_in.fab$l_fop = FAB$M_SQO;
3789 fab_in.fab$l_nam = &nam;
3790 fab_in.fab$l_xab = (void *) &xabdat;
3793 nam.nam$l_rsa = rsa;
3794 nam.nam$b_rss = sizeof(rsa);
3795 nam.nam$l_esa = esa;
3796 nam.nam$b_ess = sizeof (esa);
3797 nam.nam$b_esl = nam.nam$b_rsl = 0;
3799 xabdat = cc$rms_xabdat; /* To get creation date */
3800 xabdat.xab$l_nxt = (void *) &xabfhc;
3802 xabfhc = cc$rms_xabfhc; /* To get record length */
3803 xabfhc.xab$l_nxt = (void *) &xabsum;
3805 xabsum = cc$rms_xabsum; /* To get key and area information */
3807 if (!((sts = sys$open(&fab_in)) & 1)) {
3808 set_vaxc_errno(sts);
3812 set_errno(ENOENT); break;
3814 set_errno(ENODEV); break;
3816 set_errno(EINVAL); break;
3818 set_errno(EACCES); break;
3826 fab_out.fab$w_ifi = 0;
3827 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3828 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3829 fab_out.fab$l_fop = FAB$M_SQO;
3830 fab_out.fab$l_fna = vmsout;
3831 fab_out.fab$b_fns = strlen(vmsout);
3832 fab_out.fab$l_dna = nam.nam$l_name;
3833 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3835 if (preserve_dates == 0) { /* Act like DCL COPY */
3836 nam.nam$b_nop = NAM$M_SYNCHK;
3837 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3838 if (!((sts = sys$parse(&fab_out)) & 1)) {
3839 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3840 set_vaxc_errno(sts);
3843 fab_out.fab$l_xab = (void *) &xabdat;
3844 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3846 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3847 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3848 preserve_dates =0; /* bitmask from this point forward */
3850 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3851 if (!((sts = sys$create(&fab_out)) & 1)) {
3852 set_vaxc_errno(sts);
3855 set_errno(ENOENT); break;
3857 set_errno(ENODEV); break;
3859 set_errno(EINVAL); break;
3861 set_errno(EACCES); break;
3867 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3868 if (preserve_dates & 2) {
3869 /* sys$close() will process xabrdt, not xabdat */
3870 xabrdt = cc$rms_xabrdt;
3872 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3874 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3875 * is unsigned long[2], while DECC & VAXC use a struct */
3876 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3878 fab_out.fab$l_xab = (void *) &xabrdt;
3881 rab_in = cc$rms_rab;
3882 rab_in.rab$l_fab = &fab_in;
3883 rab_in.rab$l_rop = RAB$M_BIO;
3884 rab_in.rab$l_ubf = ubf;
3885 rab_in.rab$w_usz = sizeof ubf;
3886 if (!((sts = sys$connect(&rab_in)) & 1)) {
3887 sys$close(&fab_in); sys$close(&fab_out);
3888 set_errno(EVMSERR); set_vaxc_errno(sts);
3892 rab_out = cc$rms_rab;
3893 rab_out.rab$l_fab = &fab_out;
3894 rab_out.rab$l_rbf = ubf;
3895 if (!((sts = sys$connect(&rab_out)) & 1)) {
3896 sys$close(&fab_in); sys$close(&fab_out);
3897 set_errno(EVMSERR); set_vaxc_errno(sts);
3901 while ((sts = sys$read(&rab_in))) { /* always true */
3902 if (sts == RMS$_EOF) break;
3903 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3904 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3905 sys$close(&fab_in); sys$close(&fab_out);
3906 set_errno(EVMSERR); set_vaxc_errno(sts);
3911 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3912 sys$close(&fab_in); sys$close(&fab_out);
3913 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3915 set_errno(EVMSERR); set_vaxc_errno(sts);
3921 } /* end of rmscopy() */
3925 /*** The following glue provides 'hooks' to make some of the routines
3926 * from this file available from Perl. These routines are sufficiently
3927 * basic, and are required sufficiently early in the build process,
3928 * that's it's nice to have them available to miniperl as well as the
3929 * full Perl, so they're set up here instead of in an extension. The
3930 * Perl code which handles importation of these names into a given
3931 * package lives in [.VMS]Filespec.pm in @INC.
3935 rmsexpand_fromperl(CV *cv)
3938 char *fspec, *defspec = NULL, *rslt;
3940 if (!items || items > 2)
3941 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3942 fspec = SvPV(ST(0),na);
3943 if (!fspec || !*fspec) XSRETURN_UNDEF;
3944 if (items == 2) defspec = SvPV(ST(1),na);
3946 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3947 ST(0) = sv_newmortal();
3948 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3953 vmsify_fromperl(CV *cv)
3958 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3959 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3960 ST(0) = sv_newmortal();
3961 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3966 unixify_fromperl(CV *cv)
3971 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3972 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3973 ST(0) = sv_newmortal();
3974 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3979 fileify_fromperl(CV *cv)
3984 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3985 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3986 ST(0) = sv_newmortal();
3987 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3992 pathify_fromperl(CV *cv)
3997 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3998 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3999 ST(0) = sv_newmortal();
4000 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4005 vmspath_fromperl(CV *cv)
4010 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4011 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4012 ST(0) = sv_newmortal();
4013 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4018 unixpath_fromperl(CV *cv)
4023 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4024 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4025 ST(0) = sv_newmortal();
4026 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4031 candelete_fromperl(CV *cv)
4034 char fspec[NAM$C_MAXRSS+1], *fsp;
4038 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4040 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4041 if (SvTYPE(mysv) == SVt_PVGV) {
4042 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4043 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4050 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4051 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4057 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4062 rmscopy_fromperl(CV *cv)
4065 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4067 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4068 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4069 unsigned long int sts;
4073 if (items < 2 || items > 3)
4074 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4076 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4077 if (SvTYPE(mysv) == SVt_PVGV) {
4078 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4079 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4086 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4087 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4092 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4093 if (SvTYPE(mysv) == SVt_PVGV) {
4094 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4095 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4102 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4103 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4108 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4110 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4117 char* file = __FILE__;
4119 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4120 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4121 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4122 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4123 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4124 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4125 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4126 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4127 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);