3 * VMS-specific routines for perl5
5 * Last revised: 11-Apr-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(1301,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.
777 static char *do_tounixspec(char *, char *, int);
780 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
782 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
783 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
784 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
785 struct FAB myfab = cc$rms_fab;
786 struct NAM mynam = cc$rms_nam;
788 unsigned long int retsts, haslower = 0, isunix = 0;
790 if (!filespec || !*filespec) {
791 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
795 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
796 else outbuf = __rmsexpand_retbuf;
798 if ((isunix = (strchr(filespec,'/') != NULL))) {
799 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
803 myfab.fab$l_fna = filespec;
804 myfab.fab$b_fns = strlen(filespec);
805 myfab.fab$l_nam = &mynam;
807 if (defspec && *defspec) {
808 if (strchr(defspec,'/') != NULL) {
809 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
812 myfab.fab$l_dna = defspec;
813 myfab.fab$b_dns = strlen(defspec);
816 mynam.nam$l_esa = esa;
817 mynam.nam$b_ess = sizeof esa;
818 mynam.nam$l_rsa = outbuf;
819 mynam.nam$b_rss = NAM$C_MAXRSS;
821 retsts = sys$parse(&myfab,0,0);
823 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
824 retsts == RMS$_DEV || retsts == RMS$_DEV) {
825 mynam.nam$b_nop |= NAM$M_SYNCHK;
826 retsts = sys$parse(&myfab,0,0);
827 if (retsts & 1) goto expanded;
829 if (out) Safefree(out);
830 set_vaxc_errno(retsts);
831 if (retsts == RMS$_PRV) set_errno(EACCES);
832 else if (retsts == RMS$_DEV) set_errno(ENODEV);
833 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
834 else set_errno(EVMSERR);
837 retsts = sys$search(&myfab,0,0);
838 if (!(retsts & 1) && retsts != RMS$_FNF) {
839 if (out) Safefree(out);
840 set_vaxc_errno(retsts);
841 if (retsts == RMS$_PRV) set_errno(EACCES);
842 else set_errno(EVMSERR);
846 /* If the input filespec contained any lowercase characters,
847 * downcase the result for compatibility with Unix-minded code. */
849 for (out = myfab.fab$l_fna; *out; out++)
850 if (islower(*out)) { haslower = 1; break; }
851 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
852 else { out = esa; speclen = mynam.nam$b_esl; }
853 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
854 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
855 speclen = mynam.nam$l_ver - out;
856 /* If we just had a directory spec on input, $PARSE "helpfully"
857 * adds an empty name and type for us */
858 if (mynam.nam$l_name == mynam.nam$l_type &&
859 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
860 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
861 speclen = mynam.nam$l_name - out;
863 if (haslower) __mystrtolower(out);
865 /* Have we been working with an expanded, but not resultant, spec? */
866 /* Also, convert back to Unix syntax if necessary. */
867 if (!mynam.nam$b_rsl) {
869 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
871 else strcpy(outbuf,esa);
874 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
875 strcpy(outbuf,tmpfspec);
880 /* External entry points */
881 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
882 { return do_rmsexpand(spec,buf,0,def,opt); }
883 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
884 { return do_rmsexpand(spec,buf,1,def,opt); }
888 ** The following routines are provided to make life easier when
889 ** converting among VMS-style and Unix-style directory specifications.
890 ** All will take input specifications in either VMS or Unix syntax. On
891 ** failure, all return NULL. If successful, the routines listed below
892 ** return a pointer to a buffer containing the appropriately
893 ** reformatted spec (and, therefore, subsequent calls to that routine
894 ** will clobber the result), while the routines of the same names with
895 ** a _ts suffix appended will return a pointer to a mallocd string
896 ** containing the appropriately reformatted spec.
897 ** In all cases, only explicit syntax is altered; no check is made that
898 ** the resulting string is valid or that the directory in question
901 ** fileify_dirspec() - convert a directory spec into the name of the
902 ** directory file (i.e. what you can stat() to see if it's a dir).
903 ** The style (VMS or Unix) of the result is the same as the style
904 ** of the parameter passed in.
905 ** pathify_dirspec() - convert a directory spec into a path (i.e.
906 ** what you prepend to a filename to indicate what directory it's in).
907 ** The style (VMS or Unix) of the result is the same as the style
908 ** of the parameter passed in.
909 ** tounixpath() - convert a directory spec into a Unix-style path.
910 ** tovmspath() - convert a directory spec into a VMS-style path.
911 ** tounixspec() - convert any file spec into a Unix-style file spec.
912 ** tovmsspec() - convert any file spec into a VMS-style spec.
914 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
915 ** Permission is given to distribute this code as part of the Perl
916 ** standard distribution under the terms of the GNU General Public
917 ** License or the Perl Artistic License. Copies of each may be
918 ** found in the Perl standard distribution.
921 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
922 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
924 static char __fileify_retbuf[NAM$C_MAXRSS+1];
925 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
926 char *retspec, *cp1, *cp2, *lastdir;
927 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
930 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
932 dirlen = strlen(dir);
933 if (dir[dirlen-1] == '/') --dirlen;
936 set_vaxc_errno(RMS$_DIR);
939 if (!strpbrk(dir+1,"/]>:")) {
940 strcpy(trndir,*dir == '/' ? dir + 1: dir);
941 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
943 dirlen = strlen(dir);
946 strncpy(trndir,dir,dirlen);
947 trndir[dirlen] = '\0';
950 /* If we were handed a rooted logical name or spec, treat it like a
951 * simple directory, so that
952 * $ Define myroot dev:[dir.]
953 * ... do_fileify_dirspec("myroot",buf,1) ...
954 * does something useful.
956 if (!strcmp(dir+dirlen-2,".]")) {
957 dir[--dirlen] = '\0';
961 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
962 /* If we've got an explicit filename, we can just shuffle the string. */
963 if (*(cp1+1)) hasfilename = 1;
964 /* Similarly, we can just back up a level if we've got multiple levels
965 of explicit directories in a VMS spec which ends with directories. */
967 for (cp2 = cp1; cp2 > dir; cp2--) {
969 *cp2 = *cp1; *cp1 = '\0';
973 if (*cp2 == '[' || *cp2 == '<') break;
978 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
980 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
981 return do_fileify_dirspec("[]",buf,ts);
982 else if (dir[1] == '.' &&
983 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
984 return do_fileify_dirspec("[-]",buf,ts);
986 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
987 dirlen -= 1; /* to last element */
988 lastdir = strrchr(dir,'/');
990 else if ((cp1 = strstr(dir,"/.")) != NULL) {
991 /* If we have "/." or "/..", VMSify it and let the VMS code
992 * below expand it, rather than repeating the code to handle
993 * relative components of a filespec here */
995 if (*(cp1+2) == '.') cp1++;
996 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
997 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
998 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
999 return do_tounixspec(trndir,buf,ts);
1002 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1005 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1006 !(lastdir = cp1 = strrchr(dir,']')) &&
1007 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1008 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1010 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1011 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1012 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1013 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1014 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1015 (ver || *cp3)))))) {
1017 set_vaxc_errno(RMS$_DIR);
1023 /* If we lead off with a device or rooted logical, add the MFD
1024 if we're specifying a top-level directory. */
1025 if (lastdir && *dir == '/') {
1027 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1034 retlen = dirlen + (addmfd ? 13 : 6);
1035 if (buf) retspec = buf;
1036 else if (ts) New(1309,retspec,retlen+1,char);
1037 else retspec = __fileify_retbuf;
1039 dirlen = lastdir - dir;
1040 memcpy(retspec,dir,dirlen);
1041 strcpy(&retspec[dirlen],"/000000");
1042 strcpy(&retspec[dirlen+7],lastdir);
1045 memcpy(retspec,dir,dirlen);
1046 retspec[dirlen] = '\0';
1048 /* We've picked up everything up to the directory file name.
1049 Now just add the type and version, and we're set. */
1050 strcat(retspec,".dir;1");
1053 else { /* VMS-style directory spec */
1054 char esa[NAM$C_MAXRSS+1], term, *cp;
1055 unsigned long int sts, cmplen, haslower = 0;
1056 struct FAB dirfab = cc$rms_fab;
1057 struct NAM savnam, dirnam = cc$rms_nam;
1059 dirfab.fab$b_fns = strlen(dir);
1060 dirfab.fab$l_fna = dir;
1061 dirfab.fab$l_nam = &dirnam;
1062 dirfab.fab$l_dna = ".DIR;1";
1063 dirfab.fab$b_dns = 6;
1064 dirnam.nam$b_ess = NAM$C_MAXRSS;
1065 dirnam.nam$l_esa = esa;
1067 for (cp = dir; *cp; cp++)
1068 if (islower(*cp)) { haslower = 1; break; }
1069 if (!((sts = sys$parse(&dirfab))&1)) {
1070 if (dirfab.fab$l_sts == RMS$_DIR) {
1071 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1072 sts = sys$parse(&dirfab) & 1;
1076 set_vaxc_errno(dirfab.fab$l_sts);
1082 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1083 /* Yes; fake the fnb bits so we'll check type below */
1084 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1087 if (dirfab.fab$l_sts != RMS$_FNF) {
1089 set_vaxc_errno(dirfab.fab$l_sts);
1092 dirnam = savnam; /* No; just work with potential name */
1095 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1096 cp1 = strchr(esa,']');
1097 if (!cp1) cp1 = strchr(esa,'>');
1098 if (cp1) { /* Should always be true */
1099 dirnam.nam$b_esl -= cp1 - esa - 1;
1100 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1103 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1104 /* Yep; check version while we're at it, if it's there. */
1105 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1106 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1107 /* Something other than .DIR[;1]. Bzzt. */
1109 set_vaxc_errno(RMS$_DIR);
1113 esa[dirnam.nam$b_esl] = '\0';
1114 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1115 /* They provided at least the name; we added the type, if necessary, */
1116 if (buf) retspec = buf; /* in sys$parse() */
1117 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1118 else retspec = __fileify_retbuf;
1119 strcpy(retspec,esa);
1122 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1123 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1125 dirnam.nam$b_esl -= 9;
1127 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1128 if (cp1 == NULL) return NULL; /* should never happen */
1131 retlen = strlen(esa);
1132 if ((cp1 = strrchr(esa,'.')) != NULL) {
1133 /* There's more than one directory in the path. Just roll back. */
1135 if (buf) retspec = buf;
1136 else if (ts) New(1311,retspec,retlen+7,char);
1137 else retspec = __fileify_retbuf;
1138 strcpy(retspec,esa);
1141 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1142 /* Go back and expand rooted logical name */
1143 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1144 if (!(sys$parse(&dirfab) & 1)) {
1146 set_vaxc_errno(dirfab.fab$l_sts);
1149 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1150 if (buf) retspec = buf;
1151 else if (ts) New(1312,retspec,retlen+16,char);
1152 else retspec = __fileify_retbuf;
1153 cp1 = strstr(esa,"][");
1155 memcpy(retspec,esa,dirlen);
1156 if (!strncmp(cp1+2,"000000]",7)) {
1157 retspec[dirlen-1] = '\0';
1158 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1159 if (*cp1 == '.') *cp1 = ']';
1161 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1162 memcpy(cp1+1,"000000]",7);
1166 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1167 retspec[retlen] = '\0';
1168 /* Convert last '.' to ']' */
1169 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1170 if (*cp1 == '.') *cp1 = ']';
1172 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1173 memcpy(cp1+1,"000000]",7);
1177 else { /* This is a top-level dir. Add the MFD to the path. */
1178 if (buf) retspec = buf;
1179 else if (ts) New(1312,retspec,retlen+16,char);
1180 else retspec = __fileify_retbuf;
1183 while (*cp1 != ':') *(cp2++) = *(cp1++);
1184 strcpy(cp2,":[000000]");
1189 /* We've set up the string up through the filename. Add the
1190 type and version, and we're done. */
1191 strcat(retspec,".DIR;1");
1193 /* $PARSE may have upcased filespec, so convert output to lower
1194 * case if input contained any lowercase characters. */
1195 if (haslower) __mystrtolower(retspec);
1198 } /* end of do_fileify_dirspec() */
1200 /* External entry points */
1201 char *fileify_dirspec(char *dir, char *buf)
1202 { return do_fileify_dirspec(dir,buf,0); }
1203 char *fileify_dirspec_ts(char *dir, char *buf)
1204 { return do_fileify_dirspec(dir,buf,1); }
1206 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1207 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1209 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1210 unsigned long int retlen;
1211 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1213 if (!dir || !*dir) {
1214 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1217 if (*dir) strcpy(trndir,dir);
1218 else getcwd(trndir,sizeof trndir - 1);
1220 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1221 STRLEN trnlen = strlen(trndir);
1223 /* Trap simple rooted lnms, and return lnm:[000000] */
1224 if (!strcmp(trndir+trnlen-2,".]")) {
1225 if (buf) retpath = buf;
1226 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1227 else retpath = __pathify_retbuf;
1228 strcpy(retpath,dir);
1229 strcat(retpath,":[000000]");
1235 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1236 if (*dir == '.' && (*(dir+1) == '\0' ||
1237 (*(dir+1) == '.' && *(dir+2) == '\0')))
1238 retlen = 2 + (*(dir+1) != '\0');
1240 if ( !(cp1 = strrchr(dir,'/')) &&
1241 !(cp1 = strrchr(dir,']')) &&
1242 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1243 if ((cp2 = strchr(cp1,'.')) != NULL &&
1244 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1245 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1246 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1247 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1249 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1250 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1251 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1252 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1253 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1254 (ver || *cp3)))))) {
1256 set_vaxc_errno(RMS$_DIR);
1259 retlen = cp2 - dir + 1;
1261 else { /* No file type present. Treat the filename as a directory. */
1262 retlen = strlen(dir) + 1;
1265 if (buf) retpath = buf;
1266 else if (ts) New(1313,retpath,retlen+1,char);
1267 else retpath = __pathify_retbuf;
1268 strncpy(retpath,dir,retlen-1);
1269 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1270 retpath[retlen-1] = '/'; /* with '/', add it. */
1271 retpath[retlen] = '\0';
1273 else retpath[retlen-1] = '\0';
1275 else { /* VMS-style directory spec */
1276 char esa[NAM$C_MAXRSS+1], *cp;
1277 unsigned long int sts, cmplen, haslower;
1278 struct FAB dirfab = cc$rms_fab;
1279 struct NAM savnam, dirnam = cc$rms_nam;
1281 /* If we've got an explicit filename, we can just shuffle the string. */
1282 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1283 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1284 if ((cp2 = strchr(cp1,'.')) != NULL) {
1286 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1287 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1288 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1289 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1290 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1291 (ver || *cp3)))))) {
1293 set_vaxc_errno(RMS$_DIR);
1297 else { /* No file type, so just draw name into directory part */
1298 for (cp2 = cp1; *cp2; cp2++) ;
1301 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1303 /* We've now got a VMS 'path'; fall through */
1305 dirfab.fab$b_fns = strlen(dir);
1306 dirfab.fab$l_fna = dir;
1307 if (dir[dirfab.fab$b_fns-1] == ']' ||
1308 dir[dirfab.fab$b_fns-1] == '>' ||
1309 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1310 if (buf) retpath = buf;
1311 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1312 else retpath = __pathify_retbuf;
1313 strcpy(retpath,dir);
1316 dirfab.fab$l_dna = ".DIR;1";
1317 dirfab.fab$b_dns = 6;
1318 dirfab.fab$l_nam = &dirnam;
1319 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1320 dirnam.nam$l_esa = esa;
1322 for (cp = dir; *cp; cp++)
1323 if (islower(*cp)) { haslower = 1; break; }
1325 if (!(sts = (sys$parse(&dirfab)&1))) {
1326 if (dirfab.fab$l_sts == RMS$_DIR) {
1327 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1328 sts = sys$parse(&dirfab) & 1;
1332 set_vaxc_errno(dirfab.fab$l_sts);
1338 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1339 if (dirfab.fab$l_sts != RMS$_FNF) {
1341 set_vaxc_errno(dirfab.fab$l_sts);
1344 dirnam = savnam; /* No; just work with potential name */
1347 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1348 /* Yep; check version while we're at it, if it's there. */
1349 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1350 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1351 /* Something other than .DIR[;1]. Bzzt. */
1353 set_vaxc_errno(RMS$_DIR);
1357 /* OK, the type was fine. Now pull any file name into the
1359 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1361 cp1 = strrchr(esa,'>');
1362 *dirnam.nam$l_type = '>';
1365 *(dirnam.nam$l_type + 1) = '\0';
1366 retlen = dirnam.nam$l_type - esa + 2;
1367 if (buf) retpath = buf;
1368 else if (ts) New(1314,retpath,retlen,char);
1369 else retpath = __pathify_retbuf;
1370 strcpy(retpath,esa);
1371 /* $PARSE may have upcased filespec, so convert output to lower
1372 * case if input contained any lowercase characters. */
1373 if (haslower) __mystrtolower(retpath);
1377 } /* end of do_pathify_dirspec() */
1379 /* External entry points */
1380 char *pathify_dirspec(char *dir, char *buf)
1381 { return do_pathify_dirspec(dir,buf,0); }
1382 char *pathify_dirspec_ts(char *dir, char *buf)
1383 { return do_pathify_dirspec(dir,buf,1); }
1385 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1386 static char *do_tounixspec(char *spec, char *buf, int ts)
1388 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1389 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1390 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1392 if (spec == NULL) return NULL;
1393 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1394 if (buf) rslt = buf;
1396 retlen = strlen(spec);
1397 cp1 = strchr(spec,'[');
1398 if (!cp1) cp1 = strchr(spec,'<');
1400 for (cp1++; *cp1; cp1++) {
1401 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1402 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1403 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1406 New(1315,rslt,retlen+2+2*expand,char);
1408 else rslt = __tounixspec_retbuf;
1409 if (strchr(spec,'/') != NULL) {
1416 dirend = strrchr(spec,']');
1417 if (dirend == NULL) dirend = strrchr(spec,'>');
1418 if (dirend == NULL) dirend = strchr(spec,':');
1419 if (dirend == NULL) {
1423 if (*cp2 != '[' && *cp2 != '<') {
1426 else { /* the VMS spec begins with directories */
1428 if (*cp2 == ']' || *cp2 == '>') {
1429 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1432 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1433 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1434 if (ts) Safefree(rslt);
1439 while (*cp3 != ':' && *cp3) cp3++;
1441 if (strchr(cp3,']') != NULL) break;
1442 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1444 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1445 retlen = devlen + dirlen;
1446 Renew(rslt,retlen+1+2*expand,char);
1452 *(cp1++) = *(cp3++);
1453 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1457 else if ( *cp2 == '.') {
1458 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1459 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1465 for (; cp2 <= dirend; cp2++) {
1468 if (*(cp2+1) == '[') cp2++;
1470 else if (*cp2 == ']' || *cp2 == '>') {
1471 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1473 else if (*cp2 == '.') {
1475 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1476 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1477 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1478 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1479 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1481 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1482 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1486 else if (*cp2 == '-') {
1487 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1488 while (*cp2 == '-') {
1490 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1492 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1493 if (ts) Safefree(rslt); /* filespecs like */
1494 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1498 else *(cp1++) = *cp2;
1500 else *(cp1++) = *cp2;
1502 while (*cp2) *(cp1++) = *(cp2++);
1507 } /* end of do_tounixspec() */
1509 /* External entry points */
1510 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1511 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1513 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1514 static char *do_tovmsspec(char *path, char *buf, int ts) {
1515 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1516 char *rslt, *dirend;
1517 register char *cp1, *cp2;
1518 unsigned long int infront = 0, hasdir = 1;
1520 if (path == NULL) return NULL;
1521 if (buf) rslt = buf;
1522 else if (ts) New(1316,rslt,strlen(path)+9,char);
1523 else rslt = __tovmsspec_retbuf;
1524 if (strpbrk(path,"]:>") ||
1525 (dirend = strrchr(path,'/')) == NULL) {
1526 if (path[0] == '.') {
1527 if (path[1] == '\0') strcpy(rslt,"[]");
1528 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1529 else strcpy(rslt,path); /* probably garbage */
1531 else strcpy(rslt,path);
1534 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1535 if (!*(dirend+2)) dirend +=2;
1536 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1537 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1542 char trndev[NAM$C_MAXRSS+1];
1546 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1547 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1549 islnm = my_trnlnm(rslt,trndev,0);
1550 trnend = islnm ? strlen(trndev) - 1 : 0;
1551 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1552 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1553 /* If the first element of the path is a logical name, determine
1554 * whether it has to be translated so we can add more directories. */
1555 if (!islnm || rooted) {
1558 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1562 if (cp2 != dirend) {
1563 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1564 strcpy(rslt,trndev);
1565 cp1 = rslt + trnend;
1578 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1579 cp2 += 2; /* skip over "./" - it's redundant */
1580 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1582 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1583 *(cp1++) = '-'; /* "../" --> "-" */
1586 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1587 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1588 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1589 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1592 if (cp2 > dirend) cp2 = dirend;
1594 else *(cp1++) = '.';
1596 for (; cp2 < dirend; cp2++) {
1598 if (*(cp2-1) == '/') continue;
1599 if (*(cp1-1) != '.') *(cp1++) = '.';
1602 else if (!infront && *cp2 == '.') {
1603 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1604 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1605 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1606 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1607 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1608 else { /* back up over previous directory name */
1610 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1611 if (*(cp1-1) == '[') {
1612 memcpy(cp1,"000000.",7);
1617 if (cp2 == dirend) break;
1619 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1620 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1621 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1622 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1624 *(cp1++) = '.'; /* Simulate trailing '/' */
1625 cp2 += 2; /* for loop will incr this to == dirend */
1627 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1629 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1632 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1633 if (*cp2 == '.') *(cp1++) = '_';
1634 else *(cp1++) = *cp2;
1638 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1639 if (hasdir) *(cp1++) = ']';
1640 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1641 while (*cp2) *(cp1++) = *(cp2++);
1646 } /* end of do_tovmsspec() */
1648 /* External entry points */
1649 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1650 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1652 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1653 static char *do_tovmspath(char *path, char *buf, int ts) {
1654 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1656 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1658 if (path == NULL) return NULL;
1659 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1660 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1661 if (buf) return buf;
1663 vmslen = strlen(vmsified);
1664 New(1317,cp,vmslen+1,char);
1665 memcpy(cp,vmsified,vmslen);
1670 strcpy(__tovmspath_retbuf,vmsified);
1671 return __tovmspath_retbuf;
1674 } /* end of do_tovmspath() */
1676 /* External entry points */
1677 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1678 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1681 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1682 static char *do_tounixpath(char *path, char *buf, int ts) {
1683 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1685 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1687 if (path == NULL) return NULL;
1688 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1689 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1690 if (buf) return buf;
1692 unixlen = strlen(unixified);
1693 New(1317,cp,unixlen+1,char);
1694 memcpy(cp,unixified,unixlen);
1699 strcpy(__tounixpath_retbuf,unixified);
1700 return __tounixpath_retbuf;
1703 } /* end of do_tounixpath() */
1705 /* External entry points */
1706 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1707 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1710 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1712 *****************************************************************************
1714 * Copyright (C) 1989-1994 by *
1715 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1717 * Permission is hereby granted for the reproduction of this software, *
1718 * on condition that this copyright notice is included in the reproduction, *
1719 * and that such reproduction is not for purposes of profit or material *
1722 * 27-Aug-1994 Modified for inclusion in perl5 *
1723 * by Charles Bailey bailey@genetics.upenn.edu *
1724 *****************************************************************************
1728 * getredirection() is intended to aid in porting C programs
1729 * to VMS (Vax-11 C). The native VMS environment does not support
1730 * '>' and '<' I/O redirection, or command line wild card expansion,
1731 * or a command line pipe mechanism using the '|' AND background
1732 * command execution '&'. All of these capabilities are provided to any
1733 * C program which calls this procedure as the first thing in the
1735 * The piping mechanism will probably work with almost any 'filter' type
1736 * of program. With suitable modification, it may useful for other
1737 * portability problems as well.
1739 * Author: Mark Pizzolato mark@infocomm.com
1743 struct list_item *next;
1747 static void add_item(struct list_item **head,
1748 struct list_item **tail,
1752 static void expand_wild_cards(char *item,
1753 struct list_item **head,
1754 struct list_item **tail,
1757 static int background_process(int argc, char **argv);
1759 static void pipe_and_fork(char **cmargv);
1761 /*{{{ void getredirection(int *ac, char ***av)*/
1763 getredirection(int *ac, char ***av)
1765 * Process vms redirection arg's. Exit if any error is seen.
1766 * If getredirection() processes an argument, it is erased
1767 * from the vector. getredirection() returns a new argc and argv value.
1768 * In the event that a background command is requested (by a trailing "&"),
1769 * this routine creates a background subprocess, and simply exits the program.
1771 * Warning: do not try to simplify the code for vms. The code
1772 * presupposes that getredirection() is called before any data is
1773 * read from stdin or written to stdout.
1775 * Normal usage is as follows:
1781 * getredirection(&argc, &argv);
1785 int argc = *ac; /* Argument Count */
1786 char **argv = *av; /* Argument Vector */
1787 char *ap; /* Argument pointer */
1788 int j; /* argv[] index */
1789 int item_count = 0; /* Count of Items in List */
1790 struct list_item *list_head = 0; /* First Item in List */
1791 struct list_item *list_tail; /* Last Item in List */
1792 char *in = NULL; /* Input File Name */
1793 char *out = NULL; /* Output File Name */
1794 char *outmode = "w"; /* Mode to Open Output File */
1795 char *err = NULL; /* Error File Name */
1796 char *errmode = "w"; /* Mode to Open Error File */
1797 int cmargc = 0; /* Piped Command Arg Count */
1798 char **cmargv = NULL;/* Piped Command Arg Vector */
1801 * First handle the case where the last thing on the line ends with
1802 * a '&'. This indicates the desire for the command to be run in a
1803 * subprocess, so we satisfy that desire.
1806 if (0 == strcmp("&", ap))
1807 exit(background_process(--argc, argv));
1808 if (*ap && '&' == ap[strlen(ap)-1])
1810 ap[strlen(ap)-1] = '\0';
1811 exit(background_process(argc, argv));
1814 * Now we handle the general redirection cases that involve '>', '>>',
1815 * '<', and pipes '|'.
1817 for (j = 0; j < argc; ++j)
1819 if (0 == strcmp("<", argv[j]))
1823 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1824 exit(LIB$_WRONUMARG);
1829 if ('<' == *(ap = argv[j]))
1834 if (0 == strcmp(">", ap))
1838 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1839 exit(LIB$_WRONUMARG);
1858 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1859 exit(LIB$_WRONUMARG);
1863 if (('2' == *ap) && ('>' == ap[1]))
1880 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1881 exit(LIB$_WRONUMARG);
1885 if (0 == strcmp("|", argv[j]))
1889 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1890 exit(LIB$_WRONUMARG);
1892 cmargc = argc-(j+1);
1893 cmargv = &argv[j+1];
1897 if ('|' == *(ap = argv[j]))
1905 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1908 * Allocate and fill in the new argument vector, Some Unix's terminate
1909 * the list with an extra null pointer.
1911 New(1302, argv, item_count+1, char *);
1913 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1914 argv[j] = list_head->value;
1920 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1921 exit(LIB$_INVARGORD);
1923 pipe_and_fork(cmargv);
1926 /* Check for input from a pipe (mailbox) */
1928 if (in == NULL && 1 == isapipe(0))
1930 char mbxname[L_tmpnam];
1932 long int dvi_item = DVI$_DEVBUFSIZ;
1933 $DESCRIPTOR(mbxnam, "");
1934 $DESCRIPTOR(mbxdevnam, "");
1936 /* Input from a pipe, reopen it in binary mode to disable */
1937 /* carriage control processing. */
1939 PerlIO_getname(stdin, mbxname);
1940 mbxnam.dsc$a_pointer = mbxname;
1941 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1942 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1943 mbxdevnam.dsc$a_pointer = mbxname;
1944 mbxdevnam.dsc$w_length = sizeof(mbxname);
1945 dvi_item = DVI$_DEVNAM;
1946 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1947 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1950 freopen(mbxname, "rb", stdin);
1953 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1957 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1959 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1962 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1964 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
1969 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1971 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
1975 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1980 #ifdef ARGPROC_DEBUG
1981 PerlIO_printf(Perl_debug_log, "Arglist:\n");
1982 for (j = 0; j < *ac; ++j)
1983 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1985 /* Clear errors we may have hit expanding wildcards, so they don't
1986 show up in Perl's $! later */
1987 set_errno(0); set_vaxc_errno(1);
1988 } /* end of getredirection() */
1991 static void add_item(struct list_item **head,
1992 struct list_item **tail,
1998 New(1303,*head,1,struct list_item);
2002 New(1304,(*tail)->next,1,struct list_item);
2003 *tail = (*tail)->next;
2005 (*tail)->value = value;
2009 static void expand_wild_cards(char *item,
2010 struct list_item **head,
2011 struct list_item **tail,
2015 unsigned long int context = 0;
2021 char vmsspec[NAM$C_MAXRSS+1];
2022 $DESCRIPTOR(filespec, "");
2023 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2024 $DESCRIPTOR(resultspec, "");
2025 unsigned long int zero = 0, sts;
2027 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2029 add_item(head, tail, item, count);
2032 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2033 resultspec.dsc$b_class = DSC$K_CLASS_D;
2034 resultspec.dsc$a_pointer = NULL;
2035 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2036 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2037 if (!isunix || !filespec.dsc$a_pointer)
2038 filespec.dsc$a_pointer = item;
2039 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2041 * Only return version specs, if the caller specified a version
2043 had_version = strchr(item, ';');
2045 * Only return device and directory specs, if the caller specifed either.
2047 had_device = strchr(item, ':');
2048 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2050 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2051 &defaultspec, 0, 0, &zero))))
2056 New(1305,string,resultspec.dsc$w_length+1,char);
2057 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2058 string[resultspec.dsc$w_length] = '\0';
2059 if (NULL == had_version)
2060 *((char *)strrchr(string, ';')) = '\0';
2061 if ((!had_directory) && (had_device == NULL))
2063 if (NULL == (devdir = strrchr(string, ']')))
2064 devdir = strrchr(string, '>');
2065 strcpy(string, devdir + 1);
2068 * Be consistent with what the C RTL has already done to the rest of
2069 * the argv items and lowercase all of these names.
2071 for (c = string; *c; ++c)
2074 if (isunix) trim_unixpath(string,item,1);
2075 add_item(head, tail, string, count);
2078 if (sts != RMS$_NMF)
2080 set_vaxc_errno(sts);
2086 set_errno(ENOENT); break;
2088 set_errno(ENODEV); break;
2091 set_errno(EINVAL); break;
2093 set_errno(EACCES); break;
2095 _ckvmssts_noperl(sts);
2099 add_item(head, tail, item, count);
2100 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2101 _ckvmssts_noperl(lib$find_file_end(&context));
2104 static int child_st[2];/* Event Flag set when child process completes */
2106 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2108 static unsigned long int exit_handler(int *status)
2112 if (0 == child_st[0])
2114 #ifdef ARGPROC_DEBUG
2115 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2117 fflush(stdout); /* Have to flush pipe for binary data to */
2118 /* terminate properly -- <tp@mccall.com> */
2119 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2120 sys$dassgn(child_chan);
2122 sys$synch(0, child_st);
2127 static void sig_child(int chan)
2129 #ifdef ARGPROC_DEBUG
2130 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2132 if (child_st[0] == 0)
2136 static struct exit_control_block exit_block =
2141 &exit_block.exit_status,
2145 static void pipe_and_fork(char **cmargv)
2148 $DESCRIPTOR(cmddsc, "");
2149 static char mbxname[64];
2150 $DESCRIPTOR(mbxdsc, mbxname);
2152 unsigned long int zero = 0, one = 1;
2154 strcpy(subcmd, cmargv[0]);
2155 for (j = 1; NULL != cmargv[j]; ++j)
2157 strcat(subcmd, " \"");
2158 strcat(subcmd, cmargv[j]);
2159 strcat(subcmd, "\"");
2161 cmddsc.dsc$a_pointer = subcmd;
2162 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2164 create_mbx(&child_chan,&mbxdsc);
2165 #ifdef ARGPROC_DEBUG
2166 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2167 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2169 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2170 0, &pid, child_st, &zero, sig_child,
2172 #ifdef ARGPROC_DEBUG
2173 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2175 sys$dclexh(&exit_block);
2176 if (NULL == freopen(mbxname, "wb", stdout))
2178 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2182 static int background_process(int argc, char **argv)
2184 char command[2048] = "$";
2185 $DESCRIPTOR(value, "");
2186 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2187 static $DESCRIPTOR(null, "NLA0:");
2188 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2190 $DESCRIPTOR(pidstr, "");
2192 unsigned long int flags = 17, one = 1, retsts;
2194 strcat(command, argv[0]);
2197 strcat(command, " \"");
2198 strcat(command, *(++argv));
2199 strcat(command, "\"");
2201 value.dsc$a_pointer = command;
2202 value.dsc$w_length = strlen(value.dsc$a_pointer);
2203 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2204 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2205 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2206 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2209 _ckvmssts_noperl(retsts);
2211 #ifdef ARGPROC_DEBUG
2212 PerlIO_printf(Perl_debug_log, "%s\n", command);
2214 sprintf(pidstring, "%08X", pid);
2215 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2216 pidstr.dsc$a_pointer = pidstring;
2217 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2218 lib$set_symbol(&pidsymbol, &pidstr);
2222 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2225 * Trim Unix-style prefix off filespec, so it looks like what a shell
2226 * glob expansion would return (i.e. from specified prefix on, not
2227 * full path). Note that returned filespec is Unix-style, regardless
2228 * of whether input filespec was VMS-style or Unix-style.
2230 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2231 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2232 * vector of options; at present, only bit 0 is used, and if set tells
2233 * trim unixpath to try the current default directory as a prefix when
2234 * presented with a possibly ambiguous ... wildcard.
2236 * Returns !=0 on success, with trimmed filespec replacing contents of
2237 * fspec, and 0 on failure, with contents of fpsec unchanged.
2239 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2241 trim_unixpath(char *fspec, char *wildspec, int opts)
2243 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2244 *template, *base, *end, *cp1, *cp2;
2245 register int tmplen, reslen = 0, dirs = 0;
2247 if (!wildspec || !fspec) return 0;
2248 if (strpbrk(wildspec,"]>:") != NULL) {
2249 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2250 else template = unixwild;
2252 else template = wildspec;
2253 if (strpbrk(fspec,"]>:") != NULL) {
2254 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2255 else base = unixified;
2256 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2257 * check to see that final result fits into (isn't longer than) fspec */
2258 reslen = strlen(fspec);
2262 /* No prefix or absolute path on wildcard, so nothing to remove */
2263 if (!*template || *template == '/') {
2264 if (base == fspec) return 1;
2265 tmplen = strlen(unixified);
2266 if (tmplen > reslen) return 0; /* not enough space */
2267 /* Copy unixified resultant, including trailing NUL */
2268 memmove(fspec,unixified,tmplen+1);
2272 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2273 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2274 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2275 for (cp1 = end ;cp1 >= base; cp1--)
2276 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2278 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2282 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2283 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2284 int ells = 1, totells, segdirs, match;
2285 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2286 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2288 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2290 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2291 if (ellipsis == template && opts & 1) {
2292 /* Template begins with an ellipsis. Since we can't tell how many
2293 * directory names at the front of the resultant to keep for an
2294 * arbitrary starting point, we arbitrarily choose the current
2295 * default directory as a starting point. If it's there as a prefix,
2296 * clip it off. If not, fall through and act as if the leading
2297 * ellipsis weren't there (i.e. return shortest possible path that
2298 * could match template).
2300 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2301 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2302 if (_tolower(*cp1) != _tolower(*cp2)) break;
2303 segdirs = dirs - totells; /* Min # of dirs we must have left */
2304 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2305 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2306 memcpy(fspec,cp2+1,end - cp2);
2310 /* First off, back up over constant elements at end of path */
2312 for (front = end ; front >= base; front--)
2313 if (*front == '/' && !dirs--) { front++; break; }
2315 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2316 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2317 if (cp1 != '\0') return 0; /* Path too long. */
2319 *cp2 = '\0'; /* Pick up with memcpy later */
2320 lcfront = lcres + (front - base);
2321 /* Now skip over each ellipsis and try to match the path in front of it. */
2323 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2324 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2325 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2326 if (cp1 < template) break; /* template started with an ellipsis */
2327 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2328 ellipsis = cp1; continue;
2330 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2332 for (segdirs = 0, cp2 = tpl;
2333 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2335 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2336 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2337 if (*cp2 == '/') segdirs++;
2339 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2340 /* Back up at least as many dirs as in template before matching */
2341 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2342 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2343 for (match = 0; cp1 > lcres;) {
2344 resdsc.dsc$a_pointer = cp1;
2345 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2347 if (match == 1) lcfront = cp1;
2349 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2351 if (!match) return 0; /* Can't find prefix ??? */
2352 if (match > 1 && opts & 1) {
2353 /* This ... wildcard could cover more than one set of dirs (i.e.
2354 * a set of similar dir names is repeated). If the template
2355 * contains more than 1 ..., upstream elements could resolve the
2356 * ambiguity, but it's not worth a full backtracking setup here.
2357 * As a quick heuristic, clip off the current default directory
2358 * if it's present to find the trimmed spec, else use the
2359 * shortest string that this ... could cover.
2361 char def[NAM$C_MAXRSS+1], *st;
2363 if (getcwd(def, sizeof def,0) == NULL) return 0;
2364 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2365 if (_tolower(*cp1) != _tolower(*cp2)) break;
2366 segdirs = dirs - totells; /* Min # of dirs we must have left */
2367 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2368 if (*cp1 == '\0' && *cp2 == '/') {
2369 memcpy(fspec,cp2+1,end - cp2);
2372 /* Nope -- stick with lcfront from above and keep going. */
2375 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2380 } /* end of trim_unixpath() */
2385 * VMS readdir() routines.
2386 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2388 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2389 * Minor modifications to original routines.
2392 /* Number of elements in vms_versions array */
2393 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2396 * Open a directory, return a handle for later use.
2398 /*{{{ DIR *opendir(char*name) */
2403 char dir[NAM$C_MAXRSS+1];
2405 /* Get memory for the handle, and the pattern. */
2407 if (do_tovmspath(name,dir,0) == NULL) {
2408 Safefree((char *)dd);
2411 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2413 /* Fill in the fields; mainly playing with the descriptor. */
2414 (void)sprintf(dd->pattern, "%s*.*",dir);
2417 dd->vms_wantversions = 0;
2418 dd->pat.dsc$a_pointer = dd->pattern;
2419 dd->pat.dsc$w_length = strlen(dd->pattern);
2420 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2421 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2424 } /* end of opendir() */
2428 * Set the flag to indicate we want versions or not.
2430 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2432 vmsreaddirversions(DIR *dd, int flag)
2434 dd->vms_wantversions = flag;
2439 * Free up an opened directory.
2441 /*{{{ void closedir(DIR *dd)*/
2445 (void)lib$find_file_end(&dd->context);
2446 Safefree(dd->pattern);
2447 Safefree((char *)dd);
2452 * Collect all the version numbers for the current file.
2458 struct dsc$descriptor_s pat;
2459 struct dsc$descriptor_s res;
2461 char *p, *text, buff[sizeof dd->entry.d_name];
2463 unsigned long context, tmpsts;
2465 /* Convenient shorthand. */
2468 /* Add the version wildcard, ignoring the "*.*" put on before */
2469 i = strlen(dd->pattern);
2470 New(1308,text,i + e->d_namlen + 3,char);
2471 (void)strcpy(text, dd->pattern);
2472 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2474 /* Set up the pattern descriptor. */
2475 pat.dsc$a_pointer = text;
2476 pat.dsc$w_length = i + e->d_namlen - 1;
2477 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2478 pat.dsc$b_class = DSC$K_CLASS_S;
2480 /* Set up result descriptor. */
2481 res.dsc$a_pointer = buff;
2482 res.dsc$w_length = sizeof buff - 2;
2483 res.dsc$b_dtype = DSC$K_DTYPE_T;
2484 res.dsc$b_class = DSC$K_CLASS_S;
2486 /* Read files, collecting versions. */
2487 for (context = 0, e->vms_verscount = 0;
2488 e->vms_verscount < VERSIZE(e);
2489 e->vms_verscount++) {
2490 tmpsts = lib$find_file(&pat, &res, &context);
2491 if (tmpsts == RMS$_NMF || context == 0) break;
2493 buff[sizeof buff - 1] = '\0';
2494 if ((p = strchr(buff, ';')))
2495 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2497 e->vms_versions[e->vms_verscount] = -1;
2500 _ckvmssts(lib$find_file_end(&context));
2503 } /* end of collectversions() */
2506 * Read the next entry from the directory.
2508 /*{{{ struct dirent *readdir(DIR *dd)*/
2512 struct dsc$descriptor_s res;
2513 char *p, buff[sizeof dd->entry.d_name];
2514 unsigned long int tmpsts;
2516 /* Set up result descriptor, and get next file. */
2517 res.dsc$a_pointer = buff;
2518 res.dsc$w_length = sizeof buff - 2;
2519 res.dsc$b_dtype = DSC$K_DTYPE_T;
2520 res.dsc$b_class = DSC$K_CLASS_S;
2521 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2522 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2523 if (!(tmpsts & 1)) {
2524 set_vaxc_errno(tmpsts);
2527 set_errno(EACCES); break;
2529 set_errno(ENODEV); break;
2532 set_errno(ENOENT); break;
2539 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2540 buff[sizeof buff - 1] = '\0';
2541 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2544 /* Skip any directory component and just copy the name. */
2545 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2546 else (void)strcpy(dd->entry.d_name, buff);
2548 /* Clobber the version. */
2549 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2551 dd->entry.d_namlen = strlen(dd->entry.d_name);
2552 dd->entry.vms_verscount = 0;
2553 if (dd->vms_wantversions) collectversions(dd);
2556 } /* end of readdir() */
2560 * Return something that can be used in a seekdir later.
2562 /*{{{ long telldir(DIR *dd)*/
2571 * Return to a spot where we used to be. Brute force.
2573 /*{{{ void seekdir(DIR *dd,long count)*/
2575 seekdir(DIR *dd, long count)
2577 int vms_wantversions;
2579 /* If we haven't done anything yet... */
2583 /* Remember some state, and clear it. */
2584 vms_wantversions = dd->vms_wantversions;
2585 dd->vms_wantversions = 0;
2586 _ckvmssts(lib$find_file_end(&dd->context));
2589 /* The increment is in readdir(). */
2590 for (dd->count = 0; dd->count < count; )
2593 dd->vms_wantversions = vms_wantversions;
2595 } /* end of seekdir() */
2598 /* VMS subprocess management
2600 * my_vfork() - just a vfork(), after setting a flag to record that
2601 * the current script is trying a Unix-style fork/exec.
2603 * vms_do_aexec() and vms_do_exec() are called in response to the
2604 * perl 'exec' function. If this follows a vfork call, then they
2605 * call out the the regular perl routines in doio.c which do an
2606 * execvp (for those who really want to try this under VMS).
2607 * Otherwise, they do exactly what the perl docs say exec should
2608 * do - terminate the current script and invoke a new command
2609 * (See below for notes on command syntax.)
2611 * do_aspawn() and do_spawn() implement the VMS side of the perl
2612 * 'system' function.
2614 * Note on command arguments to perl 'exec' and 'system': When handled
2615 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2616 * are concatenated to form a DCL command string. If the first arg
2617 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2618 * the the command string is hrnded off to DCL directly. Otherwise,
2619 * the first token of the command is taken as the filespec of an image
2620 * to run. The filespec is expanded using a default type of '.EXE' and
2621 * the process defaults for device, directory, etc., and the resultant
2622 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2623 * the command string as parameters. This is perhaps a bit compicated,
2624 * but I hope it will form a happy medium between what VMS folks expect
2625 * from lib$spawn and what Unix folks expect from exec.
2628 static int vfork_called;
2630 /*{{{int my_vfork()*/
2640 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2648 if (VMScmd.dsc$a_pointer) {
2649 Safefree(VMScmd.dsc$a_pointer);
2650 VMScmd.dsc$w_length = 0;
2651 VMScmd.dsc$a_pointer = Nullch;
2656 setup_argstr(SV *really, SV **mark, SV **sp)
2658 char *junk, *tmps = Nullch;
2659 register size_t cmdlen = 0;
2665 tmps = SvPV(really,rlen);
2672 for (idx++; idx <= sp; idx++) {
2674 junk = SvPVx(*idx,rlen);
2675 cmdlen += rlen ? rlen + 1 : 0;
2678 New(401,Cmd,cmdlen+1,char);
2680 if (tmps && *tmps) {
2685 while (++mark <= sp) {
2688 strcat(Cmd,SvPVx(*mark,na));
2693 } /* end of setup_argstr() */
2696 static unsigned long int
2697 setup_cmddsc(char *cmd, int check_img)
2699 char resspec[NAM$C_MAXRSS+1];
2700 $DESCRIPTOR(defdsc,".EXE");
2701 $DESCRIPTOR(resdsc,resspec);
2702 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2703 unsigned long int cxt = 0, flags = 1, retsts;
2704 register char *s, *rest, *cp;
2705 register int isdcl = 0;
2708 while (*s && isspace(*s)) s++;
2710 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2711 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2712 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2713 if (*cp == ':' || *cp == '[' || *cp == '<') {
2721 if (isdcl) { /* It's a DCL command, just do it. */
2722 VMScmd.dsc$w_length = strlen(cmd);
2724 VMScmd.dsc$a_pointer = Cmd;
2725 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2727 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2729 else { /* assume first token is an image spec */
2731 while (*s && !isspace(*s)) s++;
2733 imgdsc.dsc$a_pointer = cmd;
2734 imgdsc.dsc$w_length = s - cmd;
2735 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2736 if (!(retsts & 1)) {
2737 /* just hand off status values likely to be due to user error */
2738 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2739 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2740 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2741 else { _ckvmssts(retsts); }
2744 _ckvmssts(lib$find_file_end(&cxt));
2746 while (*s && !isspace(*s)) s++;
2748 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2749 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2750 strcat(VMScmd.dsc$a_pointer,resspec);
2751 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2752 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2756 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2758 } /* end of setup_cmddsc() */
2761 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2763 vms_do_aexec(SV *really,SV **mark,SV **sp)
2766 if (vfork_called) { /* this follows a vfork - act Unixish */
2768 if (vfork_called < 0) {
2769 warn("Internal inconsistency in tracking vforks");
2772 else return do_aexec(really,mark,sp);
2774 /* no vfork - act VMSish */
2775 return vms_do_exec(setup_argstr(really,mark,sp));
2780 } /* end of vms_do_aexec() */
2783 /* {{{bool vms_do_exec(char *cmd) */
2785 vms_do_exec(char *cmd)
2788 if (vfork_called) { /* this follows a vfork - act Unixish */
2790 if (vfork_called < 0) {
2791 warn("Internal inconsistency in tracking vforks");
2794 else return do_exec(cmd);
2797 { /* no vfork - act VMSish */
2798 unsigned long int retsts;
2801 TAINT_PROPER("exec");
2802 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2803 retsts = lib$do_command(&VMScmd);
2806 set_vaxc_errno(retsts);
2808 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2814 } /* end of vms_do_exec() */
2817 unsigned long int do_spawn(char *);
2819 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2821 do_aspawn(SV *really,SV **mark,SV **sp)
2823 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2826 } /* end of do_aspawn() */
2829 /* {{{unsigned long int do_spawn(char *cmd) */
2833 unsigned long int substs, hadcmd = 1;
2836 TAINT_PROPER("spawn");
2837 if (!cmd || !*cmd) {
2839 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2841 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2842 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2847 set_vaxc_errno(substs);
2849 warn("Can't spawn \"%s\": %s",
2850 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2855 } /* end of do_spawn() */
2859 * A simple fwrite replacement which outputs itmsz*nitm chars without
2860 * introducing record boundaries every itmsz chars.
2862 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2864 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2866 register char *cp, *end;
2868 end = (char *)src + itmsz * nitm;
2870 while ((char *)src <= end) {
2871 for (cp = src; cp <= end; cp++) if (!*cp) break;
2872 if (fputs(src,dest) == EOF) return EOF;
2874 if (fputc('\0',dest) == EOF) return EOF;
2880 } /* end of my_fwrite() */
2883 /*{{{ int my_flush(FILE *fp)*/
2888 if ((res = fflush(fp)) == 0) {
2889 #ifdef VMS_DO_SOCKETS
2891 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
2893 res = fsync(fileno(fp));
2900 * Here are replacements for the following Unix routines in the VMS environment:
2901 * getpwuid Get information for a particular UIC or UID
2902 * getpwnam Get information for a named user
2903 * getpwent Get information for each user in the rights database
2904 * setpwent Reset search to the start of the rights database
2905 * endpwent Finish searching for users in the rights database
2907 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2908 * (defined in pwd.h), which contains the following fields:-
2910 * char *pw_name; Username (in lower case)
2911 * char *pw_passwd; Hashed password
2912 * unsigned int pw_uid; UIC
2913 * unsigned int pw_gid; UIC group number
2914 * char *pw_unixdir; Default device/directory (VMS-style)
2915 * char *pw_gecos; Owner name
2916 * char *pw_dir; Default device/directory (Unix-style)
2917 * char *pw_shell; Default CLI name (eg. DCL)
2919 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2921 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2922 * not the UIC member number (eg. what's returned by getuid()),
2923 * getpwuid() can accept either as input (if uid is specified, the caller's
2924 * UIC group is used), though it won't recognise gid=0.
2926 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2927 * information about other users in your group or in other groups, respectively.
2928 * If the required privilege is not available, then these routines fill only
2929 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2932 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2935 /* sizes of various UAF record fields */
2936 #define UAI$S_USERNAME 12
2937 #define UAI$S_IDENT 31
2938 #define UAI$S_OWNER 31
2939 #define UAI$S_DEFDEV 31
2940 #define UAI$S_DEFDIR 63
2941 #define UAI$S_DEFCLI 31
2944 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2945 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2946 (uic).uic$v_group != UIC$K_WILD_GROUP)
2948 static char __empty[]= "";
2949 static struct passwd __passwd_empty=
2950 {(char *) __empty, (char *) __empty, 0, 0,
2951 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2952 static int contxt= 0;
2953 static struct passwd __pwdcache;
2954 static char __pw_namecache[UAI$S_IDENT+1];
2957 * This routine does most of the work extracting the user information.
2959 static int fillpasswd (const char *name, struct passwd *pwd)
2962 unsigned char length;
2963 char pw_gecos[UAI$S_OWNER+1];
2965 static union uicdef uic;
2967 unsigned char length;
2968 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2971 unsigned char length;
2972 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2975 unsigned char length;
2976 char pw_shell[UAI$S_DEFCLI+1];
2978 static char pw_passwd[UAI$S_PWD+1];
2980 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2981 struct dsc$descriptor_s name_desc;
2982 unsigned long int sts;
2984 static struct itmlst_3 itmlst[]= {
2985 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2986 {sizeof(uic), UAI$_UIC, &uic, &luic},
2987 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2988 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2989 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2990 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2991 {0, 0, NULL, NULL}};
2993 name_desc.dsc$w_length= strlen(name);
2994 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2995 name_desc.dsc$b_class= DSC$K_CLASS_S;
2996 name_desc.dsc$a_pointer= (char *) name;
2998 /* Note that sys$getuai returns many fields as counted strings. */
2999 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3000 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3001 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3003 else { _ckvmssts(sts); }
3004 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3006 if ((int) owner.length < lowner) lowner= (int) owner.length;
3007 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3008 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3009 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3010 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3011 owner.pw_gecos[lowner]= '\0';
3012 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3013 defcli.pw_shell[ldefcli]= '\0';
3014 if (valid_uic(uic)) {
3015 pwd->pw_uid= uic.uic$l_uic;
3016 pwd->pw_gid= uic.uic$v_group;
3019 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3020 pwd->pw_passwd= pw_passwd;
3021 pwd->pw_gecos= owner.pw_gecos;
3022 pwd->pw_dir= defdev.pw_dir;
3023 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3024 pwd->pw_shell= defcli.pw_shell;
3025 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3027 ldir= strlen(pwd->pw_unixdir) - 1;
3028 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3031 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3032 __mystrtolower(pwd->pw_unixdir);
3037 * Get information for a named user.
3039 /*{{{struct passwd *getpwnam(char *name)*/
3040 struct passwd *my_getpwnam(char *name)
3042 struct dsc$descriptor_s name_desc;
3044 unsigned long int status, sts;
3046 __pwdcache = __passwd_empty;
3047 if (!fillpasswd(name, &__pwdcache)) {
3048 /* We still may be able to determine pw_uid and pw_gid */
3049 name_desc.dsc$w_length= strlen(name);
3050 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3051 name_desc.dsc$b_class= DSC$K_CLASS_S;
3052 name_desc.dsc$a_pointer= (char *) name;
3053 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3054 __pwdcache.pw_uid= uic.uic$l_uic;
3055 __pwdcache.pw_gid= uic.uic$v_group;
3058 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3059 set_vaxc_errno(sts);
3060 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3063 else { _ckvmssts(sts); }
3066 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3067 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3068 __pwdcache.pw_name= __pw_namecache;
3070 } /* end of my_getpwnam() */
3074 * Get information for a particular UIC or UID.
3075 * Called by my_getpwent with uid=-1 to list all users.
3077 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3078 struct passwd *my_getpwuid(Uid_t uid)
3080 const $DESCRIPTOR(name_desc,__pw_namecache);
3081 unsigned short lname;
3083 unsigned long int status;
3085 if (uid == (unsigned int) -1) {
3087 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3088 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3089 set_vaxc_errno(status);
3090 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3094 else { _ckvmssts(status); }
3095 } while (!valid_uic (uic));
3099 if (!uic.uic$v_group)
3100 uic.uic$v_group= getgid();
3102 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3103 else status = SS$_IVIDENT;
3104 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3105 status == RMS$_PRV) {
3106 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3109 else { _ckvmssts(status); }
3111 __pw_namecache[lname]= '\0';
3112 __mystrtolower(__pw_namecache);
3114 __pwdcache = __passwd_empty;
3115 __pwdcache.pw_name = __pw_namecache;
3117 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3118 The identifier's value is usually the UIC, but it doesn't have to be,
3119 so if we can, we let fillpasswd update this. */
3120 __pwdcache.pw_uid = uic.uic$l_uic;
3121 __pwdcache.pw_gid = uic.uic$v_group;
3123 fillpasswd(__pw_namecache, &__pwdcache);
3126 } /* end of my_getpwuid() */
3130 * Get information for next user.
3132 /*{{{struct passwd *my_getpwent()*/
3133 struct passwd *my_getpwent()
3135 return (my_getpwuid((unsigned int) -1));
3140 * Finish searching rights database for users.
3142 /*{{{void my_endpwent()*/
3146 _ckvmssts(sys$finish_rdb(&contxt));
3153 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3154 * my_utime(), and flex_stat(), all of which operate on UTC unless
3155 * VMSISH_TIMES is true.
3157 /* method used to handle UTC conversions:
3158 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3160 static int gmtime_emulation_type;
3161 /* number of secs to add to UTC POSIX-style time to get local time */
3162 static long int utc_offset_secs;
3164 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3165 * in vmsish.h. #undef them here so we can call the CRTL routines
3172 /* my_time(), my_localtime(), my_gmtime()
3173 * By default traffic in UTC time values, suing CRTL gmtime() or
3174 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3175 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3176 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3179 /*{{{time_t my_time(time_t *timep)*/
3180 time_t my_time(time_t *timep)
3184 if (gmtime_emulation_type == 0) {
3186 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3188 gmtime_emulation_type++;
3189 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3192 gmtime_emulation_type++;
3193 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3194 gmtime_emulation_type++;
3195 warn("no UTC offset information; assuming local time is UTC");
3197 else { utc_offset_secs = atol(off); }
3199 else { /* We've got a working gmtime() */
3200 struct tm gmt, local;
3203 tm_p = localtime(&base);
3205 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3206 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3207 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3208 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3217 when != -1) when -= utc_offset_secs;
3218 if (timep != NULL) *timep = when;
3221 } /* end of my_time() */
3225 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3227 my_gmtime(const time_t *timep)
3232 if (timep == NULL) {
3233 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3236 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3237 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3241 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3243 /* CRTL localtime() wants local time as input, so does no tz correction */
3244 return localtime(&when);
3246 } /* end of my_gmtime() */
3250 /*{{{struct tm *my_localtime(const time_t *timep)*/
3252 my_localtime(const time_t *timep)
3256 if (timep == NULL) {
3257 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3260 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3261 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3265 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3267 /* CRTL localtime() wants local time as input, so does no tz correction */
3268 return localtime(&when);
3270 } /* end of my_localtime() */
3273 /* Reset definitions for later calls */
3274 #define gmtime(t) my_gmtime(t)
3275 #define localtime(t) my_localtime(t)
3276 #define time(t) my_time(t)
3279 /* my_utime - update modification time of a file
3280 * calling sequence is identical to POSIX utime(), but under
3281 * VMS only the modification time is changed; ODS-2 does not
3282 * maintain access times. Restrictions differ from the POSIX
3283 * definition in that the time can be changed as long as the
3284 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3285 * no separate checks are made to insure that the caller is the
3286 * owner of the file or has special privs enabled.
3287 * Code here is based on Joe Meadows' FILE utility.
3290 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3291 * to VMS epoch (01-JAN-1858 00:00:00.00)
3292 * in 100 ns intervals.
3294 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3296 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3297 int my_utime(char *file, struct utimbuf *utimes)
3300 long int bintime[2], len = 2, lowbit, unixtime,
3301 secscale = 10000000; /* seconds --> 100 ns intervals */
3302 unsigned long int chan, iosb[2], retsts;
3303 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3304 struct FAB myfab = cc$rms_fab;
3305 struct NAM mynam = cc$rms_nam;
3306 #if defined (__DECC) && defined (__VAX)
3307 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3308 * at least through VMS V6.1, which causes a type-conversion warning.
3310 # pragma message save
3311 # pragma message disable cvtdiftypes
3313 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3314 struct fibdef myfib;
3315 #if defined (__DECC) && defined (__VAX)
3316 /* This should be right after the declaration of myatr, but due
3317 * to a bug in VAX DEC C, this takes effect a statement early.
3319 # pragma message restore
3321 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3322 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3323 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3325 if (file == NULL || *file == '\0') {
3327 set_vaxc_errno(LIB$_INVARG);
3330 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3332 if (utimes != NULL) {
3333 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3334 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3335 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3336 * as input, we force the sign bit to be clear by shifting unixtime right
3337 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3339 lowbit = (utimes->modtime & 1) ? secscale : 0;
3340 unixtime = (long int) utimes->modtime;
3342 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3343 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3344 unixtime += utc_offset_secs;
3347 unixtime >> 1; secscale << 1;
3348 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3349 if (!(retsts & 1)) {
3351 set_vaxc_errno(retsts);
3354 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3355 if (!(retsts & 1)) {
3357 set_vaxc_errno(retsts);
3362 /* Just get the current time in VMS format directly */
3363 retsts = sys$gettim(bintime);
3364 if (!(retsts & 1)) {
3366 set_vaxc_errno(retsts);
3371 myfab.fab$l_fna = vmsspec;
3372 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3373 myfab.fab$l_nam = &mynam;
3374 mynam.nam$l_esa = esa;
3375 mynam.nam$b_ess = (unsigned char) sizeof esa;
3376 mynam.nam$l_rsa = rsa;
3377 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3379 /* Look for the file to be affected, letting RMS parse the file
3380 * specification for us as well. I have set errno using only
3381 * values documented in the utime() man page for VMS POSIX.
3383 retsts = sys$parse(&myfab,0,0);
3384 if (!(retsts & 1)) {
3385 set_vaxc_errno(retsts);
3386 if (retsts == RMS$_PRV) set_errno(EACCES);
3387 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3388 else set_errno(EVMSERR);
3391 retsts = sys$search(&myfab,0,0);
3392 if (!(retsts & 1)) {
3393 set_vaxc_errno(retsts);
3394 if (retsts == RMS$_PRV) set_errno(EACCES);
3395 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3396 else set_errno(EVMSERR);
3400 devdsc.dsc$w_length = mynam.nam$b_dev;
3401 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3403 retsts = sys$assign(&devdsc,&chan,0,0);
3404 if (!(retsts & 1)) {
3405 set_vaxc_errno(retsts);
3406 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3407 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3408 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3409 else set_errno(EVMSERR);
3413 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3414 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3416 memset((void *) &myfib, 0, sizeof myfib);
3418 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3419 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3420 /* This prevents the revision time of the file being reset to the current
3421 * time as a result of our IO$_MODIFY $QIO. */
3422 myfib.fib$l_acctl = FIB$M_NORECORD;
3424 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3425 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3426 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3428 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3429 _ckvmssts(sys$dassgn(chan));
3430 if (retsts & 1) retsts = iosb[0];
3431 if (!(retsts & 1)) {
3432 set_vaxc_errno(retsts);
3433 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3434 else set_errno(EVMSERR);
3439 } /* end of my_utime() */
3443 * flex_stat, flex_fstat
3444 * basic stat, but gets it right when asked to stat
3445 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3448 /* encode_dev packs a VMS device name string into an integer to allow
3449 * simple comparisons. This can be used, for example, to check whether two
3450 * files are located on the same device, by comparing their encoded device
3451 * names. Even a string comparison would not do, because stat() reuses the
3452 * device name buffer for each call; so without encode_dev, it would be
3453 * necessary to save the buffer and use strcmp (this would mean a number of
3454 * changes to the standard Perl code, to say nothing of what a Perl script
3457 * The device lock id, if it exists, should be unique (unless perhaps compared
3458 * with lock ids transferred from other nodes). We have a lock id if the disk is
3459 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3460 * device names. Thus we use the lock id in preference, and only if that isn't
3461 * available, do we try to pack the device name into an integer (flagged by
3462 * the sign bit (LOCKID_MASK) being set).
3464 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3465 * name and its encoded form, but it seems very unlikely that we will find
3466 * two files on different disks that share the same encoded device names,
3467 * and even more remote that they will share the same file id (if the test
3468 * is to check for the same file).
3470 * A better method might be to use sys$device_scan on the first call, and to
3471 * search for the device, returning an index into the cached array.
3472 * The number returned would be more intelligable.
3473 * This is probably not worth it, and anyway would take quite a bit longer
3474 * on the first call.
3476 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3477 static mydev_t encode_dev (const char *dev)
3480 unsigned long int f;
3485 if (!dev || !dev[0]) return 0;
3489 struct dsc$descriptor_s dev_desc;
3490 unsigned long int status, lockid, item = DVI$_LOCKID;
3492 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3493 can try that first. */
3494 dev_desc.dsc$w_length = strlen (dev);
3495 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3496 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3497 dev_desc.dsc$a_pointer = (char *) dev;
3498 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3499 if (lockid) return (lockid & ~LOCKID_MASK);
3503 /* Otherwise we try to encode the device name */
3507 for (q = dev + strlen(dev); q--; q >= dev) {
3510 else if (isalpha (toupper (*q)))
3511 c= toupper (*q) - 'A' + (char)10;
3513 continue; /* Skip '$'s */
3515 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3517 enc += f * (unsigned long int) c;
3519 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3521 } /* end of encode_dev() */
3523 static char namecache[NAM$C_MAXRSS+1];
3526 is_null_device(name)
3529 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3530 The underscore prefix, controller letter, and unit number are
3531 independently optional; for our purposes, the colon punctuation
3532 is not. The colon can be trailed by optional directory and/or
3533 filename, but two consecutive colons indicates a nodename rather
3534 than a device. [pr] */
3535 if (*name == '_') ++name;
3536 if (tolower(*name++) != 'n') return 0;
3537 if (tolower(*name++) != 'l') return 0;
3538 if (tolower(*name) == 'a') ++name;
3539 if (*name == '0') ++name;
3540 return (*name++ == ':') && (*name != ':');
3543 /* Do the permissions allow some operation? Assumes statcache already set. */
3544 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3545 * subset of the applicable information. (We have to stick with struct
3546 * stat instead of struct mystat in the prototype since we have to match
3547 * the one in proto.h.)
3549 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3551 cando(I32 bit, I32 effective, struct stat *statbufp)
3553 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3555 char fname[NAM$C_MAXRSS+1];
3556 unsigned long int retsts;
3557 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3558 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3560 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3561 device name on successive calls */
3562 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3563 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3564 namdsc.dsc$a_pointer = fname;
3565 namdsc.dsc$w_length = sizeof fname - 1;
3567 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3568 &namdsc,&namdsc.dsc$w_length,0,0);
3570 fname[namdsc.dsc$w_length] = '\0';
3571 return cando_by_name(bit,effective,fname);
3573 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3574 warn("Can't get filespec - stale stat buffer?\n");
3578 return FALSE; /* Should never get to here */
3580 } /* end of cando() */
3584 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3586 cando_by_name(I32 bit, I32 effective, char *fname)
3588 static char usrname[L_cuserid];
3589 static struct dsc$descriptor_s usrdsc =
3590 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3591 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3592 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3593 unsigned short int retlen;
3594 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3595 union prvdef curprv;
3596 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3597 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3598 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3601 if (!fname || !*fname) return FALSE;
3602 /* Make sure we expand logical names, since sys$check_access doesn't */
3603 if (!strpbrk(fname,"/]>:")) {
3604 strcpy(fileified,fname);
3605 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3608 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3609 retlen = namdsc.dsc$w_length = strlen(vmsname);
3610 namdsc.dsc$a_pointer = vmsname;
3611 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3612 vmsname[retlen-1] == ':') {
3613 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3614 namdsc.dsc$w_length = strlen(fileified);
3615 namdsc.dsc$a_pointer = fileified;
3618 if (!usrdsc.dsc$w_length) {
3620 usrdsc.dsc$w_length = strlen(usrname);
3627 access = ARM$M_EXECUTE;
3632 access = ARM$M_READ;
3637 access = ARM$M_WRITE;
3642 access = ARM$M_DELETE;
3648 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3649 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3650 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3651 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3652 set_vaxc_errno(retsts);
3653 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3654 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3655 else set_errno(ENOENT);
3658 if (retsts == SS$_NORMAL) {
3659 if (!privused) return TRUE;
3660 /* We can get access, but only by using privs. Do we have the
3661 necessary privs currently enabled? */
3662 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3663 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3664 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3665 !curprv.prv$v_bypass) return FALSE;
3666 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3667 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3668 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3673 return FALSE; /* Should never get here */
3675 } /* end of cando_by_name() */
3679 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3681 flex_fstat(int fd, struct mystat *statbufp)
3683 if (!fstat(fd,(stat_t *) statbufp)) {
3684 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3685 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3687 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3691 if (!gmtime_emulation_type) (void)time(NULL);
3692 statbufp->st_mtime -= utc_offset_secs;
3693 statbufp->st_atime -= utc_offset_secs;
3694 statbufp->st_ctime -= utc_offset_secs;
3700 } /* end of flex_fstat() */
3703 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3705 flex_stat(char *fspec, struct mystat *statbufp)
3707 char fileified[NAM$C_MAXRSS+1];
3710 if (statbufp == (struct mystat *) &statcache)
3711 do_tovmsspec(fspec,namecache,0);
3712 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3713 memset(statbufp,0,sizeof *statbufp);
3714 statbufp->st_dev = encode_dev("_NLA0:");
3715 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3716 statbufp->st_uid = 0x00010001;
3717 statbufp->st_gid = 0x0001;
3718 time((time_t *)&statbufp->st_mtime);
3719 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3723 /* Try for a directory name first. If fspec contains a filename without
3724 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3725 * and sea:[wine.dark]water. exist, we prefer the directory here.
3726 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3727 * not sea:[wine.dark]., if the latter exists. If the intended target is
3728 * the file with null type, specify this by calling flex_stat() with
3729 * a '.' at the end of fspec.
3731 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3732 retval = stat(fileified,(stat_t *) statbufp);
3733 if (!retval && statbufp == (struct mystat *) &statcache)
3734 strcpy(namecache,fileified);
3736 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3738 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3740 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3744 if (!gmtime_emulation_type) (void)time(NULL);
3745 statbufp->st_mtime -= utc_offset_secs;
3746 statbufp->st_atime -= utc_offset_secs;
3747 statbufp->st_ctime -= utc_offset_secs;
3752 } /* end of flex_stat() */
3755 /* Insures that no carriage-control translation will be done on a file. */
3756 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3758 my_binmode(FILE *fp, char iotype)
3760 char filespec[NAM$C_MAXRSS], *acmode;
3763 if (!fgetname(fp,filespec)) return NULL;
3764 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3766 case '<': case 'r': acmode = "rb"; break;
3768 /* use 'a' instead of 'w' to avoid creating new file;
3769 fsetpos below will take care of restoring file position */
3770 case 'a': acmode = "ab"; break;
3771 case '+': case '|': case 's': acmode = "rb+"; break;
3772 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3774 warn("Unrecognized iotype %c in my_binmode",iotype);
3777 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3778 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3780 } /* end of my_binmode() */
3784 /*{{{char *my_getlogin()*/
3785 /* VMS cuserid == Unix getlogin, except calling sequence */
3789 static char user[L_cuserid];
3790 return cuserid(user);
3795 /* rmscopy - copy a file using VMS RMS routines
3797 * Copies contents and attributes of spec_in to spec_out, except owner
3798 * and protection information. Name and type of spec_in are used as
3799 * defaults for spec_out. The third parameter specifies whether rmscopy()
3800 * should try to propagate timestamps from the input file to the output file.
3801 * If it is less than 0, no timestamps are preserved. If it is 0, then
3802 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3803 * propagated to the output file at creation iff the output file specification
3804 * did not contain an explicit name or type, and the revision date is always
3805 * updated at the end of the copy operation. If it is greater than 0, then
3806 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3807 * other than the revision date should be propagated, and bit 1 indicates
3808 * that the revision date should be propagated.
3810 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3812 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3813 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3814 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3815 * as part of the Perl standard distribution under the terms of the
3816 * GNU General Public License or the Perl Artistic License. Copies
3817 * of each may be found in the Perl standard distribution.
3819 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3821 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3823 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3824 rsa[NAM$C_MAXRSS], ubf[32256];
3825 unsigned long int i, sts, sts2;
3826 struct FAB fab_in, fab_out;
3827 struct RAB rab_in, rab_out;
3829 struct XABDAT xabdat;
3830 struct XABFHC xabfhc;
3831 struct XABRDT xabrdt;
3832 struct XABSUM xabsum;
3834 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3835 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3836 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3840 fab_in = cc$rms_fab;
3841 fab_in.fab$l_fna = vmsin;
3842 fab_in.fab$b_fns = strlen(vmsin);
3843 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3844 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3845 fab_in.fab$l_fop = FAB$M_SQO;
3846 fab_in.fab$l_nam = &nam;
3847 fab_in.fab$l_xab = (void *) &xabdat;
3850 nam.nam$l_rsa = rsa;
3851 nam.nam$b_rss = sizeof(rsa);
3852 nam.nam$l_esa = esa;
3853 nam.nam$b_ess = sizeof (esa);
3854 nam.nam$b_esl = nam.nam$b_rsl = 0;
3856 xabdat = cc$rms_xabdat; /* To get creation date */
3857 xabdat.xab$l_nxt = (void *) &xabfhc;
3859 xabfhc = cc$rms_xabfhc; /* To get record length */
3860 xabfhc.xab$l_nxt = (void *) &xabsum;
3862 xabsum = cc$rms_xabsum; /* To get key and area information */
3864 if (!((sts = sys$open(&fab_in)) & 1)) {
3865 set_vaxc_errno(sts);
3869 set_errno(ENOENT); break;
3871 set_errno(ENODEV); break;
3873 set_errno(EINVAL); break;
3875 set_errno(EACCES); break;
3883 fab_out.fab$w_ifi = 0;
3884 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3885 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3886 fab_out.fab$l_fop = FAB$M_SQO;
3887 fab_out.fab$l_fna = vmsout;
3888 fab_out.fab$b_fns = strlen(vmsout);
3889 fab_out.fab$l_dna = nam.nam$l_name;
3890 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3892 if (preserve_dates == 0) { /* Act like DCL COPY */
3893 nam.nam$b_nop = NAM$M_SYNCHK;
3894 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3895 if (!((sts = sys$parse(&fab_out)) & 1)) {
3896 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3897 set_vaxc_errno(sts);
3900 fab_out.fab$l_xab = (void *) &xabdat;
3901 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3903 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3904 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3905 preserve_dates =0; /* bitmask from this point forward */
3907 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3908 if (!((sts = sys$create(&fab_out)) & 1)) {
3909 set_vaxc_errno(sts);
3912 set_errno(ENOENT); break;
3914 set_errno(ENODEV); break;
3916 set_errno(EINVAL); break;
3918 set_errno(EACCES); break;
3924 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3925 if (preserve_dates & 2) {
3926 /* sys$close() will process xabrdt, not xabdat */
3927 xabrdt = cc$rms_xabrdt;
3929 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3931 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3932 * is unsigned long[2], while DECC & VAXC use a struct */
3933 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3935 fab_out.fab$l_xab = (void *) &xabrdt;
3938 rab_in = cc$rms_rab;
3939 rab_in.rab$l_fab = &fab_in;
3940 rab_in.rab$l_rop = RAB$M_BIO;
3941 rab_in.rab$l_ubf = ubf;
3942 rab_in.rab$w_usz = sizeof ubf;
3943 if (!((sts = sys$connect(&rab_in)) & 1)) {
3944 sys$close(&fab_in); sys$close(&fab_out);
3945 set_errno(EVMSERR); set_vaxc_errno(sts);
3949 rab_out = cc$rms_rab;
3950 rab_out.rab$l_fab = &fab_out;
3951 rab_out.rab$l_rbf = ubf;
3952 if (!((sts = sys$connect(&rab_out)) & 1)) {
3953 sys$close(&fab_in); sys$close(&fab_out);
3954 set_errno(EVMSERR); set_vaxc_errno(sts);
3958 while ((sts = sys$read(&rab_in))) { /* always true */
3959 if (sts == RMS$_EOF) break;
3960 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3961 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3962 sys$close(&fab_in); sys$close(&fab_out);
3963 set_errno(EVMSERR); set_vaxc_errno(sts);
3968 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3969 sys$close(&fab_in); sys$close(&fab_out);
3970 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3972 set_errno(EVMSERR); set_vaxc_errno(sts);
3978 } /* end of rmscopy() */
3982 /*** The following glue provides 'hooks' to make some of the routines
3983 * from this file available from Perl. These routines are sufficiently
3984 * basic, and are required sufficiently early in the build process,
3985 * that's it's nice to have them available to miniperl as well as the
3986 * full Perl, so they're set up here instead of in an extension. The
3987 * Perl code which handles importation of these names into a given
3988 * package lives in [.VMS]Filespec.pm in @INC.
3992 rmsexpand_fromperl(CV *cv)
3995 char *fspec, *defspec = NULL, *rslt;
3997 if (!items || items > 2)
3998 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3999 fspec = SvPV(ST(0),na);
4000 if (!fspec || !*fspec) XSRETURN_UNDEF;
4001 if (items == 2) defspec = SvPV(ST(1),na);
4003 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4004 ST(0) = sv_newmortal();
4005 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4010 vmsify_fromperl(CV *cv)
4015 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4016 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4017 ST(0) = sv_newmortal();
4018 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4023 unixify_fromperl(CV *cv)
4028 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4029 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4030 ST(0) = sv_newmortal();
4031 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4036 fileify_fromperl(CV *cv)
4041 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4042 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4043 ST(0) = sv_newmortal();
4044 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4049 pathify_fromperl(CV *cv)
4054 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4055 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4056 ST(0) = sv_newmortal();
4057 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4062 vmspath_fromperl(CV *cv)
4067 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4068 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4069 ST(0) = sv_newmortal();
4070 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4075 unixpath_fromperl(CV *cv)
4080 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4081 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4082 ST(0) = sv_newmortal();
4083 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4088 candelete_fromperl(CV *cv)
4091 char fspec[NAM$C_MAXRSS+1], *fsp;
4095 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4097 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4098 if (SvTYPE(mysv) == SVt_PVGV) {
4099 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4100 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4107 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4108 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4114 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4119 rmscopy_fromperl(CV *cv)
4122 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4124 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4125 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4126 unsigned long int sts;
4130 if (items < 2 || items > 3)
4131 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4133 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4134 if (SvTYPE(mysv) == SVt_PVGV) {
4135 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4136 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4143 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4144 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4149 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4150 if (SvTYPE(mysv) == SVt_PVGV) {
4151 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4152 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4159 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4160 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4165 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4167 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4174 char* file = __FILE__;
4176 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4177 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4178 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4179 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4180 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4181 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4182 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4183 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4184 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);