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 /*{{{int my_mkdir(char *,mode_t)*/
461 my_mkdir(char *dir, mode_t mode)
463 STRLEN dirlen = strlen(dir);
465 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
466 * null file name/type. However, it's commonplace under Unix,
467 * so we'll allow it for a gain in portability.
469 if (dir[dirlen-1] == '/') {
470 char *newdir = savepvn(dir,dirlen-1);
471 int ret = mkdir(newdir,mode);
475 else return mkdir(dir,mode);
476 } /* end of my_mkdir */
481 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
483 static unsigned long int mbxbufsiz;
484 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
488 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
489 * preprocessor consant BUFSIZ from stdio.h as the size of the
492 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
493 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
495 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
497 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
498 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
500 } /* end of create_mbx() */
502 /*{{{ my_popen and my_pclose*/
505 struct pipe_details *next;
506 PerlIO *fp; /* stdio file pointer to pipe mailbox */
507 int pid; /* PID of subprocess */
508 int mode; /* == 'r' if pipe open for reading */
509 int done; /* subprocess has completed */
510 unsigned long int completion; /* termination status of subprocess */
513 struct exit_control_block
515 struct exit_control_block *flink;
516 unsigned long int (*exit_routine)();
517 unsigned long int arg_count;
518 unsigned long int *status_address;
519 unsigned long int exit_status;
522 static struct pipe_details *open_pipes = NULL;
523 static $DESCRIPTOR(nl_desc, "NL:");
524 static int waitpid_asleep = 0;
526 static unsigned long int
529 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
532 while (open_pipes != NULL) {
533 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
534 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
537 if (!open_pipes->done) /* We tried to be nice . . . */
538 _ckvmssts(sys$delprc(&open_pipes->pid,0));
539 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
540 else if (!(sts & 1)) retsts = sts;
545 static struct exit_control_block pipe_exitblock =
546 {(struct exit_control_block *) 0,
547 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
551 popen_completion_ast(struct pipe_details *thispipe)
553 thispipe->done = TRUE;
554 if (waitpid_asleep) {
561 safe_popen(char *cmd, char *mode)
563 static int handler_set_up = FALSE;
565 unsigned short int chan;
566 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
567 struct pipe_details *info;
568 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
569 DSC$K_CLASS_S, mbxname},
570 cmddsc = {0, DSC$K_DTYPE_T,
574 cmddsc.dsc$w_length=strlen(cmd);
575 cmddsc.dsc$a_pointer=cmd;
576 if (cmddsc.dsc$w_length > 255) {
577 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
581 New(7001,info,1,struct pipe_details);
584 create_mbx(&chan,&namdsc);
586 /* open a FILE* onto it */
587 info->fp = PerlIO_open(mbxname, mode);
589 /* give up other channel onto it */
590 _ckvmssts(sys$dassgn(chan));
600 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
601 0 /* name */, &info->pid, &info->completion,
602 0, popen_completion_ast,info,0,0,0));
605 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
606 0 /* name */, &info->pid, &info->completion,
607 0, popen_completion_ast,info,0,0,0));
610 if (!handler_set_up) {
611 _ckvmssts(sys$dclexh(&pipe_exitblock));
612 handler_set_up = TRUE;
614 info->next=open_pipes; /* prepend to list */
617 forkprocess = info->pid;
619 } /* end of safe_popen */
622 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
624 my_popen(char *cmd, char *mode)
627 TAINT_PROPER("popen");
628 return safe_popen(cmd,mode);
633 /*{{{ I32 my_pclose(FILE *fp)*/
634 I32 my_pclose(FILE *fp)
636 struct pipe_details *info, *last = NULL;
637 unsigned long int retsts;
639 for (info = open_pipes; info != NULL; last = info, info = info->next)
640 if (info->fp == fp) break;
642 if (info == NULL) { /* no such pipe open */
643 set_errno(ECHILD); /* quoth POSIX */
644 set_vaxc_errno(SS$_NONEXPR);
648 /* If we were writing to a subprocess, insure that someone reading from
649 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
650 * produce an EOF record in the mailbox. */
651 if (info->mode != 'r') {
652 char devnam[NAM$C_MAXRSS+1], *cp;
653 unsigned long int chan, iosb[2], retsts, retsts2;
654 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
656 if (fgetname(info->fp,devnam)) {
657 /* It oughta be a mailbox, so fgetname should give just the device
658 * name, but just in case . . . */
659 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
660 devdsc.dsc$w_length = strlen(devnam);
661 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
662 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
663 if (retsts & 1) retsts = iosb[0];
664 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
665 if (retsts & 1) retsts = retsts2;
668 else _ckvmssts(vaxc$errno); /* Should never happen */
670 PerlIO_close(info->fp);
672 if (info->done) retsts = info->completion;
673 else waitpid(info->pid,(int *) &retsts,0);
675 /* remove from list of open pipes */
676 if (last) last->next = info->next;
677 else open_pipes = info->next;
682 } /* end of my_pclose() */
684 /* sort-of waitpid; use only with popen() */
685 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
687 my_waitpid(Pid_t pid, int *statusp, int flags)
689 struct pipe_details *info;
691 for (info = open_pipes; info != NULL; info = info->next)
692 if (info->pid == pid) break;
694 if (info != NULL) { /* we know about this child */
695 while (!info->done) {
700 *statusp = info->completion;
703 else { /* we haven't heard of this child */
704 $DESCRIPTOR(intdsc,"0 00:00:01");
705 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
706 unsigned long int interval[2],sts;
709 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
710 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
711 if (ownerpid != mypid)
712 warn("pid %d not a child",pid);
715 _ckvmssts(sys$bintim(&intdsc,interval));
716 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
717 _ckvmssts(sys$schdwk(0,0,interval,0));
718 _ckvmssts(sys$hiber());
722 /* There's no easy way to find the termination status a child we're
723 * not aware of beforehand. If we're really interested in the future,
724 * we can go looking for a termination mailbox, or chase after the
725 * accounting record for the process.
731 } /* end of waitpid() */
736 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
738 my_gconvert(double val, int ndig, int trail, char *buf)
740 static char __gcvtbuf[DBL_DIG+1];
743 loc = buf ? buf : __gcvtbuf;
745 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
747 sprintf(loc,"%.*g",ndig,val);
753 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
754 return gcvt(val,ndig,loc);
757 loc[0] = '0'; loc[1] = '\0';
765 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
766 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
767 * to expand file specification. Allows for a single default file
768 * specification and a simple mask of options. If outbuf is non-NULL,
769 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
770 * the resultant file specification is placed. If outbuf is NULL, the
771 * resultant file specification is placed into a static buffer.
772 * The third argument, if non-NULL, is taken to be a default file
773 * specification string. The fourth argument is unused at present.
774 * rmesexpand() returns the address of the resultant string if
775 * successful, and NULL on error.
778 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
780 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
781 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
782 struct FAB myfab = cc$rms_fab;
783 struct NAM mynam = cc$rms_nam;
785 unsigned long int retsts, haslower = 0;
787 if (!filespec || !*filespec) {
788 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
792 if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
793 else outbuf = __rmsexpand_retbuf;
796 myfab.fab$l_fna = filespec;
797 myfab.fab$b_fns = strlen(filespec);
798 myfab.fab$l_nam = &mynam;
800 if (defspec && *defspec) {
801 myfab.fab$l_dna = defspec;
802 myfab.fab$b_dns = strlen(defspec);
805 mynam.nam$l_esa = esa;
806 mynam.nam$b_ess = sizeof esa;
807 mynam.nam$l_rsa = outbuf;
808 mynam.nam$b_rss = NAM$C_MAXRSS;
810 retsts = sys$parse(&myfab,0,0);
812 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
813 retsts == RMS$_DEV || retsts == RMS$_DEV) {
814 mynam.nam$b_nop |= NAM$M_SYNCHK;
815 retsts = sys$parse(&myfab,0,0);
816 if (retsts & 1) goto expanded;
818 if (out) Safefree(out);
819 set_vaxc_errno(retsts);
820 if (retsts == RMS$_PRV) set_errno(EACCES);
821 else if (retsts == RMS$_DEV) set_errno(ENODEV);
822 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
823 else set_errno(EVMSERR);
826 retsts = sys$search(&myfab,0,0);
827 if (!(retsts & 1) && retsts != RMS$_FNF) {
828 if (out) Safefree(out);
829 set_vaxc_errno(retsts);
830 if (retsts == RMS$_PRV) set_errno(EACCES);
831 else set_errno(EVMSERR);
835 /* If the input filespec contained any lowercase characters,
836 * downcase the result for compatibility with Unix-minded code. */
838 for (out = myfab.fab$l_fna; *out; out++)
839 if (islower(*out)) { haslower = 1; break; }
840 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
841 else { out = esa; speclen = mynam.nam$b_esl; }
842 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
843 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
844 speclen = mynam.nam$l_ver - out;
845 /* If we just had a directory spec on input, $PARSE "helpfully"
846 * adds an empty name and type for us */
847 if (mynam.nam$l_name == mynam.nam$l_type &&
848 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
849 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
850 speclen = mynam.nam$l_name - out;
852 if (haslower) __mystrtolower(out);
854 /* Have we been working with an expanded, but not resultant, spec? */
855 if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
859 /* External entry points */
860 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
861 { return do_rmsexpand(spec,buf,0,def,opt); }
862 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
863 { return do_rmsexpand(spec,buf,1,def,opt); }
867 ** The following routines are provided to make life easier when
868 ** converting among VMS-style and Unix-style directory specifications.
869 ** All will take input specifications in either VMS or Unix syntax. On
870 ** failure, all return NULL. If successful, the routines listed below
871 ** return a pointer to a buffer containing the appropriately
872 ** reformatted spec (and, therefore, subsequent calls to that routine
873 ** will clobber the result), while the routines of the same names with
874 ** a _ts suffix appended will return a pointer to a mallocd string
875 ** containing the appropriately reformatted spec.
876 ** In all cases, only explicit syntax is altered; no check is made that
877 ** the resulting string is valid or that the directory in question
880 ** fileify_dirspec() - convert a directory spec into the name of the
881 ** directory file (i.e. what you can stat() to see if it's a dir).
882 ** The style (VMS or Unix) of the result is the same as the style
883 ** of the parameter passed in.
884 ** pathify_dirspec() - convert a directory spec into a path (i.e.
885 ** what you prepend to a filename to indicate what directory it's in).
886 ** The style (VMS or Unix) of the result is the same as the style
887 ** of the parameter passed in.
888 ** tounixpath() - convert a directory spec into a Unix-style path.
889 ** tovmspath() - convert a directory spec into a VMS-style path.
890 ** tounixspec() - convert any file spec into a Unix-style file spec.
891 ** tovmsspec() - convert any file spec into a VMS-style spec.
893 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
894 ** Permission is given to distribute this code as part of the Perl
895 ** standard distribution under the terms of the GNU General Public
896 ** License or the Perl Artistic License. Copies of each may be
897 ** found in the Perl standard distribution.
900 static char *do_tounixspec(char *, char *, int);
902 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
903 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
905 static char __fileify_retbuf[NAM$C_MAXRSS+1];
906 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
907 char *retspec, *cp1, *cp2, *lastdir;
908 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
911 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
913 dirlen = strlen(dir);
914 if (dir[dirlen-1] == '/') --dirlen;
917 set_vaxc_errno(RMS$_DIR);
920 if (!strpbrk(dir+1,"/]>:")) {
921 strcpy(trndir,*dir == '/' ? dir + 1: dir);
922 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
924 dirlen = strlen(dir);
927 strncpy(trndir,dir,dirlen);
928 trndir[dirlen] = '\0';
931 /* If we were handed a rooted logical name or spec, treat it like a
932 * simple directory, so that
933 * $ Define myroot dev:[dir.]
934 * ... do_fileify_dirspec("myroot",buf,1) ...
935 * does something useful.
937 if (!strcmp(dir+dirlen-2,".]")) {
938 dir[--dirlen] = '\0';
942 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
943 /* If we've got an explicit filename, we can just shuffle the string. */
944 if (*(cp1+1)) hasfilename = 1;
945 /* Similarly, we can just back up a level if we've got multiple levels
946 of explicit directories in a VMS spec which ends with directories. */
948 for (cp2 = cp1; cp2 > dir; cp2--) {
950 *cp2 = *cp1; *cp1 = '\0';
954 if (*cp2 == '[' || *cp2 == '<') break;
959 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
961 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
962 return do_fileify_dirspec("[]",buf,ts);
963 else if (dir[1] == '.' &&
964 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
965 return do_fileify_dirspec("[-]",buf,ts);
967 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
968 dirlen -= 1; /* to last element */
969 lastdir = strrchr(dir,'/');
971 else if ((cp1 = strstr(dir,"/.")) != NULL) {
972 /* If we have "/." or "/..", VMSify it and let the VMS code
973 * below expand it, rather than repeating the code to handle
974 * relative components of a filespec here */
976 if (*(cp1+2) == '.') cp1++;
977 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
978 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
979 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
980 return do_tounixspec(trndir,buf,ts);
983 } while ((cp1 = strstr(cp1,"/.")) != NULL);
986 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
987 !(lastdir = cp1 = strrchr(dir,']')) &&
988 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
989 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
991 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
992 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
993 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
994 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
995 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
998 set_vaxc_errno(RMS$_DIR);
1004 /* If we lead off with a device or rooted logical, add the MFD
1005 if we're specifying a top-level directory. */
1006 if (lastdir && *dir == '/') {
1008 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1015 retlen = dirlen + (addmfd ? 13 : 6);
1016 if (buf) retspec = buf;
1017 else if (ts) New(7009,retspec,retlen+1,char);
1018 else retspec = __fileify_retbuf;
1020 dirlen = lastdir - dir;
1021 memcpy(retspec,dir,dirlen);
1022 strcpy(&retspec[dirlen],"/000000");
1023 strcpy(&retspec[dirlen+7],lastdir);
1026 memcpy(retspec,dir,dirlen);
1027 retspec[dirlen] = '\0';
1029 /* We've picked up everything up to the directory file name.
1030 Now just add the type and version, and we're set. */
1031 strcat(retspec,".dir;1");
1034 else { /* VMS-style directory spec */
1035 char esa[NAM$C_MAXRSS+1], term, *cp;
1036 unsigned long int sts, cmplen, haslower = 0;
1037 struct FAB dirfab = cc$rms_fab;
1038 struct NAM savnam, dirnam = cc$rms_nam;
1040 dirfab.fab$b_fns = strlen(dir);
1041 dirfab.fab$l_fna = dir;
1042 dirfab.fab$l_nam = &dirnam;
1043 dirfab.fab$l_dna = ".DIR;1";
1044 dirfab.fab$b_dns = 6;
1045 dirnam.nam$b_ess = NAM$C_MAXRSS;
1046 dirnam.nam$l_esa = esa;
1048 for (cp = dir; *cp; cp++)
1049 if (islower(*cp)) { haslower = 1; break; }
1050 if (!((sts = sys$parse(&dirfab))&1)) {
1051 if (dirfab.fab$l_sts == RMS$_DIR) {
1052 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1053 sts = sys$parse(&dirfab) & 1;
1057 set_vaxc_errno(dirfab.fab$l_sts);
1063 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1064 /* Yes; fake the fnb bits so we'll check type below */
1065 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1068 if (dirfab.fab$l_sts != RMS$_FNF) {
1070 set_vaxc_errno(dirfab.fab$l_sts);
1073 dirnam = savnam; /* No; just work with potential name */
1076 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1077 cp1 = strchr(esa,']');
1078 if (!cp1) cp1 = strchr(esa,'>');
1079 if (cp1) { /* Should always be true */
1080 dirnam.nam$b_esl -= cp1 - esa - 1;
1081 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1084 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1085 /* Yep; check version while we're at it, if it's there. */
1086 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1087 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1088 /* Something other than .DIR[;1]. Bzzt. */
1090 set_vaxc_errno(RMS$_DIR);
1094 esa[dirnam.nam$b_esl] = '\0';
1095 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1096 /* They provided at least the name; we added the type, if necessary, */
1097 if (buf) retspec = buf; /* in sys$parse() */
1098 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1099 else retspec = __fileify_retbuf;
1100 strcpy(retspec,esa);
1103 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1104 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1106 dirnam.nam$b_esl -= 9;
1108 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1109 if (cp1 == NULL) return NULL; /* should never happen */
1112 retlen = strlen(esa);
1113 if ((cp1 = strrchr(esa,'.')) != NULL) {
1114 /* There's more than one directory in the path. Just roll back. */
1116 if (buf) retspec = buf;
1117 else if (ts) New(7011,retspec,retlen+7,char);
1118 else retspec = __fileify_retbuf;
1119 strcpy(retspec,esa);
1122 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1123 /* Go back and expand rooted logical name */
1124 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1125 if (!(sys$parse(&dirfab) & 1)) {
1127 set_vaxc_errno(dirfab.fab$l_sts);
1130 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1131 if (buf) retspec = buf;
1132 else if (ts) New(7012,retspec,retlen+16,char);
1133 else retspec = __fileify_retbuf;
1134 cp1 = strstr(esa,"][");
1136 memcpy(retspec,esa,dirlen);
1137 if (!strncmp(cp1+2,"000000]",7)) {
1138 retspec[dirlen-1] = '\0';
1139 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1140 if (*cp1 == '.') *cp1 = ']';
1142 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1143 memcpy(cp1+1,"000000]",7);
1147 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1148 retspec[retlen] = '\0';
1149 /* Convert last '.' to ']' */
1150 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1151 if (*cp1 == '.') *cp1 = ']';
1153 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1154 memcpy(cp1+1,"000000]",7);
1158 else { /* This is a top-level dir. Add the MFD to the path. */
1159 if (buf) retspec = buf;
1160 else if (ts) New(7012,retspec,retlen+16,char);
1161 else retspec = __fileify_retbuf;
1164 while (*cp1 != ':') *(cp2++) = *(cp1++);
1165 strcpy(cp2,":[000000]");
1170 /* We've set up the string up through the filename. Add the
1171 type and version, and we're done. */
1172 strcat(retspec,".DIR;1");
1174 /* $PARSE may have upcased filespec, so convert output to lower
1175 * case if input contained any lowercase characters. */
1176 if (haslower) __mystrtolower(retspec);
1179 } /* end of do_fileify_dirspec() */
1181 /* External entry points */
1182 char *fileify_dirspec(char *dir, char *buf)
1183 { return do_fileify_dirspec(dir,buf,0); }
1184 char *fileify_dirspec_ts(char *dir, char *buf)
1185 { return do_fileify_dirspec(dir,buf,1); }
1187 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1188 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1190 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1191 unsigned long int retlen;
1192 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1194 if (!dir || !*dir) {
1195 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1198 if (*dir) strcpy(trndir,dir);
1199 else getcwd(trndir,sizeof trndir - 1);
1201 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1202 STRLEN trnlen = strlen(trndir);
1204 /* Trap simple rooted lnms, and return lnm:[000000] */
1205 if (!strcmp(trndir+trnlen-2,".]")) {
1206 if (buf) retpath = buf;
1207 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1208 else retpath = __pathify_retbuf;
1209 strcpy(retpath,dir);
1210 strcat(retpath,":[000000]");
1216 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1217 if (*dir == '.' && (*(dir+1) == '\0' ||
1218 (*(dir+1) == '.' && *(dir+2) == '\0')))
1219 retlen = 2 + (*(dir+1) != '\0');
1221 if ( !(cp1 = strrchr(dir,'/')) &&
1222 !(cp1 = strrchr(dir,']')) &&
1223 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1224 if ((cp2 = strchr(cp1,'.')) != NULL &&
1225 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1226 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1227 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1228 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1230 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1231 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1232 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1233 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1234 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1235 (ver || *cp3)))))) {
1237 set_vaxc_errno(RMS$_DIR);
1240 retlen = cp2 - dir + 1;
1242 else { /* No file type present. Treat the filename as a directory. */
1243 retlen = strlen(dir) + 1;
1246 if (buf) retpath = buf;
1247 else if (ts) New(7013,retpath,retlen+1,char);
1248 else retpath = __pathify_retbuf;
1249 strncpy(retpath,dir,retlen-1);
1250 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1251 retpath[retlen-1] = '/'; /* with '/', add it. */
1252 retpath[retlen] = '\0';
1254 else retpath[retlen-1] = '\0';
1256 else { /* VMS-style directory spec */
1257 char esa[NAM$C_MAXRSS+1], *cp;
1258 unsigned long int sts, cmplen, haslower;
1259 struct FAB dirfab = cc$rms_fab;
1260 struct NAM savnam, dirnam = cc$rms_nam;
1262 /* If we've got an explicit filename, we can just shuffle the string. */
1263 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1264 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1265 if ((cp2 = strchr(cp1,'.')) != NULL) {
1267 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1268 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1269 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1270 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1271 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1272 (ver || *cp3)))))) {
1274 set_vaxc_errno(RMS$_DIR);
1278 else { /* No file type, so just draw name into directory part */
1279 for (cp2 = cp1; *cp2; cp2++) ;
1282 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1284 /* We've now got a VMS 'path'; fall through */
1286 dirfab.fab$b_fns = strlen(dir);
1287 dirfab.fab$l_fna = dir;
1288 if (dir[dirfab.fab$b_fns-1] == ']' ||
1289 dir[dirfab.fab$b_fns-1] == '>' ||
1290 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1291 if (buf) retpath = buf;
1292 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1293 else retpath = __pathify_retbuf;
1294 strcpy(retpath,dir);
1297 dirfab.fab$l_dna = ".DIR;1";
1298 dirfab.fab$b_dns = 6;
1299 dirfab.fab$l_nam = &dirnam;
1300 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1301 dirnam.nam$l_esa = esa;
1303 for (cp = dir; *cp; cp++)
1304 if (islower(*cp)) { haslower = 1; break; }
1306 if (!(sts = (sys$parse(&dirfab)&1))) {
1307 if (dirfab.fab$l_sts == RMS$_DIR) {
1308 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1309 sts = sys$parse(&dirfab) & 1;
1313 set_vaxc_errno(dirfab.fab$l_sts);
1319 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1320 if (dirfab.fab$l_sts != RMS$_FNF) {
1322 set_vaxc_errno(dirfab.fab$l_sts);
1325 dirnam = savnam; /* No; just work with potential name */
1328 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1329 /* Yep; check version while we're at it, if it's there. */
1330 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1331 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1332 /* Something other than .DIR[;1]. Bzzt. */
1334 set_vaxc_errno(RMS$_DIR);
1338 /* OK, the type was fine. Now pull any file name into the
1340 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1342 cp1 = strrchr(esa,'>');
1343 *dirnam.nam$l_type = '>';
1346 *(dirnam.nam$l_type + 1) = '\0';
1347 retlen = dirnam.nam$l_type - esa + 2;
1348 if (buf) retpath = buf;
1349 else if (ts) New(7014,retpath,retlen,char);
1350 else retpath = __pathify_retbuf;
1351 strcpy(retpath,esa);
1352 /* $PARSE may have upcased filespec, so convert output to lower
1353 * case if input contained any lowercase characters. */
1354 if (haslower) __mystrtolower(retpath);
1358 } /* end of do_pathify_dirspec() */
1360 /* External entry points */
1361 char *pathify_dirspec(char *dir, char *buf)
1362 { return do_pathify_dirspec(dir,buf,0); }
1363 char *pathify_dirspec_ts(char *dir, char *buf)
1364 { return do_pathify_dirspec(dir,buf,1); }
1366 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1367 static char *do_tounixspec(char *spec, char *buf, int ts)
1369 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1370 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1371 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1373 if (spec == NULL) return NULL;
1374 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1375 if (buf) rslt = buf;
1377 retlen = strlen(spec);
1378 cp1 = strchr(spec,'[');
1379 if (!cp1) cp1 = strchr(spec,'<');
1381 for (cp1++; *cp1; cp1++) {
1382 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1383 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1384 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1387 New(7015,rslt,retlen+2+2*expand,char);
1389 else rslt = __tounixspec_retbuf;
1390 if (strchr(spec,'/') != NULL) {
1397 dirend = strrchr(spec,']');
1398 if (dirend == NULL) dirend = strrchr(spec,'>');
1399 if (dirend == NULL) dirend = strchr(spec,':');
1400 if (dirend == NULL) {
1404 if (*cp2 != '[' && *cp2 != '<') {
1407 else { /* the VMS spec begins with directories */
1409 if (*cp2 == ']' || *cp2 == '>') {
1410 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1413 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1414 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1415 if (ts) Safefree(rslt);
1420 while (*cp3 != ':' && *cp3) cp3++;
1422 if (strchr(cp3,']') != NULL) break;
1423 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1425 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1426 retlen = devlen + dirlen;
1427 Renew(rslt,retlen+1+2*expand,char);
1433 *(cp1++) = *(cp3++);
1434 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1438 else if ( *cp2 == '.') {
1439 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1440 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1446 for (; cp2 <= dirend; cp2++) {
1449 if (*(cp2+1) == '[') cp2++;
1451 else if (*cp2 == ']' || *cp2 == '>') {
1452 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1454 else if (*cp2 == '.') {
1456 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1457 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1458 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1459 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1460 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1462 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1463 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1467 else if (*cp2 == '-') {
1468 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1469 while (*cp2 == '-') {
1471 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1473 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1474 if (ts) Safefree(rslt); /* filespecs like */
1475 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1479 else *(cp1++) = *cp2;
1481 else *(cp1++) = *cp2;
1483 while (*cp2) *(cp1++) = *(cp2++);
1488 } /* end of do_tounixspec() */
1490 /* External entry points */
1491 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1492 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1494 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1495 static char *do_tovmsspec(char *path, char *buf, int ts) {
1496 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1497 char *rslt, *dirend;
1498 register char *cp1, *cp2;
1499 unsigned long int infront = 0, hasdir = 1;
1501 if (path == NULL) return NULL;
1502 if (buf) rslt = buf;
1503 else if (ts) New(7016,rslt,strlen(path)+9,char);
1504 else rslt = __tovmsspec_retbuf;
1505 if (strpbrk(path,"]:>") ||
1506 (dirend = strrchr(path,'/')) == NULL) {
1507 if (path[0] == '.') {
1508 if (path[1] == '\0') strcpy(rslt,"[]");
1509 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1510 else strcpy(rslt,path); /* probably garbage */
1512 else strcpy(rslt,path);
1515 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1516 if (!*(dirend+2)) dirend +=2;
1517 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1518 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1523 char trndev[NAM$C_MAXRSS+1];
1527 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1528 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1530 islnm = my_trnlnm(rslt,trndev,0);
1531 trnend = islnm ? strlen(trndev) - 1 : 0;
1532 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1533 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1534 /* If the first element of the path is a logical name, determine
1535 * whether it has to be translated so we can add more directories. */
1536 if (!islnm || rooted) {
1539 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1543 if (cp2 != dirend) {
1544 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1545 strcpy(rslt,trndev);
1546 cp1 = rslt + trnend;
1559 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1560 cp2 += 2; /* skip over "./" - it's redundant */
1561 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1563 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1564 *(cp1++) = '-'; /* "../" --> "-" */
1567 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1568 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1569 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1570 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1573 if (cp2 > dirend) cp2 = dirend;
1575 else *(cp1++) = '.';
1577 for (; cp2 < dirend; cp2++) {
1579 if (*(cp2-1) == '/') continue;
1580 if (*(cp1-1) != '.') *(cp1++) = '.';
1583 else if (!infront && *cp2 == '.') {
1584 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1585 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1586 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1587 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1588 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1589 else { /* back up over previous directory name */
1591 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1592 if (*(cp1-1) == '[') {
1593 memcpy(cp1,"000000.",7);
1598 if (cp2 == dirend) break;
1600 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1601 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1602 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1603 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1605 *(cp1++) = '.'; /* Simulate trailing '/' */
1606 cp2 += 2; /* for loop will incr this to == dirend */
1608 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1610 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1613 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1614 if (*cp2 == '.') *(cp1++) = '_';
1615 else *(cp1++) = *cp2;
1619 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1620 if (hasdir) *(cp1++) = ']';
1621 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1622 while (*cp2) *(cp1++) = *(cp2++);
1627 } /* end of do_tovmsspec() */
1629 /* External entry points */
1630 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1631 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1633 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1634 static char *do_tovmspath(char *path, char *buf, int ts) {
1635 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1637 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1639 if (path == NULL) return NULL;
1640 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1641 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1642 if (buf) return buf;
1644 vmslen = strlen(vmsified);
1645 New(7017,cp,vmslen+1,char);
1646 memcpy(cp,vmsified,vmslen);
1651 strcpy(__tovmspath_retbuf,vmsified);
1652 return __tovmspath_retbuf;
1655 } /* end of do_tovmspath() */
1657 /* External entry points */
1658 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1659 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1662 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1663 static char *do_tounixpath(char *path, char *buf, int ts) {
1664 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1666 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1668 if (path == NULL) return NULL;
1669 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1670 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1671 if (buf) return buf;
1673 unixlen = strlen(unixified);
1674 New(7017,cp,unixlen+1,char);
1675 memcpy(cp,unixified,unixlen);
1680 strcpy(__tounixpath_retbuf,unixified);
1681 return __tounixpath_retbuf;
1684 } /* end of do_tounixpath() */
1686 /* External entry points */
1687 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1688 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1691 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1693 *****************************************************************************
1695 * Copyright (C) 1989-1994 by *
1696 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1698 * Permission is hereby granted for the reproduction of this software, *
1699 * on condition that this copyright notice is included in the reproduction, *
1700 * and that such reproduction is not for purposes of profit or material *
1703 * 27-Aug-1994 Modified for inclusion in perl5 *
1704 * by Charles Bailey bailey@genetics.upenn.edu *
1705 *****************************************************************************
1709 * getredirection() is intended to aid in porting C programs
1710 * to VMS (Vax-11 C). The native VMS environment does not support
1711 * '>' and '<' I/O redirection, or command line wild card expansion,
1712 * or a command line pipe mechanism using the '|' AND background
1713 * command execution '&'. All of these capabilities are provided to any
1714 * C program which calls this procedure as the first thing in the
1716 * The piping mechanism will probably work with almost any 'filter' type
1717 * of program. With suitable modification, it may useful for other
1718 * portability problems as well.
1720 * Author: Mark Pizzolato mark@infocomm.com
1724 struct list_item *next;
1728 static void add_item(struct list_item **head,
1729 struct list_item **tail,
1733 static void expand_wild_cards(char *item,
1734 struct list_item **head,
1735 struct list_item **tail,
1738 static int background_process(int argc, char **argv);
1740 static void pipe_and_fork(char **cmargv);
1742 /*{{{ void getredirection(int *ac, char ***av)*/
1744 getredirection(int *ac, char ***av)
1746 * Process vms redirection arg's. Exit if any error is seen.
1747 * If getredirection() processes an argument, it is erased
1748 * from the vector. getredirection() returns a new argc and argv value.
1749 * In the event that a background command is requested (by a trailing "&"),
1750 * this routine creates a background subprocess, and simply exits the program.
1752 * Warning: do not try to simplify the code for vms. The code
1753 * presupposes that getredirection() is called before any data is
1754 * read from stdin or written to stdout.
1756 * Normal usage is as follows:
1762 * getredirection(&argc, &argv);
1766 int argc = *ac; /* Argument Count */
1767 char **argv = *av; /* Argument Vector */
1768 char *ap; /* Argument pointer */
1769 int j; /* argv[] index */
1770 int item_count = 0; /* Count of Items in List */
1771 struct list_item *list_head = 0; /* First Item in List */
1772 struct list_item *list_tail; /* Last Item in List */
1773 char *in = NULL; /* Input File Name */
1774 char *out = NULL; /* Output File Name */
1775 char *outmode = "w"; /* Mode to Open Output File */
1776 char *err = NULL; /* Error File Name */
1777 char *errmode = "w"; /* Mode to Open Error File */
1778 int cmargc = 0; /* Piped Command Arg Count */
1779 char **cmargv = NULL;/* Piped Command Arg Vector */
1782 * First handle the case where the last thing on the line ends with
1783 * a '&'. This indicates the desire for the command to be run in a
1784 * subprocess, so we satisfy that desire.
1787 if (0 == strcmp("&", ap))
1788 exit(background_process(--argc, argv));
1789 if (*ap && '&' == ap[strlen(ap)-1])
1791 ap[strlen(ap)-1] = '\0';
1792 exit(background_process(argc, argv));
1795 * Now we handle the general redirection cases that involve '>', '>>',
1796 * '<', and pipes '|'.
1798 for (j = 0; j < argc; ++j)
1800 if (0 == strcmp("<", argv[j]))
1804 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1805 exit(LIB$_WRONUMARG);
1810 if ('<' == *(ap = argv[j]))
1815 if (0 == strcmp(">", ap))
1819 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1820 exit(LIB$_WRONUMARG);
1839 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1840 exit(LIB$_WRONUMARG);
1844 if (('2' == *ap) && ('>' == ap[1]))
1861 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1862 exit(LIB$_WRONUMARG);
1866 if (0 == strcmp("|", argv[j]))
1870 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1871 exit(LIB$_WRONUMARG);
1873 cmargc = argc-(j+1);
1874 cmargv = &argv[j+1];
1878 if ('|' == *(ap = argv[j]))
1886 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1889 * Allocate and fill in the new argument vector, Some Unix's terminate
1890 * the list with an extra null pointer.
1892 New(7002, argv, item_count+1, char *);
1894 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1895 argv[j] = list_head->value;
1901 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1902 exit(LIB$_INVARGORD);
1904 pipe_and_fork(cmargv);
1907 /* Check for input from a pipe (mailbox) */
1909 if (in == NULL && 1 == isapipe(0))
1911 char mbxname[L_tmpnam];
1913 long int dvi_item = DVI$_DEVBUFSIZ;
1914 $DESCRIPTOR(mbxnam, "");
1915 $DESCRIPTOR(mbxdevnam, "");
1917 /* Input from a pipe, reopen it in binary mode to disable */
1918 /* carriage control processing. */
1920 PerlIO_getname(stdin, mbxname);
1921 mbxnam.dsc$a_pointer = mbxname;
1922 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1923 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1924 mbxdevnam.dsc$a_pointer = mbxname;
1925 mbxdevnam.dsc$w_length = sizeof(mbxname);
1926 dvi_item = DVI$_DEVNAM;
1927 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1928 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1931 freopen(mbxname, "rb", stdin);
1934 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1938 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1940 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1943 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1945 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
1950 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1952 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
1956 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1961 #ifdef ARGPROC_DEBUG
1962 PerlIO_printf(Perl_debug_log, "Arglist:\n");
1963 for (j = 0; j < *ac; ++j)
1964 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1966 /* Clear errors we may have hit expanding wildcards, so they don't
1967 show up in Perl's $! later */
1968 set_errno(0); set_vaxc_errno(1);
1969 } /* end of getredirection() */
1972 static void add_item(struct list_item **head,
1973 struct list_item **tail,
1979 New(7003,*head,1,struct list_item);
1983 New(7004,(*tail)->next,1,struct list_item);
1984 *tail = (*tail)->next;
1986 (*tail)->value = value;
1990 static void expand_wild_cards(char *item,
1991 struct list_item **head,
1992 struct list_item **tail,
1996 unsigned long int context = 0;
2002 char vmsspec[NAM$C_MAXRSS+1];
2003 $DESCRIPTOR(filespec, "");
2004 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2005 $DESCRIPTOR(resultspec, "");
2006 unsigned long int zero = 0, sts;
2008 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2010 add_item(head, tail, item, count);
2013 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2014 resultspec.dsc$b_class = DSC$K_CLASS_D;
2015 resultspec.dsc$a_pointer = NULL;
2016 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2017 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2018 if (!isunix || !filespec.dsc$a_pointer)
2019 filespec.dsc$a_pointer = item;
2020 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2022 * Only return version specs, if the caller specified a version
2024 had_version = strchr(item, ';');
2026 * Only return device and directory specs, if the caller specifed either.
2028 had_device = strchr(item, ':');
2029 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2031 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2032 &defaultspec, 0, 0, &zero))))
2037 New(7005,string,resultspec.dsc$w_length+1,char);
2038 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2039 string[resultspec.dsc$w_length] = '\0';
2040 if (NULL == had_version)
2041 *((char *)strrchr(string, ';')) = '\0';
2042 if ((!had_directory) && (had_device == NULL))
2044 if (NULL == (devdir = strrchr(string, ']')))
2045 devdir = strrchr(string, '>');
2046 strcpy(string, devdir + 1);
2049 * Be consistent with what the C RTL has already done to the rest of
2050 * the argv items and lowercase all of these names.
2052 for (c = string; *c; ++c)
2055 if (isunix) trim_unixpath(string,item,1);
2056 add_item(head, tail, string, count);
2059 if (sts != RMS$_NMF)
2061 set_vaxc_errno(sts);
2067 set_errno(ENOENT); break;
2069 set_errno(ENODEV); break;
2072 set_errno(EINVAL); break;
2074 set_errno(EACCES); break;
2076 _ckvmssts_noperl(sts);
2080 add_item(head, tail, item, count);
2081 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2082 _ckvmssts_noperl(lib$find_file_end(&context));
2085 static int child_st[2];/* Event Flag set when child process completes */
2087 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2089 static unsigned long int exit_handler(int *status)
2093 if (0 == child_st[0])
2095 #ifdef ARGPROC_DEBUG
2096 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2098 fflush(stdout); /* Have to flush pipe for binary data to */
2099 /* terminate properly -- <tp@mccall.com> */
2100 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2101 sys$dassgn(child_chan);
2103 sys$synch(0, child_st);
2108 static void sig_child(int chan)
2110 #ifdef ARGPROC_DEBUG
2111 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2113 if (child_st[0] == 0)
2117 static struct exit_control_block exit_block =
2122 &exit_block.exit_status,
2126 static void pipe_and_fork(char **cmargv)
2129 $DESCRIPTOR(cmddsc, "");
2130 static char mbxname[64];
2131 $DESCRIPTOR(mbxdsc, mbxname);
2133 unsigned long int zero = 0, one = 1;
2135 strcpy(subcmd, cmargv[0]);
2136 for (j = 1; NULL != cmargv[j]; ++j)
2138 strcat(subcmd, " \"");
2139 strcat(subcmd, cmargv[j]);
2140 strcat(subcmd, "\"");
2142 cmddsc.dsc$a_pointer = subcmd;
2143 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2145 create_mbx(&child_chan,&mbxdsc);
2146 #ifdef ARGPROC_DEBUG
2147 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2148 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2150 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2151 0, &pid, child_st, &zero, sig_child,
2153 #ifdef ARGPROC_DEBUG
2154 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2156 sys$dclexh(&exit_block);
2157 if (NULL == freopen(mbxname, "wb", stdout))
2159 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2163 static int background_process(int argc, char **argv)
2165 char command[2048] = "$";
2166 $DESCRIPTOR(value, "");
2167 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2168 static $DESCRIPTOR(null, "NLA0:");
2169 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2171 $DESCRIPTOR(pidstr, "");
2173 unsigned long int flags = 17, one = 1, retsts;
2175 strcat(command, argv[0]);
2178 strcat(command, " \"");
2179 strcat(command, *(++argv));
2180 strcat(command, "\"");
2182 value.dsc$a_pointer = command;
2183 value.dsc$w_length = strlen(value.dsc$a_pointer);
2184 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2185 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2186 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2187 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2190 _ckvmssts_noperl(retsts);
2192 #ifdef ARGPROC_DEBUG
2193 PerlIO_printf(Perl_debug_log, "%s\n", command);
2195 sprintf(pidstring, "%08X", pid);
2196 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2197 pidstr.dsc$a_pointer = pidstring;
2198 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2199 lib$set_symbol(&pidsymbol, &pidstr);
2203 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2206 * Trim Unix-style prefix off filespec, so it looks like what a shell
2207 * glob expansion would return (i.e. from specified prefix on, not
2208 * full path). Note that returned filespec is Unix-style, regardless
2209 * of whether input filespec was VMS-style or Unix-style.
2211 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2212 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2213 * vector of options; at present, only bit 0 is used, and if set tells
2214 * trim unixpath to try the current default directory as a prefix when
2215 * presented with a possibly ambiguous ... wildcard.
2217 * Returns !=0 on success, with trimmed filespec replacing contents of
2218 * fspec, and 0 on failure, with contents of fpsec unchanged.
2220 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2222 trim_unixpath(char *fspec, char *wildspec, int opts)
2224 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2225 *template, *base, *end, *cp1, *cp2;
2226 register int tmplen, reslen = 0, dirs = 0;
2228 if (!wildspec || !fspec) return 0;
2229 if (strpbrk(wildspec,"]>:") != NULL) {
2230 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2231 else template = unixwild;
2233 else template = wildspec;
2234 if (strpbrk(fspec,"]>:") != NULL) {
2235 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2236 else base = unixified;
2237 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2238 * check to see that final result fits into (isn't longer than) fspec */
2239 reslen = strlen(fspec);
2243 /* No prefix or absolute path on wildcard, so nothing to remove */
2244 if (!*template || *template == '/') {
2245 if (base == fspec) return 1;
2246 tmplen = strlen(unixified);
2247 if (tmplen > reslen) return 0; /* not enough space */
2248 /* Copy unixified resultant, including trailing NUL */
2249 memmove(fspec,unixified,tmplen+1);
2253 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2254 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2255 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2256 for (cp1 = end ;cp1 >= base; cp1--)
2257 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2259 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2263 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2264 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2265 int ells = 1, totells, segdirs, match;
2266 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2267 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2269 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2271 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2272 if (ellipsis == template && opts & 1) {
2273 /* Template begins with an ellipsis. Since we can't tell how many
2274 * directory names at the front of the resultant to keep for an
2275 * arbitrary starting point, we arbitrarily choose the current
2276 * default directory as a starting point. If it's there as a prefix,
2277 * clip it off. If not, fall through and act as if the leading
2278 * ellipsis weren't there (i.e. return shortest possible path that
2279 * could match template).
2281 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2282 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2283 if (_tolower(*cp1) != _tolower(*cp2)) break;
2284 segdirs = dirs - totells; /* Min # of dirs we must have left */
2285 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2286 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2287 memcpy(fspec,cp2+1,end - cp2);
2291 /* First off, back up over constant elements at end of path */
2293 for (front = end ; front >= base; front--)
2294 if (*front == '/' && !dirs--) { front++; break; }
2296 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2297 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2298 if (cp1 != '\0') return 0; /* Path too long. */
2300 *cp2 = '\0'; /* Pick up with memcpy later */
2301 lcfront = lcres + (front - base);
2302 /* Now skip over each ellipsis and try to match the path in front of it. */
2304 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2305 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2306 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2307 if (cp1 < template) break; /* template started with an ellipsis */
2308 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2309 ellipsis = cp1; continue;
2311 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2313 for (segdirs = 0, cp2 = tpl;
2314 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2316 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2317 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2318 if (*cp2 == '/') segdirs++;
2320 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2321 /* Back up at least as many dirs as in template before matching */
2322 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2323 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2324 for (match = 0; cp1 > lcres;) {
2325 resdsc.dsc$a_pointer = cp1;
2326 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2328 if (match == 1) lcfront = cp1;
2330 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2332 if (!match) return 0; /* Can't find prefix ??? */
2333 if (match > 1 && opts & 1) {
2334 /* This ... wildcard could cover more than one set of dirs (i.e.
2335 * a set of similar dir names is repeated). If the template
2336 * contains more than 1 ..., upstream elements could resolve the
2337 * ambiguity, but it's not worth a full backtracking setup here.
2338 * As a quick heuristic, clip off the current default directory
2339 * if it's present to find the trimmed spec, else use the
2340 * shortest string that this ... could cover.
2342 char def[NAM$C_MAXRSS+1], *st;
2344 if (getcwd(def, sizeof def,0) == NULL) return 0;
2345 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2346 if (_tolower(*cp1) != _tolower(*cp2)) break;
2347 segdirs = dirs - totells; /* Min # of dirs we must have left */
2348 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2349 if (*cp1 == '\0' && *cp2 == '/') {
2350 memcpy(fspec,cp2+1,end - cp2);
2353 /* Nope -- stick with lcfront from above and keep going. */
2356 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2361 } /* end of trim_unixpath() */
2366 * VMS readdir() routines.
2367 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2369 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2370 * Minor modifications to original routines.
2373 /* Number of elements in vms_versions array */
2374 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2377 * Open a directory, return a handle for later use.
2379 /*{{{ DIR *opendir(char*name) */
2384 char dir[NAM$C_MAXRSS+1];
2386 /* Get memory for the handle, and the pattern. */
2388 if (do_tovmspath(name,dir,0) == NULL) {
2389 Safefree((char *)dd);
2392 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2394 /* Fill in the fields; mainly playing with the descriptor. */
2395 (void)sprintf(dd->pattern, "%s*.*",dir);
2398 dd->vms_wantversions = 0;
2399 dd->pat.dsc$a_pointer = dd->pattern;
2400 dd->pat.dsc$w_length = strlen(dd->pattern);
2401 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2402 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2405 } /* end of opendir() */
2409 * Set the flag to indicate we want versions or not.
2411 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2413 vmsreaddirversions(DIR *dd, int flag)
2415 dd->vms_wantversions = flag;
2420 * Free up an opened directory.
2422 /*{{{ void closedir(DIR *dd)*/
2426 (void)lib$find_file_end(&dd->context);
2427 Safefree(dd->pattern);
2428 Safefree((char *)dd);
2433 * Collect all the version numbers for the current file.
2439 struct dsc$descriptor_s pat;
2440 struct dsc$descriptor_s res;
2442 char *p, *text, buff[sizeof dd->entry.d_name];
2444 unsigned long context, tmpsts;
2446 /* Convenient shorthand. */
2449 /* Add the version wildcard, ignoring the "*.*" put on before */
2450 i = strlen(dd->pattern);
2451 New(7008,text,i + e->d_namlen + 3,char);
2452 (void)strcpy(text, dd->pattern);
2453 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2455 /* Set up the pattern descriptor. */
2456 pat.dsc$a_pointer = text;
2457 pat.dsc$w_length = i + e->d_namlen - 1;
2458 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2459 pat.dsc$b_class = DSC$K_CLASS_S;
2461 /* Set up result descriptor. */
2462 res.dsc$a_pointer = buff;
2463 res.dsc$w_length = sizeof buff - 2;
2464 res.dsc$b_dtype = DSC$K_DTYPE_T;
2465 res.dsc$b_class = DSC$K_CLASS_S;
2467 /* Read files, collecting versions. */
2468 for (context = 0, e->vms_verscount = 0;
2469 e->vms_verscount < VERSIZE(e);
2470 e->vms_verscount++) {
2471 tmpsts = lib$find_file(&pat, &res, &context);
2472 if (tmpsts == RMS$_NMF || context == 0) break;
2474 buff[sizeof buff - 1] = '\0';
2475 if ((p = strchr(buff, ';')))
2476 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2478 e->vms_versions[e->vms_verscount] = -1;
2481 _ckvmssts(lib$find_file_end(&context));
2484 } /* end of collectversions() */
2487 * Read the next entry from the directory.
2489 /*{{{ struct dirent *readdir(DIR *dd)*/
2493 struct dsc$descriptor_s res;
2494 char *p, buff[sizeof dd->entry.d_name];
2495 unsigned long int tmpsts;
2497 /* Set up result descriptor, and get next file. */
2498 res.dsc$a_pointer = buff;
2499 res.dsc$w_length = sizeof buff - 2;
2500 res.dsc$b_dtype = DSC$K_DTYPE_T;
2501 res.dsc$b_class = DSC$K_CLASS_S;
2502 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2503 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2504 if (!(tmpsts & 1)) {
2505 set_vaxc_errno(tmpsts);
2508 set_errno(EACCES); break;
2510 set_errno(ENODEV); break;
2513 set_errno(ENOENT); break;
2520 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2521 buff[sizeof buff - 1] = '\0';
2522 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2525 /* Skip any directory component and just copy the name. */
2526 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2527 else (void)strcpy(dd->entry.d_name, buff);
2529 /* Clobber the version. */
2530 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2532 dd->entry.d_namlen = strlen(dd->entry.d_name);
2533 dd->entry.vms_verscount = 0;
2534 if (dd->vms_wantversions) collectversions(dd);
2537 } /* end of readdir() */
2541 * Return something that can be used in a seekdir later.
2543 /*{{{ long telldir(DIR *dd)*/
2552 * Return to a spot where we used to be. Brute force.
2554 /*{{{ void seekdir(DIR *dd,long count)*/
2556 seekdir(DIR *dd, long count)
2558 int vms_wantversions;
2560 /* If we haven't done anything yet... */
2564 /* Remember some state, and clear it. */
2565 vms_wantversions = dd->vms_wantversions;
2566 dd->vms_wantversions = 0;
2567 _ckvmssts(lib$find_file_end(&dd->context));
2570 /* The increment is in readdir(). */
2571 for (dd->count = 0; dd->count < count; )
2574 dd->vms_wantversions = vms_wantversions;
2576 } /* end of seekdir() */
2579 /* VMS subprocess management
2581 * my_vfork() - just a vfork(), after setting a flag to record that
2582 * the current script is trying a Unix-style fork/exec.
2584 * vms_do_aexec() and vms_do_exec() are called in response to the
2585 * perl 'exec' function. If this follows a vfork call, then they
2586 * call out the the regular perl routines in doio.c which do an
2587 * execvp (for those who really want to try this under VMS).
2588 * Otherwise, they do exactly what the perl docs say exec should
2589 * do - terminate the current script and invoke a new command
2590 * (See below for notes on command syntax.)
2592 * do_aspawn() and do_spawn() implement the VMS side of the perl
2593 * 'system' function.
2595 * Note on command arguments to perl 'exec' and 'system': When handled
2596 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2597 * are concatenated to form a DCL command string. If the first arg
2598 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2599 * the the command string is hrnded off to DCL directly. Otherwise,
2600 * the first token of the command is taken as the filespec of an image
2601 * to run. The filespec is expanded using a default type of '.EXE' and
2602 * the process defaults for device, directory, etc., and the resultant
2603 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2604 * the command string as parameters. This is perhaps a bit compicated,
2605 * but I hope it will form a happy medium between what VMS folks expect
2606 * from lib$spawn and what Unix folks expect from exec.
2609 static int vfork_called;
2611 /*{{{int my_vfork()*/
2621 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2629 if (VMScmd.dsc$a_pointer) {
2630 Safefree(VMScmd.dsc$a_pointer);
2631 VMScmd.dsc$w_length = 0;
2632 VMScmd.dsc$a_pointer = Nullch;
2637 setup_argstr(SV *really, SV **mark, SV **sp)
2639 char *junk, *tmps = Nullch;
2640 register size_t cmdlen = 0;
2646 tmps = SvPV(really,rlen);
2653 for (idx++; idx <= sp; idx++) {
2655 junk = SvPVx(*idx,rlen);
2656 cmdlen += rlen ? rlen + 1 : 0;
2659 New(401,Cmd,cmdlen+1,char);
2661 if (tmps && *tmps) {
2666 while (++mark <= sp) {
2669 strcat(Cmd,SvPVx(*mark,na));
2674 } /* end of setup_argstr() */
2677 static unsigned long int
2678 setup_cmddsc(char *cmd, int check_img)
2680 char resspec[NAM$C_MAXRSS+1];
2681 $DESCRIPTOR(defdsc,".EXE");
2682 $DESCRIPTOR(resdsc,resspec);
2683 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2684 unsigned long int cxt = 0, flags = 1, retsts;
2685 register char *s, *rest, *cp;
2686 register int isdcl = 0;
2689 while (*s && isspace(*s)) s++;
2691 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2692 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2693 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2694 if (*cp == ':' || *cp == '[' || *cp == '<') {
2702 if (isdcl) { /* It's a DCL command, just do it. */
2703 VMScmd.dsc$w_length = strlen(cmd);
2705 VMScmd.dsc$a_pointer = Cmd;
2706 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2708 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2710 else { /* assume first token is an image spec */
2712 while (*s && !isspace(*s)) s++;
2714 imgdsc.dsc$a_pointer = cmd;
2715 imgdsc.dsc$w_length = s - cmd;
2716 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2717 if (!(retsts & 1)) {
2718 /* just hand off status values likely to be due to user error */
2719 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2720 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2721 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2722 else { _ckvmssts(retsts); }
2725 _ckvmssts(lib$find_file_end(&cxt));
2727 while (*s && !isspace(*s)) s++;
2729 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2730 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2731 strcat(VMScmd.dsc$a_pointer,resspec);
2732 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2733 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2737 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2739 } /* end of setup_cmddsc() */
2742 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2744 vms_do_aexec(SV *really,SV **mark,SV **sp)
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_aexec(really,mark,sp);
2755 /* no vfork - act VMSish */
2756 return vms_do_exec(setup_argstr(really,mark,sp));
2761 } /* end of vms_do_aexec() */
2764 /* {{{bool vms_do_exec(char *cmd) */
2766 vms_do_exec(char *cmd)
2769 if (vfork_called) { /* this follows a vfork - act Unixish */
2771 if (vfork_called < 0) {
2772 warn("Internal inconsistency in tracking vforks");
2775 else return do_exec(cmd);
2778 { /* no vfork - act VMSish */
2779 unsigned long int retsts;
2782 TAINT_PROPER("exec");
2783 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2784 retsts = lib$do_command(&VMScmd);
2787 set_vaxc_errno(retsts);
2789 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2795 } /* end of vms_do_exec() */
2798 unsigned long int do_spawn(char *);
2800 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2802 do_aspawn(SV *really,SV **mark,SV **sp)
2804 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2807 } /* end of do_aspawn() */
2810 /* {{{unsigned long int do_spawn(char *cmd) */
2814 unsigned long int substs, hadcmd = 1;
2817 TAINT_PROPER("spawn");
2818 if (!cmd || !*cmd) {
2820 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2822 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2823 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2828 set_vaxc_errno(substs);
2830 warn("Can't spawn \"%s\": %s",
2831 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2836 } /* end of do_spawn() */
2840 * A simple fwrite replacement which outputs itmsz*nitm chars without
2841 * introducing record boundaries every itmsz chars.
2843 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2845 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2847 register char *cp, *end;
2849 end = (char *)src + itmsz * nitm;
2851 while ((char *)src <= end) {
2852 for (cp = src; cp <= end; cp++) if (!*cp) break;
2853 if (fputs(src,dest) == EOF) return EOF;
2855 if (fputc('\0',dest) == EOF) return EOF;
2861 } /* end of my_fwrite() */
2865 * Here are replacements for the following Unix routines in the VMS environment:
2866 * getpwuid Get information for a particular UIC or UID
2867 * getpwnam Get information for a named user
2868 * getpwent Get information for each user in the rights database
2869 * setpwent Reset search to the start of the rights database
2870 * endpwent Finish searching for users in the rights database
2872 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2873 * (defined in pwd.h), which contains the following fields:-
2875 * char *pw_name; Username (in lower case)
2876 * char *pw_passwd; Hashed password
2877 * unsigned int pw_uid; UIC
2878 * unsigned int pw_gid; UIC group number
2879 * char *pw_unixdir; Default device/directory (VMS-style)
2880 * char *pw_gecos; Owner name
2881 * char *pw_dir; Default device/directory (Unix-style)
2882 * char *pw_shell; Default CLI name (eg. DCL)
2884 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2886 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2887 * not the UIC member number (eg. what's returned by getuid()),
2888 * getpwuid() can accept either as input (if uid is specified, the caller's
2889 * UIC group is used), though it won't recognise gid=0.
2891 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2892 * information about other users in your group or in other groups, respectively.
2893 * If the required privilege is not available, then these routines fill only
2894 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2897 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2900 /* sizes of various UAF record fields */
2901 #define UAI$S_USERNAME 12
2902 #define UAI$S_IDENT 31
2903 #define UAI$S_OWNER 31
2904 #define UAI$S_DEFDEV 31
2905 #define UAI$S_DEFDIR 63
2906 #define UAI$S_DEFCLI 31
2909 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2910 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2911 (uic).uic$v_group != UIC$K_WILD_GROUP)
2913 static char __empty[]= "";
2914 static struct passwd __passwd_empty=
2915 {(char *) __empty, (char *) __empty, 0, 0,
2916 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2917 static int contxt= 0;
2918 static struct passwd __pwdcache;
2919 static char __pw_namecache[UAI$S_IDENT+1];
2922 * This routine does most of the work extracting the user information.
2924 static int fillpasswd (const char *name, struct passwd *pwd)
2927 unsigned char length;
2928 char pw_gecos[UAI$S_OWNER+1];
2930 static union uicdef uic;
2932 unsigned char length;
2933 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2936 unsigned char length;
2937 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2940 unsigned char length;
2941 char pw_shell[UAI$S_DEFCLI+1];
2943 static char pw_passwd[UAI$S_PWD+1];
2945 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2946 struct dsc$descriptor_s name_desc;
2947 unsigned long int sts;
2949 static struct itmlst_3 itmlst[]= {
2950 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2951 {sizeof(uic), UAI$_UIC, &uic, &luic},
2952 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2953 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2954 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2955 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2956 {0, 0, NULL, NULL}};
2958 name_desc.dsc$w_length= strlen(name);
2959 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2960 name_desc.dsc$b_class= DSC$K_CLASS_S;
2961 name_desc.dsc$a_pointer= (char *) name;
2963 /* Note that sys$getuai returns many fields as counted strings. */
2964 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2965 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2966 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2968 else { _ckvmssts(sts); }
2969 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2971 if ((int) owner.length < lowner) lowner= (int) owner.length;
2972 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2973 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2974 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2975 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2976 owner.pw_gecos[lowner]= '\0';
2977 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2978 defcli.pw_shell[ldefcli]= '\0';
2979 if (valid_uic(uic)) {
2980 pwd->pw_uid= uic.uic$l_uic;
2981 pwd->pw_gid= uic.uic$v_group;
2984 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2985 pwd->pw_passwd= pw_passwd;
2986 pwd->pw_gecos= owner.pw_gecos;
2987 pwd->pw_dir= defdev.pw_dir;
2988 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2989 pwd->pw_shell= defcli.pw_shell;
2990 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2992 ldir= strlen(pwd->pw_unixdir) - 1;
2993 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2996 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2997 __mystrtolower(pwd->pw_unixdir);
3002 * Get information for a named user.
3004 /*{{{struct passwd *getpwnam(char *name)*/
3005 struct passwd *my_getpwnam(char *name)
3007 struct dsc$descriptor_s name_desc;
3009 unsigned long int status, sts;
3011 __pwdcache = __passwd_empty;
3012 if (!fillpasswd(name, &__pwdcache)) {
3013 /* We still may be able to determine pw_uid and pw_gid */
3014 name_desc.dsc$w_length= strlen(name);
3015 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3016 name_desc.dsc$b_class= DSC$K_CLASS_S;
3017 name_desc.dsc$a_pointer= (char *) name;
3018 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3019 __pwdcache.pw_uid= uic.uic$l_uic;
3020 __pwdcache.pw_gid= uic.uic$v_group;
3023 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3024 set_vaxc_errno(sts);
3025 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3028 else { _ckvmssts(sts); }
3031 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3032 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3033 __pwdcache.pw_name= __pw_namecache;
3035 } /* end of my_getpwnam() */
3039 * Get information for a particular UIC or UID.
3040 * Called by my_getpwent with uid=-1 to list all users.
3042 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3043 struct passwd *my_getpwuid(Uid_t uid)
3045 const $DESCRIPTOR(name_desc,__pw_namecache);
3046 unsigned short lname;
3048 unsigned long int status;
3050 if (uid == (unsigned int) -1) {
3052 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3053 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3054 set_vaxc_errno(status);
3055 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3059 else { _ckvmssts(status); }
3060 } while (!valid_uic (uic));
3064 if (!uic.uic$v_group)
3065 uic.uic$v_group= getgid();
3067 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3068 else status = SS$_IVIDENT;
3069 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3070 status == RMS$_PRV) {
3071 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3074 else { _ckvmssts(status); }
3076 __pw_namecache[lname]= '\0';
3077 __mystrtolower(__pw_namecache);
3079 __pwdcache = __passwd_empty;
3080 __pwdcache.pw_name = __pw_namecache;
3082 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3083 The identifier's value is usually the UIC, but it doesn't have to be,
3084 so if we can, we let fillpasswd update this. */
3085 __pwdcache.pw_uid = uic.uic$l_uic;
3086 __pwdcache.pw_gid = uic.uic$v_group;
3088 fillpasswd(__pw_namecache, &__pwdcache);
3091 } /* end of my_getpwuid() */
3095 * Get information for next user.
3097 /*{{{struct passwd *my_getpwent()*/
3098 struct passwd *my_getpwent()
3100 return (my_getpwuid((unsigned int) -1));
3105 * Finish searching rights database for users.
3107 /*{{{void my_endpwent()*/
3111 _ckvmssts(sys$finish_rdb(&contxt));
3118 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3119 * my_utime(), and flex_stat(), all of which operate on UTC unless
3120 * VMSISH_TIMES is true.
3122 /* method used to handle UTC conversions:
3123 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3125 static int gmtime_emulation_type;
3126 /* number of secs to add to UTC POSIX-style time to get local time */
3127 static long int utc_offset_secs;
3129 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3130 * in vmsish.h. #undef them here so we can call the CRTL routines
3137 /* my_time(), my_localtime(), my_gmtime()
3138 * By default traffic in UTC time values, suing CRTL gmtime() or
3139 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3140 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3141 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3144 /*{{{time_t my_time(time_t *timep)*/
3145 time_t my_time(time_t *timep)
3149 if (gmtime_emulation_type == 0) {
3151 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3153 gmtime_emulation_type++;
3154 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3157 gmtime_emulation_type++;
3158 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3159 gmtime_emulation_type++;
3160 warn("no UTC offset information; assuming local time is UTC");
3162 else { utc_offset_secs = atol(off); }
3164 else { /* We've got a working gmtime() */
3165 struct tm gmt, local;
3168 tm_p = localtime(&base);
3170 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3171 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3172 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3173 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3182 when != -1) when -= utc_offset_secs;
3183 if (timep != NULL) *timep = when;
3186 } /* end of my_time() */
3190 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3192 my_gmtime(const time_t *timep)
3197 if (timep == NULL) {
3198 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3201 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3202 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3206 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3208 /* CRTL localtime() wants local time as input, so does no tz correction */
3209 return localtime(&when);
3211 } /* end of my_gmtime() */
3215 /*{{{struct tm *my_localtime(const time_t *timep)*/
3217 my_localtime(const time_t *timep)
3221 if (timep == NULL) {
3222 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3225 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3226 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3230 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3232 /* CRTL localtime() wants local time as input, so does no tz correction */
3233 return localtime(&when);
3235 } /* end of my_localtime() */
3238 /* Reset definitions for later calls */
3239 #define gmtime(t) my_gmtime(t)
3240 #define localtime(t) my_localtime(t)
3241 #define time(t) my_time(t)
3244 /* my_utime - update modification time of a file
3245 * calling sequence is identical to POSIX utime(), but under
3246 * VMS only the modification time is changed; ODS-2 does not
3247 * maintain access times. Restrictions differ from the POSIX
3248 * definition in that the time can be changed as long as the
3249 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3250 * no separate checks are made to insure that the caller is the
3251 * owner of the file or has special privs enabled.
3252 * Code here is based on Joe Meadows' FILE utility.
3255 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3256 * to VMS epoch (01-JAN-1858 00:00:00.00)
3257 * in 100 ns intervals.
3259 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3261 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3262 int my_utime(char *file, struct utimbuf *utimes)
3265 long int bintime[2], len = 2, lowbit, unixtime,
3266 secscale = 10000000; /* seconds --> 100 ns intervals */
3267 unsigned long int chan, iosb[2], retsts;
3268 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3269 struct FAB myfab = cc$rms_fab;
3270 struct NAM mynam = cc$rms_nam;
3271 #if defined (__DECC) && defined (__VAX)
3272 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3273 * at least through VMS V6.1, which causes a type-conversion warning.
3275 # pragma message save
3276 # pragma message disable cvtdiftypes
3278 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3279 struct fibdef myfib;
3280 #if defined (__DECC) && defined (__VAX)
3281 /* This should be right after the declaration of myatr, but due
3282 * to a bug in VAX DEC C, this takes effect a statement early.
3284 # pragma message restore
3286 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3287 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3288 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3290 if (file == NULL || *file == '\0') {
3292 set_vaxc_errno(LIB$_INVARG);
3295 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3297 if (utimes != NULL) {
3298 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3299 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3300 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3301 * as input, we force the sign bit to be clear by shifting unixtime right
3302 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3304 lowbit = (utimes->modtime & 1) ? secscale : 0;
3305 unixtime = (long int) utimes->modtime;
3307 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3308 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3309 unixtime += utc_offset_secs;
3312 unixtime >> 1; secscale << 1;
3313 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3314 if (!(retsts & 1)) {
3316 set_vaxc_errno(retsts);
3319 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3320 if (!(retsts & 1)) {
3322 set_vaxc_errno(retsts);
3327 /* Just get the current time in VMS format directly */
3328 retsts = sys$gettim(bintime);
3329 if (!(retsts & 1)) {
3331 set_vaxc_errno(retsts);
3336 myfab.fab$l_fna = vmsspec;
3337 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3338 myfab.fab$l_nam = &mynam;
3339 mynam.nam$l_esa = esa;
3340 mynam.nam$b_ess = (unsigned char) sizeof esa;
3341 mynam.nam$l_rsa = rsa;
3342 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3344 /* Look for the file to be affected, letting RMS parse the file
3345 * specification for us as well. I have set errno using only
3346 * values documented in the utime() man page for VMS POSIX.
3348 retsts = sys$parse(&myfab,0,0);
3349 if (!(retsts & 1)) {
3350 set_vaxc_errno(retsts);
3351 if (retsts == RMS$_PRV) set_errno(EACCES);
3352 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3353 else set_errno(EVMSERR);
3356 retsts = sys$search(&myfab,0,0);
3357 if (!(retsts & 1)) {
3358 set_vaxc_errno(retsts);
3359 if (retsts == RMS$_PRV) set_errno(EACCES);
3360 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3361 else set_errno(EVMSERR);
3365 devdsc.dsc$w_length = mynam.nam$b_dev;
3366 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3368 retsts = sys$assign(&devdsc,&chan,0,0);
3369 if (!(retsts & 1)) {
3370 set_vaxc_errno(retsts);
3371 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3372 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3373 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3374 else set_errno(EVMSERR);
3378 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3379 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3381 memset((void *) &myfib, 0, sizeof myfib);
3383 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3384 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3385 /* This prevents the revision time of the file being reset to the current
3386 * time as a result of our IO$_MODIFY $QIO. */
3387 myfib.fib$l_acctl = FIB$M_NORECORD;
3389 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3390 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3391 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3393 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3394 _ckvmssts(sys$dassgn(chan));
3395 if (retsts & 1) retsts = iosb[0];
3396 if (!(retsts & 1)) {
3397 set_vaxc_errno(retsts);
3398 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3399 else set_errno(EVMSERR);
3404 } /* end of my_utime() */
3408 * flex_stat, flex_fstat
3409 * basic stat, but gets it right when asked to stat
3410 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3413 /* encode_dev packs a VMS device name string into an integer to allow
3414 * simple comparisons. This can be used, for example, to check whether two
3415 * files are located on the same device, by comparing their encoded device
3416 * names. Even a string comparison would not do, because stat() reuses the
3417 * device name buffer for each call; so without encode_dev, it would be
3418 * necessary to save the buffer and use strcmp (this would mean a number of
3419 * changes to the standard Perl code, to say nothing of what a Perl script
3422 * The device lock id, if it exists, should be unique (unless perhaps compared
3423 * with lock ids transferred from other nodes). We have a lock id if the disk is
3424 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3425 * device names. Thus we use the lock id in preference, and only if that isn't
3426 * available, do we try to pack the device name into an integer (flagged by
3427 * the sign bit (LOCKID_MASK) being set).
3429 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3430 * name and its encoded form, but it seems very unlikely that we will find
3431 * two files on different disks that share the same encoded device names,
3432 * and even more remote that they will share the same file id (if the test
3433 * is to check for the same file).
3435 * A better method might be to use sys$device_scan on the first call, and to
3436 * search for the device, returning an index into the cached array.
3437 * The number returned would be more intelligable.
3438 * This is probably not worth it, and anyway would take quite a bit longer
3439 * on the first call.
3441 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3442 static mydev_t encode_dev (const char *dev)
3445 unsigned long int f;
3450 if (!dev || !dev[0]) return 0;
3454 struct dsc$descriptor_s dev_desc;
3455 unsigned long int status, lockid, item = DVI$_LOCKID;
3457 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3458 can try that first. */
3459 dev_desc.dsc$w_length = strlen (dev);
3460 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3461 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3462 dev_desc.dsc$a_pointer = (char *) dev;
3463 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3464 if (lockid) return (lockid & ~LOCKID_MASK);
3468 /* Otherwise we try to encode the device name */
3472 for (q = dev + strlen(dev); q--; q >= dev) {
3475 else if (isalpha (toupper (*q)))
3476 c= toupper (*q) - 'A' + (char)10;
3478 continue; /* Skip '$'s */
3480 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3482 enc += f * (unsigned long int) c;
3484 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3486 } /* end of encode_dev() */
3488 static char namecache[NAM$C_MAXRSS+1];
3491 is_null_device(name)
3494 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3495 The underscore prefix, controller letter, and unit number are
3496 independently optional; for our purposes, the colon punctuation
3497 is not. The colon can be trailed by optional directory and/or
3498 filename, but two consecutive colons indicates a nodename rather
3499 than a device. [pr] */
3500 if (*name == '_') ++name;
3501 if (tolower(*name++) != 'n') return 0;
3502 if (tolower(*name++) != 'l') return 0;
3503 if (tolower(*name) == 'a') ++name;
3504 if (*name == '0') ++name;
3505 return (*name++ == ':') && (*name != ':');
3508 /* Do the permissions allow some operation? Assumes statcache already set. */
3509 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3510 * subset of the applicable information. (We have to stick with struct
3511 * stat instead of struct mystat in the prototype since we have to match
3512 * the one in proto.h.)
3514 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3516 cando(I32 bit, I32 effective, struct stat *statbufp)
3518 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3520 char fname[NAM$C_MAXRSS+1];
3521 unsigned long int retsts;
3522 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3523 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3525 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3526 device name on successive calls */
3527 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3528 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3529 namdsc.dsc$a_pointer = fname;
3530 namdsc.dsc$w_length = sizeof fname - 1;
3532 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3533 &namdsc,&namdsc.dsc$w_length,0,0);
3535 fname[namdsc.dsc$w_length] = '\0';
3536 return cando_by_name(bit,effective,fname);
3538 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3539 warn("Can't get filespec - stale stat buffer?\n");
3543 return FALSE; /* Should never get to here */
3545 } /* end of cando() */
3549 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3551 cando_by_name(I32 bit, I32 effective, char *fname)
3553 static char usrname[L_cuserid];
3554 static struct dsc$descriptor_s usrdsc =
3555 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3556 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3557 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3558 unsigned short int retlen;
3559 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3560 union prvdef curprv;
3561 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3562 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3563 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3566 if (!fname || !*fname) return FALSE;
3567 /* Make sure we expand logical names, since sys$check_access doesn't */
3568 if (!strpbrk(fname,"/]>:")) {
3569 strcpy(fileified,fname);
3570 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3573 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3574 retlen = namdsc.dsc$w_length = strlen(vmsname);
3575 namdsc.dsc$a_pointer = vmsname;
3576 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3577 vmsname[retlen-1] == ':') {
3578 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3579 namdsc.dsc$w_length = strlen(fileified);
3580 namdsc.dsc$a_pointer = fileified;
3583 if (!usrdsc.dsc$w_length) {
3585 usrdsc.dsc$w_length = strlen(usrname);
3592 access = ARM$M_EXECUTE;
3597 access = ARM$M_READ;
3602 access = ARM$M_WRITE;
3607 access = ARM$M_DELETE;
3613 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3614 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3615 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3616 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3617 set_vaxc_errno(retsts);
3618 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3619 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3620 else set_errno(ENOENT);
3623 if (retsts == SS$_NORMAL) {
3624 if (!privused) return TRUE;
3625 /* We can get access, but only by using privs. Do we have the
3626 necessary privs currently enabled? */
3627 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3628 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3629 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3630 !curprv.prv$v_bypass) return FALSE;
3631 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3632 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3633 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3638 return FALSE; /* Should never get here */
3640 } /* end of cando_by_name() */
3644 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3646 flex_fstat(int fd, struct mystat *statbufp)
3648 if (!fstat(fd,(stat_t *) statbufp)) {
3649 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3650 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3652 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3656 if (!gmtime_emulation_type) (void)time(NULL);
3657 statbufp->st_mtime -= utc_offset_secs;
3658 statbufp->st_atime -= utc_offset_secs;
3659 statbufp->st_ctime -= utc_offset_secs;
3665 } /* end of flex_fstat() */
3668 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3670 flex_stat(char *fspec, struct mystat *statbufp)
3672 char fileified[NAM$C_MAXRSS+1];
3675 if (statbufp == (struct mystat *) &statcache)
3676 do_tovmsspec(fspec,namecache,0);
3677 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3678 memset(statbufp,0,sizeof *statbufp);
3679 statbufp->st_dev = encode_dev("_NLA0:");
3680 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3681 statbufp->st_uid = 0x00010001;
3682 statbufp->st_gid = 0x0001;
3683 time((time_t *)&statbufp->st_mtime);
3684 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3688 /* Try for a directory name first. If fspec contains a filename without
3689 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3690 * and sea:[wine.dark]water. exist, we prefer the directory here.
3691 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3692 * not sea:[wine.dark]., if the latter exists. If the intended target is
3693 * the file with null type, specify this by calling flex_stat() with
3694 * a '.' at the end of fspec.
3696 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3697 retval = stat(fileified,(stat_t *) statbufp);
3698 if (!retval && statbufp == (struct mystat *) &statcache)
3699 strcpy(namecache,fileified);
3701 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3703 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3705 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3709 if (!gmtime_emulation_type) (void)time(NULL);
3710 statbufp->st_mtime -= utc_offset_secs;
3711 statbufp->st_atime -= utc_offset_secs;
3712 statbufp->st_ctime -= utc_offset_secs;
3717 } /* end of flex_stat() */
3720 /* Insures that no carriage-control translation will be done on a file. */
3721 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3723 my_binmode(FILE *fp, char iotype)
3725 char filespec[NAM$C_MAXRSS], *acmode;
3728 if (!fgetname(fp,filespec)) return NULL;
3729 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3731 case '<': case 'r': acmode = "rb"; break;
3733 /* use 'a' instead of 'w' to avoid creating new file;
3734 fsetpos below will take care of restoring file position */
3735 case 'a': acmode = "ab"; break;
3736 case '+': case '|': case 's': acmode = "rb+"; break;
3737 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3739 warn("Unrecognized iotype %c in my_binmode",iotype);
3742 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3743 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3745 } /* end of my_binmode() */
3749 /*{{{char *my_getlogin()*/
3750 /* VMS cuserid == Unix getlogin, except calling sequence */
3754 static char user[L_cuserid];
3755 return cuserid(user);
3760 /* rmscopy - copy a file using VMS RMS routines
3762 * Copies contents and attributes of spec_in to spec_out, except owner
3763 * and protection information. Name and type of spec_in are used as
3764 * defaults for spec_out. The third parameter specifies whether rmscopy()
3765 * should try to propagate timestamps from the input file to the output file.
3766 * If it is less than 0, no timestamps are preserved. If it is 0, then
3767 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3768 * propagated to the output file at creation iff the output file specification
3769 * did not contain an explicit name or type, and the revision date is always
3770 * updated at the end of the copy operation. If it is greater than 0, then
3771 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3772 * other than the revision date should be propagated, and bit 1 indicates
3773 * that the revision date should be propagated.
3775 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3777 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3778 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3779 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3780 * as part of the Perl standard distribution under the terms of the
3781 * GNU General Public License or the Perl Artistic License. Copies
3782 * of each may be found in the Perl standard distribution.
3784 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3786 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3788 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3789 rsa[NAM$C_MAXRSS], ubf[32256];
3790 unsigned long int i, sts, sts2;
3791 struct FAB fab_in, fab_out;
3792 struct RAB rab_in, rab_out;
3794 struct XABDAT xabdat;
3795 struct XABFHC xabfhc;
3796 struct XABRDT xabrdt;
3797 struct XABSUM xabsum;
3799 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3800 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3801 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3805 fab_in = cc$rms_fab;
3806 fab_in.fab$l_fna = vmsin;
3807 fab_in.fab$b_fns = strlen(vmsin);
3808 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3809 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3810 fab_in.fab$l_fop = FAB$M_SQO;
3811 fab_in.fab$l_nam = &nam;
3812 fab_in.fab$l_xab = (void *) &xabdat;
3815 nam.nam$l_rsa = rsa;
3816 nam.nam$b_rss = sizeof(rsa);
3817 nam.nam$l_esa = esa;
3818 nam.nam$b_ess = sizeof (esa);
3819 nam.nam$b_esl = nam.nam$b_rsl = 0;
3821 xabdat = cc$rms_xabdat; /* To get creation date */
3822 xabdat.xab$l_nxt = (void *) &xabfhc;
3824 xabfhc = cc$rms_xabfhc; /* To get record length */
3825 xabfhc.xab$l_nxt = (void *) &xabsum;
3827 xabsum = cc$rms_xabsum; /* To get key and area information */
3829 if (!((sts = sys$open(&fab_in)) & 1)) {
3830 set_vaxc_errno(sts);
3834 set_errno(ENOENT); break;
3836 set_errno(ENODEV); break;
3838 set_errno(EINVAL); break;
3840 set_errno(EACCES); break;
3848 fab_out.fab$w_ifi = 0;
3849 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3850 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3851 fab_out.fab$l_fop = FAB$M_SQO;
3852 fab_out.fab$l_fna = vmsout;
3853 fab_out.fab$b_fns = strlen(vmsout);
3854 fab_out.fab$l_dna = nam.nam$l_name;
3855 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3857 if (preserve_dates == 0) { /* Act like DCL COPY */
3858 nam.nam$b_nop = NAM$M_SYNCHK;
3859 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3860 if (!((sts = sys$parse(&fab_out)) & 1)) {
3861 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3862 set_vaxc_errno(sts);
3865 fab_out.fab$l_xab = (void *) &xabdat;
3866 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3868 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3869 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3870 preserve_dates =0; /* bitmask from this point forward */
3872 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3873 if (!((sts = sys$create(&fab_out)) & 1)) {
3874 set_vaxc_errno(sts);
3877 set_errno(ENOENT); break;
3879 set_errno(ENODEV); break;
3881 set_errno(EINVAL); break;
3883 set_errno(EACCES); break;
3889 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3890 if (preserve_dates & 2) {
3891 /* sys$close() will process xabrdt, not xabdat */
3892 xabrdt = cc$rms_xabrdt;
3894 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3896 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3897 * is unsigned long[2], while DECC & VAXC use a struct */
3898 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3900 fab_out.fab$l_xab = (void *) &xabrdt;
3903 rab_in = cc$rms_rab;
3904 rab_in.rab$l_fab = &fab_in;
3905 rab_in.rab$l_rop = RAB$M_BIO;
3906 rab_in.rab$l_ubf = ubf;
3907 rab_in.rab$w_usz = sizeof ubf;
3908 if (!((sts = sys$connect(&rab_in)) & 1)) {
3909 sys$close(&fab_in); sys$close(&fab_out);
3910 set_errno(EVMSERR); set_vaxc_errno(sts);
3914 rab_out = cc$rms_rab;
3915 rab_out.rab$l_fab = &fab_out;
3916 rab_out.rab$l_rbf = ubf;
3917 if (!((sts = sys$connect(&rab_out)) & 1)) {
3918 sys$close(&fab_in); sys$close(&fab_out);
3919 set_errno(EVMSERR); set_vaxc_errno(sts);
3923 while ((sts = sys$read(&rab_in))) { /* always true */
3924 if (sts == RMS$_EOF) break;
3925 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3926 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3927 sys$close(&fab_in); sys$close(&fab_out);
3928 set_errno(EVMSERR); set_vaxc_errno(sts);
3933 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3934 sys$close(&fab_in); sys$close(&fab_out);
3935 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3937 set_errno(EVMSERR); set_vaxc_errno(sts);
3943 } /* end of rmscopy() */
3947 /*** The following glue provides 'hooks' to make some of the routines
3948 * from this file available from Perl. These routines are sufficiently
3949 * basic, and are required sufficiently early in the build process,
3950 * that's it's nice to have them available to miniperl as well as the
3951 * full Perl, so they're set up here instead of in an extension. The
3952 * Perl code which handles importation of these names into a given
3953 * package lives in [.VMS]Filespec.pm in @INC.
3957 rmsexpand_fromperl(CV *cv)
3960 char *fspec, *defspec = NULL, *rslt;
3962 if (!items || items > 2)
3963 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3964 fspec = SvPV(ST(0),na);
3965 if (!fspec || !*fspec) XSRETURN_UNDEF;
3966 if (items == 2) defspec = SvPV(ST(1),na);
3968 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3969 ST(0) = sv_newmortal();
3970 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3975 vmsify_fromperl(CV *cv)
3980 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3981 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3982 ST(0) = sv_newmortal();
3983 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3988 unixify_fromperl(CV *cv)
3993 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3994 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3995 ST(0) = sv_newmortal();
3996 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4001 fileify_fromperl(CV *cv)
4006 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4007 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4008 ST(0) = sv_newmortal();
4009 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4014 pathify_fromperl(CV *cv)
4019 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4020 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4021 ST(0) = sv_newmortal();
4022 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4027 vmspath_fromperl(CV *cv)
4032 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4033 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4034 ST(0) = sv_newmortal();
4035 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4040 unixpath_fromperl(CV *cv)
4045 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4046 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4047 ST(0) = sv_newmortal();
4048 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4053 candelete_fromperl(CV *cv)
4056 char fspec[NAM$C_MAXRSS+1], *fsp;
4060 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4062 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4063 if (SvTYPE(mysv) == SVt_PVGV) {
4064 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4065 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4072 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4073 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4079 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
4084 rmscopy_fromperl(CV *cv)
4087 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4089 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4090 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4091 unsigned long int sts;
4095 if (items < 2 || items > 3)
4096 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4098 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4099 if (SvTYPE(mysv) == SVt_PVGV) {
4100 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4101 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4108 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4109 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4114 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4115 if (SvTYPE(mysv) == SVt_PVGV) {
4116 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4117 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4124 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4125 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4130 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4132 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
4139 char* file = __FILE__;
4141 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4142 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4143 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4144 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4145 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4146 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4147 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4148 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4149 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);