3 * VMS-specific routines for perl5
5 * Last revised: 15-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
14 #include <climsgdef.h>
23 #include <lib$routines.h>
32 #include <str$routines.h>
37 /* Older versions of ssdef.h don't have these */
38 #ifndef SS$_INVFILFOROP
39 # define SS$_INVFILFOROP 3930
41 #ifndef SS$_NOSUCHOBJECT
42 # define SS$_NOSUCHOBJECT 2696
45 /* Don't intercept calls to vfork, since my_vfork below needs to
46 * get to the underlying CRTL routine. */
47 #define __DONT_MASK_VFORK
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 /*{{{ void prime_env_iter() */
168 /* Fill the %ENV associative array with all logical names we can
169 * find, in preparation for iterating over it.
172 static int primed = 0; /* XXX Not thread-safe!!! */
173 HV *envhv = GvHVn(envgv);
175 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
177 SV *oldrs, *linesv, *eqvsv;
180 /* Perform a dummy fetch as an lval to insure that the hash table is
181 * set up. Otherwise, the hv_store() will turn into a nullop */
182 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
183 /* Also, set up the four "special" keys that the CRTL defines,
184 * whether or not underlying logical names exist. */
185 (void) hv_fetch(envhv,"HOME",4,TRUE);
186 (void) hv_fetch(envhv,"TERM",4,TRUE);
187 (void) hv_fetch(envhv,"PATH",4,TRUE);
188 (void) hv_fetch(envhv,"USER",4,TRUE);
190 /* Now, go get the logical names */
191 if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
192 _ckvmssts(vaxc$errno);
193 /* We use Perl's sv_gets to read from the pipe, since my_popen is
194 * tied to Perl's I/O layer, so it may not return a simple FILE * */
196 rs = newSVpv("\n",1);
197 linesv = newSVpv("",0);
199 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
201 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
205 while (*start != '"' && *start != '=' && *start) start++;
206 if (*start != '"') continue;
207 for (end = ++start; *end && *end != '"'; end++) ;
208 if (*end) *end = '\0';
210 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
211 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
213 warn("Ill-formed logical name |%s| in prime_env_iter",start);
216 else _ckvmssts(vaxc$errno);
219 eqvsv = newSVpv(eqv,eqvlen);
220 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
223 } /* end of prime_env_iter */
227 /*{{{ void my_setenv(char *lnm, char *eqv)*/
229 my_setenv(char *lnm,char *eqv)
230 /* Define a supervisor-mode logical name in the process table.
231 * In the future we'll add tables, attribs, and acmodes,
232 * probably through a different call.
235 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
236 unsigned long int retsts, usermode = PSL$C_USER;
237 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
238 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
239 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
241 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
242 lnmdsc.dsc$w_length = cp1 - lnm;
244 if (!eqv || !*eqv) { /* we're deleting a logical name */
245 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
246 if (retsts == SS$_IVLOGNAM) return;
247 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
249 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
250 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
254 eqvdsc.dsc$w_length = strlen(eqv);
255 eqvdsc.dsc$a_pointer = eqv;
257 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
260 } /* end of my_setenv() */
264 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
265 /* my_crypt - VMS password hashing
266 * my_crypt() provides an interface compatible with the Unix crypt()
267 * C library function, and uses sys$hash_password() to perform VMS
268 * password hashing. The quadword hashed password value is returned
269 * as a NUL-terminated 8 character string. my_crypt() does not change
270 * the case of its string arguments; in order to match the behavior
271 * of LOGINOUT et al., alphabetic characters in both arguments must
272 * be upcased by the caller.
275 my_crypt(const char *textpasswd, const char *usrname)
277 # ifndef UAI$C_PREFERRED_ALGORITHM
278 # define UAI$C_PREFERRED_ALGORITHM 127
280 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
281 unsigned short int salt = 0;
282 unsigned long int sts;
284 unsigned short int dsc$w_length;
285 unsigned char dsc$b_type;
286 unsigned char dsc$b_class;
287 const char * dsc$a_pointer;
288 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
289 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
290 struct itmlst_3 uailst[3] = {
291 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
292 { sizeof salt, UAI$_SALT, &salt, 0},
293 { 0, 0, NULL, NULL}};
296 usrdsc.dsc$w_length = strlen(usrname);
297 usrdsc.dsc$a_pointer = usrname;
298 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
305 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
311 if (sts != RMS$_RNF) return NULL;
314 txtdsc.dsc$w_length = strlen(textpasswd);
315 txtdsc.dsc$a_pointer = textpasswd;
316 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
317 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
320 return (char *) hash;
322 } /* end of my_crypt() */
326 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
327 static char *do_fileify_dirspec(char *, char *, int);
328 static char *do_tovmsspec(char *, char *, int);
330 /*{{{int do_rmdir(char *name)*/
334 char dirfile[NAM$C_MAXRSS+1];
338 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
339 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
340 else retval = kill_file(dirfile);
343 } /* end of do_rmdir */
347 * Delete any file to which user has control access, regardless of whether
348 * delete access is explicitly allowed.
349 * Limitations: User must have write access to parent directory.
350 * Does not block signals or ASTs; if interrupted in midstream
351 * may leave file with an altered ACL.
354 /*{{{int kill_file(char *name)*/
356 kill_file(char *name)
358 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
359 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
360 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
361 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
363 unsigned char myace$b_length;
364 unsigned char myace$b_type;
365 unsigned short int myace$w_flags;
366 unsigned long int myace$l_access;
367 unsigned long int myace$l_ident;
368 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
369 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
370 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
372 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
373 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
374 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
375 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
376 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
377 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
379 /* Expand the input spec using RMS, since the CRTL remove() and
380 * system services won't do this by themselves, so we may miss
381 * a file "hiding" behind a logical name or search list. */
382 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
383 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
384 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
385 /* If not, can changing protections help? */
386 if (vaxc$errno != RMS$_PRV) return -1;
388 /* No, so we get our own UIC to use as a rights identifier,
389 * and the insert an ACE at the head of the ACL which allows us
390 * to delete the file.
392 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
393 fildsc.dsc$w_length = strlen(rspec);
394 fildsc.dsc$a_pointer = rspec;
396 newace.myace$l_ident = oldace.myace$l_ident;
397 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
402 case SS$_NOSUCHOBJECT:
403 set_errno(ENOENT); break;
405 set_errno(ENODEV); break;
407 case SS$_INVFILFOROP:
408 set_errno(EINVAL); break;
410 set_errno(EACCES); break;
414 set_vaxc_errno(aclsts);
417 /* Grab any existing ACEs with this identifier in case we fail */
418 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
419 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
420 || fndsts == SS$_NOMOREACE ) {
421 /* Add the new ACE . . . */
422 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
424 if ((rmsts = remove(name))) {
425 /* We blew it - dir with files in it, no write priv for
426 * parent directory, etc. Put things back the way they were. */
427 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
430 addlst[0].bufadr = &oldace;
431 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
438 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
439 /* We just deleted it, so of course it's not there. Some versions of
440 * VMS seem to return success on the unlock operation anyhow (after all
441 * the unlock is successful), but others don't.
443 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
444 if (aclsts & 1) aclsts = fndsts;
447 set_vaxc_errno(aclsts);
453 } /* end of kill_file() */
457 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
459 static unsigned long int mbxbufsiz;
460 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
464 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
465 * preprocessor consant BUFSIZ from stdio.h as the size of the
468 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
469 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
471 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
473 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
474 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
476 } /* end of create_mbx() */
478 /*{{{ my_popen and my_pclose*/
481 struct pipe_details *next;
482 PerlIO *fp; /* stdio file pointer to pipe mailbox */
483 int pid; /* PID of subprocess */
484 int mode; /* == 'r' if pipe open for reading */
485 int done; /* subprocess has completed */
486 unsigned long int completion; /* termination status of subprocess */
489 struct exit_control_block
491 struct exit_control_block *flink;
492 unsigned long int (*exit_routine)();
493 unsigned long int arg_count;
494 unsigned long int *status_address;
495 unsigned long int exit_status;
498 static struct pipe_details *open_pipes = NULL;
499 static $DESCRIPTOR(nl_desc, "NL:");
500 static int waitpid_asleep = 0;
502 static unsigned long int
505 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
507 while (open_pipes != NULL) {
508 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
509 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
512 if (!open_pipes->done) /* We tried to be nice . . . */
513 _ckvmssts(sys$delprc(&open_pipes->pid,0));
514 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
519 static struct exit_control_block pipe_exitblock =
520 {(struct exit_control_block *) 0,
521 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
525 popen_completion_ast(struct pipe_details *thispipe)
527 thispipe->done = TRUE;
528 if (waitpid_asleep) {
534 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
536 my_popen(char *cmd, char *mode)
538 static int handler_set_up = FALSE;
540 unsigned short int chan;
541 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
542 struct pipe_details *info;
543 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
544 DSC$K_CLASS_S, mbxname},
545 cmddsc = {0, DSC$K_DTYPE_T,
549 cmddsc.dsc$w_length=strlen(cmd);
550 cmddsc.dsc$a_pointer=cmd;
551 if (cmddsc.dsc$w_length > 255) {
552 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
556 New(7001,info,1,struct pipe_details);
559 create_mbx(&chan,&namdsc);
561 /* open a FILE* onto it */
562 info->fp = PerlIO_open(mbxname, mode);
564 /* give up other channel onto it */
565 _ckvmssts(sys$dassgn(chan));
575 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
576 0 /* name */, &info->pid, &info->completion,
577 0, popen_completion_ast,info,0,0,0));
580 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
581 0 /* name */, &info->pid, &info->completion,
582 0, popen_completion_ast,info,0,0,0));
585 if (!handler_set_up) {
586 _ckvmssts(sys$dclexh(&pipe_exitblock));
587 handler_set_up = TRUE;
589 info->next=open_pipes; /* prepend to list */
592 forkprocess = info->pid;
597 /*{{{ I32 my_pclose(FILE *fp)*/
598 I32 my_pclose(FILE *fp)
600 struct pipe_details *info, *last = NULL;
601 unsigned long int retsts;
603 for (info = open_pipes; info != NULL; last = info, info = info->next)
604 if (info->fp == fp) break;
607 /* get here => no such pipe open */
608 croak("No such pipe open");
610 /* If we were writing to a subprocess, insure that someone reading from
611 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
612 * produce an EOF record in the mailbox. */
613 if (info->mode != 'r') {
614 char devnam[NAM$C_MAXRSS+1], *cp;
615 unsigned long int chan, iosb[2], retsts, retsts2;
616 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
618 if (fgetname(info->fp,devnam)) {
619 /* It oughta be a mailbox, so fgetname should give just the device
620 * name, but just in case . . . */
621 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
622 devdsc.dsc$w_length = strlen(devnam);
623 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
624 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
625 if (retsts & 1) retsts = iosb[0];
626 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
627 if (retsts & 1) retsts = retsts2;
630 else _ckvmssts(vaxc$errno); /* Should never happen */
632 PerlIO_close(info->fp);
634 if (info->done) retsts = info->completion;
635 else waitpid(info->pid,(int *) &retsts,0);
637 /* remove from list of open pipes */
638 if (last) last->next = info->next;
639 else open_pipes = info->next;
644 } /* end of my_pclose() */
646 /* sort-of waitpid; use only with popen() */
647 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
649 my_waitpid(Pid_t pid, int *statusp, int flags)
651 struct pipe_details *info;
653 for (info = open_pipes; info != NULL; info = info->next)
654 if (info->pid == pid) break;
656 if (info != NULL) { /* we know about this child */
657 while (!info->done) {
662 *statusp = info->completion;
665 else { /* we haven't heard of this child */
666 $DESCRIPTOR(intdsc,"0 00:00:01");
667 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
668 unsigned long int interval[2],sts;
671 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
672 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
673 if (ownerpid != mypid)
674 warn("pid %d not a child",pid);
677 _ckvmssts(sys$bintim(&intdsc,interval));
678 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
679 _ckvmssts(sys$schdwk(0,0,interval,0));
680 _ckvmssts(sys$hiber());
684 /* There's no easy way to find the termination status a child we're
685 * not aware of beforehand. If we're really interested in the future,
686 * we can go looking for a termination mailbox, or chase after the
687 * accounting record for the process.
693 } /* end of waitpid() */
698 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
700 my_gconvert(double val, int ndig, int trail, char *buf)
702 static char __gcvtbuf[DBL_DIG+1];
705 loc = buf ? buf : __gcvtbuf;
707 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
709 sprintf(loc,"%.*g",ndig,val);
715 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
716 return gcvt(val,ndig,loc);
719 loc[0] = '0'; loc[1] = '\0';
727 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
728 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
729 * to expand file specification. Allows for a single default file
730 * specification and a simple mask of options. If outbuf is non-NULL,
731 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
732 * the resultant file specification is placed. If outbuf is NULL, the
733 * resultant file specification is placed into a static buffer.
734 * The third argument, if non-NULL, is taken to be a default file
735 * specification string. The fourth argument is unused at present.
736 * rmesexpand() returns the address of the resultant string if
737 * successful, and NULL on error.
740 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
742 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
743 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
744 struct FAB myfab = cc$rms_fab;
745 struct NAM mynam = cc$rms_nam;
747 unsigned long int retsts, haslower = 0;
749 if (!filespec || !*filespec) {
750 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
754 if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
755 else outbuf = __rmsexpand_retbuf;
758 myfab.fab$l_fna = filespec;
759 myfab.fab$b_fns = strlen(filespec);
760 myfab.fab$l_nam = &mynam;
762 if (defspec && *defspec) {
763 myfab.fab$l_dna = defspec;
764 myfab.fab$b_dns = strlen(defspec);
767 mynam.nam$l_esa = esa;
768 mynam.nam$b_ess = sizeof esa;
769 mynam.nam$l_rsa = outbuf;
770 mynam.nam$b_rss = NAM$C_MAXRSS;
772 retsts = sys$parse(&myfab,0,0);
774 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
775 retsts == RMS$_DEV || retsts == RMS$_DEV) {
776 mynam.nam$b_nop |= NAM$M_SYNCHK;
777 retsts = sys$parse(&myfab,0,0);
778 if (retsts & 1) goto expanded;
780 if (out) Safefree(out);
781 set_vaxc_errno(retsts);
782 if (retsts == RMS$_PRV) set_errno(EACCES);
783 else if (retsts == RMS$_DEV) set_errno(ENODEV);
784 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
785 else set_errno(EVMSERR);
788 retsts = sys$search(&myfab,0,0);
789 if (!(retsts & 1) && retsts != RMS$_FNF) {
790 if (out) Safefree(out);
791 set_vaxc_errno(retsts);
792 if (retsts == RMS$_PRV) set_errno(EACCES);
793 else set_errno(EVMSERR);
797 /* If the input filespec contained any lowercase characters,
798 * downcase the result for compatibility with Unix-minded code. */
800 for (out = myfab.fab$l_fna; *out; out++)
801 if (islower(*out)) { haslower = 1; break; }
802 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
803 else { out = esa; speclen = mynam.nam$b_esl; }
804 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
805 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
806 speclen = mynam.nam$l_ver - out;
807 /* If we just had a directory spec on input, $PARSE "helpfully"
808 * adds an empty name and type for us */
809 if (mynam.nam$l_name == mynam.nam$l_type &&
810 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
811 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
812 speclen = mynam.nam$l_name - out;
814 if (haslower) __mystrtolower(out);
816 /* Have we been working with an expanded, but not resultant, spec? */
817 if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
821 /* External entry points */
822 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
823 { return do_rmsexpand(spec,buf,0,def,opt); }
824 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
825 { return do_rmsexpand(spec,buf,1,def,opt); }
829 ** The following routines are provided to make life easier when
830 ** converting among VMS-style and Unix-style directory specifications.
831 ** All will take input specifications in either VMS or Unix syntax. On
832 ** failure, all return NULL. If successful, the routines listed below
833 ** return a pointer to a buffer containing the appropriately
834 ** reformatted spec (and, therefore, subsequent calls to that routine
835 ** will clobber the result), while the routines of the same names with
836 ** a _ts suffix appended will return a pointer to a mallocd string
837 ** containing the appropriately reformatted spec.
838 ** In all cases, only explicit syntax is altered; no check is made that
839 ** the resulting string is valid or that the directory in question
842 ** fileify_dirspec() - convert a directory spec into the name of the
843 ** directory file (i.e. what you can stat() to see if it's a dir).
844 ** The style (VMS or Unix) of the result is the same as the style
845 ** of the parameter passed in.
846 ** pathify_dirspec() - convert a directory spec into a path (i.e.
847 ** what you prepend to a filename to indicate what directory it's in).
848 ** The style (VMS or Unix) of the result is the same as the style
849 ** of the parameter passed in.
850 ** tounixpath() - convert a directory spec into a Unix-style path.
851 ** tovmspath() - convert a directory spec into a VMS-style path.
852 ** tounixspec() - convert any file spec into a Unix-style file spec.
853 ** tovmsspec() - convert any file spec into a VMS-style spec.
855 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
856 ** Permission is given to distribute this code as part of the Perl
857 ** standard distribution under the terms of the GNU General Public
858 ** License or the Perl Artistic License. Copies of each may be
859 ** found in the Perl standard distribution.
862 static char *do_tounixspec(char *, char *, int);
864 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
865 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
867 static char __fileify_retbuf[NAM$C_MAXRSS+1];
868 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
869 char *retspec, *cp1, *cp2, *lastdir;
870 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
873 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
875 dirlen = strlen(dir);
876 if (dir[dirlen-1] == '/') --dirlen;
879 set_vaxc_errno(RMS$_DIR);
882 if (!strpbrk(dir+1,"/]>:")) {
883 strcpy(trndir,*dir == '/' ? dir + 1: dir);
884 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
886 dirlen = strlen(dir);
889 strncpy(trndir,dir,dirlen);
890 trndir[dirlen] = '\0';
893 /* If we were handed a rooted logical name or spec, treat it like a
894 * simple directory, so that
895 * $ Define myroot dev:[dir.]
896 * ... do_fileify_dirspec("myroot",buf,1) ...
897 * does something useful.
899 if (!strcmp(dir+dirlen-2,".]")) {
900 dir[--dirlen] = '\0';
904 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
905 /* If we've got an explicit filename, we can just shuffle the string. */
906 if (*(cp1+1)) hasfilename = 1;
907 /* Similarly, we can just back up a level if we've got multiple levels
908 of explicit directories in a VMS spec which ends with directories. */
910 for (cp2 = cp1; cp2 > dir; cp2--) {
912 *cp2 = *cp1; *cp1 = '\0';
916 if (*cp2 == '[' || *cp2 == '<') break;
921 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
923 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
924 return do_fileify_dirspec("[]",buf,ts);
925 else if (dir[1] == '.' &&
926 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
927 return do_fileify_dirspec("[-]",buf,ts);
929 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
930 dirlen -= 1; /* to last element */
931 lastdir = strrchr(dir,'/');
933 else if ((cp1 = strstr(dir,"/.")) != NULL) {
934 /* If we have "/." or "/..", VMSify it and let the VMS code
935 * below expand it, rather than repeating the code to handle
936 * relative components of a filespec here */
938 if (*(cp1+2) == '.') cp1++;
939 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
940 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
941 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
942 return do_tounixspec(trndir,buf,ts);
945 } while ((cp1 = strstr(cp1,"/.")) != NULL);
948 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
949 !(lastdir = cp1 = strrchr(dir,']')) &&
950 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
951 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
953 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
954 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
955 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
956 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
957 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
960 set_vaxc_errno(RMS$_DIR);
966 /* If we lead off with a device or rooted logical, add the MFD
967 if we're specifying a top-level directory. */
968 if (lastdir && *dir == '/') {
970 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
977 retlen = dirlen + (addmfd ? 13 : 6);
978 if (buf) retspec = buf;
979 else if (ts) New(7009,retspec,retlen+1,char);
980 else retspec = __fileify_retbuf;
982 dirlen = lastdir - dir;
983 memcpy(retspec,dir,dirlen);
984 strcpy(&retspec[dirlen],"/000000");
985 strcpy(&retspec[dirlen+7],lastdir);
988 memcpy(retspec,dir,dirlen);
989 retspec[dirlen] = '\0';
991 /* We've picked up everything up to the directory file name.
992 Now just add the type and version, and we're set. */
993 strcat(retspec,".dir;1");
996 else { /* VMS-style directory spec */
997 char esa[NAM$C_MAXRSS+1], term, *cp;
998 unsigned long int sts, cmplen, haslower = 0;
999 struct FAB dirfab = cc$rms_fab;
1000 struct NAM savnam, dirnam = cc$rms_nam;
1002 dirfab.fab$b_fns = strlen(dir);
1003 dirfab.fab$l_fna = dir;
1004 dirfab.fab$l_nam = &dirnam;
1005 dirfab.fab$l_dna = ".DIR;1";
1006 dirfab.fab$b_dns = 6;
1007 dirnam.nam$b_ess = NAM$C_MAXRSS;
1008 dirnam.nam$l_esa = esa;
1010 for (cp = dir; *cp; cp++)
1011 if (islower(*cp)) { haslower = 1; break; }
1012 if (!((sts = sys$parse(&dirfab))&1)) {
1013 if (dirfab.fab$l_sts == RMS$_DIR) {
1014 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1015 sts = sys$parse(&dirfab) & 1;
1019 set_vaxc_errno(dirfab.fab$l_sts);
1025 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1026 /* Yes; fake the fnb bits so we'll check type below */
1027 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1030 if (dirfab.fab$l_sts != RMS$_FNF) {
1032 set_vaxc_errno(dirfab.fab$l_sts);
1035 dirnam = savnam; /* No; just work with potential name */
1038 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1039 cp1 = strchr(esa,']');
1040 if (!cp1) cp1 = strchr(esa,'>');
1041 if (cp1) { /* Should always be true */
1042 dirnam.nam$b_esl -= cp1 - esa - 1;
1043 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1046 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1047 /* Yep; check version while we're at it, if it's there. */
1048 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1049 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1050 /* Something other than .DIR[;1]. Bzzt. */
1052 set_vaxc_errno(RMS$_DIR);
1056 esa[dirnam.nam$b_esl] = '\0';
1057 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1058 /* They provided at least the name; we added the type, if necessary, */
1059 if (buf) retspec = buf; /* in sys$parse() */
1060 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1061 else retspec = __fileify_retbuf;
1062 strcpy(retspec,esa);
1065 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1066 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1068 dirnam.nam$b_esl -= 9;
1070 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1071 if (cp1 == NULL) return NULL; /* should never happen */
1074 retlen = strlen(esa);
1075 if ((cp1 = strrchr(esa,'.')) != NULL) {
1076 /* There's more than one directory in the path. Just roll back. */
1078 if (buf) retspec = buf;
1079 else if (ts) New(7011,retspec,retlen+7,char);
1080 else retspec = __fileify_retbuf;
1081 strcpy(retspec,esa);
1084 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1085 /* Go back and expand rooted logical name */
1086 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1087 if (!(sys$parse(&dirfab) & 1)) {
1089 set_vaxc_errno(dirfab.fab$l_sts);
1092 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1093 if (buf) retspec = buf;
1094 else if (ts) New(7012,retspec,retlen+16,char);
1095 else retspec = __fileify_retbuf;
1096 cp1 = strstr(esa,"][");
1098 memcpy(retspec,esa,dirlen);
1099 if (!strncmp(cp1+2,"000000]",7)) {
1100 retspec[dirlen-1] = '\0';
1101 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1102 if (*cp1 == '.') *cp1 = ']';
1104 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1105 memcpy(cp1+1,"000000]",7);
1109 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1110 retspec[retlen] = '\0';
1111 /* Convert last '.' to ']' */
1112 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1113 if (*cp1 == '.') *cp1 = ']';
1115 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1116 memcpy(cp1+1,"000000]",7);
1120 else { /* This is a top-level dir. Add the MFD to the path. */
1121 if (buf) retspec = buf;
1122 else if (ts) New(7012,retspec,retlen+16,char);
1123 else retspec = __fileify_retbuf;
1126 while (*cp1 != ':') *(cp2++) = *(cp1++);
1127 strcpy(cp2,":[000000]");
1132 /* We've set up the string up through the filename. Add the
1133 type and version, and we're done. */
1134 strcat(retspec,".DIR;1");
1136 /* $PARSE may have upcased filespec, so convert output to lower
1137 * case if input contained any lowercase characters. */
1138 if (haslower) __mystrtolower(retspec);
1141 } /* end of do_fileify_dirspec() */
1143 /* External entry points */
1144 char *fileify_dirspec(char *dir, char *buf)
1145 { return do_fileify_dirspec(dir,buf,0); }
1146 char *fileify_dirspec_ts(char *dir, char *buf)
1147 { return do_fileify_dirspec(dir,buf,1); }
1149 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1150 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1152 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1153 unsigned long int retlen;
1154 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1156 if (!dir || !*dir) {
1157 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1160 if (*dir) strcpy(trndir,dir);
1161 else getcwd(trndir,sizeof trndir - 1);
1163 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1164 STRLEN trnlen = strlen(trndir);
1166 /* Trap simple rooted lnms, and return lnm:[000000] */
1167 if (!strcmp(trndir+trnlen-2,".]")) {
1168 if (buf) retpath = buf;
1169 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1170 else retpath = __pathify_retbuf;
1171 strcpy(retpath,dir);
1172 strcat(retpath,":[000000]");
1178 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1179 if (*dir == '.' && (*(dir+1) == '\0' ||
1180 (*(dir+1) == '.' && *(dir+2) == '\0')))
1181 retlen = 2 + (*(dir+1) != '\0');
1183 if ( !(cp1 = strrchr(dir,'/')) &&
1184 !(cp1 = strrchr(dir,']')) &&
1185 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1186 if ((cp2 = strchr(cp1,'.')) != NULL &&
1187 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1188 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1189 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1190 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1192 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1193 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1194 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1195 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1196 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1197 (ver || *cp3)))))) {
1199 set_vaxc_errno(RMS$_DIR);
1202 retlen = cp2 - dir + 1;
1204 else { /* No file type present. Treat the filename as a directory. */
1205 retlen = strlen(dir) + 1;
1208 if (buf) retpath = buf;
1209 else if (ts) New(7013,retpath,retlen+1,char);
1210 else retpath = __pathify_retbuf;
1211 strncpy(retpath,dir,retlen-1);
1212 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1213 retpath[retlen-1] = '/'; /* with '/', add it. */
1214 retpath[retlen] = '\0';
1216 else retpath[retlen-1] = '\0';
1218 else { /* VMS-style directory spec */
1219 char esa[NAM$C_MAXRSS+1], *cp;
1220 unsigned long int sts, cmplen, haslower;
1221 struct FAB dirfab = cc$rms_fab;
1222 struct NAM savnam, dirnam = cc$rms_nam;
1224 /* If we've got an explicit filename, we can just shuffle the string. */
1225 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1226 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1227 if ((cp2 = strchr(cp1,'.')) != NULL) {
1229 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1230 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1231 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1232 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1233 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1234 (ver || *cp3)))))) {
1236 set_vaxc_errno(RMS$_DIR);
1240 else { /* No file type, so just draw name into directory part */
1241 for (cp2 = cp1; *cp2; cp2++) ;
1244 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1246 /* We've now got a VMS 'path'; fall through */
1248 dirfab.fab$b_fns = strlen(dir);
1249 dirfab.fab$l_fna = dir;
1250 if (dir[dirfab.fab$b_fns-1] == ']' ||
1251 dir[dirfab.fab$b_fns-1] == '>' ||
1252 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1253 if (buf) retpath = buf;
1254 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1255 else retpath = __pathify_retbuf;
1256 strcpy(retpath,dir);
1259 dirfab.fab$l_dna = ".DIR;1";
1260 dirfab.fab$b_dns = 6;
1261 dirfab.fab$l_nam = &dirnam;
1262 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1263 dirnam.nam$l_esa = esa;
1265 for (cp = dir; *cp; cp++)
1266 if (islower(*cp)) { haslower = 1; break; }
1268 if (!(sts = (sys$parse(&dirfab)&1))) {
1269 if (dirfab.fab$l_sts == RMS$_DIR) {
1270 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1271 sts = sys$parse(&dirfab) & 1;
1275 set_vaxc_errno(dirfab.fab$l_sts);
1281 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1282 if (dirfab.fab$l_sts != RMS$_FNF) {
1284 set_vaxc_errno(dirfab.fab$l_sts);
1287 dirnam = savnam; /* No; just work with potential name */
1290 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1291 /* Yep; check version while we're at it, if it's there. */
1292 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1293 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1294 /* Something other than .DIR[;1]. Bzzt. */
1296 set_vaxc_errno(RMS$_DIR);
1300 /* OK, the type was fine. Now pull any file name into the
1302 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1304 cp1 = strrchr(esa,'>');
1305 *dirnam.nam$l_type = '>';
1308 *(dirnam.nam$l_type + 1) = '\0';
1309 retlen = dirnam.nam$l_type - esa + 2;
1310 if (buf) retpath = buf;
1311 else if (ts) New(7014,retpath,retlen,char);
1312 else retpath = __pathify_retbuf;
1313 strcpy(retpath,esa);
1314 /* $PARSE may have upcased filespec, so convert output to lower
1315 * case if input contained any lowercase characters. */
1316 if (haslower) __mystrtolower(retpath);
1320 } /* end of do_pathify_dirspec() */
1322 /* External entry points */
1323 char *pathify_dirspec(char *dir, char *buf)
1324 { return do_pathify_dirspec(dir,buf,0); }
1325 char *pathify_dirspec_ts(char *dir, char *buf)
1326 { return do_pathify_dirspec(dir,buf,1); }
1328 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1329 static char *do_tounixspec(char *spec, char *buf, int ts)
1331 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1332 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1333 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1335 if (spec == NULL) return NULL;
1336 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1337 if (buf) rslt = buf;
1339 retlen = strlen(spec);
1340 cp1 = strchr(spec,'[');
1341 if (!cp1) cp1 = strchr(spec,'<');
1343 for (cp1++; *cp1; cp1++) {
1344 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1345 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1346 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1349 New(7015,rslt,retlen+2+2*expand,char);
1351 else rslt = __tounixspec_retbuf;
1352 if (strchr(spec,'/') != NULL) {
1359 dirend = strrchr(spec,']');
1360 if (dirend == NULL) dirend = strrchr(spec,'>');
1361 if (dirend == NULL) dirend = strchr(spec,':');
1362 if (dirend == NULL) {
1366 if (*cp2 != '[' && *cp2 != '<') {
1369 else { /* the VMS spec begins with directories */
1371 if (*cp2 == ']' || *cp2 == '>') {
1372 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1375 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1376 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1377 if (ts) Safefree(rslt);
1382 while (*cp3 != ':' && *cp3) cp3++;
1384 if (strchr(cp3,']') != NULL) break;
1385 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1387 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1388 retlen = devlen + dirlen;
1389 Renew(rslt,retlen+1+2*expand,char);
1395 *(cp1++) = *(cp3++);
1396 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1400 else if ( *cp2 == '.') {
1401 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1402 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1408 for (; cp2 <= dirend; cp2++) {
1411 if (*(cp2+1) == '[') cp2++;
1413 else if (*cp2 == ']' || *cp2 == '>') {
1414 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1416 else if (*cp2 == '.') {
1418 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1419 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1420 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1421 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1422 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1424 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1425 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1429 else if (*cp2 == '-') {
1430 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1431 while (*cp2 == '-') {
1433 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1435 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1436 if (ts) Safefree(rslt); /* filespecs like */
1437 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1441 else *(cp1++) = *cp2;
1443 else *(cp1++) = *cp2;
1445 while (*cp2) *(cp1++) = *(cp2++);
1450 } /* end of do_tounixspec() */
1452 /* External entry points */
1453 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1454 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1456 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1457 static char *do_tovmsspec(char *path, char *buf, int ts) {
1458 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1459 char *rslt, *dirend;
1460 register char *cp1, *cp2;
1461 unsigned long int infront = 0, hasdir = 1;
1463 if (path == NULL) return NULL;
1464 if (buf) rslt = buf;
1465 else if (ts) New(7016,rslt,strlen(path)+9,char);
1466 else rslt = __tovmsspec_retbuf;
1467 if (strpbrk(path,"]:>") ||
1468 (dirend = strrchr(path,'/')) == NULL) {
1469 if (path[0] == '.') {
1470 if (path[1] == '\0') strcpy(rslt,"[]");
1471 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1472 else strcpy(rslt,path); /* probably garbage */
1474 else strcpy(rslt,path);
1477 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1478 if (!*(dirend+2)) dirend +=2;
1479 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1480 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1485 char trndev[NAM$C_MAXRSS+1];
1489 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1490 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1492 islnm = my_trnlnm(rslt,trndev,0);
1493 trnend = islnm ? strlen(trndev) - 1 : 0;
1494 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1495 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1496 /* If the first element of the path is a logical name, determine
1497 * whether it has to be translated so we can add more directories. */
1498 if (!islnm || rooted) {
1501 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1505 if (cp2 != dirend) {
1506 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1507 strcpy(rslt,trndev);
1508 cp1 = rslt + trnend;
1521 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1522 cp2 += 2; /* skip over "./" - it's redundant */
1523 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1525 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1526 *(cp1++) = '-'; /* "../" --> "-" */
1529 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1530 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1531 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1532 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1535 if (cp2 > dirend) cp2 = dirend;
1537 else *(cp1++) = '.';
1539 for (; cp2 < dirend; cp2++) {
1541 if (*(cp2-1) == '/') continue;
1542 if (*(cp1-1) != '.') *(cp1++) = '.';
1545 else if (!infront && *cp2 == '.') {
1546 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1547 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1548 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1549 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1550 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1551 else { /* back up over previous directory name */
1553 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1554 if (*(cp1-1) == '[') {
1555 memcpy(cp1,"000000.",7);
1560 if (cp2 == dirend) break;
1562 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1563 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1564 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1565 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1567 *(cp1++) = '.'; /* Simulate trailing '/' */
1568 cp2 += 2; /* for loop will incr this to == dirend */
1570 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1572 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1575 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1576 if (*cp2 == '.') *(cp1++) = '_';
1577 else *(cp1++) = *cp2;
1581 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1582 if (hasdir) *(cp1++) = ']';
1583 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1584 while (*cp2) *(cp1++) = *(cp2++);
1589 } /* end of do_tovmsspec() */
1591 /* External entry points */
1592 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1593 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1595 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1596 static char *do_tovmspath(char *path, char *buf, int ts) {
1597 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1599 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1601 if (path == NULL) return NULL;
1602 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1603 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1604 if (buf) return buf;
1606 vmslen = strlen(vmsified);
1607 New(7017,cp,vmslen+1,char);
1608 memcpy(cp,vmsified,vmslen);
1613 strcpy(__tovmspath_retbuf,vmsified);
1614 return __tovmspath_retbuf;
1617 } /* end of do_tovmspath() */
1619 /* External entry points */
1620 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1621 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1624 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1625 static char *do_tounixpath(char *path, char *buf, int ts) {
1626 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1628 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1630 if (path == NULL) return NULL;
1631 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1632 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1633 if (buf) return buf;
1635 unixlen = strlen(unixified);
1636 New(7017,cp,unixlen+1,char);
1637 memcpy(cp,unixified,unixlen);
1642 strcpy(__tounixpath_retbuf,unixified);
1643 return __tounixpath_retbuf;
1646 } /* end of do_tounixpath() */
1648 /* External entry points */
1649 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1650 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1653 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1655 *****************************************************************************
1657 * Copyright (C) 1989-1994 by *
1658 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1660 * Permission is hereby granted for the reproduction of this software, *
1661 * on condition that this copyright notice is included in the reproduction, *
1662 * and that such reproduction is not for purposes of profit or material *
1665 * 27-Aug-1994 Modified for inclusion in perl5 *
1666 * by Charles Bailey bailey@genetics.upenn.edu *
1667 *****************************************************************************
1671 * getredirection() is intended to aid in porting C programs
1672 * to VMS (Vax-11 C). The native VMS environment does not support
1673 * '>' and '<' I/O redirection, or command line wild card expansion,
1674 * or a command line pipe mechanism using the '|' AND background
1675 * command execution '&'. All of these capabilities are provided to any
1676 * C program which calls this procedure as the first thing in the
1678 * The piping mechanism will probably work with almost any 'filter' type
1679 * of program. With suitable modification, it may useful for other
1680 * portability problems as well.
1682 * Author: Mark Pizzolato mark@infocomm.com
1686 struct list_item *next;
1690 static void add_item(struct list_item **head,
1691 struct list_item **tail,
1695 static void expand_wild_cards(char *item,
1696 struct list_item **head,
1697 struct list_item **tail,
1700 static int background_process(int argc, char **argv);
1702 static void pipe_and_fork(char **cmargv);
1704 /*{{{ void getredirection(int *ac, char ***av)*/
1706 getredirection(int *ac, char ***av)
1708 * Process vms redirection arg's. Exit if any error is seen.
1709 * If getredirection() processes an argument, it is erased
1710 * from the vector. getredirection() returns a new argc and argv value.
1711 * In the event that a background command is requested (by a trailing "&"),
1712 * this routine creates a background subprocess, and simply exits the program.
1714 * Warning: do not try to simplify the code for vms. The code
1715 * presupposes that getredirection() is called before any data is
1716 * read from stdin or written to stdout.
1718 * Normal usage is as follows:
1724 * getredirection(&argc, &argv);
1728 int argc = *ac; /* Argument Count */
1729 char **argv = *av; /* Argument Vector */
1730 char *ap; /* Argument pointer */
1731 int j; /* argv[] index */
1732 int item_count = 0; /* Count of Items in List */
1733 struct list_item *list_head = 0; /* First Item in List */
1734 struct list_item *list_tail; /* Last Item in List */
1735 char *in = NULL; /* Input File Name */
1736 char *out = NULL; /* Output File Name */
1737 char *outmode = "w"; /* Mode to Open Output File */
1738 char *err = NULL; /* Error File Name */
1739 char *errmode = "w"; /* Mode to Open Error File */
1740 int cmargc = 0; /* Piped Command Arg Count */
1741 char **cmargv = NULL;/* Piped Command Arg Vector */
1744 * First handle the case where the last thing on the line ends with
1745 * a '&'. This indicates the desire for the command to be run in a
1746 * subprocess, so we satisfy that desire.
1749 if (0 == strcmp("&", ap))
1750 exit(background_process(--argc, argv));
1751 if (*ap && '&' == ap[strlen(ap)-1])
1753 ap[strlen(ap)-1] = '\0';
1754 exit(background_process(argc, argv));
1757 * Now we handle the general redirection cases that involve '>', '>>',
1758 * '<', and pipes '|'.
1760 for (j = 0; j < argc; ++j)
1762 if (0 == strcmp("<", argv[j]))
1766 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1767 exit(LIB$_WRONUMARG);
1772 if ('<' == *(ap = argv[j]))
1777 if (0 == strcmp(">", ap))
1781 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1782 exit(LIB$_WRONUMARG);
1801 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1802 exit(LIB$_WRONUMARG);
1806 if (('2' == *ap) && ('>' == ap[1]))
1823 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1824 exit(LIB$_WRONUMARG);
1828 if (0 == strcmp("|", argv[j]))
1832 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1833 exit(LIB$_WRONUMARG);
1835 cmargc = argc-(j+1);
1836 cmargv = &argv[j+1];
1840 if ('|' == *(ap = argv[j]))
1848 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1851 * Allocate and fill in the new argument vector, Some Unix's terminate
1852 * the list with an extra null pointer.
1854 New(7002, argv, item_count+1, char *);
1856 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1857 argv[j] = list_head->value;
1863 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1864 exit(LIB$_INVARGORD);
1866 pipe_and_fork(cmargv);
1869 /* Check for input from a pipe (mailbox) */
1871 if (in == NULL && 1 == isapipe(0))
1873 char mbxname[L_tmpnam];
1875 long int dvi_item = DVI$_DEVBUFSIZ;
1876 $DESCRIPTOR(mbxnam, "");
1877 $DESCRIPTOR(mbxdevnam, "");
1879 /* Input from a pipe, reopen it in binary mode to disable */
1880 /* carriage control processing. */
1882 PerlIO_getname(stdin, mbxname);
1883 mbxnam.dsc$a_pointer = mbxname;
1884 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1885 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1886 mbxdevnam.dsc$a_pointer = mbxname;
1887 mbxdevnam.dsc$w_length = sizeof(mbxname);
1888 dvi_item = DVI$_DEVNAM;
1889 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1890 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1893 freopen(mbxname, "rb", stdin);
1896 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1900 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1902 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1905 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1907 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
1912 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1914 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
1918 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1923 #ifdef ARGPROC_DEBUG
1924 PerlIO_printf(Perl_debug_log, "Arglist:\n");
1925 for (j = 0; j < *ac; ++j)
1926 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1928 /* Clear errors we may have hit expanding wildcards, so they don't
1929 show up in Perl's $! later */
1930 set_errno(0); set_vaxc_errno(1);
1931 } /* end of getredirection() */
1934 static void add_item(struct list_item **head,
1935 struct list_item **tail,
1941 New(7003,*head,1,struct list_item);
1945 New(7004,(*tail)->next,1,struct list_item);
1946 *tail = (*tail)->next;
1948 (*tail)->value = value;
1952 static void expand_wild_cards(char *item,
1953 struct list_item **head,
1954 struct list_item **tail,
1958 unsigned long int context = 0;
1964 char vmsspec[NAM$C_MAXRSS+1];
1965 $DESCRIPTOR(filespec, "");
1966 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1967 $DESCRIPTOR(resultspec, "");
1968 unsigned long int zero = 0, sts;
1970 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
1972 add_item(head, tail, item, count);
1975 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1976 resultspec.dsc$b_class = DSC$K_CLASS_D;
1977 resultspec.dsc$a_pointer = NULL;
1978 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1979 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1980 if (!isunix || !filespec.dsc$a_pointer)
1981 filespec.dsc$a_pointer = item;
1982 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1984 * Only return version specs, if the caller specified a version
1986 had_version = strchr(item, ';');
1988 * Only return device and directory specs, if the caller specifed either.
1990 had_device = strchr(item, ':');
1991 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1993 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1994 &defaultspec, 0, 0, &zero))))
1999 New(7005,string,resultspec.dsc$w_length+1,char);
2000 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2001 string[resultspec.dsc$w_length] = '\0';
2002 if (NULL == had_version)
2003 *((char *)strrchr(string, ';')) = '\0';
2004 if ((!had_directory) && (had_device == NULL))
2006 if (NULL == (devdir = strrchr(string, ']')))
2007 devdir = strrchr(string, '>');
2008 strcpy(string, devdir + 1);
2011 * Be consistent with what the C RTL has already done to the rest of
2012 * the argv items and lowercase all of these names.
2014 for (c = string; *c; ++c)
2017 if (isunix) trim_unixpath(string,item,1);
2018 add_item(head, tail, string, count);
2021 if (sts != RMS$_NMF)
2023 set_vaxc_errno(sts);
2029 set_errno(ENOENT); break;
2031 set_errno(ENODEV); break;
2034 set_errno(EINVAL); break;
2036 set_errno(EACCES); break;
2038 _ckvmssts_noperl(sts);
2042 add_item(head, tail, item, count);
2043 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2044 _ckvmssts_noperl(lib$find_file_end(&context));
2047 static int child_st[2];/* Event Flag set when child process completes */
2049 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2051 static unsigned long int exit_handler(int *status)
2055 if (0 == child_st[0])
2057 #ifdef ARGPROC_DEBUG
2058 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2060 fflush(stdout); /* Have to flush pipe for binary data to */
2061 /* terminate properly -- <tp@mccall.com> */
2062 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2063 sys$dassgn(child_chan);
2065 sys$synch(0, child_st);
2070 static void sig_child(int chan)
2072 #ifdef ARGPROC_DEBUG
2073 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2075 if (child_st[0] == 0)
2079 static struct exit_control_block exit_block =
2084 &exit_block.exit_status,
2088 static void pipe_and_fork(char **cmargv)
2091 $DESCRIPTOR(cmddsc, "");
2092 static char mbxname[64];
2093 $DESCRIPTOR(mbxdsc, mbxname);
2095 unsigned long int zero = 0, one = 1;
2097 strcpy(subcmd, cmargv[0]);
2098 for (j = 1; NULL != cmargv[j]; ++j)
2100 strcat(subcmd, " \"");
2101 strcat(subcmd, cmargv[j]);
2102 strcat(subcmd, "\"");
2104 cmddsc.dsc$a_pointer = subcmd;
2105 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2107 create_mbx(&child_chan,&mbxdsc);
2108 #ifdef ARGPROC_DEBUG
2109 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2110 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2112 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2113 0, &pid, child_st, &zero, sig_child,
2115 #ifdef ARGPROC_DEBUG
2116 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2118 sys$dclexh(&exit_block);
2119 if (NULL == freopen(mbxname, "wb", stdout))
2121 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2125 static int background_process(int argc, char **argv)
2127 char command[2048] = "$";
2128 $DESCRIPTOR(value, "");
2129 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2130 static $DESCRIPTOR(null, "NLA0:");
2131 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2133 $DESCRIPTOR(pidstr, "");
2135 unsigned long int flags = 17, one = 1, retsts;
2137 strcat(command, argv[0]);
2140 strcat(command, " \"");
2141 strcat(command, *(++argv));
2142 strcat(command, "\"");
2144 value.dsc$a_pointer = command;
2145 value.dsc$w_length = strlen(value.dsc$a_pointer);
2146 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2147 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2148 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2149 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2152 _ckvmssts_noperl(retsts);
2154 #ifdef ARGPROC_DEBUG
2155 PerlIO_printf(Perl_debug_log, "%s\n", command);
2157 sprintf(pidstring, "%08X", pid);
2158 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2159 pidstr.dsc$a_pointer = pidstring;
2160 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2161 lib$set_symbol(&pidsymbol, &pidstr);
2165 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2168 * Trim Unix-style prefix off filespec, so it looks like what a shell
2169 * glob expansion would return (i.e. from specified prefix on, not
2170 * full path). Note that returned filespec is Unix-style, regardless
2171 * of whether input filespec was VMS-style or Unix-style.
2173 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2174 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2175 * vector of options; at present, only bit 0 is used, and if set tells
2176 * trim unixpath to try the current default directory as a prefix when
2177 * presented with a possibly ambiguous ... wildcard.
2179 * Returns !=0 on success, with trimmed filespec replacing contents of
2180 * fspec, and 0 on failure, with contents of fpsec unchanged.
2182 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2184 trim_unixpath(char *fspec, char *wildspec, int opts)
2186 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2187 *template, *base, *end, *cp1, *cp2;
2188 register int tmplen, reslen = 0, dirs = 0;
2190 if (!wildspec || !fspec) return 0;
2191 if (strpbrk(wildspec,"]>:") != NULL) {
2192 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2193 else template = unixwild;
2195 else template = wildspec;
2196 if (strpbrk(fspec,"]>:") != NULL) {
2197 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2198 else base = unixified;
2199 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2200 * check to see that final result fits into (isn't longer than) fspec */
2201 reslen = strlen(fspec);
2205 /* No prefix or absolute path on wildcard, so nothing to remove */
2206 if (!*template || *template == '/') {
2207 if (base == fspec) return 1;
2208 tmplen = strlen(unixified);
2209 if (tmplen > reslen) return 0; /* not enough space */
2210 /* Copy unixified resultant, including trailing NUL */
2211 memmove(fspec,unixified,tmplen+1);
2215 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2216 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2217 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2218 for (cp1 = end ;cp1 >= base; cp1--)
2219 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2221 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2225 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2226 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2227 int ells = 1, totells, segdirs, match;
2228 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2229 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2231 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2233 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2234 if (ellipsis == template && opts & 1) {
2235 /* Template begins with an ellipsis. Since we can't tell how many
2236 * directory names at the front of the resultant to keep for an
2237 * arbitrary starting point, we arbitrarily choose the current
2238 * default directory as a starting point. If it's there as a prefix,
2239 * clip it off. If not, fall through and act as if the leading
2240 * ellipsis weren't there (i.e. return shortest possible path that
2241 * could match template).
2243 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2244 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2245 if (_tolower(*cp1) != _tolower(*cp2)) break;
2246 segdirs = dirs - totells; /* Min # of dirs we must have left */
2247 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2248 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2249 memcpy(fspec,cp2+1,end - cp2);
2253 /* First off, back up over constant elements at end of path */
2255 for (front = end ; front >= base; front--)
2256 if (*front == '/' && !dirs--) { front++; break; }
2258 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2259 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2260 if (cp1 != '\0') return 0; /* Path too long. */
2262 *cp2 = '\0'; /* Pick up with memcpy later */
2263 lcfront = lcres + (front - base);
2264 /* Now skip over each ellipsis and try to match the path in front of it. */
2266 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2267 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2268 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2269 if (cp1 < template) break; /* template started with an ellipsis */
2270 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2271 ellipsis = cp1; continue;
2273 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2275 for (segdirs = 0, cp2 = tpl;
2276 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2278 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2279 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2280 if (*cp2 == '/') segdirs++;
2282 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2283 /* Back up at least as many dirs as in template before matching */
2284 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2285 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2286 for (match = 0; cp1 > lcres;) {
2287 resdsc.dsc$a_pointer = cp1;
2288 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2290 if (match == 1) lcfront = cp1;
2292 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2294 if (!match) return 0; /* Can't find prefix ??? */
2295 if (match > 1 && opts & 1) {
2296 /* This ... wildcard could cover more than one set of dirs (i.e.
2297 * a set of similar dir names is repeated). If the template
2298 * contains more than 1 ..., upstream elements could resolve the
2299 * ambiguity, but it's not worth a full backtracking setup here.
2300 * As a quick heuristic, clip off the current default directory
2301 * if it's present to find the trimmed spec, else use the
2302 * shortest string that this ... could cover.
2304 char def[NAM$C_MAXRSS+1], *st;
2306 if (getcwd(def, sizeof def,0) == NULL) return 0;
2307 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2308 if (_tolower(*cp1) != _tolower(*cp2)) break;
2309 segdirs = dirs - totells; /* Min # of dirs we must have left */
2310 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2311 if (*cp1 == '\0' && *cp2 == '/') {
2312 memcpy(fspec,cp2+1,end - cp2);
2315 /* Nope -- stick with lcfront from above and keep going. */
2318 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2323 } /* end of trim_unixpath() */
2328 * VMS readdir() routines.
2329 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2330 * This code has no copyright.
2332 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2333 * Minor modifications to original routines.
2336 /* Number of elements in vms_versions array */
2337 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2340 * Open a directory, return a handle for later use.
2342 /*{{{ DIR *opendir(char*name) */
2347 char dir[NAM$C_MAXRSS+1];
2349 /* Get memory for the handle, and the pattern. */
2351 if (do_tovmspath(name,dir,0) == NULL) {
2352 Safefree((char *)dd);
2355 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2357 /* Fill in the fields; mainly playing with the descriptor. */
2358 (void)sprintf(dd->pattern, "%s*.*",dir);
2361 dd->vms_wantversions = 0;
2362 dd->pat.dsc$a_pointer = dd->pattern;
2363 dd->pat.dsc$w_length = strlen(dd->pattern);
2364 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2365 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2368 } /* end of opendir() */
2372 * Set the flag to indicate we want versions or not.
2374 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2376 vmsreaddirversions(DIR *dd, int flag)
2378 dd->vms_wantversions = flag;
2383 * Free up an opened directory.
2385 /*{{{ void closedir(DIR *dd)*/
2389 (void)lib$find_file_end(&dd->context);
2390 Safefree(dd->pattern);
2391 Safefree((char *)dd);
2396 * Collect all the version numbers for the current file.
2402 struct dsc$descriptor_s pat;
2403 struct dsc$descriptor_s res;
2405 char *p, *text, buff[sizeof dd->entry.d_name];
2407 unsigned long context, tmpsts;
2409 /* Convenient shorthand. */
2412 /* Add the version wildcard, ignoring the "*.*" put on before */
2413 i = strlen(dd->pattern);
2414 New(7008,text,i + e->d_namlen + 3,char);
2415 (void)strcpy(text, dd->pattern);
2416 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2418 /* Set up the pattern descriptor. */
2419 pat.dsc$a_pointer = text;
2420 pat.dsc$w_length = i + e->d_namlen - 1;
2421 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2422 pat.dsc$b_class = DSC$K_CLASS_S;
2424 /* Set up result descriptor. */
2425 res.dsc$a_pointer = buff;
2426 res.dsc$w_length = sizeof buff - 2;
2427 res.dsc$b_dtype = DSC$K_DTYPE_T;
2428 res.dsc$b_class = DSC$K_CLASS_S;
2430 /* Read files, collecting versions. */
2431 for (context = 0, e->vms_verscount = 0;
2432 e->vms_verscount < VERSIZE(e);
2433 e->vms_verscount++) {
2434 tmpsts = lib$find_file(&pat, &res, &context);
2435 if (tmpsts == RMS$_NMF || context == 0) break;
2437 buff[sizeof buff - 1] = '\0';
2438 if ((p = strchr(buff, ';')))
2439 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2441 e->vms_versions[e->vms_verscount] = -1;
2444 _ckvmssts(lib$find_file_end(&context));
2447 } /* end of collectversions() */
2450 * Read the next entry from the directory.
2452 /*{{{ struct dirent *readdir(DIR *dd)*/
2456 struct dsc$descriptor_s res;
2457 char *p, buff[sizeof dd->entry.d_name];
2458 unsigned long int tmpsts;
2460 /* Set up result descriptor, and get next file. */
2461 res.dsc$a_pointer = buff;
2462 res.dsc$w_length = sizeof buff - 2;
2463 res.dsc$b_dtype = DSC$K_DTYPE_T;
2464 res.dsc$b_class = DSC$K_CLASS_S;
2465 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2466 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2467 if (!(tmpsts & 1)) {
2468 set_vaxc_errno(tmpsts);
2471 set_errno(EACCES); break;
2473 set_errno(ENODEV); break;
2476 set_errno(ENOENT); break;
2483 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2484 buff[sizeof buff - 1] = '\0';
2485 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2488 /* Skip any directory component and just copy the name. */
2489 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2490 else (void)strcpy(dd->entry.d_name, buff);
2492 /* Clobber the version. */
2493 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2495 dd->entry.d_namlen = strlen(dd->entry.d_name);
2496 dd->entry.vms_verscount = 0;
2497 if (dd->vms_wantversions) collectversions(dd);
2500 } /* end of readdir() */
2504 * Return something that can be used in a seekdir later.
2506 /*{{{ long telldir(DIR *dd)*/
2515 * Return to a spot where we used to be. Brute force.
2517 /*{{{ void seekdir(DIR *dd,long count)*/
2519 seekdir(DIR *dd, long count)
2521 int vms_wantversions;
2523 /* If we haven't done anything yet... */
2527 /* Remember some state, and clear it. */
2528 vms_wantversions = dd->vms_wantversions;
2529 dd->vms_wantversions = 0;
2530 _ckvmssts(lib$find_file_end(&dd->context));
2533 /* The increment is in readdir(). */
2534 for (dd->count = 0; dd->count < count; )
2537 dd->vms_wantversions = vms_wantversions;
2539 } /* end of seekdir() */
2542 /* VMS subprocess management
2544 * my_vfork() - just a vfork(), after setting a flag to record that
2545 * the current script is trying a Unix-style fork/exec.
2547 * vms_do_aexec() and vms_do_exec() are called in response to the
2548 * perl 'exec' function. If this follows a vfork call, then they
2549 * call out the the regular perl routines in doio.c which do an
2550 * execvp (for those who really want to try this under VMS).
2551 * Otherwise, they do exactly what the perl docs say exec should
2552 * do - terminate the current script and invoke a new command
2553 * (See below for notes on command syntax.)
2555 * do_aspawn() and do_spawn() implement the VMS side of the perl
2556 * 'system' function.
2558 * Note on command arguments to perl 'exec' and 'system': When handled
2559 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2560 * are concatenated to form a DCL command string. If the first arg
2561 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2562 * the the command string is hrnded off to DCL directly. Otherwise,
2563 * the first token of the command is taken as the filespec of an image
2564 * to run. The filespec is expanded using a default type of '.EXE' and
2565 * the process defaults for device, directory, etc., and the resultant
2566 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2567 * the command string as parameters. This is perhaps a bit compicated,
2568 * but I hope it will form a happy medium between what VMS folks expect
2569 * from lib$spawn and what Unix folks expect from exec.
2572 static int vfork_called;
2574 /*{{{int my_vfork()*/
2584 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2592 if (VMScmd.dsc$a_pointer) {
2593 Safefree(VMScmd.dsc$a_pointer);
2594 VMScmd.dsc$w_length = 0;
2595 VMScmd.dsc$a_pointer = Nullch;
2600 setup_argstr(SV *really, SV **mark, SV **sp)
2602 char *junk, *tmps = Nullch;
2603 register size_t cmdlen = 0;
2609 tmps = SvPV(really,rlen);
2616 for (idx++; idx <= sp; idx++) {
2618 junk = SvPVx(*idx,rlen);
2619 cmdlen += rlen ? rlen + 1 : 0;
2622 New(401,Cmd,cmdlen+1,char);
2624 if (tmps && *tmps) {
2629 while (++mark <= sp) {
2632 strcat(Cmd,SvPVx(*mark,na));
2637 } /* end of setup_argstr() */
2640 static unsigned long int
2641 setup_cmddsc(char *cmd, int check_img)
2643 char resspec[NAM$C_MAXRSS+1];
2644 $DESCRIPTOR(defdsc,".EXE");
2645 $DESCRIPTOR(resdsc,resspec);
2646 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2647 unsigned long int cxt = 0, flags = 1, retsts;
2648 register char *s, *rest, *cp;
2649 register int isdcl = 0;
2652 while (*s && isspace(*s)) s++;
2654 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2655 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2656 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2657 if (*cp == ':' || *cp == '[' || *cp == '<') {
2665 if (isdcl) { /* It's a DCL command, just do it. */
2666 VMScmd.dsc$w_length = strlen(cmd);
2668 VMScmd.dsc$a_pointer = Cmd;
2669 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2671 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2673 else { /* assume first token is an image spec */
2675 while (*s && !isspace(*s)) s++;
2677 imgdsc.dsc$a_pointer = cmd;
2678 imgdsc.dsc$w_length = s - cmd;
2679 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2680 if (!(retsts & 1)) {
2681 /* just hand off status values likely to be due to user error */
2682 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2683 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2684 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2685 else { _ckvmssts(retsts); }
2688 _ckvmssts(lib$find_file_end(&cxt));
2690 while (*s && !isspace(*s)) s++;
2692 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2693 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2694 strcat(VMScmd.dsc$a_pointer,resspec);
2695 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2696 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2700 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2702 } /* end of setup_cmddsc() */
2705 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2707 vms_do_aexec(SV *really,SV **mark,SV **sp)
2710 if (vfork_called) { /* this follows a vfork - act Unixish */
2712 if (vfork_called < 0) {
2713 warn("Internal inconsistency in tracking vforks");
2716 else return do_aexec(really,mark,sp);
2718 /* no vfork - act VMSish */
2719 return vms_do_exec(setup_argstr(really,mark,sp));
2724 } /* end of vms_do_aexec() */
2727 /* {{{bool vms_do_exec(char *cmd) */
2729 vms_do_exec(char *cmd)
2732 if (vfork_called) { /* this follows a vfork - act Unixish */
2734 if (vfork_called < 0) {
2735 warn("Internal inconsistency in tracking vforks");
2738 else return do_exec(cmd);
2741 { /* no vfork - act VMSish */
2742 unsigned long int retsts;
2744 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2745 retsts = lib$do_command(&VMScmd);
2748 set_vaxc_errno(retsts);
2750 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2756 } /* end of vms_do_exec() */
2759 unsigned long int do_spawn(char *);
2761 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2763 do_aspawn(SV *really,SV **mark,SV **sp)
2765 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2768 } /* end of do_aspawn() */
2771 /* {{{unsigned long int do_spawn(char *cmd) */
2775 unsigned long int substs, hadcmd = 1;
2777 if (!cmd || !*cmd) {
2779 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2781 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2782 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2787 set_vaxc_errno(substs);
2789 warn("Can't spawn \"%s\": %s",
2790 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2795 } /* end of do_spawn() */
2799 * A simple fwrite replacement which outputs itmsz*nitm chars without
2800 * introducing record boundaries every itmsz chars.
2802 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2804 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2806 register char *cp, *end;
2808 end = (char *)src + itmsz * nitm;
2810 while ((char *)src <= end) {
2811 for (cp = src; cp <= end; cp++) if (!*cp) break;
2812 if (fputs(src,dest) == EOF) return EOF;
2814 if (fputc('\0',dest) == EOF) return EOF;
2820 } /* end of my_fwrite() */
2824 * Here are replacements for the following Unix routines in the VMS environment:
2825 * getpwuid Get information for a particular UIC or UID
2826 * getpwnam Get information for a named user
2827 * getpwent Get information for each user in the rights database
2828 * setpwent Reset search to the start of the rights database
2829 * endpwent Finish searching for users in the rights database
2831 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2832 * (defined in pwd.h), which contains the following fields:-
2834 * char *pw_name; Username (in lower case)
2835 * char *pw_passwd; Hashed password
2836 * unsigned int pw_uid; UIC
2837 * unsigned int pw_gid; UIC group number
2838 * char *pw_unixdir; Default device/directory (VMS-style)
2839 * char *pw_gecos; Owner name
2840 * char *pw_dir; Default device/directory (Unix-style)
2841 * char *pw_shell; Default CLI name (eg. DCL)
2843 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2845 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2846 * not the UIC member number (eg. what's returned by getuid()),
2847 * getpwuid() can accept either as input (if uid is specified, the caller's
2848 * UIC group is used), though it won't recognise gid=0.
2850 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2851 * information about other users in your group or in other groups, respectively.
2852 * If the required privilege is not available, then these routines fill only
2853 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2856 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2859 /* sizes of various UAF record fields */
2860 #define UAI$S_USERNAME 12
2861 #define UAI$S_IDENT 31
2862 #define UAI$S_OWNER 31
2863 #define UAI$S_DEFDEV 31
2864 #define UAI$S_DEFDIR 63
2865 #define UAI$S_DEFCLI 31
2868 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2869 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2870 (uic).uic$v_group != UIC$K_WILD_GROUP)
2872 static char __empty[]= "";
2873 static struct passwd __passwd_empty=
2874 {(char *) __empty, (char *) __empty, 0, 0,
2875 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2876 static int contxt= 0;
2877 static struct passwd __pwdcache;
2878 static char __pw_namecache[UAI$S_IDENT+1];
2881 * This routine does most of the work extracting the user information.
2883 static int fillpasswd (const char *name, struct passwd *pwd)
2886 unsigned char length;
2887 char pw_gecos[UAI$S_OWNER+1];
2889 static union uicdef uic;
2891 unsigned char length;
2892 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2895 unsigned char length;
2896 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2899 unsigned char length;
2900 char pw_shell[UAI$S_DEFCLI+1];
2902 static char pw_passwd[UAI$S_PWD+1];
2904 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2905 struct dsc$descriptor_s name_desc;
2906 unsigned long int sts;
2908 static struct itmlst_3 itmlst[]= {
2909 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2910 {sizeof(uic), UAI$_UIC, &uic, &luic},
2911 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2912 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2913 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2914 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2915 {0, 0, NULL, NULL}};
2917 name_desc.dsc$w_length= strlen(name);
2918 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2919 name_desc.dsc$b_class= DSC$K_CLASS_S;
2920 name_desc.dsc$a_pointer= (char *) name;
2922 /* Note that sys$getuai returns many fields as counted strings. */
2923 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2924 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2925 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2927 else { _ckvmssts(sts); }
2928 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2930 if ((int) owner.length < lowner) lowner= (int) owner.length;
2931 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2932 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2933 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2934 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2935 owner.pw_gecos[lowner]= '\0';
2936 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2937 defcli.pw_shell[ldefcli]= '\0';
2938 if (valid_uic(uic)) {
2939 pwd->pw_uid= uic.uic$l_uic;
2940 pwd->pw_gid= uic.uic$v_group;
2943 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2944 pwd->pw_passwd= pw_passwd;
2945 pwd->pw_gecos= owner.pw_gecos;
2946 pwd->pw_dir= defdev.pw_dir;
2947 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2948 pwd->pw_shell= defcli.pw_shell;
2949 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2951 ldir= strlen(pwd->pw_unixdir) - 1;
2952 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2955 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2956 __mystrtolower(pwd->pw_unixdir);
2961 * Get information for a named user.
2963 /*{{{struct passwd *getpwnam(char *name)*/
2964 struct passwd *my_getpwnam(char *name)
2966 struct dsc$descriptor_s name_desc;
2968 unsigned long int status, stat;
2970 __pwdcache = __passwd_empty;
2971 if (!fillpasswd(name, &__pwdcache)) {
2972 /* We still may be able to determine pw_uid and pw_gid */
2973 name_desc.dsc$w_length= strlen(name);
2974 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2975 name_desc.dsc$b_class= DSC$K_CLASS_S;
2976 name_desc.dsc$a_pointer= (char *) name;
2977 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2978 __pwdcache.pw_uid= uic.uic$l_uic;
2979 __pwdcache.pw_gid= uic.uic$v_group;
2982 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2983 set_vaxc_errno(stat);
2984 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2987 else { _ckvmssts(stat); }
2990 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2991 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2992 __pwdcache.pw_name= __pw_namecache;
2994 } /* end of my_getpwnam() */
2998 * Get information for a particular UIC or UID.
2999 * Called by my_getpwent with uid=-1 to list all users.
3001 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3002 struct passwd *my_getpwuid(Uid_t uid)
3004 const $DESCRIPTOR(name_desc,__pw_namecache);
3005 unsigned short lname;
3007 unsigned long int status;
3009 if (uid == (unsigned int) -1) {
3011 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3012 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3013 set_vaxc_errno(status);
3014 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3018 else { _ckvmssts(status); }
3019 } while (!valid_uic (uic));
3023 if (!uic.uic$v_group)
3024 uic.uic$v_group= getgid();
3026 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3027 else status = SS$_IVIDENT;
3028 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3029 status == RMS$_PRV) {
3030 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3033 else { _ckvmssts(status); }
3035 __pw_namecache[lname]= '\0';
3036 __mystrtolower(__pw_namecache);
3038 __pwdcache = __passwd_empty;
3039 __pwdcache.pw_name = __pw_namecache;
3041 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3042 The identifier's value is usually the UIC, but it doesn't have to be,
3043 so if we can, we let fillpasswd update this. */
3044 __pwdcache.pw_uid = uic.uic$l_uic;
3045 __pwdcache.pw_gid = uic.uic$v_group;
3047 fillpasswd(__pw_namecache, &__pwdcache);
3050 } /* end of my_getpwuid() */
3054 * Get information for next user.
3056 /*{{{struct passwd *my_getpwent()*/
3057 struct passwd *my_getpwent()
3059 return (my_getpwuid((unsigned int) -1));
3064 * Finish searching rights database for users.
3066 /*{{{void my_endpwent()*/
3070 _ckvmssts(sys$finish_rdb(&contxt));
3077 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3078 * my_utime(), and flex_stat(), all of which operate on UTC unless
3079 * VMSISH_TIMES is true.
3081 /* method used to handle UTC conversions:
3082 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3084 static int gmtime_emulation_type;
3085 /* number of secs to add to UTC POSIX-style time to get local time */
3086 static long int utc_offset_secs;
3088 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3089 * in vmsish.h. #undef them here so we can call the CRTL routines
3096 /* my_time(), my_localtime(), my_gmtime()
3097 * By default traffic in UTC time values, suing CRTL gmtime() or
3098 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3099 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3100 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3103 /*{{{time_t my_time(time_t *timep)*/
3104 time_t my_time(time_t *timep)
3108 if (gmtime_emulation_type == 0) {
3110 time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
3112 gmtime_emulation_type++;
3113 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3116 gmtime_emulation_type++;
3117 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3118 gmtime_emulation_type++;
3119 warn("no UTC offset information; assuming local time is UTC");
3121 else { utc_offset_secs = atol(off); }
3123 else { /* We've got a working gmtime() */
3124 struct tm gmt, local;
3127 tm_p = localtime(&base);
3129 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3130 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3131 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3132 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3141 when != -1) when -= utc_offset_secs;
3142 if (timep != NULL) *timep = when;
3145 } /* end of my_time() */
3149 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3151 my_gmtime(const time_t *timep)
3156 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3160 if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
3162 /* CRTL localtime() wants local time as input, so does no tz correction */
3163 return localtime(&when);
3165 } /* end of my_gmtime() */
3169 /*{{{struct tm *my_localtime(const time_t *timep)*/
3171 my_localtime(const time_t *timep)
3175 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3179 if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
3181 /* CRTL localtime() wants local time as input, so does no tz correction */
3182 return localtime(&when);
3184 } /* end of my_localtime() */
3187 /* Reset definitions for later calls */
3188 #define gmtime(t) my_gmtime(t)
3189 #define localtime(t) my_localtime(t)
3190 #define time(t) my_time(t)
3193 /* my_utime - update modification time of a file
3194 * calling sequence is identical to POSIX utime(), but under
3195 * VMS only the modification time is changed; ODS-2 does not
3196 * maintain access times. Restrictions differ from the POSIX
3197 * definition in that the time can be changed as long as the
3198 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3199 * no separate checks are made to insure that the caller is the
3200 * owner of the file or has special privs enabled.
3201 * Code here is based on Joe Meadows' FILE utility.
3204 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3205 * to VMS epoch (01-JAN-1858 00:00:00.00)
3206 * in 100 ns intervals.
3208 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3210 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3211 int my_utime(char *file, struct utimbuf *utimes)
3214 long int bintime[2], len = 2, lowbit, unixtime,
3215 secscale = 10000000; /* seconds --> 100 ns intervals */
3216 unsigned long int chan, iosb[2], retsts;
3217 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3218 struct FAB myfab = cc$rms_fab;
3219 struct NAM mynam = cc$rms_nam;
3220 #if defined (__DECC) && defined (__VAX)
3221 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3222 * at least through VMS V6.1, which causes a type-conversion warning.
3224 # pragma message save
3225 # pragma message disable cvtdiftypes
3227 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3228 struct fibdef myfib;
3229 #if defined (__DECC) && defined (__VAX)
3230 /* This should be right after the declaration of myatr, but due
3231 * to a bug in VAX DEC C, this takes effect a statement early.
3233 # pragma message restore
3235 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3236 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3237 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3239 if (file == NULL || *file == '\0') {
3241 set_vaxc_errno(LIB$_INVARG);
3244 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3246 if (utimes != NULL) {
3247 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3248 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3249 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3250 * as input, we force the sign bit to be clear by shifting unixtime right
3251 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3253 lowbit = (utimes->modtime & 1) ? secscale : 0;
3254 unixtime = (long int) utimes->modtime;
3256 if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
3257 if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
3258 unixtime += utc_offset_secs;
3261 unixtime >> 1; secscale << 1;
3262 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3263 if (!(retsts & 1)) {
3265 set_vaxc_errno(retsts);
3268 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3269 if (!(retsts & 1)) {
3271 set_vaxc_errno(retsts);
3276 /* Just get the current time in VMS format directly */
3277 retsts = sys$gettim(bintime);
3278 if (!(retsts & 1)) {
3280 set_vaxc_errno(retsts);
3285 myfab.fab$l_fna = vmsspec;
3286 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3287 myfab.fab$l_nam = &mynam;
3288 mynam.nam$l_esa = esa;
3289 mynam.nam$b_ess = (unsigned char) sizeof esa;
3290 mynam.nam$l_rsa = rsa;
3291 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3293 /* Look for the file to be affected, letting RMS parse the file
3294 * specification for us as well. I have set errno using only
3295 * values documented in the utime() man page for VMS POSIX.
3297 retsts = sys$parse(&myfab,0,0);
3298 if (!(retsts & 1)) {
3299 set_vaxc_errno(retsts);
3300 if (retsts == RMS$_PRV) set_errno(EACCES);
3301 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3302 else set_errno(EVMSERR);
3305 retsts = sys$search(&myfab,0,0);
3306 if (!(retsts & 1)) {
3307 set_vaxc_errno(retsts);
3308 if (retsts == RMS$_PRV) set_errno(EACCES);
3309 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3310 else set_errno(EVMSERR);
3314 devdsc.dsc$w_length = mynam.nam$b_dev;
3315 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3317 retsts = sys$assign(&devdsc,&chan,0,0);
3318 if (!(retsts & 1)) {
3319 set_vaxc_errno(retsts);
3320 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3321 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3322 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3323 else set_errno(EVMSERR);
3327 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3328 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3330 memset((void *) &myfib, 0, sizeof myfib);
3332 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3333 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3334 /* This prevents the revision time of the file being reset to the current
3335 * time as a result of our IO$_MODIFY $QIO. */
3336 myfib.fib$l_acctl = FIB$M_NORECORD;
3338 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3339 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3340 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3342 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3343 _ckvmssts(sys$dassgn(chan));
3344 if (retsts & 1) retsts = iosb[0];
3345 if (!(retsts & 1)) {
3346 set_vaxc_errno(retsts);
3347 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3348 else set_errno(EVMSERR);
3353 } /* end of my_utime() */
3357 * flex_stat, flex_fstat
3358 * basic stat, but gets it right when asked to stat
3359 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3362 /* encode_dev packs a VMS device name string into an integer to allow
3363 * simple comparisons. This can be used, for example, to check whether two
3364 * files are located on the same device, by comparing their encoded device
3365 * names. Even a string comparison would not do, because stat() reuses the
3366 * device name buffer for each call; so without encode_dev, it would be
3367 * necessary to save the buffer and use strcmp (this would mean a number of
3368 * changes to the standard Perl code, to say nothing of what a Perl script
3371 * The device lock id, if it exists, should be unique (unless perhaps compared
3372 * with lock ids transferred from other nodes). We have a lock id if the disk is
3373 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3374 * device names. Thus we use the lock id in preference, and only if that isn't
3375 * available, do we try to pack the device name into an integer (flagged by
3376 * the sign bit (LOCKID_MASK) being set).
3378 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3379 * name and its encoded form, but it seems very unlikely that we will find
3380 * two files on different disks that share the same encoded device names,
3381 * and even more remote that they will share the same file id (if the test
3382 * is to check for the same file).
3384 * A better method might be to use sys$device_scan on the first call, and to
3385 * search for the device, returning an index into the cached array.
3386 * The number returned would be more intelligable.
3387 * This is probably not worth it, and anyway would take quite a bit longer
3388 * on the first call.
3390 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3391 static dev_t encode_dev (const char *dev)
3394 unsigned long int f;
3399 if (!dev || !dev[0]) return 0;
3403 struct dsc$descriptor_s dev_desc;
3404 unsigned long int status, lockid, item = DVI$_LOCKID;
3406 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3407 can try that first. */
3408 dev_desc.dsc$w_length = strlen (dev);
3409 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3410 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3411 dev_desc.dsc$a_pointer = (char *) dev;
3412 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3413 if (lockid) return (lockid & ~LOCKID_MASK);
3417 /* Otherwise we try to encode the device name */
3421 for (q = dev + strlen(dev); q--; q >= dev) {
3424 else if (isalpha (toupper (*q)))
3425 c= toupper (*q) - 'A' + (char)10;
3427 continue; /* Skip '$'s */
3429 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3431 enc += f * (unsigned long int) c;
3433 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3435 } /* end of encode_dev() */
3437 static char namecache[NAM$C_MAXRSS+1];
3440 is_null_device(name)
3443 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3444 The underscore prefix, controller letter, and unit number are
3445 independently optional; for our purposes, the colon punctuation
3446 is not. The colon can be trailed by optional directory and/or
3447 filename, but two consecutive colons indicates a nodename rather
3448 than a device. [pr] */
3449 if (*name == '_') ++name;
3450 if (tolower(*name++) != 'n') return 0;
3451 if (tolower(*name++) != 'l') return 0;
3452 if (tolower(*name) == 'a') ++name;
3453 if (*name == '0') ++name;
3454 return (*name++ == ':') && (*name != ':');
3457 /* Do the permissions allow some operation? Assumes statcache already set. */
3458 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3459 * subset of the applicable information.
3461 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3463 cando(I32 bit, I32 effective, struct stat *statbufp)
3465 if (statbufp == &statcache)
3466 return cando_by_name(bit,effective,namecache);
3468 char fname[NAM$C_MAXRSS+1];
3469 unsigned long int retsts;
3470 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3471 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3473 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3474 device name on successive calls */
3475 devdsc.dsc$a_pointer = statbufp->st_devnam;
3476 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3477 namdsc.dsc$a_pointer = fname;
3478 namdsc.dsc$w_length = sizeof fname - 1;
3480 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3481 &namdsc.dsc$w_length,0,0);
3483 fname[namdsc.dsc$w_length] = '\0';
3484 return cando_by_name(bit,effective,fname);
3486 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3487 warn("Can't get filespec - stale stat buffer?\n");
3491 return FALSE; /* Should never get to here */
3493 } /* end of cando() */
3497 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3499 cando_by_name(I32 bit, I32 effective, char *fname)
3501 static char usrname[L_cuserid];
3502 static struct dsc$descriptor_s usrdsc =
3503 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3504 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3505 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3506 unsigned short int retlen;
3507 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3508 union prvdef curprv;
3509 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3510 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3511 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3514 if (!fname || !*fname) return FALSE;
3515 /* Make sure we expand logical names, since sys$check_access doesn't */
3516 if (!strpbrk(fname,"/]>:")) {
3517 strcpy(fileified,fname);
3518 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3521 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3522 retlen = namdsc.dsc$w_length = strlen(vmsname);
3523 namdsc.dsc$a_pointer = vmsname;
3524 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3525 vmsname[retlen-1] == ':') {
3526 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3527 namdsc.dsc$w_length = strlen(fileified);
3528 namdsc.dsc$a_pointer = fileified;
3531 if (!usrdsc.dsc$w_length) {
3533 usrdsc.dsc$w_length = strlen(usrname);
3540 access = ARM$M_EXECUTE;
3545 access = ARM$M_READ;
3550 access = ARM$M_WRITE;
3555 access = ARM$M_DELETE;
3561 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3562 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3563 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3564 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3565 set_vaxc_errno(retsts);
3566 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3567 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3568 else set_errno(ENOENT);
3571 if (retsts == SS$_NORMAL) {
3572 if (!privused) return TRUE;
3573 /* We can get access, but only by using privs. Do we have the
3574 necessary privs currently enabled? */
3575 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3576 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3577 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3578 !curprv.prv$v_bypass) return FALSE;
3579 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3580 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3581 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3586 return FALSE; /* Should never get here */
3588 } /* end of cando_by_name() */
3592 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3595 flex_fstat(int fd, struct mystat *statbufp)
3597 if (!fstat(fd,(stat_t *) statbufp)) {
3598 if (statbufp == &statcache) *namecache == '\0';
3599 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3601 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3605 if (!gmtime_emulation_type) (void)time(NULL);
3606 statbufp->st_mtime -= utc_offset_secs;
3607 statbufp->st_atime -= utc_offset_secs;
3608 statbufp->st_ctime -= utc_offset_secs;
3614 } /* end of flex_fstat() */
3617 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3618 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3619 * 'struct stat' elsewhere in Perl would use our struct. We go back
3620 * to the system version here, since we're actually calling their
3624 flex_stat(char *fspec, struct mystat *statbufp)
3626 char fileified[NAM$C_MAXRSS+1];
3629 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3630 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3631 memset(statbufp,0,sizeof *statbufp);
3632 statbufp->st_dev = encode_dev("_NLA0:");
3633 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3634 statbufp->st_uid = 0x00010001;
3635 statbufp->st_gid = 0x0001;
3636 time((time_t *)&statbufp->st_mtime);
3637 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3641 /* Try for a directory name first. If fspec contains a filename without
3642 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3643 * and sea:[wine.dark]water. exist, we prefer the directory here.
3644 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3645 * not sea:[wine.dark]., if the latter exists. If the intended target is
3646 * the file with null type, specify this by calling flex_stat() with
3647 * a '.' at the end of fspec.
3649 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3650 retval = stat(fileified,(stat_t *) statbufp);
3651 if (!retval && statbufp == &statcache) strcpy(namecache,fileified);
3653 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3655 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3657 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3661 if (!gmtime_emulation_type) (void)time(NULL);
3662 statbufp->st_mtime -= utc_offset_secs;
3663 statbufp->st_atime -= utc_offset_secs;
3664 statbufp->st_ctime -= utc_offset_secs;
3669 } /* end of flex_stat() */
3670 /* Reset definition for later calls */
3674 /* Insures that no carriage-control translation will be done on a file. */
3675 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3677 my_binmode(FILE *fp, char iotype)
3679 char filespec[NAM$C_MAXRSS], *acmode;
3682 if (!fgetname(fp,filespec)) return NULL;
3683 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3685 case '<': case 'r': acmode = "rb"; break;
3687 /* use 'a' instead of 'w' to avoid creating new file;
3688 fsetpos below will take care of restoring file position */
3689 case 'a': acmode = "ab"; break;
3690 case '+': case '|': case 's': acmode = "rb+"; break;
3691 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3693 warn("Unrecognized iotype %c in my_binmode",iotype);
3696 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3697 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3699 } /* end of my_binmode() */
3703 /*{{{char *my_getlogin()*/
3704 /* VMS cuserid == Unix getlogin, except calling sequence */
3708 static char user[L_cuserid];
3709 return cuserid(user);
3714 /* rmscopy - copy a file using VMS RMS routines
3716 * Copies contents and attributes of spec_in to spec_out, except owner
3717 * and protection information. Name and type of spec_in are used as
3718 * defaults for spec_out. The third parameter specifies whether rmscopy()
3719 * should try to propagate timestamps from the input file to the output file.
3720 * If it is less than 0, no timestamps are preserved. If it is 0, then
3721 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3722 * propagated to the output file at creation iff the output file specification
3723 * did not contain an explicit name or type, and the revision date is always
3724 * updated at the end of the copy operation. If it is greater than 0, then
3725 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3726 * other than the revision date should be propagated, and bit 1 indicates
3727 * that the revision date should be propagated.
3729 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3731 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3732 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3733 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3734 * as part of the Perl standard distribution under the terms of the
3735 * GNU General Public License or the Perl Artistic License. Copies
3736 * of each may be found in the Perl standard distribution.
3738 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3740 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3742 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3743 rsa[NAM$C_MAXRSS], ubf[32256];
3744 unsigned long int i, sts, sts2;
3745 struct FAB fab_in, fab_out;
3746 struct RAB rab_in, rab_out;
3748 struct XABDAT xabdat;
3749 struct XABFHC xabfhc;
3750 struct XABRDT xabrdt;
3751 struct XABSUM xabsum;
3753 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3754 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3755 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3759 fab_in = cc$rms_fab;
3760 fab_in.fab$l_fna = vmsin;
3761 fab_in.fab$b_fns = strlen(vmsin);
3762 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3763 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3764 fab_in.fab$l_fop = FAB$M_SQO;
3765 fab_in.fab$l_nam = &nam;
3766 fab_in.fab$l_xab = (void *) &xabdat;
3769 nam.nam$l_rsa = rsa;
3770 nam.nam$b_rss = sizeof(rsa);
3771 nam.nam$l_esa = esa;
3772 nam.nam$b_ess = sizeof (esa);
3773 nam.nam$b_esl = nam.nam$b_rsl = 0;
3775 xabdat = cc$rms_xabdat; /* To get creation date */
3776 xabdat.xab$l_nxt = (void *) &xabfhc;
3778 xabfhc = cc$rms_xabfhc; /* To get record length */
3779 xabfhc.xab$l_nxt = (void *) &xabsum;
3781 xabsum = cc$rms_xabsum; /* To get key and area information */
3783 if (!((sts = sys$open(&fab_in)) & 1)) {
3784 set_vaxc_errno(sts);
3788 set_errno(ENOENT); break;
3790 set_errno(ENODEV); break;
3792 set_errno(EINVAL); break;
3794 set_errno(EACCES); break;
3802 fab_out.fab$w_ifi = 0;
3803 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3804 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3805 fab_out.fab$l_fop = FAB$M_SQO;
3806 fab_out.fab$l_fna = vmsout;
3807 fab_out.fab$b_fns = strlen(vmsout);
3808 fab_out.fab$l_dna = nam.nam$l_name;
3809 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3811 if (preserve_dates == 0) { /* Act like DCL COPY */
3812 nam.nam$b_nop = NAM$M_SYNCHK;
3813 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3814 if (!((sts = sys$parse(&fab_out)) & 1)) {
3815 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3816 set_vaxc_errno(sts);
3819 fab_out.fab$l_xab = (void *) &xabdat;
3820 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3822 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3823 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3824 preserve_dates =0; /* bitmask from this point forward */
3826 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3827 if (!((sts = sys$create(&fab_out)) & 1)) {
3828 set_vaxc_errno(sts);
3831 set_errno(ENOENT); break;
3833 set_errno(ENODEV); break;
3835 set_errno(EINVAL); break;
3837 set_errno(EACCES); break;
3843 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3844 if (preserve_dates & 2) {
3845 /* sys$close() will process xabrdt, not xabdat */
3846 xabrdt = cc$rms_xabrdt;
3848 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3850 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3851 * is unsigned long[2], while DECC & VAXC use a struct */
3852 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3854 fab_out.fab$l_xab = (void *) &xabrdt;
3857 rab_in = cc$rms_rab;
3858 rab_in.rab$l_fab = &fab_in;
3859 rab_in.rab$l_rop = RAB$M_BIO;
3860 rab_in.rab$l_ubf = ubf;
3861 rab_in.rab$w_usz = sizeof ubf;
3862 if (!((sts = sys$connect(&rab_in)) & 1)) {
3863 sys$close(&fab_in); sys$close(&fab_out);
3864 set_errno(EVMSERR); set_vaxc_errno(sts);
3868 rab_out = cc$rms_rab;
3869 rab_out.rab$l_fab = &fab_out;
3870 rab_out.rab$l_rbf = ubf;
3871 if (!((sts = sys$connect(&rab_out)) & 1)) {
3872 sys$close(&fab_in); sys$close(&fab_out);
3873 set_errno(EVMSERR); set_vaxc_errno(sts);
3877 while ((sts = sys$read(&rab_in))) { /* always true */
3878 if (sts == RMS$_EOF) break;
3879 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3880 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3881 sys$close(&fab_in); sys$close(&fab_out);
3882 set_errno(EVMSERR); set_vaxc_errno(sts);
3887 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3888 sys$close(&fab_in); sys$close(&fab_out);
3889 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3891 set_errno(EVMSERR); set_vaxc_errno(sts);
3897 } /* end of rmscopy() */
3901 /*** The following glue provides 'hooks' to make some of the routines
3902 * from this file available from Perl. These routines are sufficiently
3903 * basic, and are required sufficiently early in the build process,
3904 * that's it's nice to have them available to miniperl as well as the
3905 * full Perl, so they're set up here instead of in an extension. The
3906 * Perl code which handles importation of these names into a given
3907 * package lives in [.VMS]Filespec.pm in @INC.
3911 rmsexpand_fromperl(CV *cv)
3914 char *fspec, *defspec = NULL, *rslt;
3916 if (!items || items > 2)
3917 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3918 fspec = SvPV(ST(0),na);
3919 if (!fspec || !*fspec) XSRETURN_UNDEF;
3920 if (items == 2) defspec = SvPV(ST(1),na);
3922 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3923 ST(0) = sv_newmortal();
3924 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3929 vmsify_fromperl(CV *cv)
3934 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3935 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3936 ST(0) = sv_newmortal();
3937 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3942 unixify_fromperl(CV *cv)
3947 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3948 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3949 ST(0) = sv_newmortal();
3950 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3955 fileify_fromperl(CV *cv)
3960 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3961 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3962 ST(0) = sv_newmortal();
3963 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3968 pathify_fromperl(CV *cv)
3973 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3974 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3975 ST(0) = sv_newmortal();
3976 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3981 vmspath_fromperl(CV *cv)
3986 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3987 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3988 ST(0) = sv_newmortal();
3989 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3994 unixpath_fromperl(CV *cv)
3999 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4000 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4001 ST(0) = sv_newmortal();
4002 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4007 candelete_fromperl(CV *cv)
4010 char fspec[NAM$C_MAXRSS+1], *fsp;
4014 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4016 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4017 if (SvTYPE(mysv) == SVt_PVGV) {
4018 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4019 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4026 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4027 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4033 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
4038 rmscopy_fromperl(CV *cv)
4041 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4043 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4044 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4045 unsigned long int sts;
4049 if (items < 2 || items > 3)
4050 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4052 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4053 if (SvTYPE(mysv) == SVt_PVGV) {
4054 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4055 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4062 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4063 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4068 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4069 if (SvTYPE(mysv) == SVt_PVGV) {
4070 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4071 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4078 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4079 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4084 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4086 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
4093 char* file = __FILE__;
4095 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4096 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4097 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4098 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4099 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4100 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4101 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4102 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4103 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);