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));
3182 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3183 * my_utime(), and flex_stat(), all of which operate on UTC unless
3184 * VMSISH_TIMES is true.
3186 /* method used to handle UTC conversions:
3187 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3189 static int gmtime_emulation_type;
3190 /* number of secs to add to UTC POSIX-style time to get local time */
3191 static long int utc_offset_secs;
3193 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3194 * in vmsish.h. #undef them here so we can call the CRTL routines
3201 /* my_time(), my_localtime(), my_gmtime()
3202 * By default traffic in UTC time values, suing CRTL gmtime() or
3203 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3204 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3205 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3208 /*{{{time_t my_time(time_t *timep)*/
3209 time_t my_time(time_t *timep)
3214 if (gmtime_emulation_type == 0) {
3216 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3218 gmtime_emulation_type++;
3219 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3222 gmtime_emulation_type++;
3223 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3224 gmtime_emulation_type++;
3225 warn("no UTC offset information; assuming local time is UTC");
3227 else { utc_offset_secs = atol(off); }
3229 else { /* We've got a working gmtime() */
3230 struct tm gmt, local;
3233 tm_p = localtime(&base);
3235 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3236 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3237 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3238 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3247 when != -1) when -= utc_offset_secs;
3248 if (timep != NULL) *timep = when;
3251 } /* end of my_time() */
3255 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3257 my_gmtime(const time_t *timep)
3263 if (timep == NULL) {
3264 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3267 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3268 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3272 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3274 /* CRTL localtime() wants local time as input, so does no tz correction */
3275 return localtime(&when);
3277 } /* end of my_gmtime() */
3281 /*{{{struct tm *my_localtime(const time_t *timep)*/
3283 my_localtime(const time_t *timep)
3288 if (timep == NULL) {
3289 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3292 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3293 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3297 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3299 /* CRTL localtime() wants local time as input, so does no tz correction */
3300 return localtime(&when);
3302 } /* end of my_localtime() */
3305 /* Reset definitions for later calls */
3306 #define gmtime(t) my_gmtime(t)
3307 #define localtime(t) my_localtime(t)
3308 #define time(t) my_time(t)
3311 /* my_utime - update modification time of a file
3312 * calling sequence is identical to POSIX utime(), but under
3313 * VMS only the modification time is changed; ODS-2 does not
3314 * maintain access times. Restrictions differ from the POSIX
3315 * definition in that the time can be changed as long as the
3316 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3317 * no separate checks are made to insure that the caller is the
3318 * owner of the file or has special privs enabled.
3319 * Code here is based on Joe Meadows' FILE utility.
3322 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3323 * to VMS epoch (01-JAN-1858 00:00:00.00)
3324 * in 100 ns intervals.
3326 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3328 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3329 int my_utime(char *file, struct utimbuf *utimes)
3333 long int bintime[2], len = 2, lowbit, unixtime,
3334 secscale = 10000000; /* seconds --> 100 ns intervals */
3335 unsigned long int chan, iosb[2], retsts;
3336 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3337 struct FAB myfab = cc$rms_fab;
3338 struct NAM mynam = cc$rms_nam;
3339 #if defined (__DECC) && defined (__VAX)
3340 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3341 * at least through VMS V6.1, which causes a type-conversion warning.
3343 # pragma message save
3344 # pragma message disable cvtdiftypes
3346 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3347 struct fibdef myfib;
3348 #if defined (__DECC) && defined (__VAX)
3349 /* This should be right after the declaration of myatr, but due
3350 * to a bug in VAX DEC C, this takes effect a statement early.
3352 # pragma message restore
3354 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3355 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3356 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3358 if (file == NULL || *file == '\0') {
3360 set_vaxc_errno(LIB$_INVARG);
3363 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3365 if (utimes != NULL) {
3366 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3367 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3368 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3369 * as input, we force the sign bit to be clear by shifting unixtime right
3370 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3372 lowbit = (utimes->modtime & 1) ? secscale : 0;
3373 unixtime = (long int) utimes->modtime;
3375 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3376 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3377 unixtime += utc_offset_secs;
3380 unixtime >> 1; secscale << 1;
3381 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3382 if (!(retsts & 1)) {
3384 set_vaxc_errno(retsts);
3387 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3388 if (!(retsts & 1)) {
3390 set_vaxc_errno(retsts);
3395 /* Just get the current time in VMS format directly */
3396 retsts = sys$gettim(bintime);
3397 if (!(retsts & 1)) {
3399 set_vaxc_errno(retsts);
3404 myfab.fab$l_fna = vmsspec;
3405 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3406 myfab.fab$l_nam = &mynam;
3407 mynam.nam$l_esa = esa;
3408 mynam.nam$b_ess = (unsigned char) sizeof esa;
3409 mynam.nam$l_rsa = rsa;
3410 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3412 /* Look for the file to be affected, letting RMS parse the file
3413 * specification for us as well. I have set errno using only
3414 * values documented in the utime() man page for VMS POSIX.
3416 retsts = sys$parse(&myfab,0,0);
3417 if (!(retsts & 1)) {
3418 set_vaxc_errno(retsts);
3419 if (retsts == RMS$_PRV) set_errno(EACCES);
3420 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3421 else set_errno(EVMSERR);
3424 retsts = sys$search(&myfab,0,0);
3425 if (!(retsts & 1)) {
3426 set_vaxc_errno(retsts);
3427 if (retsts == RMS$_PRV) set_errno(EACCES);
3428 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3429 else set_errno(EVMSERR);
3433 devdsc.dsc$w_length = mynam.nam$b_dev;
3434 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3436 retsts = sys$assign(&devdsc,&chan,0,0);
3437 if (!(retsts & 1)) {
3438 set_vaxc_errno(retsts);
3439 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3440 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3441 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3442 else set_errno(EVMSERR);
3446 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3447 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3449 memset((void *) &myfib, 0, sizeof myfib);
3451 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3452 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3453 /* This prevents the revision time of the file being reset to the current
3454 * time as a result of our IO$_MODIFY $QIO. */
3455 myfib.fib$l_acctl = FIB$M_NORECORD;
3457 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3458 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3459 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3461 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3462 _ckvmssts(sys$dassgn(chan));
3463 if (retsts & 1) retsts = iosb[0];
3464 if (!(retsts & 1)) {
3465 set_vaxc_errno(retsts);
3466 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3467 else set_errno(EVMSERR);
3472 } /* end of my_utime() */
3476 * flex_stat, flex_fstat
3477 * basic stat, but gets it right when asked to stat
3478 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3481 /* encode_dev packs a VMS device name string into an integer to allow
3482 * simple comparisons. This can be used, for example, to check whether two
3483 * files are located on the same device, by comparing their encoded device
3484 * names. Even a string comparison would not do, because stat() reuses the
3485 * device name buffer for each call; so without encode_dev, it would be
3486 * necessary to save the buffer and use strcmp (this would mean a number of
3487 * changes to the standard Perl code, to say nothing of what a Perl script
3490 * The device lock id, if it exists, should be unique (unless perhaps compared
3491 * with lock ids transferred from other nodes). We have a lock id if the disk is
3492 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3493 * device names. Thus we use the lock id in preference, and only if that isn't
3494 * available, do we try to pack the device name into an integer (flagged by
3495 * the sign bit (LOCKID_MASK) being set).
3497 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3498 * name and its encoded form, but it seems very unlikely that we will find
3499 * two files on different disks that share the same encoded device names,
3500 * and even more remote that they will share the same file id (if the test
3501 * is to check for the same file).
3503 * A better method might be to use sys$device_scan on the first call, and to
3504 * search for the device, returning an index into the cached array.
3505 * The number returned would be more intelligable.
3506 * This is probably not worth it, and anyway would take quite a bit longer
3507 * on the first call.
3509 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3510 static mydev_t encode_dev (const char *dev)
3513 unsigned long int f;
3518 if (!dev || !dev[0]) return 0;
3522 struct dsc$descriptor_s dev_desc;
3523 unsigned long int status, lockid, item = DVI$_LOCKID;
3525 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3526 can try that first. */
3527 dev_desc.dsc$w_length = strlen (dev);
3528 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3529 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3530 dev_desc.dsc$a_pointer = (char *) dev;
3531 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3532 if (lockid) return (lockid & ~LOCKID_MASK);
3536 /* Otherwise we try to encode the device name */
3540 for (q = dev + strlen(dev); q--; q >= dev) {
3543 else if (isalpha (toupper (*q)))
3544 c= toupper (*q) - 'A' + (char)10;
3546 continue; /* Skip '$'s */
3548 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3550 enc += f * (unsigned long int) c;
3552 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3554 } /* end of encode_dev() */
3556 static char namecache[NAM$C_MAXRSS+1];
3559 is_null_device(name)
3562 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3563 The underscore prefix, controller letter, and unit number are
3564 independently optional; for our purposes, the colon punctuation
3565 is not. The colon can be trailed by optional directory and/or
3566 filename, but two consecutive colons indicates a nodename rather
3567 than a device. [pr] */
3568 if (*name == '_') ++name;
3569 if (tolower(*name++) != 'n') return 0;
3570 if (tolower(*name++) != 'l') return 0;
3571 if (tolower(*name) == 'a') ++name;
3572 if (*name == '0') ++name;
3573 return (*name++ == ':') && (*name != ':');
3576 /* Do the permissions allow some operation? Assumes statcache already set. */
3577 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3578 * subset of the applicable information. (We have to stick with struct
3579 * stat instead of struct mystat in the prototype since we have to match
3580 * the one in proto.h.)
3582 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3584 cando(I32 bit, I32 effective, struct stat *statbufp)
3586 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3588 char fname[NAM$C_MAXRSS+1];
3589 unsigned long int retsts;
3590 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3591 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3593 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3594 device name on successive calls */
3595 devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
3596 devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
3597 namdsc.dsc$a_pointer = fname;
3598 namdsc.dsc$w_length = sizeof fname - 1;
3600 retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
3601 &namdsc,&namdsc.dsc$w_length,0,0);
3603 fname[namdsc.dsc$w_length] = '\0';
3604 return cando_by_name(bit,effective,fname);
3606 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3607 warn("Can't get filespec - stale stat buffer?\n");
3611 return FALSE; /* Should never get to here */
3613 } /* end of cando() */
3617 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3619 cando_by_name(I32 bit, I32 effective, char *fname)
3621 static char usrname[L_cuserid];
3622 static struct dsc$descriptor_s usrdsc =
3623 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3624 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3625 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3626 unsigned short int retlen;
3627 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3628 union prvdef curprv;
3629 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3630 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3631 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3634 if (!fname || !*fname) return FALSE;
3635 /* Make sure we expand logical names, since sys$check_access doesn't */
3636 if (!strpbrk(fname,"/]>:")) {
3637 strcpy(fileified,fname);
3638 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3641 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3642 retlen = namdsc.dsc$w_length = strlen(vmsname);
3643 namdsc.dsc$a_pointer = vmsname;
3644 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3645 vmsname[retlen-1] == ':') {
3646 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3647 namdsc.dsc$w_length = strlen(fileified);
3648 namdsc.dsc$a_pointer = fileified;
3651 if (!usrdsc.dsc$w_length) {
3653 usrdsc.dsc$w_length = strlen(usrname);
3660 access = ARM$M_EXECUTE;
3665 access = ARM$M_READ;
3670 access = ARM$M_WRITE;
3675 access = ARM$M_DELETE;
3681 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3682 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3683 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3684 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3685 set_vaxc_errno(retsts);
3686 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3687 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3688 else set_errno(ENOENT);
3691 if (retsts == SS$_NORMAL) {
3692 if (!privused) return TRUE;
3693 /* We can get access, but only by using privs. Do we have the
3694 necessary privs currently enabled? */
3695 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3696 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3697 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3698 !curprv.prv$v_bypass) return FALSE;
3699 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3700 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3701 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3706 return FALSE; /* Should never get here */
3708 } /* end of cando_by_name() */
3712 /*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
3714 flex_fstat(int fd, struct mystat *statbufp)
3718 if (!fstat(fd,(stat_t *) statbufp)) {
3719 if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
3720 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3722 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3726 if (!gmtime_emulation_type) (void)time(NULL);
3727 statbufp->st_mtime -= utc_offset_secs;
3728 statbufp->st_atime -= utc_offset_secs;
3729 statbufp->st_ctime -= utc_offset_secs;
3735 } /* end of flex_fstat() */
3738 /*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
3740 flex_stat(char *fspec, struct mystat *statbufp)
3743 char fileified[NAM$C_MAXRSS+1];
3746 if (statbufp == (struct mystat *) &statcache)
3747 do_tovmsspec(fspec,namecache,0);
3748 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3749 memset(statbufp,0,sizeof *statbufp);
3750 statbufp->st_dev = encode_dev("_NLA0:");
3751 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3752 statbufp->st_uid = 0x00010001;
3753 statbufp->st_gid = 0x0001;
3754 time((time_t *)&statbufp->st_mtime);
3755 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3759 /* Try for a directory name first. If fspec contains a filename without
3760 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3761 * and sea:[wine.dark]water. exist, we prefer the directory here.
3762 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3763 * not sea:[wine.dark]., if the latter exists. If the intended target is
3764 * the file with null type, specify this by calling flex_stat() with
3765 * a '.' at the end of fspec.
3767 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3768 retval = stat(fileified,(stat_t *) statbufp);
3769 if (!retval && statbufp == (struct mystat *) &statcache)
3770 strcpy(namecache,fileified);
3772 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3774 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3776 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3780 if (!gmtime_emulation_type) (void)time(NULL);
3781 statbufp->st_mtime -= utc_offset_secs;
3782 statbufp->st_atime -= utc_offset_secs;
3783 statbufp->st_ctime -= utc_offset_secs;
3788 } /* end of flex_stat() */
3791 /* Insures that no carriage-control translation will be done on a file. */
3792 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3794 my_binmode(FILE *fp, char iotype)
3796 char filespec[NAM$C_MAXRSS], *acmode;
3799 if (!fgetname(fp,filespec)) return NULL;
3800 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3802 case '<': case 'r': acmode = "rb"; break;
3804 /* use 'a' instead of 'w' to avoid creating new file;
3805 fsetpos below will take care of restoring file position */
3806 case 'a': acmode = "ab"; break;
3807 case '+': case '|': case 's': acmode = "rb+"; break;
3808 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3810 warn("Unrecognized iotype %c in my_binmode",iotype);
3813 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3814 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3816 } /* end of my_binmode() */
3820 /*{{{char *my_getlogin()*/
3821 /* VMS cuserid == Unix getlogin, except calling sequence */
3825 static char user[L_cuserid];
3826 return cuserid(user);
3831 /* rmscopy - copy a file using VMS RMS routines
3833 * Copies contents and attributes of spec_in to spec_out, except owner
3834 * and protection information. Name and type of spec_in are used as
3835 * defaults for spec_out. The third parameter specifies whether rmscopy()
3836 * should try to propagate timestamps from the input file to the output file.
3837 * If it is less than 0, no timestamps are preserved. If it is 0, then
3838 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3839 * propagated to the output file at creation iff the output file specification
3840 * did not contain an explicit name or type, and the revision date is always
3841 * updated at the end of the copy operation. If it is greater than 0, then
3842 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3843 * other than the revision date should be propagated, and bit 1 indicates
3844 * that the revision date should be propagated.
3846 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3848 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3849 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3850 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3851 * as part of the Perl standard distribution under the terms of the
3852 * GNU General Public License or the Perl Artistic License. Copies
3853 * of each may be found in the Perl standard distribution.
3855 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3857 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3859 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3860 rsa[NAM$C_MAXRSS], ubf[32256];
3861 unsigned long int i, sts, sts2;
3862 struct FAB fab_in, fab_out;
3863 struct RAB rab_in, rab_out;
3865 struct XABDAT xabdat;
3866 struct XABFHC xabfhc;
3867 struct XABRDT xabrdt;
3868 struct XABSUM xabsum;
3870 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3871 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3872 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3876 fab_in = cc$rms_fab;
3877 fab_in.fab$l_fna = vmsin;
3878 fab_in.fab$b_fns = strlen(vmsin);
3879 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3880 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3881 fab_in.fab$l_fop = FAB$M_SQO;
3882 fab_in.fab$l_nam = &nam;
3883 fab_in.fab$l_xab = (void *) &xabdat;
3886 nam.nam$l_rsa = rsa;
3887 nam.nam$b_rss = sizeof(rsa);
3888 nam.nam$l_esa = esa;
3889 nam.nam$b_ess = sizeof (esa);
3890 nam.nam$b_esl = nam.nam$b_rsl = 0;
3892 xabdat = cc$rms_xabdat; /* To get creation date */
3893 xabdat.xab$l_nxt = (void *) &xabfhc;
3895 xabfhc = cc$rms_xabfhc; /* To get record length */
3896 xabfhc.xab$l_nxt = (void *) &xabsum;
3898 xabsum = cc$rms_xabsum; /* To get key and area information */
3900 if (!((sts = sys$open(&fab_in)) & 1)) {
3901 set_vaxc_errno(sts);
3905 set_errno(ENOENT); break;
3907 set_errno(ENODEV); break;
3909 set_errno(EINVAL); break;
3911 set_errno(EACCES); break;
3919 fab_out.fab$w_ifi = 0;
3920 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3921 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3922 fab_out.fab$l_fop = FAB$M_SQO;
3923 fab_out.fab$l_fna = vmsout;
3924 fab_out.fab$b_fns = strlen(vmsout);
3925 fab_out.fab$l_dna = nam.nam$l_name;
3926 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3928 if (preserve_dates == 0) { /* Act like DCL COPY */
3929 nam.nam$b_nop = NAM$M_SYNCHK;
3930 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3931 if (!((sts = sys$parse(&fab_out)) & 1)) {
3932 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3933 set_vaxc_errno(sts);
3936 fab_out.fab$l_xab = (void *) &xabdat;
3937 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3939 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3940 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3941 preserve_dates =0; /* bitmask from this point forward */
3943 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3944 if (!((sts = sys$create(&fab_out)) & 1)) {
3945 set_vaxc_errno(sts);
3948 set_errno(ENOENT); break;
3950 set_errno(ENODEV); break;
3952 set_errno(EINVAL); break;
3954 set_errno(EACCES); break;
3960 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3961 if (preserve_dates & 2) {
3962 /* sys$close() will process xabrdt, not xabdat */
3963 xabrdt = cc$rms_xabrdt;
3965 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3967 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3968 * is unsigned long[2], while DECC & VAXC use a struct */
3969 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3971 fab_out.fab$l_xab = (void *) &xabrdt;
3974 rab_in = cc$rms_rab;
3975 rab_in.rab$l_fab = &fab_in;
3976 rab_in.rab$l_rop = RAB$M_BIO;
3977 rab_in.rab$l_ubf = ubf;
3978 rab_in.rab$w_usz = sizeof ubf;
3979 if (!((sts = sys$connect(&rab_in)) & 1)) {
3980 sys$close(&fab_in); sys$close(&fab_out);
3981 set_errno(EVMSERR); set_vaxc_errno(sts);
3985 rab_out = cc$rms_rab;
3986 rab_out.rab$l_fab = &fab_out;
3987 rab_out.rab$l_rbf = ubf;
3988 if (!((sts = sys$connect(&rab_out)) & 1)) {
3989 sys$close(&fab_in); sys$close(&fab_out);
3990 set_errno(EVMSERR); set_vaxc_errno(sts);
3994 while ((sts = sys$read(&rab_in))) { /* always true */
3995 if (sts == RMS$_EOF) break;
3996 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3997 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3998 sys$close(&fab_in); sys$close(&fab_out);
3999 set_errno(EVMSERR); set_vaxc_errno(sts);
4004 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4005 sys$close(&fab_in); sys$close(&fab_out);
4006 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4008 set_errno(EVMSERR); set_vaxc_errno(sts);
4014 } /* end of rmscopy() */
4018 /*** The following glue provides 'hooks' to make some of the routines
4019 * from this file available from Perl. These routines are sufficiently
4020 * basic, and are required sufficiently early in the build process,
4021 * that's it's nice to have them available to miniperl as well as the
4022 * full Perl, so they're set up here instead of in an extension. The
4023 * Perl code which handles importation of these names into a given
4024 * package lives in [.VMS]Filespec.pm in @INC.
4028 rmsexpand_fromperl(CV *cv)
4031 char *fspec, *defspec = NULL, *rslt;
4033 if (!items || items > 2)
4034 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4035 fspec = SvPV(ST(0),na);
4036 if (!fspec || !*fspec) XSRETURN_UNDEF;
4037 if (items == 2) defspec = SvPV(ST(1),na);
4039 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4040 ST(0) = sv_newmortal();
4041 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4046 vmsify_fromperl(CV *cv)
4051 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4052 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4053 ST(0) = sv_newmortal();
4054 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4059 unixify_fromperl(CV *cv)
4064 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4065 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4066 ST(0) = sv_newmortal();
4067 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4072 fileify_fromperl(CV *cv)
4077 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4078 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4079 ST(0) = sv_newmortal();
4080 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4085 pathify_fromperl(CV *cv)
4090 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4091 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4092 ST(0) = sv_newmortal();
4093 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4098 vmspath_fromperl(CV *cv)
4103 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4104 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4105 ST(0) = sv_newmortal();
4106 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4111 unixpath_fromperl(CV *cv)
4116 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4117 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4118 ST(0) = sv_newmortal();
4119 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4124 candelete_fromperl(CV *cv)
4127 char fspec[NAM$C_MAXRSS+1], *fsp;
4131 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4133 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4134 if (SvTYPE(mysv) == SVt_PVGV) {
4135 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4136 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4143 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4144 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4150 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4155 rmscopy_fromperl(CV *cv)
4158 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4160 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4161 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4162 unsigned long int sts;
4166 if (items < 2 || items > 3)
4167 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4169 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4170 if (SvTYPE(mysv) == SVt_PVGV) {
4171 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4172 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4179 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4180 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4185 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4186 if (SvTYPE(mysv) == SVt_PVGV) {
4187 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4188 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4195 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4196 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4201 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4203 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4210 char* file = __FILE__;
4212 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4213 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4214 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4215 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4216 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4217 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4218 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4219 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4220 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);