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 /* OS-specific initialization at image activation (not thread startup) */
2226 /*{{{void vms_image_init(int *, char ***)*/
2228 vms_image_init(int *argcp, char ***argvp)
2230 unsigned long int *mask, iosb[2], i;
2231 unsigned short int dummy;
2233 struct itmlst_3 jpilist[2] = { {sizeof iprv, JPI$_IMAGPRIV, &iprv, &dummy},
2236 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2238 mask = (unsigned long int *) &iprv; /* Quick change of view */;
2239 for (i = 0; i < (sizeof iprv + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i++) {
2240 if (mask[i]) { /* Running image installed with privs? */
2241 _ckvmssts(sys$setprv(0,&iprv,0,NULL)); /* Turn 'em off. */
2246 getredirection(argcp,argvp);
2253 * Trim Unix-style prefix off filespec, so it looks like what a shell
2254 * glob expansion would return (i.e. from specified prefix on, not
2255 * full path). Note that returned filespec is Unix-style, regardless
2256 * of whether input filespec was VMS-style or Unix-style.
2258 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2259 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2260 * vector of options; at present, only bit 0 is used, and if set tells
2261 * trim unixpath to try the current default directory as a prefix when
2262 * presented with a possibly ambiguous ... wildcard.
2264 * Returns !=0 on success, with trimmed filespec replacing contents of
2265 * fspec, and 0 on failure, with contents of fpsec unchanged.
2267 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2269 trim_unixpath(char *fspec, char *wildspec, int opts)
2271 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2272 *template, *base, *end, *cp1, *cp2;
2273 register int tmplen, reslen = 0, dirs = 0;
2275 if (!wildspec || !fspec) return 0;
2276 if (strpbrk(wildspec,"]>:") != NULL) {
2277 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2278 else template = unixwild;
2280 else template = wildspec;
2281 if (strpbrk(fspec,"]>:") != NULL) {
2282 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2283 else base = unixified;
2284 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2285 * check to see that final result fits into (isn't longer than) fspec */
2286 reslen = strlen(fspec);
2290 /* No prefix or absolute path on wildcard, so nothing to remove */
2291 if (!*template || *template == '/') {
2292 if (base == fspec) return 1;
2293 tmplen = strlen(unixified);
2294 if (tmplen > reslen) return 0; /* not enough space */
2295 /* Copy unixified resultant, including trailing NUL */
2296 memmove(fspec,unixified,tmplen+1);
2300 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2301 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2302 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2303 for (cp1 = end ;cp1 >= base; cp1--)
2304 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2306 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2310 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2311 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2312 int ells = 1, totells, segdirs, match;
2313 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2314 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2316 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2318 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2319 if (ellipsis == template && opts & 1) {
2320 /* Template begins with an ellipsis. Since we can't tell how many
2321 * directory names at the front of the resultant to keep for an
2322 * arbitrary starting point, we arbitrarily choose the current
2323 * default directory as a starting point. If it's there as a prefix,
2324 * clip it off. If not, fall through and act as if the leading
2325 * ellipsis weren't there (i.e. return shortest possible path that
2326 * could match template).
2328 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2329 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2330 if (_tolower(*cp1) != _tolower(*cp2)) break;
2331 segdirs = dirs - totells; /* Min # of dirs we must have left */
2332 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2333 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2334 memcpy(fspec,cp2+1,end - cp2);
2338 /* First off, back up over constant elements at end of path */
2340 for (front = end ; front >= base; front--)
2341 if (*front == '/' && !dirs--) { front++; break; }
2343 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2344 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2345 if (cp1 != '\0') return 0; /* Path too long. */
2347 *cp2 = '\0'; /* Pick up with memcpy later */
2348 lcfront = lcres + (front - base);
2349 /* Now skip over each ellipsis and try to match the path in front of it. */
2351 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2352 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2353 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2354 if (cp1 < template) break; /* template started with an ellipsis */
2355 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2356 ellipsis = cp1; continue;
2358 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2360 for (segdirs = 0, cp2 = tpl;
2361 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2363 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2364 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2365 if (*cp2 == '/') segdirs++;
2367 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2368 /* Back up at least as many dirs as in template before matching */
2369 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2370 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2371 for (match = 0; cp1 > lcres;) {
2372 resdsc.dsc$a_pointer = cp1;
2373 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2375 if (match == 1) lcfront = cp1;
2377 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2379 if (!match) return 0; /* Can't find prefix ??? */
2380 if (match > 1 && opts & 1) {
2381 /* This ... wildcard could cover more than one set of dirs (i.e.
2382 * a set of similar dir names is repeated). If the template
2383 * contains more than 1 ..., upstream elements could resolve the
2384 * ambiguity, but it's not worth a full backtracking setup here.
2385 * As a quick heuristic, clip off the current default directory
2386 * if it's present to find the trimmed spec, else use the
2387 * shortest string that this ... could cover.
2389 char def[NAM$C_MAXRSS+1], *st;
2391 if (getcwd(def, sizeof def,0) == NULL) return 0;
2392 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2393 if (_tolower(*cp1) != _tolower(*cp2)) break;
2394 segdirs = dirs - totells; /* Min # of dirs we must have left */
2395 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2396 if (*cp1 == '\0' && *cp2 == '/') {
2397 memcpy(fspec,cp2+1,end - cp2);
2400 /* Nope -- stick with lcfront from above and keep going. */
2403 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2408 } /* end of trim_unixpath() */
2413 * VMS readdir() routines.
2414 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2416 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2417 * Minor modifications to original routines.
2420 /* Number of elements in vms_versions array */
2421 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2424 * Open a directory, return a handle for later use.
2426 /*{{{ DIR *opendir(char*name) */
2431 char dir[NAM$C_MAXRSS+1];
2433 /* Get memory for the handle, and the pattern. */
2435 if (do_tovmspath(name,dir,0) == NULL) {
2436 Safefree((char *)dd);
2439 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2441 /* Fill in the fields; mainly playing with the descriptor. */
2442 (void)sprintf(dd->pattern, "%s*.*",dir);
2445 dd->vms_wantversions = 0;
2446 dd->pat.dsc$a_pointer = dd->pattern;
2447 dd->pat.dsc$w_length = strlen(dd->pattern);
2448 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2449 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2452 } /* end of opendir() */
2456 * Set the flag to indicate we want versions or not.
2458 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2460 vmsreaddirversions(DIR *dd, int flag)
2462 dd->vms_wantversions = flag;
2467 * Free up an opened directory.
2469 /*{{{ void closedir(DIR *dd)*/
2473 (void)lib$find_file_end(&dd->context);
2474 Safefree(dd->pattern);
2475 Safefree((char *)dd);
2480 * Collect all the version numbers for the current file.
2486 struct dsc$descriptor_s pat;
2487 struct dsc$descriptor_s res;
2489 char *p, *text, buff[sizeof dd->entry.d_name];
2491 unsigned long context, tmpsts;
2493 /* Convenient shorthand. */
2496 /* Add the version wildcard, ignoring the "*.*" put on before */
2497 i = strlen(dd->pattern);
2498 New(1308,text,i + e->d_namlen + 3,char);
2499 (void)strcpy(text, dd->pattern);
2500 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2502 /* Set up the pattern descriptor. */
2503 pat.dsc$a_pointer = text;
2504 pat.dsc$w_length = i + e->d_namlen - 1;
2505 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2506 pat.dsc$b_class = DSC$K_CLASS_S;
2508 /* Set up result descriptor. */
2509 res.dsc$a_pointer = buff;
2510 res.dsc$w_length = sizeof buff - 2;
2511 res.dsc$b_dtype = DSC$K_DTYPE_T;
2512 res.dsc$b_class = DSC$K_CLASS_S;
2514 /* Read files, collecting versions. */
2515 for (context = 0, e->vms_verscount = 0;
2516 e->vms_verscount < VERSIZE(e);
2517 e->vms_verscount++) {
2518 tmpsts = lib$find_file(&pat, &res, &context);
2519 if (tmpsts == RMS$_NMF || context == 0) break;
2521 buff[sizeof buff - 1] = '\0';
2522 if ((p = strchr(buff, ';')))
2523 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2525 e->vms_versions[e->vms_verscount] = -1;
2528 _ckvmssts(lib$find_file_end(&context));
2531 } /* end of collectversions() */
2534 * Read the next entry from the directory.
2536 /*{{{ struct dirent *readdir(DIR *dd)*/
2540 struct dsc$descriptor_s res;
2541 char *p, buff[sizeof dd->entry.d_name];
2542 unsigned long int tmpsts;
2544 /* Set up result descriptor, and get next file. */
2545 res.dsc$a_pointer = buff;
2546 res.dsc$w_length = sizeof buff - 2;
2547 res.dsc$b_dtype = DSC$K_DTYPE_T;
2548 res.dsc$b_class = DSC$K_CLASS_S;
2549 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2550 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2551 if (!(tmpsts & 1)) {
2552 set_vaxc_errno(tmpsts);
2555 set_errno(EACCES); break;
2557 set_errno(ENODEV); break;
2560 set_errno(ENOENT); break;
2567 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2568 buff[sizeof buff - 1] = '\0';
2569 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2572 /* Skip any directory component and just copy the name. */
2573 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2574 else (void)strcpy(dd->entry.d_name, buff);
2576 /* Clobber the version. */
2577 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2579 dd->entry.d_namlen = strlen(dd->entry.d_name);
2580 dd->entry.vms_verscount = 0;
2581 if (dd->vms_wantversions) collectversions(dd);
2584 } /* end of readdir() */
2588 * Return something that can be used in a seekdir later.
2590 /*{{{ long telldir(DIR *dd)*/
2599 * Return to a spot where we used to be. Brute force.
2601 /*{{{ void seekdir(DIR *dd,long count)*/
2603 seekdir(DIR *dd, long count)
2605 int vms_wantversions;
2607 /* If we haven't done anything yet... */
2611 /* Remember some state, and clear it. */
2612 vms_wantversions = dd->vms_wantversions;
2613 dd->vms_wantversions = 0;
2614 _ckvmssts(lib$find_file_end(&dd->context));
2617 /* The increment is in readdir(). */
2618 for (dd->count = 0; dd->count < count; )
2621 dd->vms_wantversions = vms_wantversions;
2623 } /* end of seekdir() */
2626 /* VMS subprocess management
2628 * my_vfork() - just a vfork(), after setting a flag to record that
2629 * the current script is trying a Unix-style fork/exec.
2631 * vms_do_aexec() and vms_do_exec() are called in response to the
2632 * perl 'exec' function. If this follows a vfork call, then they
2633 * call out the the regular perl routines in doio.c which do an
2634 * execvp (for those who really want to try this under VMS).
2635 * Otherwise, they do exactly what the perl docs say exec should
2636 * do - terminate the current script and invoke a new command
2637 * (See below for notes on command syntax.)
2639 * do_aspawn() and do_spawn() implement the VMS side of the perl
2640 * 'system' function.
2642 * Note on command arguments to perl 'exec' and 'system': When handled
2643 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2644 * are concatenated to form a DCL command string. If the first arg
2645 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2646 * the the command string is hrnded off to DCL directly. Otherwise,
2647 * the first token of the command is taken as the filespec of an image
2648 * to run. The filespec is expanded using a default type of '.EXE' and
2649 * the process defaults for device, directory, etc., and the resultant
2650 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2651 * the command string as parameters. This is perhaps a bit compicated,
2652 * but I hope it will form a happy medium between what VMS folks expect
2653 * from lib$spawn and what Unix folks expect from exec.
2656 static int vfork_called;
2658 /*{{{int my_vfork()*/
2668 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2676 if (VMScmd.dsc$a_pointer) {
2677 Safefree(VMScmd.dsc$a_pointer);
2678 VMScmd.dsc$w_length = 0;
2679 VMScmd.dsc$a_pointer = Nullch;
2684 setup_argstr(SV *really, SV **mark, SV **sp)
2687 char *junk, *tmps = Nullch;
2688 register size_t cmdlen = 0;
2694 tmps = SvPV(really,rlen);
2701 for (idx++; idx <= sp; idx++) {
2703 junk = SvPVx(*idx,rlen);
2704 cmdlen += rlen ? rlen + 1 : 0;
2707 New(401,Cmd,cmdlen+1,char);
2709 if (tmps && *tmps) {
2714 while (++mark <= sp) {
2717 strcat(Cmd,SvPVx(*mark,na));
2722 } /* end of setup_argstr() */
2725 static unsigned long int
2726 setup_cmddsc(char *cmd, int check_img)
2728 char resspec[NAM$C_MAXRSS+1];
2729 $DESCRIPTOR(defdsc,".EXE");
2730 $DESCRIPTOR(resdsc,resspec);
2731 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2732 unsigned long int cxt = 0, flags = 1, retsts;
2733 register char *s, *rest, *cp;
2734 register int isdcl = 0;
2737 while (*s && isspace(*s)) s++;
2739 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2740 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2741 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2742 if (*cp == ':' || *cp == '[' || *cp == '<') {
2750 if (isdcl) { /* It's a DCL command, just do it. */
2751 VMScmd.dsc$w_length = strlen(cmd);
2753 VMScmd.dsc$a_pointer = Cmd;
2754 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2756 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2758 else { /* assume first token is an image spec */
2760 while (*s && !isspace(*s)) s++;
2762 imgdsc.dsc$a_pointer = cmd;
2763 imgdsc.dsc$w_length = s - cmd;
2764 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2765 if (!(retsts & 1)) {
2766 /* just hand off status values likely to be due to user error */
2767 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2768 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2769 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2770 else { _ckvmssts(retsts); }
2773 _ckvmssts(lib$find_file_end(&cxt));
2775 while (*s && !isspace(*s)) s++;
2777 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2778 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2779 strcat(VMScmd.dsc$a_pointer,resspec);
2780 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2781 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2785 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2787 } /* end of setup_cmddsc() */
2790 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2792 vms_do_aexec(SV *really,SV **mark,SV **sp)
2795 if (vfork_called) { /* this follows a vfork - act Unixish */
2797 if (vfork_called < 0) {
2798 warn("Internal inconsistency in tracking vforks");
2801 else return do_aexec(really,mark,sp);
2803 /* no vfork - act VMSish */
2804 return vms_do_exec(setup_argstr(really,mark,sp));
2809 } /* end of vms_do_aexec() */
2812 /* {{{bool vms_do_exec(char *cmd) */
2814 vms_do_exec(char *cmd)
2817 if (vfork_called) { /* this follows a vfork - act Unixish */
2819 if (vfork_called < 0) {
2820 warn("Internal inconsistency in tracking vforks");
2823 else return do_exec(cmd);
2826 { /* no vfork - act VMSish */
2827 unsigned long int retsts;
2830 TAINT_PROPER("exec");
2831 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2832 retsts = lib$do_command(&VMScmd);
2835 set_vaxc_errno(retsts);
2837 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2843 } /* end of vms_do_exec() */
2846 unsigned long int do_spawn(char *);
2848 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2850 do_aspawn(SV *really,SV **mark,SV **sp)
2852 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2855 } /* end of do_aspawn() */
2858 /* {{{unsigned long int do_spawn(char *cmd) */
2862 unsigned long int substs, hadcmd = 1;
2865 TAINT_PROPER("spawn");
2866 if (!cmd || !*cmd) {
2868 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2870 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2871 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2876 set_vaxc_errno(substs);
2878 warn("Can't spawn \"%s\": %s",
2879 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2884 } /* end of do_spawn() */
2888 * A simple fwrite replacement which outputs itmsz*nitm chars without
2889 * introducing record boundaries every itmsz chars.
2891 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2893 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2895 register char *cp, *end;
2897 end = (char *)src + itmsz * nitm;
2899 while ((char *)src <= end) {
2900 for (cp = src; cp <= end; cp++) if (!*cp) break;
2901 if (fputs(src,dest) == EOF) return EOF;
2903 if (fputc('\0',dest) == EOF) return EOF;
2909 } /* end of my_fwrite() */
2912 /*{{{ int my_flush(FILE *fp)*/
2917 if ((res = fflush(fp)) == 0) {
2918 #ifdef VMS_DO_SOCKETS
2920 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
2922 res = fsync(fileno(fp));
2929 * Here are replacements for the following Unix routines in the VMS environment:
2930 * getpwuid Get information for a particular UIC or UID
2931 * getpwnam Get information for a named user
2932 * getpwent Get information for each user in the rights database
2933 * setpwent Reset search to the start of the rights database
2934 * endpwent Finish searching for users in the rights database
2936 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2937 * (defined in pwd.h), which contains the following fields:-
2939 * char *pw_name; Username (in lower case)
2940 * char *pw_passwd; Hashed password
2941 * unsigned int pw_uid; UIC
2942 * unsigned int pw_gid; UIC group number
2943 * char *pw_unixdir; Default device/directory (VMS-style)
2944 * char *pw_gecos; Owner name
2945 * char *pw_dir; Default device/directory (Unix-style)
2946 * char *pw_shell; Default CLI name (eg. DCL)
2948 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2950 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2951 * not the UIC member number (eg. what's returned by getuid()),
2952 * getpwuid() can accept either as input (if uid is specified, the caller's
2953 * UIC group is used), though it won't recognise gid=0.
2955 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2956 * information about other users in your group or in other groups, respectively.
2957 * If the required privilege is not available, then these routines fill only
2958 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2961 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2964 /* sizes of various UAF record fields */
2965 #define UAI$S_USERNAME 12
2966 #define UAI$S_IDENT 31
2967 #define UAI$S_OWNER 31
2968 #define UAI$S_DEFDEV 31
2969 #define UAI$S_DEFDIR 63
2970 #define UAI$S_DEFCLI 31
2973 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2974 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2975 (uic).uic$v_group != UIC$K_WILD_GROUP)
2977 static char __empty[]= "";
2978 static struct passwd __passwd_empty=
2979 {(char *) __empty, (char *) __empty, 0, 0,
2980 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2981 static int contxt= 0;
2982 static struct passwd __pwdcache;
2983 static char __pw_namecache[UAI$S_IDENT+1];
2986 * This routine does most of the work extracting the user information.
2988 static int fillpasswd (const char *name, struct passwd *pwd)
2991 unsigned char length;
2992 char pw_gecos[UAI$S_OWNER+1];
2994 static union uicdef uic;
2996 unsigned char length;
2997 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3000 unsigned char length;
3001 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3004 unsigned char length;
3005 char pw_shell[UAI$S_DEFCLI+1];
3007 static char pw_passwd[UAI$S_PWD+1];
3009 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3010 struct dsc$descriptor_s name_desc;
3011 unsigned long int sts;
3013 static struct itmlst_3 itmlst[]= {
3014 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3015 {sizeof(uic), UAI$_UIC, &uic, &luic},
3016 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3017 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3018 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3019 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3020 {0, 0, NULL, NULL}};
3022 name_desc.dsc$w_length= strlen(name);
3023 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3024 name_desc.dsc$b_class= DSC$K_CLASS_S;
3025 name_desc.dsc$a_pointer= (char *) name;
3027 /* Note that sys$getuai returns many fields as counted strings. */
3028 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3029 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3030 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3032 else { _ckvmssts(sts); }
3033 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3035 if ((int) owner.length < lowner) lowner= (int) owner.length;
3036 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3037 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3038 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3039 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3040 owner.pw_gecos[lowner]= '\0';
3041 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3042 defcli.pw_shell[ldefcli]= '\0';
3043 if (valid_uic(uic)) {
3044 pwd->pw_uid= uic.uic$l_uic;
3045 pwd->pw_gid= uic.uic$v_group;
3048 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3049 pwd->pw_passwd= pw_passwd;
3050 pwd->pw_gecos= owner.pw_gecos;
3051 pwd->pw_dir= defdev.pw_dir;
3052 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3053 pwd->pw_shell= defcli.pw_shell;
3054 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3056 ldir= strlen(pwd->pw_unixdir) - 1;
3057 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3060 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3061 __mystrtolower(pwd->pw_unixdir);
3066 * Get information for a named user.
3068 /*{{{struct passwd *getpwnam(char *name)*/
3069 struct passwd *my_getpwnam(char *name)
3071 struct dsc$descriptor_s name_desc;
3073 unsigned long int status, sts;
3075 __pwdcache = __passwd_empty;
3076 if (!fillpasswd(name, &__pwdcache)) {
3077 /* We still may be able to determine pw_uid and pw_gid */
3078 name_desc.dsc$w_length= strlen(name);
3079 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3080 name_desc.dsc$b_class= DSC$K_CLASS_S;
3081 name_desc.dsc$a_pointer= (char *) name;
3082 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3083 __pwdcache.pw_uid= uic.uic$l_uic;
3084 __pwdcache.pw_gid= uic.uic$v_group;
3087 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3088 set_vaxc_errno(sts);
3089 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3092 else { _ckvmssts(sts); }
3095 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3096 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3097 __pwdcache.pw_name= __pw_namecache;
3099 } /* end of my_getpwnam() */
3103 * Get information for a particular UIC or UID.
3104 * Called by my_getpwent with uid=-1 to list all users.
3106 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3107 struct passwd *my_getpwuid(Uid_t uid)
3109 const $DESCRIPTOR(name_desc,__pw_namecache);
3110 unsigned short lname;
3112 unsigned long int status;
3114 if (uid == (unsigned int) -1) {
3116 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3117 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3118 set_vaxc_errno(status);
3119 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3123 else { _ckvmssts(status); }
3124 } while (!valid_uic (uic));
3128 if (!uic.uic$v_group)
3129 uic.uic$v_group= getgid();
3131 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3132 else status = SS$_IVIDENT;
3133 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3134 status == RMS$_PRV) {
3135 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3138 else { _ckvmssts(status); }
3140 __pw_namecache[lname]= '\0';
3141 __mystrtolower(__pw_namecache);
3143 __pwdcache = __passwd_empty;
3144 __pwdcache.pw_name = __pw_namecache;
3146 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3147 The identifier's value is usually the UIC, but it doesn't have to be,
3148 so if we can, we let fillpasswd update this. */
3149 __pwdcache.pw_uid = uic.uic$l_uic;
3150 __pwdcache.pw_gid = uic.uic$v_group;
3152 fillpasswd(__pw_namecache, &__pwdcache);
3155 } /* end of my_getpwuid() */
3159 * Get information for next user.
3161 /*{{{struct passwd *my_getpwent()*/
3162 struct passwd *my_getpwent()
3164 return (my_getpwuid((unsigned int) -1));
3169 * Finish searching rights database for users.
3171 /*{{{void my_endpwent()*/
3175 _ckvmssts(sys$finish_rdb(&contxt));
3181 #if __VMS_VER < 70000000 || __DECC_VER < 50200000
3182 /* Signal handling routines, pulled into the core from POSIX.xs.
3184 * We need these for threads, so they've been rolled into the core,
3185 * rather than left in POSIX.xs.
3187 * (DRS, Oct 23, 1997)
3190 /* sigset_t is atomic under VMS, so these routines are easy */
3191 int my_sigemptyset(sigset_t *set) {
3192 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3195 int my_sigfillset(sigset_t *set) {
3197 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3198 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3201 int my_sigaddset(sigset_t *set, int sig) {
3202 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3203 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3204 *set |= (1 << (sig - 1));
3207 int my_sigdelset(sigset_t *set, int sig) {
3208 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3209 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3210 *set &= ~(1 << (sig - 1));
3213 int my_sigismember(sigset_t *set, int sig) {
3214 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3215 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3216 *set & (1 << (sig - 1));
3218 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3221 /* If set and oset are both null, then things are badky wrong. Bail */
3222 if ((oset == NULL) && (set == NULL)) {
3223 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3227 /* If set's null, then we're just handling a fetch. */
3229 tempmask = sigblock(0);
3233 tempmask = sigsetmask(*set);
3236 tempmask = sigblock(*set);
3239 tempmask = sigblock(0);
3240 sigsetmask(*oset & ~tempmask);
3243 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3248 /* Did they pass us an oset? If so, stick our holding mask into it */
3255 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3256 * my_utime(), and flex_stat(), all of which operate on UTC unless
3257 * VMSISH_TIMES is true.
3259 /* method used to handle UTC conversions:
3260 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3262 static int gmtime_emulation_type;
3263 /* number of secs to add to UTC POSIX-style time to get local time */
3264 static long int utc_offset_secs;
3266 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3267 * in vmsish.h. #undef them here so we can call the CRTL routines
3274 /* my_time(), my_localtime(), my_gmtime()
3275 * By default traffic in UTC time values, suing CRTL gmtime() or
3276 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3277 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3278 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3281 /*{{{time_t my_time(time_t *timep)*/
3282 time_t my_time(time_t *timep)
3287 if (gmtime_emulation_type == 0) {
3289 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3291 gmtime_emulation_type++;
3292 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3295 gmtime_emulation_type++;
3296 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3297 gmtime_emulation_type++;
3298 warn("no UTC offset information; assuming local time is UTC");
3300 else { utc_offset_secs = atol(off); }
3302 else { /* We've got a working gmtime() */
3303 struct tm gmt, local;
3306 tm_p = localtime(&base);
3308 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3309 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3310 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3311 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3320 when != -1) when -= utc_offset_secs;
3321 if (timep != NULL) *timep = when;
3324 } /* end of my_time() */
3328 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3330 my_gmtime(const time_t *timep)
3336 if (timep == NULL) {
3337 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3340 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3341 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3345 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3347 /* CRTL localtime() wants local time as input, so does no tz correction */
3348 return localtime(&when);
3350 } /* end of my_gmtime() */
3354 /*{{{struct tm *my_localtime(const time_t *timep)*/
3356 my_localtime(const time_t *timep)
3361 if (timep == NULL) {
3362 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3365 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3366 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3370 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3372 /* CRTL localtime() wants local time as input, so does no tz correction */
3373 return localtime(&when);
3375 } /* end of my_localtime() */
3378 /* Reset definitions for later calls */
3379 #define gmtime(t) my_gmtime(t)
3380 #define localtime(t) my_localtime(t)
3381 #define time(t) my_time(t)
3383 #endif /* VMS VER < 7.0 || Dec C < 5.2
3385 /* my_utime - update modification time of a file
3386 * calling sequence is identical to POSIX utime(), but under
3387 * VMS only the modification time is changed; ODS-2 does not
3388 * maintain access times. Restrictions differ from the POSIX
3389 * definition in that the time can be changed as long as the
3390 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3391 * no separate checks are made to insure that the caller is the
3392 * owner of the file or has special privs enabled.
3393 * Code here is based on Joe Meadows' FILE utility.
3396 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3397 * to VMS epoch (01-JAN-1858 00:00:00.00)
3398 * in 100 ns intervals.
3400 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3402 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3403 int my_utime(char *file, struct utimbuf *utimes)
3407 long int bintime[2], len = 2, lowbit, unixtime,
3408 secscale = 10000000; /* seconds --> 100 ns intervals */
3409 unsigned long int chan, iosb[2], retsts;
3410 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3411 struct FAB myfab = cc$rms_fab;
3412 struct NAM mynam = cc$rms_nam;
3413 #if defined (__DECC) && defined (__VAX)
3414 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3415 * at least through VMS V6.1, which causes a type-conversion warning.
3417 # pragma message save
3418 # pragma message disable cvtdiftypes
3420 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3421 struct fibdef myfib;
3422 #if defined (__DECC) && defined (__VAX)
3423 /* This should be right after the declaration of myatr, but due
3424 * to a bug in VAX DEC C, this takes effect a statement early.
3426 # pragma message restore
3428 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3429 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3430 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3432 if (file == NULL || *file == '\0') {
3434 set_vaxc_errno(LIB$_INVARG);
3437 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3439 if (utimes != NULL) {
3440 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3441 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3442 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3443 * as input, we force the sign bit to be clear by shifting unixtime right
3444 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3446 lowbit = (utimes->modtime & 1) ? secscale : 0;
3447 unixtime = (long int) utimes->modtime;
3448 #if defined(VMSISH_TIME) && (__VMS_VER < 70000000 || __DECC_VER < 50200000)
3449 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3450 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3451 unixtime += utc_offset_secs;
3454 unixtime >> 1; secscale << 1;
3455 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3456 if (!(retsts & 1)) {
3458 set_vaxc_errno(retsts);
3461 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3462 if (!(retsts & 1)) {
3464 set_vaxc_errno(retsts);
3469 /* Just get the current time in VMS format directly */
3470 retsts = sys$gettim(bintime);
3471 if (!(retsts & 1)) {
3473 set_vaxc_errno(retsts);
3478 myfab.fab$l_fna = vmsspec;
3479 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3480 myfab.fab$l_nam = &mynam;
3481 mynam.nam$l_esa = esa;
3482 mynam.nam$b_ess = (unsigned char) sizeof esa;
3483 mynam.nam$l_rsa = rsa;
3484 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3486 /* Look for the file to be affected, letting RMS parse the file
3487 * specification for us as well. I have set errno using only
3488 * values documented in the utime() man page for VMS POSIX.
3490 retsts = sys$parse(&myfab,0,0);
3491 if (!(retsts & 1)) {
3492 set_vaxc_errno(retsts);
3493 if (retsts == RMS$_PRV) set_errno(EACCES);
3494 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3495 else set_errno(EVMSERR);
3498 retsts = sys$search(&myfab,0,0);
3499 if (!(retsts & 1)) {
3500 set_vaxc_errno(retsts);
3501 if (retsts == RMS$_PRV) set_errno(EACCES);
3502 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3503 else set_errno(EVMSERR);
3507 devdsc.dsc$w_length = mynam.nam$b_dev;
3508 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3510 retsts = sys$assign(&devdsc,&chan,0,0);
3511 if (!(retsts & 1)) {
3512 set_vaxc_errno(retsts);
3513 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3514 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3515 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3516 else set_errno(EVMSERR);
3520 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3521 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3523 memset((void *) &myfib, 0, sizeof myfib);
3525 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3526 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3527 /* This prevents the revision time of the file being reset to the current
3528 * time as a result of our IO$_MODIFY $QIO. */
3529 myfib.fib$l_acctl = FIB$M_NORECORD;
3531 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3532 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3533 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3535 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3536 _ckvmssts(sys$dassgn(chan));
3537 if (retsts & 1) retsts = iosb[0];
3538 if (!(retsts & 1)) {
3539 set_vaxc_errno(retsts);
3540 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3541 else set_errno(EVMSERR);
3546 } /* end of my_utime() */
3550 * flex_stat, flex_fstat
3551 * basic stat, but gets it right when asked to stat
3552 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3555 /* encode_dev packs a VMS device name string into an integer to allow
3556 * simple comparisons. This can be used, for example, to check whether two
3557 * files are located on the same device, by comparing their encoded device
3558 * names. Even a string comparison would not do, because stat() reuses the
3559 * device name buffer for each call; so without encode_dev, it would be
3560 * necessary to save the buffer and use strcmp (this would mean a number of
3561 * changes to the standard Perl code, to say nothing of what a Perl script
3564 * The device lock id, if it exists, should be unique (unless perhaps compared
3565 * with lock ids transferred from other nodes). We have a lock id if the disk is
3566 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3567 * device names. Thus we use the lock id in preference, and only if that isn't
3568 * available, do we try to pack the device name into an integer (flagged by
3569 * the sign bit (LOCKID_MASK) being set).
3571 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3572 * name and its encoded form, but it seems very unlikely that we will find
3573 * two files on different disks that share the same encoded device names,
3574 * and even more remote that they will share the same file id (if the test
3575 * is to check for the same file).
3577 * A better method might be to use sys$device_scan on the first call, and to
3578 * search for the device, returning an index into the cached array.
3579 * The number returned would be more intelligable.
3580 * This is probably not worth it, and anyway would take quite a bit longer
3581 * on the first call.
3583 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3584 static mydev_t encode_dev (const char *dev)
3587 unsigned long int f;
3592 if (!dev || !dev[0]) return 0;
3596 struct dsc$descriptor_s dev_desc;
3597 unsigned long int status, lockid, item = DVI$_LOCKID;
3599 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3600 can try that first. */
3601 dev_desc.dsc$w_length = strlen (dev);
3602 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3603 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3604 dev_desc.dsc$a_pointer = (char *) dev;
3605 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3606 if (lockid) return (lockid & ~LOCKID_MASK);
3610 /* Otherwise we try to encode the device name */
3614 for (q = dev + strlen(dev); q--; q >= dev) {
3617 else if (isalpha (toupper (*q)))
3618 c= toupper (*q) - 'A' + (char)10;
3620 continue; /* Skip '$'s */
3622 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3624 enc += f * (unsigned long int) c;
3626 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3628 } /* end of encode_dev() */
3630 static char namecache[NAM$C_MAXRSS+1];
3633 is_null_device(name)
3636 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3637 The underscore prefix, controller letter, and unit number are
3638 independently optional; for our purposes, the colon punctuation
3639 is not. The colon can be trailed by optional directory and/or
3640 filename, but two consecutive colons indicates a nodename rather
3641 than a device. [pr] */
3642 if (*name == '_') ++name;
3643 if (tolower(*name++) != 'n') return 0;
3644 if (tolower(*name++) != 'l') return 0;
3645 if (tolower(*name) == 'a') ++name;
3646 if (*name == '0') ++name;
3647 return (*name++ == ':') && (*name != ':');
3650 /* Do the permissions allow some operation? Assumes statcache already set. */
3651 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3652 * subset of the applicable information. (We have to stick with struct
3653 * stat instead of struct mystat in the prototype since we have to match
3654 * the one in proto.h.)
3656 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3658 cando(I32 bit, I32 effective, struct stat *statbufp)
3660 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3662 char fname[NAM$C_MAXRSS+1];
3663 unsigned long int retsts;
3664 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3665 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3667 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3668 device name on successive calls */
3669 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3670 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3671 namdsc.dsc$a_pointer = fname;
3672 namdsc.dsc$w_length = sizeof fname - 1;
3674 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3675 &namdsc,&namdsc.dsc$w_length,0,0);
3677 fname[namdsc.dsc$w_length] = '\0';
3678 return cando_by_name(bit,effective,fname);
3680 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3681 warn("Can't get filespec - stale stat buffer?\n");
3685 return FALSE; /* Should never get to here */
3687 } /* end of cando() */
3691 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3693 cando_by_name(I32 bit, I32 effective, char *fname)
3695 static char usrname[L_cuserid];
3696 static struct dsc$descriptor_s usrdsc =
3697 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3698 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3699 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3700 unsigned short int retlen;
3701 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3702 union prvdef curprv;
3703 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3704 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3705 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3708 if (!fname || !*fname) return FALSE;
3709 /* Make sure we expand logical names, since sys$check_access doesn't */
3710 if (!strpbrk(fname,"/]>:")) {
3711 strcpy(fileified,fname);
3712 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3715 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3716 retlen = namdsc.dsc$w_length = strlen(vmsname);
3717 namdsc.dsc$a_pointer = vmsname;
3718 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3719 vmsname[retlen-1] == ':') {
3720 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3721 namdsc.dsc$w_length = strlen(fileified);
3722 namdsc.dsc$a_pointer = fileified;
3725 if (!usrdsc.dsc$w_length) {
3727 usrdsc.dsc$w_length = strlen(usrname);
3734 access = ARM$M_EXECUTE;
3739 access = ARM$M_READ;
3744 access = ARM$M_WRITE;
3749 access = ARM$M_DELETE;
3755 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3756 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3757 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3758 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3759 set_vaxc_errno(retsts);
3760 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3761 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3762 else set_errno(ENOENT);
3765 if (retsts == SS$_NORMAL) {
3766 if (!privused) return TRUE;
3767 /* We can get access, but only by using privs. Do we have the
3768 necessary privs currently enabled? */
3769 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3770 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3771 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3772 !curprv.prv$v_bypass) return FALSE;
3773 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3774 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3775 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3780 return FALSE; /* Should never get here */
3782 } /* end of cando_by_name() */
3786 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3788 flex_fstat(int fd, struct mystat *statbufp)
3792 if (!fstat(fd,(stat_t *) statbufp)) {
3793 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3794 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3796 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3800 #if __VMS_VER < 70000000 || __DECC_VER < 50200000
3801 if (!gmtime_emulation_type) (void)time(NULL);
3802 statbufp->st_mtime -= utc_offset_secs;
3803 statbufp->st_atime -= utc_offset_secs;
3804 statbufp->st_ctime -= utc_offset_secs;
3811 } /* end of flex_fstat() */
3814 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3816 flex_stat(char *fspec, struct mystat *statbufp)
3819 char fileified[NAM$C_MAXRSS+1];
3822 if (statbufp == (struct mystat *) &statcache)
3823 do_tovmsspec(fspec,namecache,0);
3824 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3825 memset(statbufp,0,sizeof *statbufp);
3826 statbufp->st_dev = encode_dev("_NLA0:");
3827 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3828 statbufp->st_uid = 0x00010001;
3829 statbufp->st_gid = 0x0001;
3830 time((time_t *)&statbufp->st_mtime);
3831 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3835 /* Try for a directory name first. If fspec contains a filename without
3836 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3837 * and sea:[wine.dark]water. exist, we prefer the directory here.
3838 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3839 * not sea:[wine.dark]., if the latter exists. If the intended target is
3840 * the file with null type, specify this by calling flex_stat() with
3841 * a '.' at the end of fspec.
3843 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3844 retval = stat(fileified,(stat_t *) statbufp);
3845 if (!retval && statbufp == (struct mystat *) &statcache)
3846 strcpy(namecache,fileified);
3848 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3850 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3852 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3856 #if __VMS_VER < 70000000 || __DECC_VER < 50200000
3857 if (!gmtime_emulation_type) (void)time(NULL);
3858 statbufp->st_mtime -= utc_offset_secs;
3859 statbufp->st_atime -= utc_offset_secs;
3860 statbufp->st_ctime -= utc_offset_secs;
3866 } /* end of flex_stat() */
3869 /* Insures that no carriage-control translation will be done on a file. */
3870 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3872 my_binmode(FILE *fp, char iotype)
3874 char filespec[NAM$C_MAXRSS], *acmode;
3877 if (!fgetname(fp,filespec)) return NULL;
3878 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3880 case '<': case 'r': acmode = "rb"; break;
3882 /* use 'a' instead of 'w' to avoid creating new file;
3883 fsetpos below will take care of restoring file position */
3884 case 'a': acmode = "ab"; break;
3885 case '+': case '|': case 's': acmode = "rb+"; break;
3886 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3888 warn("Unrecognized iotype %c in my_binmode",iotype);
3891 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3892 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3894 } /* end of my_binmode() */
3898 /*{{{char *my_getlogin()*/
3899 /* VMS cuserid == Unix getlogin, except calling sequence */
3903 static char user[L_cuserid];
3904 return cuserid(user);
3909 /* rmscopy - copy a file using VMS RMS routines
3911 * Copies contents and attributes of spec_in to spec_out, except owner
3912 * and protection information. Name and type of spec_in are used as
3913 * defaults for spec_out. The third parameter specifies whether rmscopy()
3914 * should try to propagate timestamps from the input file to the output file.
3915 * If it is less than 0, no timestamps are preserved. If it is 0, then
3916 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3917 * propagated to the output file at creation iff the output file specification
3918 * did not contain an explicit name or type, and the revision date is always
3919 * updated at the end of the copy operation. If it is greater than 0, then
3920 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3921 * other than the revision date should be propagated, and bit 1 indicates
3922 * that the revision date should be propagated.
3924 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3926 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3927 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3928 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3929 * as part of the Perl standard distribution under the terms of the
3930 * GNU General Public License or the Perl Artistic License. Copies
3931 * of each may be found in the Perl standard distribution.
3933 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3935 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3937 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3938 rsa[NAM$C_MAXRSS], ubf[32256];
3939 unsigned long int i, sts, sts2;
3940 struct FAB fab_in, fab_out;
3941 struct RAB rab_in, rab_out;
3943 struct XABDAT xabdat;
3944 struct XABFHC xabfhc;
3945 struct XABRDT xabrdt;
3946 struct XABSUM xabsum;
3948 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3949 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3950 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3954 fab_in = cc$rms_fab;
3955 fab_in.fab$l_fna = vmsin;
3956 fab_in.fab$b_fns = strlen(vmsin);
3957 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3958 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3959 fab_in.fab$l_fop = FAB$M_SQO;
3960 fab_in.fab$l_nam = &nam;
3961 fab_in.fab$l_xab = (void *) &xabdat;
3964 nam.nam$l_rsa = rsa;
3965 nam.nam$b_rss = sizeof(rsa);
3966 nam.nam$l_esa = esa;
3967 nam.nam$b_ess = sizeof (esa);
3968 nam.nam$b_esl = nam.nam$b_rsl = 0;
3970 xabdat = cc$rms_xabdat; /* To get creation date */
3971 xabdat.xab$l_nxt = (void *) &xabfhc;
3973 xabfhc = cc$rms_xabfhc; /* To get record length */
3974 xabfhc.xab$l_nxt = (void *) &xabsum;
3976 xabsum = cc$rms_xabsum; /* To get key and area information */
3978 if (!((sts = sys$open(&fab_in)) & 1)) {
3979 set_vaxc_errno(sts);
3983 set_errno(ENOENT); break;
3985 set_errno(ENODEV); break;
3987 set_errno(EINVAL); break;
3989 set_errno(EACCES); break;
3997 fab_out.fab$w_ifi = 0;
3998 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3999 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4000 fab_out.fab$l_fop = FAB$M_SQO;
4001 fab_out.fab$l_fna = vmsout;
4002 fab_out.fab$b_fns = strlen(vmsout);
4003 fab_out.fab$l_dna = nam.nam$l_name;
4004 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4006 if (preserve_dates == 0) { /* Act like DCL COPY */
4007 nam.nam$b_nop = NAM$M_SYNCHK;
4008 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4009 if (!((sts = sys$parse(&fab_out)) & 1)) {
4010 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4011 set_vaxc_errno(sts);
4014 fab_out.fab$l_xab = (void *) &xabdat;
4015 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4017 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4018 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4019 preserve_dates =0; /* bitmask from this point forward */
4021 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4022 if (!((sts = sys$create(&fab_out)) & 1)) {
4023 set_vaxc_errno(sts);
4026 set_errno(ENOENT); break;
4028 set_errno(ENODEV); break;
4030 set_errno(EINVAL); break;
4032 set_errno(EACCES); break;
4038 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4039 if (preserve_dates & 2) {
4040 /* sys$close() will process xabrdt, not xabdat */
4041 xabrdt = cc$rms_xabrdt;
4043 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4045 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4046 * is unsigned long[2], while DECC & VAXC use a struct */
4047 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4049 fab_out.fab$l_xab = (void *) &xabrdt;
4052 rab_in = cc$rms_rab;
4053 rab_in.rab$l_fab = &fab_in;
4054 rab_in.rab$l_rop = RAB$M_BIO;
4055 rab_in.rab$l_ubf = ubf;
4056 rab_in.rab$w_usz = sizeof ubf;
4057 if (!((sts = sys$connect(&rab_in)) & 1)) {
4058 sys$close(&fab_in); sys$close(&fab_out);
4059 set_errno(EVMSERR); set_vaxc_errno(sts);
4063 rab_out = cc$rms_rab;
4064 rab_out.rab$l_fab = &fab_out;
4065 rab_out.rab$l_rbf = ubf;
4066 if (!((sts = sys$connect(&rab_out)) & 1)) {
4067 sys$close(&fab_in); sys$close(&fab_out);
4068 set_errno(EVMSERR); set_vaxc_errno(sts);
4072 while ((sts = sys$read(&rab_in))) { /* always true */
4073 if (sts == RMS$_EOF) break;
4074 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4075 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4076 sys$close(&fab_in); sys$close(&fab_out);
4077 set_errno(EVMSERR); set_vaxc_errno(sts);
4082 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4083 sys$close(&fab_in); sys$close(&fab_out);
4084 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4086 set_errno(EVMSERR); set_vaxc_errno(sts);
4092 } /* end of rmscopy() */
4096 /*** The following glue provides 'hooks' to make some of the routines
4097 * from this file available from Perl. These routines are sufficiently
4098 * basic, and are required sufficiently early in the build process,
4099 * that's it's nice to have them available to miniperl as well as the
4100 * full Perl, so they're set up here instead of in an extension. The
4101 * Perl code which handles importation of these names into a given
4102 * package lives in [.VMS]Filespec.pm in @INC.
4106 rmsexpand_fromperl(CV *cv)
4109 char *fspec, *defspec = NULL, *rslt;
4111 if (!items || items > 2)
4112 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4113 fspec = SvPV(ST(0),na);
4114 if (!fspec || !*fspec) XSRETURN_UNDEF;
4115 if (items == 2) defspec = SvPV(ST(1),na);
4117 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4118 ST(0) = sv_newmortal();
4119 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4124 vmsify_fromperl(CV *cv)
4129 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4130 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4131 ST(0) = sv_newmortal();
4132 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4137 unixify_fromperl(CV *cv)
4142 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4143 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4144 ST(0) = sv_newmortal();
4145 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4150 fileify_fromperl(CV *cv)
4155 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4156 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4157 ST(0) = sv_newmortal();
4158 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4163 pathify_fromperl(CV *cv)
4168 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4169 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4170 ST(0) = sv_newmortal();
4171 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4176 vmspath_fromperl(CV *cv)
4181 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4182 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4183 ST(0) = sv_newmortal();
4184 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4189 unixpath_fromperl(CV *cv)
4194 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4195 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4196 ST(0) = sv_newmortal();
4197 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4202 candelete_fromperl(CV *cv)
4205 char fspec[NAM$C_MAXRSS+1], *fsp;
4209 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4211 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4212 if (SvTYPE(mysv) == SVt_PVGV) {
4213 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4214 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4221 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4222 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4228 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4233 rmscopy_fromperl(CV *cv)
4236 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4238 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4239 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4240 unsigned long int sts;
4244 if (items < 2 || items > 3)
4245 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4247 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4248 if (SvTYPE(mysv) == SVt_PVGV) {
4249 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4250 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4257 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4258 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4263 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4264 if (SvTYPE(mysv) == SVt_PVGV) {
4265 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4266 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4273 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4274 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4279 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4281 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4288 char* file = __FILE__;
4290 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4291 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4292 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4293 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4294 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4295 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4296 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4297 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4298 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);