3 * VMS-specific routines for perl5
5 * Last revised: 18-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu
22 #include <lib$routines.h>
39 /* gcc's header files don't #define direct access macros
40 * corresponding to VAXC's variant structs */
42 # define uic$v_format uic$r_uic_form.uic$v_format
43 # define uic$v_group uic$r_uic_form.uic$v_group
44 # define uic$v_member uic$r_uic_form.uic$v_member
45 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
46 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
47 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
48 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
53 unsigned short int buflen;
54 unsigned short int itmcode;
56 unsigned short int *retlen;
60 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
62 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
63 unsigned short int eqvlen;
64 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
65 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
66 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
67 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
68 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
71 if (!eqv) eqv = __my_trnlnm_eqv;
72 lnmlst[1].bufadr = (void *)eqv;
73 lnmdsc.dsc$a_pointer = lnm;
74 lnmdsc.dsc$w_length = strlen(lnm);
75 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
76 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
77 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
79 else if (retsts & 1) {
83 _ckvmssts(retsts); /* Must be an error */
84 return 0; /* Not reached, assuming _ckvmssts() bails out */
86 } /* end of my_trnlnm */
89 * Translate a logical name. Substitute for CRTL getenv() to avoid
90 * memory leak, and to keep my_getenv() and my_setenv() in the same
91 * domain (mostly - my_getenv() need not return a translation from
92 * the process logical name table)
94 * Note: Uses static buffer -- not thread-safe!
96 /*{{{ char *my_getenv(char *lnm)*/
100 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
101 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
102 unsigned long int idx = 0;
104 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
106 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
107 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
108 return __my_getenv_eqv;
111 if ((cp2 = strchr(uplnm,';')) != NULL) {
113 idx = strtoul(cp2+1,NULL,0);
115 if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
116 return __my_getenv_eqv;
119 unsigned long int retsts;
120 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
121 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
122 DSC$K_CLASS_S, __my_getenv_eqv};
123 symdsc.dsc$w_length = cp1 - lnm;
124 symdsc.dsc$a_pointer = uplnm;
125 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
126 if (retsts == LIB$_INVSYMNAM) return Nullch;
127 if (retsts != LIB$_NOSUCHSYM) {
128 /* We want to return only logical names or CRTL Unix emulations */
129 if (retsts & 1) return Nullch;
132 /* Try for CRTL emulation of a Unix/POSIX name */
133 else return getenv(lnm);
138 } /* end of my_getenv() */
141 /*{{{ void my_setenv(char *lnm, char *eqv)*/
143 my_setenv(char *lnm,char *eqv)
144 /* Define a supervisor-mode logical name in the process table.
145 * In the future we'll add tables, attribs, and acmodes,
146 * probably through a different call.
149 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
150 unsigned long int retsts, usermode = PSL$C_USER;
151 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
152 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
153 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
155 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
156 lnmdsc.dsc$w_length = cp1 - lnm;
158 if (!eqv || !*eqv) { /* we're deleting a logical name */
159 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
160 if (retsts == SS$_IVLOGNAM) return;
161 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
163 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
164 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
168 eqvdsc.dsc$w_length = strlen(eqv);
169 eqvdsc.dsc$a_pointer = eqv;
171 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
174 } /* end of my_setenv() */
178 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
179 /* my_crypt - VMS password hashing
180 * my_crypt() provides an interface compatible with the Unix crypt()
181 * C library function, and uses sys$hash_password() to perform VMS
182 * password hashing. The quadword hashed password value is returned
183 * as a NUL-terminated 8 character string. my_crypt() does not change
184 * the case of its string arguments; in order to match the behavior
185 * of LOGINOUT et al., alphabetic characters in both arguments must
186 * be upcased by the caller.
189 my_crypt(const char *textpasswd, const char *usrname)
191 # ifndef UAI$C_PREFERRED_ALGORITHM
192 # define UAI$C_PREFERRED_ALGORITHM 127
194 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
195 unsigned short int salt = 0;
196 unsigned long int sts;
198 unsigned short int dsc$w_length;
199 unsigned char dsc$b_type;
200 unsigned char dsc$b_class;
201 const char * dsc$a_pointer;
202 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
203 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
204 struct itmlst_3 uailst[3] = {
205 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
206 { sizeof salt, UAI$_SALT, &salt, 0},
207 { 0, 0, NULL, NULL}};
210 usrdsc.dsc$w_length = strlen(usrname);
211 usrdsc.dsc$a_pointer = usrname;
212 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
219 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
225 if (sts != RMS$_RNF) return NULL;
228 txtdsc.dsc$w_length = strlen(textpasswd);
229 txtdsc.dsc$a_pointer = textpasswd;
230 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
231 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
234 return (char *) hash;
236 } /* end of my_crypt() */
240 static char *do_fileify_dirspec(char *, char *, int);
241 static char *do_tovmsspec(char *, char *, int);
243 /*{{{int do_rmdir(char *name)*/
247 char dirfile[NAM$C_MAXRSS+1];
251 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
252 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
253 else retval = kill_file(dirfile);
256 } /* end of do_rmdir */
260 * Delete any file to which user has control access, regardless of whether
261 * delete access is explicitly allowed.
262 * Limitations: User must have write access to parent directory.
263 * Does not block signals or ASTs; if interrupted in midstream
264 * may leave file with an altered ACL.
267 /*{{{int kill_file(char *name)*/
269 kill_file(char *name)
271 char vmsname[NAM$C_MAXRSS+1];
272 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
273 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
274 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
276 unsigned char myace$b_length;
277 unsigned char myace$b_type;
278 unsigned short int myace$w_flags;
279 unsigned long int myace$l_access;
280 unsigned long int myace$l_ident;
281 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
282 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
283 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
285 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
286 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
287 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
288 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
289 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
290 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
292 if (!remove(name)) return 0; /* Can we just get rid of it? */
294 /* No, so we get our own UIC to use as a rights identifier,
295 * and the insert an ACE at the head of the ACL which allows us
296 * to delete the file.
298 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
299 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
300 fildsc.dsc$w_length = strlen(vmsname);
301 fildsc.dsc$a_pointer = vmsname;
303 newace.myace$l_ident = oldace.myace$l_ident;
304 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
306 set_vaxc_errno(aclsts);
309 /* Grab any existing ACEs with this identifier in case we fail */
310 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
311 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
312 || fndsts == SS$_NOMOREACE ) {
313 /* Add the new ACE . . . */
314 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
316 if ((rmsts = remove(name))) {
317 /* We blew it - dir with files in it, no write priv for
318 * parent directory, etc. Put things back the way they were. */
319 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
322 addlst[0].bufadr = &oldace;
323 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
331 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
332 if (aclsts & 1) aclsts = fndsts;
336 set_vaxc_errno(aclsts);
342 } /* end of kill_file() */
345 /* my_utime - update modification time of a file
346 * calling sequence is identical to POSIX utime(), but under
347 * VMS only the modification time is changed; ODS-2 does not
348 * maintain access times. Restrictions differ from the POSIX
349 * definition in that the time can be changed as long as the
350 * caller has permission to execute the necessary IO$_MODIFY $QIO;
351 * no separate checks are made to insure that the caller is the
352 * owner of the file or has special privs enabled.
353 * Code here is based on Joe Meadows' FILE utility.
356 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
357 * to VMS epoch (01-JAN-1858 00:00:00.00)
358 * in 100 ns intervals.
360 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
362 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
363 int my_utime(char *file, struct utimbuf *utimes)
366 long int bintime[2], len = 2, lowbit, unixtime,
367 secscale = 10000000; /* seconds --> 100 ns intervals */
368 unsigned long int chan, iosb[2], retsts;
369 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
370 struct FAB myfab = cc$rms_fab;
371 struct NAM mynam = cc$rms_nam;
372 #if defined (__DECC) && defined (__VAX)
373 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
374 * at least through VMS V6.1, which causes a type-conversion warning.
376 # pragma message save
377 # pragma message disable cvtdiftypes
379 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
381 #if defined (__DECC) && defined (__VAX)
382 /* This should be right after the declaration of myatr, but due
383 * to a bug in VAX DEC C, this takes effect a statement early.
385 # pragma message restore
387 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
388 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
389 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
391 if (file == NULL || *file == '\0') {
393 set_vaxc_errno(LIB$_INVARG);
396 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
398 if (utimes != NULL) {
399 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
400 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
401 * Since time_t is unsigned long int, and lib$emul takes a signed long int
402 * as input, we force the sign bit to be clear by shifting unixtime right
403 * one bit, then multiplying by an extra factor of 2 in lib$emul().
405 lowbit = (utimes->modtime & 1) ? secscale : 0;
406 unixtime = (long int) utimes->modtime;
407 unixtime >> 1; secscale << 1;
408 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
411 set_vaxc_errno(retsts);
414 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
417 set_vaxc_errno(retsts);
422 /* Just get the current time in VMS format directly */
423 retsts = sys$gettim(bintime);
426 set_vaxc_errno(retsts);
431 myfab.fab$l_fna = vmsspec;
432 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
433 myfab.fab$l_nam = &mynam;
434 mynam.nam$l_esa = esa;
435 mynam.nam$b_ess = (unsigned char) sizeof esa;
436 mynam.nam$l_rsa = rsa;
437 mynam.nam$b_rss = (unsigned char) sizeof rsa;
439 /* Look for the file to be affected, letting RMS parse the file
440 * specification for us as well. I have set errno using only
441 * values documented in the utime() man page for VMS POSIX.
443 retsts = sys$parse(&myfab,0,0);
445 set_vaxc_errno(retsts);
446 if (retsts == RMS$_PRV) set_errno(EACCES);
447 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
448 else set_errno(EVMSERR);
451 retsts = sys$search(&myfab,0,0);
453 set_vaxc_errno(retsts);
454 if (retsts == RMS$_PRV) set_errno(EACCES);
455 else if (retsts == RMS$_FNF) set_errno(ENOENT);
456 else set_errno(EVMSERR);
460 devdsc.dsc$w_length = mynam.nam$b_dev;
461 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
463 retsts = sys$assign(&devdsc,&chan,0,0);
465 set_vaxc_errno(retsts);
466 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
467 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
468 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
469 else set_errno(EVMSERR);
473 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
474 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
476 memset((void *) &myfib, 0, sizeof myfib);
478 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
479 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
480 /* This prevents the revision time of the file being reset to the current
481 * time as a reqult of our IO$_MODIFY $QIO. */
482 myfib.fib$l_acctl = FIB$M_NORECORD;
484 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
485 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
486 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
488 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
489 if (retsts & 1) retsts = iosb[0];
491 set_vaxc_errno(retsts);
492 if (retsts == SS$_NOPRIV) set_errno(EACCES);
493 else set_errno(EVMSERR);
498 } /* end of my_utime() */
502 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
504 static unsigned long int mbxbufsiz;
505 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
509 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
510 * preprocessor consant BUFSIZ from stdio.h as the size of the
513 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
514 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
516 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
518 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
519 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
521 } /* end of create_mbx() */
523 /*{{{ my_popen and my_pclose*/
526 struct pipe_details *next;
527 FILE *fp; /* stdio file pointer to pipe mailbox */
528 int pid; /* PID of subprocess */
529 int mode; /* == 'r' if pipe open for reading */
530 int done; /* subprocess has completed */
531 unsigned long int completion; /* termination status of subprocess */
534 struct exit_control_block
536 struct exit_control_block *flink;
537 unsigned long int (*exit_routine)();
538 unsigned long int arg_count;
539 unsigned long int *status_address;
540 unsigned long int exit_status;
543 static struct pipe_details *open_pipes = NULL;
544 static $DESCRIPTOR(nl_desc, "NL:");
545 static int waitpid_asleep = 0;
547 static unsigned long int
550 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
552 while (open_pipes != NULL) {
553 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
554 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
557 if (!open_pipes->done) /* We tried to be nice . . . */
558 _ckvmssts(sys$delprc(&open_pipes->pid,0));
559 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
564 static struct exit_control_block pipe_exitblock =
565 {(struct exit_control_block *) 0,
566 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
570 popen_completion_ast(struct pipe_details *thispipe)
572 thispipe->done = TRUE;
573 if (waitpid_asleep) {
579 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
581 my_popen(char *cmd, char *mode)
583 static int handler_set_up = FALSE;
585 unsigned short int chan;
586 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
587 struct pipe_details *info;
588 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
589 DSC$K_CLASS_S, mbxname},
590 cmddsc = {0, DSC$K_DTYPE_T,
594 New(7001,info,1,struct pipe_details);
597 create_mbx(&chan,&namdsc);
599 /* open a FILE* onto it */
600 info->fp=fopen(mbxname, mode);
602 /* give up other channel onto it */
603 _ckvmssts(sys$dassgn(chan));
608 cmddsc.dsc$w_length=strlen(cmd);
609 cmddsc.dsc$a_pointer=cmd;
616 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
617 0 /* name */, &info->pid, &info->completion,
618 0, popen_completion_ast,info,0,0,0));
621 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
622 0 /* name */, &info->pid, &info->completion,
623 0, popen_completion_ast,info,0,0,0));
626 if (!handler_set_up) {
627 _ckvmssts(sys$dclexh(&pipe_exitblock));
628 handler_set_up = TRUE;
630 info->next=open_pipes; /* prepend to list */
633 forkprocess = info->pid;
638 /*{{{ I32 my_pclose(FILE *fp)*/
639 I32 my_pclose(FILE *fp)
641 struct pipe_details *info, *last = NULL;
642 unsigned long int retsts;
644 for (info = open_pipes; info != NULL; last = info, info = info->next)
645 if (info->fp == fp) break;
648 /* get here => no such pipe open */
649 croak("No such pipe open");
653 if (info->done) retsts = info->completion;
654 else waitpid(info->pid,(int *) &retsts,0);
656 /* remove from list of open pipes */
657 if (last) last->next = info->next;
658 else open_pipes = info->next;
663 } /* end of my_pclose() */
665 /* sort-of waitpid; use only with popen() */
666 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
668 waitpid(unsigned long int pid, int *statusp, int flags)
670 struct pipe_details *info;
672 for (info = open_pipes; info != NULL; info = info->next)
673 if (info->pid == pid) break;
675 if (info != NULL) { /* we know about this child */
676 while (!info->done) {
681 *statusp = info->completion;
684 else { /* we haven't heard of this child */
685 $DESCRIPTOR(intdsc,"0 00:00:01");
686 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
687 unsigned long int interval[2],sts;
690 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
691 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
692 if (ownerpid != mypid)
693 warn("pid %d not a child",pid);
696 _ckvmssts(sys$bintim(&intdsc,interval));
697 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
698 _ckvmssts(sys$schdwk(0,0,interval,0));
699 _ckvmssts(sys$hiber());
703 /* There's no easy way to find the termination status a child we're
704 * not aware of beforehand. If we're really interested in the future,
705 * we can go looking for a termination mailbox, or chase after the
706 * accounting record for the process.
712 } /* end of waitpid() */
717 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
719 my_gconvert(double val, int ndig, int trail, char *buf)
721 static char __gcvtbuf[DBL_DIG+1];
724 loc = buf ? buf : __gcvtbuf;
726 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
727 return gcvt(val,ndig,loc);
730 loc[0] = '0'; loc[1] = '\0';
738 ** The following routines are provided to make life easier when
739 ** converting among VMS-style and Unix-style directory specifications.
740 ** All will take input specifications in either VMS or Unix syntax. On
741 ** failure, all return NULL. If successful, the routines listed below
742 ** return a pointer to a buffer containing the appropriately
743 ** reformatted spec (and, therefore, subsequent calls to that routine
744 ** will clobber the result), while the routines of the same names with
745 ** a _ts suffix appended will return a pointer to a mallocd string
746 ** containing the appropriately reformatted spec.
747 ** In all cases, only explicit syntax is altered; no check is made that
748 ** the resulting string is valid or that the directory in question
751 ** fileify_dirspec() - convert a directory spec into the name of the
752 ** directory file (i.e. what you can stat() to see if it's a dir).
753 ** The style (VMS or Unix) of the result is the same as the style
754 ** of the parameter passed in.
755 ** pathify_dirspec() - convert a directory spec into a path (i.e.
756 ** what you prepend to a filename to indicate what directory it's in).
757 ** The style (VMS or Unix) of the result is the same as the style
758 ** of the parameter passed in.
759 ** tounixpath() - convert a directory spec into a Unix-style path.
760 ** tovmspath() - convert a directory spec into a VMS-style path.
761 ** tounixspec() - convert any file spec into a Unix-style file spec.
762 ** tovmsspec() - convert any file spec into a VMS-style spec.
764 ** Copyright 1995 by Charles Bailey <bailey@genetics.upenn.edu>
765 ** Permission is given for non-commercial use of this code according
766 ** to the terms of the GNU General Public License or the Perl
767 ** Artistic License. Copies of each may be found in the Perl
768 ** standard distribution. This software is supplied without any
769 ** warranty whatsoever.
772 static char *do_tounixspec(char *, char *, int);
774 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
775 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
777 static char __fileify_retbuf[NAM$C_MAXRSS+1];
778 unsigned long int dirlen, retlen, addmfd = 0;
779 char *retspec, *cp1, *cp2, *lastdir;
780 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
783 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
785 dirlen = strlen(dir);
786 if (dir[dirlen-1] == '/') dir[--dirlen] = '\0';
789 set_vaxc_errno(RMS$_DIR);
792 if (!strpbrk(dir+1,"/]>:")) {
793 strcpy(trndir,*dir == '/' ? dir + 1: dir);
794 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
796 dirlen = strlen(dir);
798 /* If we were handed a rooted logical name or spec, treat it like a
799 * simple directory, so that
800 * $ Define myroot dev:[dir.]
801 * ... do_fileify_dirspec("myroot",buf,1) ...
802 * does something useful.
804 if (!strcmp(dir+dirlen-2,".]")) {
805 dir[--dirlen] = '\0';
809 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
811 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
812 return do_fileify_dirspec("[]",buf,ts);
813 else if (dir[1] == '.' &&
814 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
815 return do_fileify_dirspec("[-]",buf,ts);
817 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
818 dirlen -= 1; /* to last element */
819 lastdir = strrchr(dir,'/');
821 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
823 if (*(cp1+2) == '.') cp1++;
824 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
829 } while ((cp1 = strstr(cp1,"/.")) != NULL);
830 /* If we have a relative path, VMSify it and let the VMS code
831 * below expand it, rather than repeating the code here */
833 if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
834 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
835 return do_tounixspec(trndir,buf,ts);
839 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
840 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
841 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
842 toupper(*(cp2+2)) == 'I' &&
843 toupper(*(cp2+3)) == 'R') {
844 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
845 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
846 set_errno(ENOTDIR); /* Bzzt. */
847 set_vaxc_errno(RMS$_DIR);
853 else { /* There's a type, and it's not .dir. Bzzt. */
855 set_vaxc_errno(RMS$_DIR);
860 /* If we lead off with a device or rooted logical, add the MFD
861 if we're specifying a top-level directory. */
862 if (lastdir && *dir == '/') {
864 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
871 retlen = dirlen + (addmfd ? 13 : 6);
872 if (buf) retspec = buf;
873 else if (ts) New(7009,retspec,retlen+1,char);
874 else retspec = __fileify_retbuf;
876 dirlen = lastdir - dir;
877 memcpy(retspec,dir,dirlen);
878 strcpy(&retspec[dirlen],"/000000");
879 strcpy(&retspec[dirlen+7],lastdir);
882 memcpy(retspec,dir,dirlen);
883 retspec[dirlen] = '\0';
885 /* We've picked up everything up to the directory file name.
886 Now just add the type and version, and we're set. */
887 strcat(retspec,".dir;1");
890 else { /* VMS-style directory spec */
891 char esa[NAM$C_MAXRSS+1], term;
892 unsigned long int sts, cmplen, hasdev, hasdir, hastype, hasver;
893 struct FAB dirfab = cc$rms_fab;
894 struct NAM savnam, dirnam = cc$rms_nam;
896 dirfab.fab$b_fns = strlen(dir);
897 dirfab.fab$l_fna = dir;
898 dirfab.fab$l_nam = &dirnam;
899 dirfab.fab$l_dna = ".DIR;1";
900 dirfab.fab$b_dns = 6;
901 dirnam.nam$b_ess = NAM$C_MAXRSS;
902 dirnam.nam$l_esa = esa;
903 if (!((sts = sys$parse(&dirfab))&1)) {
904 if (dirfab.fab$l_sts == RMS$_DIR) {
905 dirnam.nam$b_nop |= NAM$M_SYNCHK;
906 sts = sys$parse(&dirfab) & 1;
910 set_vaxc_errno(dirfab.fab$l_sts);
916 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
917 /* Yes; fake the fnb bits so we'll check type below */
918 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
921 if (dirfab.fab$l_sts != RMS$_FNF) {
923 set_vaxc_errno(dirfab.fab$l_sts);
926 dirnam = savnam; /* No; just work with potential name */
929 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
930 cp1 = strchr(esa,']');
931 if (!cp1) cp1 = strchr(esa,'>');
932 if (cp1) { /* Should always be true */
933 dirnam.nam$b_esl -= cp1 - esa - 1;
934 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
937 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
938 /* Yep; check version while we're at it, if it's there. */
939 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
940 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
941 /* Something other than .DIR[;1]. Bzzt. */
943 set_vaxc_errno(RMS$_DIR);
947 esa[dirnam.nam$b_esl] = '\0';
948 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
949 /* They provided at least the name; we added the type, if necessary, */
950 if (buf) retspec = buf; /* in sys$parse() */
951 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
952 else retspec = __fileify_retbuf;
956 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
957 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
959 dirnam.nam$b_esl -= 9;
961 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
962 if (cp1 == NULL) return NULL; /* should never happen */
965 retlen = strlen(esa);
966 if ((cp1 = strrchr(esa,'.')) != NULL) {
967 /* There's more than one directory in the path. Just roll back. */
969 if (buf) retspec = buf;
970 else if (ts) New(7011,retspec,retlen+7,char);
971 else retspec = __fileify_retbuf;
975 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
976 /* Go back and expand rooted logical name */
977 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
978 if (!(sys$parse(&dirfab) & 1)) {
980 set_vaxc_errno(dirfab.fab$l_sts);
983 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
984 if (buf) retspec = buf;
985 else if (ts) New(7012,retspec,retlen+16,char);
986 else retspec = __fileify_retbuf;
987 cp1 = strstr(esa,"][");
989 memcpy(retspec,esa,dirlen);
990 if (!strncmp(cp1+2,"000000]",7)) {
991 retspec[dirlen-1] = '\0';
992 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
993 if (*cp1 == '.') *cp1 = ']';
995 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
996 memcpy(cp1+1,"000000]",7);
1000 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1001 retspec[retlen] = '\0';
1002 /* Convert last '.' to ']' */
1003 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1004 if (*cp1 == '.') *cp1 = ']';
1006 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1007 memcpy(cp1+1,"000000]",7);
1011 else { /* This is a top-level dir. Add the MFD to the path. */
1012 if (buf) retspec = buf;
1013 else if (ts) New(7012,retspec,retlen+16,char);
1014 else retspec = __fileify_retbuf;
1017 while (*cp1 != ':') *(cp2++) = *(cp1++);
1018 strcpy(cp2,":[000000]");
1023 /* We've set up the string up through the filename. Add the
1024 type and version, and we're done. */
1025 strcat(retspec,".DIR;1");
1028 } /* end of do_fileify_dirspec() */
1030 /* External entry points */
1031 char *fileify_dirspec(char *dir, char *buf)
1032 { return do_fileify_dirspec(dir,buf,0); }
1033 char *fileify_dirspec_ts(char *dir, char *buf)
1034 { return do_fileify_dirspec(dir,buf,1); }
1036 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1037 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1039 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1040 unsigned long int retlen;
1041 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1043 if (!dir || !*dir) {
1044 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1047 if (*dir) strcpy(trndir,dir);
1048 else getcwd(trndir,sizeof trndir - 1);
1050 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1051 STRLEN trnlen = strlen(trndir);
1053 /* Trap simple rooted lnms, and return lnm:[000000] */
1054 if (!strcmp(trndir+trnlen-2,".]")) {
1055 if (buf) retpath = buf;
1056 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1057 else retpath = __pathify_retbuf;
1058 strcpy(retpath,dir);
1059 strcat(retpath,":[000000]");
1065 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
1066 if (*dir == '.' && (*(dir+1) == '\0' ||
1067 (*(dir+1) == '.' && *(dir+2) == '\0')))
1068 retlen = 2 + (*(dir+1) != '\0');
1070 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
1071 if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
1072 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
1073 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
1074 toupper(*(cp2+3)) == 'R') {
1075 retlen = cp2 - dir + 1;
1077 else { /* Some other file type. Bzzt. */
1079 set_vaxc_errno(RMS$_DIR);
1083 else { /* No file type present. Treat the filename as a directory. */
1084 retlen = strlen(dir) + 1;
1087 if (buf) retpath = buf;
1088 else if (ts) New(7013,retpath,retlen+1,char);
1089 else retpath = __pathify_retbuf;
1090 strncpy(retpath,dir,retlen-1);
1091 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1092 retpath[retlen-1] = '/'; /* with '/', add it. */
1093 retpath[retlen] = '\0';
1095 else retpath[retlen-1] = '\0';
1097 else { /* VMS-style directory spec */
1098 char esa[NAM$C_MAXRSS+1];
1099 unsigned long int sts, cmplen;
1100 struct FAB dirfab = cc$rms_fab;
1101 struct NAM savnam, dirnam = cc$rms_nam;
1103 dirfab.fab$b_fns = strlen(dir);
1104 dirfab.fab$l_fna = dir;
1105 if (dir[dirfab.fab$b_fns-1] == ']' ||
1106 dir[dirfab.fab$b_fns-1] == '>' ||
1107 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1108 if (buf) retpath = buf;
1109 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1110 else retpath = __pathify_retbuf;
1111 strcpy(retpath,dir);
1114 dirfab.fab$l_dna = ".DIR;1";
1115 dirfab.fab$b_dns = 6;
1116 dirfab.fab$l_nam = &dirnam;
1117 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1118 dirnam.nam$l_esa = esa;
1119 if (!((sts = sys$parse(&dirfab))&1)) {
1120 if (dirfab.fab$l_sts == RMS$_DIR) {
1121 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1122 sts = sys$parse(&dirfab) & 1;
1126 set_vaxc_errno(dirfab.fab$l_sts);
1132 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1133 if (dirfab.fab$l_sts != RMS$_FNF) {
1135 set_vaxc_errno(dirfab.fab$l_sts);
1138 dirnam = savnam; /* No; just work with potential name */
1141 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1142 /* Yep; check version while we're at it, if it's there. */
1143 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1144 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1145 /* Something other than .DIR[;1]. Bzzt. */
1147 set_vaxc_errno(RMS$_DIR);
1151 /* OK, the type was fine. Now pull any file name into the
1153 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1155 cp1 = strrchr(esa,'>');
1156 *dirnam.nam$l_type = '>';
1159 *(dirnam.nam$l_type + 1) = '\0';
1160 retlen = dirnam.nam$l_type - esa + 2;
1161 if (buf) retpath = buf;
1162 else if (ts) New(7014,retpath,retlen,char);
1163 else retpath = __pathify_retbuf;
1164 strcpy(retpath,esa);
1168 } /* end of do_pathify_dirspec() */
1170 /* External entry points */
1171 char *pathify_dirspec(char *dir, char *buf)
1172 { return do_pathify_dirspec(dir,buf,0); }
1173 char *pathify_dirspec_ts(char *dir, char *buf)
1174 { return do_pathify_dirspec(dir,buf,1); }
1176 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1177 static char *do_tounixspec(char *spec, char *buf, int ts)
1179 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1180 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1181 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1183 if (spec == NULL) return NULL;
1184 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1185 if (buf) rslt = buf;
1187 retlen = strlen(spec);
1188 cp1 = strchr(spec,'[');
1189 if (!cp1) cp1 = strchr(spec,'<');
1191 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1193 New(7015,rslt,retlen+2+2*dashes,char);
1195 else rslt = __tounixspec_retbuf;
1196 if (strchr(spec,'/') != NULL) {
1203 dirend = strrchr(spec,']');
1204 if (dirend == NULL) dirend = strrchr(spec,'>');
1205 if (dirend == NULL) dirend = strchr(spec,':');
1206 if (dirend == NULL) {
1210 if (*cp2 != '[' && *cp2 != '<') {
1213 else { /* the VMS spec begins with directories */
1215 if (*cp2 == ']' || *cp2 == '>') {
1219 else if (*cp2 == '-') {
1220 while (*cp2 == '-') {
1221 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1224 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1225 if (ts) Safefree(rslt); /* filespecs like */
1226 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1231 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1233 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1234 if (ts) Safefree(rslt);
1239 while (*cp3 != ':' && *cp3) cp3++;
1241 if (strchr(cp3,']') != NULL) break;
1242 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1244 while (*cp3) *(cp1++) = *(cp3++);
1247 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1248 int offset = cp1 - rslt;
1250 retlen = devlen + dirlen;
1251 Renew(rslt,retlen+1+2*dashes,char);
1252 cp1 = rslt + offset;
1257 for (; cp2 <= dirend; cp2++) {
1260 if (*(cp2+1) == '[') cp2++;
1262 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1263 else if (*cp2 == '.') {
1265 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1266 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1267 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1268 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1269 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1272 else if (*cp2 == '-') {
1273 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1274 while (*cp2 == '-') {
1276 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1278 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1279 if (ts) Safefree(rslt); /* filespecs like */
1280 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1285 else *(cp1++) = *cp2;
1287 else *(cp1++) = *cp2;
1289 while (*cp2) *(cp1++) = *(cp2++);
1294 } /* end of do_tounixspec() */
1296 /* External entry points */
1297 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1298 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1300 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1301 static char *do_tovmsspec(char *path, char *buf, int ts) {
1302 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1303 char *rslt, *dirend;
1304 register char *cp1, *cp2;
1305 unsigned long int infront = 0, hasdir = 1;
1307 if (path == NULL) return NULL;
1308 if (buf) rslt = buf;
1309 else if (ts) New(7016,rslt,strlen(path)+9,char);
1310 else rslt = __tovmsspec_retbuf;
1311 if (strpbrk(path,"]:>") ||
1312 (dirend = strrchr(path,'/')) == NULL) {
1313 if (path[0] == '.') {
1314 if (path[1] == '\0') strcpy(rslt,"[]");
1315 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1316 else strcpy(rslt,path); /* probably garbage */
1318 else strcpy(rslt,path);
1321 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1322 if (!*(dirend+2)) dirend +=2;
1323 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1328 char trndev[NAM$C_MAXRSS+1];
1332 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1334 islnm = my_trnlnm(rslt,trndev,0);
1335 trnend = islnm ? strlen(trndev) - 1 : 0;
1336 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1337 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1338 /* If the first element of the path is a logical name, determine
1339 * whether it has to be translated so we can add more directories. */
1340 if (!islnm || rooted) {
1343 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1347 if (cp2 != dirend) {
1348 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1349 strcpy(rslt,trndev);
1350 cp1 = rslt + trnend;
1363 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1364 cp2 += 2; /* skip over "./" - it's redundant */
1365 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1367 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1368 *(cp1++) = '-'; /* "../" --> "-" */
1371 if (cp2 > dirend) cp2 = dirend;
1373 else *(cp1++) = '.';
1375 for (; cp2 < dirend; cp2++) {
1377 if (*(cp1-1) != '.') *(cp1++) = '.';
1380 else if (!infront && *cp2 == '.') {
1381 if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1382 else if (*(cp2+1) == '\0') { cp2++; break; }
1383 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1384 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1385 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1386 else { /* back up over previous directory name */
1388 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1389 if (*(cp1-1) == '[') {
1390 memcpy(cp1,"000000.",7);
1395 if (cp2 == dirend) {
1396 if (*(cp1-1) == '.') cp1--;
1400 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1403 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1404 if (*cp2 == '/') *(cp1++) = '.';
1405 else if (*cp2 == '.') *(cp1++) = '_';
1406 else *(cp1++) = *cp2;
1410 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1411 if (hasdir) *(cp1++) = ']';
1412 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1413 while (*cp2) *(cp1++) = *(cp2++);
1418 } /* end of do_tovmsspec() */
1420 /* External entry points */
1421 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1422 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1424 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1425 static char *do_tovmspath(char *path, char *buf, int ts) {
1426 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1428 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1430 if (path == NULL) return NULL;
1431 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1432 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1433 if (buf) return buf;
1435 vmslen = strlen(vmsified);
1436 New(7017,cp,vmslen+1,char);
1437 memcpy(cp,vmsified,vmslen);
1442 strcpy(__tovmspath_retbuf,vmsified);
1443 return __tovmspath_retbuf;
1446 } /* end of do_tovmspath() */
1448 /* External entry points */
1449 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1450 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1453 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1454 static char *do_tounixpath(char *path, char *buf, int ts) {
1455 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1457 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1459 if (path == NULL) return NULL;
1460 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1461 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1462 if (buf) return buf;
1464 unixlen = strlen(unixified);
1465 New(7017,cp,unixlen+1,char);
1466 memcpy(cp,unixified,unixlen);
1471 strcpy(__tounixpath_retbuf,unixified);
1472 return __tounixpath_retbuf;
1475 } /* end of do_tounixpath() */
1477 /* External entry points */
1478 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1479 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1482 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1484 *****************************************************************************
1486 * Copyright (C) 1989-1994 by *
1487 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1489 * Permission is hereby granted for the reproduction of this software, *
1490 * on condition that this copyright notice is included in the reproduction, *
1491 * and that such reproduction is not for purposes of profit or material *
1494 * 27-Aug-1994 Modified for inclusion in perl5 *
1495 * by Charles Bailey bailey@genetics.upenn.edu *
1496 *****************************************************************************
1500 * getredirection() is intended to aid in porting C programs
1501 * to VMS (Vax-11 C). The native VMS environment does not support
1502 * '>' and '<' I/O redirection, or command line wild card expansion,
1503 * or a command line pipe mechanism using the '|' AND background
1504 * command execution '&'. All of these capabilities are provided to any
1505 * C program which calls this procedure as the first thing in the
1507 * The piping mechanism will probably work with almost any 'filter' type
1508 * of program. With suitable modification, it may useful for other
1509 * portability problems as well.
1511 * Author: Mark Pizzolato mark@infocomm.com
1515 struct list_item *next;
1519 static void add_item(struct list_item **head,
1520 struct list_item **tail,
1524 static void expand_wild_cards(char *item,
1525 struct list_item **head,
1526 struct list_item **tail,
1529 static int background_process(int argc, char **argv);
1531 static void pipe_and_fork(char **cmargv);
1533 /*{{{ void getredirection(int *ac, char ***av)*/
1535 getredirection(int *ac, char ***av)
1537 * Process vms redirection arg's. Exit if any error is seen.
1538 * If getredirection() processes an argument, it is erased
1539 * from the vector. getredirection() returns a new argc and argv value.
1540 * In the event that a background command is requested (by a trailing "&"),
1541 * this routine creates a background subprocess, and simply exits the program.
1543 * Warning: do not try to simplify the code for vms. The code
1544 * presupposes that getredirection() is called before any data is
1545 * read from stdin or written to stdout.
1547 * Normal usage is as follows:
1553 * getredirection(&argc, &argv);
1557 int argc = *ac; /* Argument Count */
1558 char **argv = *av; /* Argument Vector */
1559 char *ap; /* Argument pointer */
1560 int j; /* argv[] index */
1561 int item_count = 0; /* Count of Items in List */
1562 struct list_item *list_head = 0; /* First Item in List */
1563 struct list_item *list_tail; /* Last Item in List */
1564 char *in = NULL; /* Input File Name */
1565 char *out = NULL; /* Output File Name */
1566 char *outmode = "w"; /* Mode to Open Output File */
1567 char *err = NULL; /* Error File Name */
1568 char *errmode = "w"; /* Mode to Open Error File */
1569 int cmargc = 0; /* Piped Command Arg Count */
1570 char **cmargv = NULL;/* Piped Command Arg Vector */
1573 * First handle the case where the last thing on the line ends with
1574 * a '&'. This indicates the desire for the command to be run in a
1575 * subprocess, so we satisfy that desire.
1578 if (0 == strcmp("&", ap))
1579 exit(background_process(--argc, argv));
1580 if (*ap && '&' == ap[strlen(ap)-1])
1582 ap[strlen(ap)-1] = '\0';
1583 exit(background_process(argc, argv));
1586 * Now we handle the general redirection cases that involve '>', '>>',
1587 * '<', and pipes '|'.
1589 for (j = 0; j < argc; ++j)
1591 if (0 == strcmp("<", argv[j]))
1595 fprintf(stderr,"No input file after < on command line");
1596 exit(LIB$_WRONUMARG);
1601 if ('<' == *(ap = argv[j]))
1606 if (0 == strcmp(">", ap))
1610 fprintf(stderr,"No output file after > on command line");
1611 exit(LIB$_WRONUMARG);
1630 fprintf(stderr,"No output file after > or >> on command line");
1631 exit(LIB$_WRONUMARG);
1635 if (('2' == *ap) && ('>' == ap[1]))
1652 fprintf(stderr,"No output file after 2> or 2>> on command line");
1653 exit(LIB$_WRONUMARG);
1657 if (0 == strcmp("|", argv[j]))
1661 fprintf(stderr,"No command into which to pipe on command line");
1662 exit(LIB$_WRONUMARG);
1664 cmargc = argc-(j+1);
1665 cmargv = &argv[j+1];
1669 if ('|' == *(ap = argv[j]))
1677 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1680 * Allocate and fill in the new argument vector, Some Unix's terminate
1681 * the list with an extra null pointer.
1683 New(7002, argv, item_count+1, char *);
1685 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1686 argv[j] = list_head->value;
1692 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1693 exit(LIB$_INVARGORD);
1695 pipe_and_fork(cmargv);
1698 /* Check for input from a pipe (mailbox) */
1700 if (in == NULL && 1 == isapipe(0))
1702 char mbxname[L_tmpnam];
1704 long int dvi_item = DVI$_DEVBUFSIZ;
1705 $DESCRIPTOR(mbxnam, "");
1706 $DESCRIPTOR(mbxdevnam, "");
1708 /* Input from a pipe, reopen it in binary mode to disable */
1709 /* carriage control processing. */
1711 fgetname(stdin, mbxname,1);
1712 mbxnam.dsc$a_pointer = mbxname;
1713 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1714 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1715 mbxdevnam.dsc$a_pointer = mbxname;
1716 mbxdevnam.dsc$w_length = sizeof(mbxname);
1717 dvi_item = DVI$_DEVNAM;
1718 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1719 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1722 freopen(mbxname, "rb", stdin);
1725 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1729 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1731 fprintf(stderr,"Can't open input file %s as stdin",in);
1734 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1736 fprintf(stderr,"Can't open output file %s as stdout",out);
1741 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1743 fprintf(stderr,"Can't open error file %s as stderr",err);
1747 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1752 #ifdef ARGPROC_DEBUG
1753 fprintf(stderr, "Arglist:\n");
1754 for (j = 0; j < *ac; ++j)
1755 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1757 } /* end of getredirection() */
1760 static void add_item(struct list_item **head,
1761 struct list_item **tail,
1767 New(7003,*head,1,struct list_item);
1771 New(7004,(*tail)->next,1,struct list_item);
1772 *tail = (*tail)->next;
1774 (*tail)->value = value;
1778 static void expand_wild_cards(char *item,
1779 struct list_item **head,
1780 struct list_item **tail,
1784 unsigned long int context = 0;
1790 char vmsspec[NAM$C_MAXRSS+1];
1791 $DESCRIPTOR(filespec, "");
1792 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1793 $DESCRIPTOR(resultspec, "");
1794 unsigned long int zero = 0, sts;
1796 if (strcspn(item, "*%") == strlen(item))
1798 add_item(head, tail, item, count);
1801 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1802 resultspec.dsc$b_class = DSC$K_CLASS_D;
1803 resultspec.dsc$a_pointer = NULL;
1804 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1805 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1806 if (!isunix || !filespec.dsc$a_pointer)
1807 filespec.dsc$a_pointer = item;
1808 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1810 * Only return version specs, if the caller specified a version
1812 had_version = strchr(item, ';');
1814 * Only return device and directory specs, if the caller specifed either.
1816 had_device = strchr(item, ':');
1817 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1819 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1820 &defaultspec, 0, 0, &zero))))
1825 New(7005,string,resultspec.dsc$w_length+1,char);
1826 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1827 string[resultspec.dsc$w_length] = '\0';
1828 if (NULL == had_version)
1829 *((char *)strrchr(string, ';')) = '\0';
1830 if ((!had_directory) && (had_device == NULL))
1832 if (NULL == (devdir = strrchr(string, ']')))
1833 devdir = strrchr(string, '>');
1834 strcpy(string, devdir + 1);
1837 * Be consistent with what the C RTL has already done to the rest of
1838 * the argv items and lowercase all of these names.
1840 for (c = string; *c; ++c)
1843 if (isunix) trim_unixpath(item,string);
1844 add_item(head, tail, string, count);
1847 if (sts != RMS$_NMF)
1849 set_vaxc_errno(sts);
1854 set_errno(ENOENT); break;
1856 set_errno(ENODEV); break;
1858 set_errno(EINVAL); break;
1860 set_errno(EACCES); break;
1866 add_item(head, tail, item, count);
1867 _ckvmssts(lib$sfree1_dd(&resultspec));
1868 _ckvmssts(lib$find_file_end(&context));
1871 static int child_st[2];/* Event Flag set when child process completes */
1873 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
1875 static unsigned long int exit_handler(int *status)
1879 if (0 == child_st[0])
1881 #ifdef ARGPROC_DEBUG
1882 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1884 fflush(stdout); /* Have to flush pipe for binary data to */
1885 /* terminate properly -- <tp@mccall.com> */
1886 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1887 sys$dassgn(child_chan);
1889 sys$synch(0, child_st);
1894 static void sig_child(int chan)
1896 #ifdef ARGPROC_DEBUG
1897 fprintf(stderr, "Child Completion AST\n");
1899 if (child_st[0] == 0)
1903 static struct exit_control_block exit_block =
1908 &exit_block.exit_status,
1912 static void pipe_and_fork(char **cmargv)
1915 $DESCRIPTOR(cmddsc, "");
1916 static char mbxname[64];
1917 $DESCRIPTOR(mbxdsc, mbxname);
1919 unsigned long int zero = 0, one = 1;
1921 strcpy(subcmd, cmargv[0]);
1922 for (j = 1; NULL != cmargv[j]; ++j)
1924 strcat(subcmd, " \"");
1925 strcat(subcmd, cmargv[j]);
1926 strcat(subcmd, "\"");
1928 cmddsc.dsc$a_pointer = subcmd;
1929 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1931 create_mbx(&child_chan,&mbxdsc);
1932 #ifdef ARGPROC_DEBUG
1933 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1934 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1936 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1937 0, &pid, child_st, &zero, sig_child,
1939 #ifdef ARGPROC_DEBUG
1940 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1942 sys$dclexh(&exit_block);
1943 if (NULL == freopen(mbxname, "wb", stdout))
1945 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1949 static int background_process(int argc, char **argv)
1951 char command[2048] = "$";
1952 $DESCRIPTOR(value, "");
1953 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1954 static $DESCRIPTOR(null, "NLA0:");
1955 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1957 $DESCRIPTOR(pidstr, "");
1959 unsigned long int flags = 17, one = 1, retsts;
1961 strcat(command, argv[0]);
1964 strcat(command, " \"");
1965 strcat(command, *(++argv));
1966 strcat(command, "\"");
1968 value.dsc$a_pointer = command;
1969 value.dsc$w_length = strlen(value.dsc$a_pointer);
1970 _ckvmssts(lib$set_symbol(&cmd, &value));
1971 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1972 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1973 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1978 #ifdef ARGPROC_DEBUG
1979 fprintf(stderr, "%s\n", command);
1981 sprintf(pidstring, "%08X", pid);
1982 fprintf(stderr, "%s\n", pidstring);
1983 pidstr.dsc$a_pointer = pidstring;
1984 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1985 lib$set_symbol(&pidsymbol, &pidstr);
1989 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1992 * Trim Unix-style prefix off filespec, so it looks like what a shell
1993 * glob expansion would return (i.e. from specified prefix on, not
1994 * full path). Note that returned filespec is Unix-style, regardless
1995 * of whether input filespec was VMS-style or Unix-style.
1997 * Returns !=0 on success, 0 on failure.
1999 /*{{{int trim_unixpath(char *template, char *fspec)*/
2001 trim_unixpath(char *template, char *fspec)
2003 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
2004 register int tmplen;
2006 if (strpbrk(fspec,"]>:") != NULL) {
2007 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2008 else base = unixified;
2011 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
2013 /* Find prefix to template consisting of path elements without wildcards */
2014 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2015 for (cp1 = template; *cp1; cp1++) ;
2016 else while (cp1 >= template && *cp1 != '/') cp1--;
2017 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
2018 tmplen = cp1 - template;
2020 /* Try to find template prefix on filespec */
2021 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
2022 for (; cp2 - base > tmplen; base++) {
2023 if (*base != '/') continue;
2024 if (!memcmp(base + 1,template,tmplen)) break;
2026 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2027 base++; /* Move past leading '/' */
2028 /* Copy down remaining portion of filespec, including trailing NUL */
2029 memmove(fspec,base,cp2 - base + 1);
2032 } /* end of trim_unixpath() */
2037 * VMS readdir() routines.
2038 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2039 * This code has no copyright.
2041 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2042 * Minor modifications to original routines.
2045 /* Number of elements in vms_versions array */
2046 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2049 * Open a directory, return a handle for later use.
2051 /*{{{ DIR *opendir(char*name) */
2056 char dir[NAM$C_MAXRSS+1];
2058 /* Get memory for the handle, and the pattern. */
2060 if (do_tovmspath(name,dir,0) == NULL) {
2061 Safefree((char *)dd);
2064 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2066 /* Fill in the fields; mainly playing with the descriptor. */
2067 (void)sprintf(dd->pattern, "%s*.*",dir);
2070 dd->vms_wantversions = 0;
2071 dd->pat.dsc$a_pointer = dd->pattern;
2072 dd->pat.dsc$w_length = strlen(dd->pattern);
2073 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2074 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2077 } /* end of opendir() */
2081 * Set the flag to indicate we want versions or not.
2083 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2085 vmsreaddirversions(DIR *dd, int flag)
2087 dd->vms_wantversions = flag;
2092 * Free up an opened directory.
2094 /*{{{ void closedir(DIR *dd)*/
2098 (void)lib$find_file_end(&dd->context);
2099 Safefree(dd->pattern);
2100 Safefree((char *)dd);
2105 * Collect all the version numbers for the current file.
2111 struct dsc$descriptor_s pat;
2112 struct dsc$descriptor_s res;
2114 char *p, *text, buff[sizeof dd->entry.d_name];
2116 unsigned long context, tmpsts;
2118 /* Convenient shorthand. */
2121 /* Add the version wildcard, ignoring the "*.*" put on before */
2122 i = strlen(dd->pattern);
2123 New(7008,text,i + e->d_namlen + 3,char);
2124 (void)strcpy(text, dd->pattern);
2125 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2127 /* Set up the pattern descriptor. */
2128 pat.dsc$a_pointer = text;
2129 pat.dsc$w_length = i + e->d_namlen - 1;
2130 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2131 pat.dsc$b_class = DSC$K_CLASS_S;
2133 /* Set up result descriptor. */
2134 res.dsc$a_pointer = buff;
2135 res.dsc$w_length = sizeof buff - 2;
2136 res.dsc$b_dtype = DSC$K_DTYPE_T;
2137 res.dsc$b_class = DSC$K_CLASS_S;
2139 /* Read files, collecting versions. */
2140 for (context = 0, e->vms_verscount = 0;
2141 e->vms_verscount < VERSIZE(e);
2142 e->vms_verscount++) {
2143 tmpsts = lib$find_file(&pat, &res, &context);
2144 if (tmpsts == RMS$_NMF || context == 0) break;
2146 buff[sizeof buff - 1] = '\0';
2147 if ((p = strchr(buff, ';')))
2148 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2150 e->vms_versions[e->vms_verscount] = -1;
2153 _ckvmssts(lib$find_file_end(&context));
2156 } /* end of collectversions() */
2159 * Read the next entry from the directory.
2161 /*{{{ struct dirent *readdir(DIR *dd)*/
2165 struct dsc$descriptor_s res;
2166 char *p, buff[sizeof dd->entry.d_name];
2167 unsigned long int tmpsts;
2169 /* Set up result descriptor, and get next file. */
2170 res.dsc$a_pointer = buff;
2171 res.dsc$w_length = sizeof buff - 2;
2172 res.dsc$b_dtype = DSC$K_DTYPE_T;
2173 res.dsc$b_class = DSC$K_CLASS_S;
2174 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2175 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2176 if (!(tmpsts & 1)) {
2177 set_vaxc_errno(tmpsts);
2180 set_errno(EACCES); break;
2182 set_errno(ENODEV); break;
2185 set_errno(ENOENT); break;
2192 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2193 buff[sizeof buff - 1] = '\0';
2194 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2197 /* Skip any directory component and just copy the name. */
2198 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2199 else (void)strcpy(dd->entry.d_name, buff);
2201 /* Clobber the version. */
2202 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2204 dd->entry.d_namlen = strlen(dd->entry.d_name);
2205 dd->entry.vms_verscount = 0;
2206 if (dd->vms_wantversions) collectversions(dd);
2209 } /* end of readdir() */
2213 * Return something that can be used in a seekdir later.
2215 /*{{{ long telldir(DIR *dd)*/
2224 * Return to a spot where we used to be. Brute force.
2226 /*{{{ void seekdir(DIR *dd,long count)*/
2228 seekdir(DIR *dd, long count)
2230 int vms_wantversions;
2232 /* If we haven't done anything yet... */
2236 /* Remember some state, and clear it. */
2237 vms_wantversions = dd->vms_wantversions;
2238 dd->vms_wantversions = 0;
2239 _ckvmssts(lib$find_file_end(&dd->context));
2242 /* The increment is in readdir(). */
2243 for (dd->count = 0; dd->count < count; )
2246 dd->vms_wantversions = vms_wantversions;
2248 } /* end of seekdir() */
2251 /* VMS subprocess management
2253 * my_vfork() - just a vfork(), after setting a flag to record that
2254 * the current script is trying a Unix-style fork/exec.
2256 * vms_do_aexec() and vms_do_exec() are called in response to the
2257 * perl 'exec' function. If this follows a vfork call, then they
2258 * call out the the regular perl routines in doio.c which do an
2259 * execvp (for those who really want to try this under VMS).
2260 * Otherwise, they do exactly what the perl docs say exec should
2261 * do - terminate the current script and invoke a new command
2262 * (See below for notes on command syntax.)
2264 * do_aspawn() and do_spawn() implement the VMS side of the perl
2265 * 'system' function.
2267 * Note on command arguments to perl 'exec' and 'system': When handled
2268 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2269 * are concatenated to form a DCL command string. If the first arg
2270 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2271 * the the command string is hrnded off to DCL directly. Otherwise,
2272 * the first token of the command is taken as the filespec of an image
2273 * to run. The filespec is expanded using a default type of '.EXE' and
2274 * the process defaults for device, directory, etc., and the resultant
2275 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2276 * the command string as parameters. This is perhaps a bit compicated,
2277 * but I hope it will form a happy medium between what VMS folks expect
2278 * from lib$spawn and what Unix folks expect from exec.
2281 static int vfork_called;
2283 /*{{{int my_vfork()*/
2293 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2301 if (VMScmd.dsc$a_pointer) {
2302 Safefree(VMScmd.dsc$a_pointer);
2303 VMScmd.dsc$w_length = 0;
2304 VMScmd.dsc$a_pointer = Nullch;
2309 setup_argstr(SV *really, SV **mark, SV **sp)
2311 char *junk, *tmps = Nullch;
2312 register size_t cmdlen = 0;
2318 tmps = SvPV(really,rlen);
2325 for (idx++; idx <= sp; idx++) {
2327 junk = SvPVx(*idx,rlen);
2328 cmdlen += rlen ? rlen + 1 : 0;
2331 New(401,Cmd,cmdlen+1,char);
2333 if (tmps && *tmps) {
2338 while (++mark <= sp) {
2341 strcat(Cmd,SvPVx(*mark,na));
2346 } /* end of setup_argstr() */
2349 static unsigned long int
2350 setup_cmddsc(char *cmd, int check_img)
2352 char resspec[NAM$C_MAXRSS+1];
2353 $DESCRIPTOR(defdsc,".EXE");
2354 $DESCRIPTOR(resdsc,resspec);
2355 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2356 unsigned long int cxt = 0, flags = 1, retsts;
2357 register char *s, *rest, *cp;
2358 register int isdcl = 0;
2361 while (*s && isspace(*s)) s++;
2363 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2364 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2365 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2366 if (*cp == ':' || *cp == '[' || *cp == '<') {
2374 if (isdcl) { /* It's a DCL command, just do it. */
2375 VMScmd.dsc$w_length = strlen(cmd);
2377 VMScmd.dsc$a_pointer = Cmd;
2378 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2380 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2382 else { /* assume first token is an image spec */
2384 while (*s && !isspace(*s)) s++;
2386 imgdsc.dsc$a_pointer = cmd;
2387 imgdsc.dsc$w_length = s - cmd;
2388 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2389 if (!(retsts & 1)) {
2390 /* just hand off status values likely to be due to user error */
2391 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2392 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2393 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2394 else { _ckvmssts(retsts); }
2397 _ckvmssts(lib$find_file_end(&cxt));
2399 while (*s && !isspace(*s)) s++;
2401 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2402 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2403 strcat(VMScmd.dsc$a_pointer,resspec);
2404 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2405 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2410 } /* end of setup_cmddsc() */
2412 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2414 vms_do_aexec(SV *really,SV **mark,SV **sp)
2417 if (vfork_called) { /* this follows a vfork - act Unixish */
2419 if (vfork_called < 0) {
2420 warn("Internal inconsistency in tracking vforks");
2423 else return do_aexec(really,mark,sp);
2425 /* no vfork - act VMSish */
2426 return vms_do_exec(setup_argstr(really,mark,sp));
2431 } /* end of vms_do_aexec() */
2434 /* {{{bool vms_do_exec(char *cmd) */
2436 vms_do_exec(char *cmd)
2439 if (vfork_called) { /* this follows a vfork - act Unixish */
2441 if (vfork_called < 0) {
2442 warn("Internal inconsistency in tracking vforks");
2445 else return do_exec(cmd);
2448 { /* no vfork - act VMSish */
2449 unsigned long int retsts;
2451 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2452 retsts = lib$do_command(&VMScmd);
2455 set_vaxc_errno(retsts);
2457 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2463 } /* end of vms_do_exec() */
2466 unsigned long int do_spawn(char *);
2468 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2470 do_aspawn(SV *really,SV **mark,SV **sp)
2472 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2475 } /* end of do_aspawn() */
2478 /* {{{unsigned long int do_spawn(char *cmd) */
2482 unsigned long int substs, hadcmd = 1;
2484 if (!cmd || !*cmd) {
2486 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2488 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2489 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2494 set_vaxc_errno(substs);
2496 warn("Can't exec \"%s\": %s",
2497 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2502 } /* end of do_spawn() */
2506 * A simple fwrite replacement which outputs itmsz*nitm chars without
2507 * introducing record boundaries every itmsz chars.
2509 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2511 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2513 register char *cp, *end;
2515 end = (char *)src + itmsz * nitm;
2517 while ((char *)src <= end) {
2518 for (cp = src; cp <= end; cp++) if (!*cp) break;
2519 if (fputs(src,dest) == EOF) return EOF;
2521 if (fputc('\0',dest) == EOF) return EOF;
2527 } /* end of my_fwrite() */
2531 * Here are replacements for the following Unix routines in the VMS environment:
2532 * getpwuid Get information for a particular UIC or UID
2533 * getpwnam Get information for a named user
2534 * getpwent Get information for each user in the rights database
2535 * setpwent Reset search to the start of the rights database
2536 * endpwent Finish searching for users in the rights database
2538 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2539 * (defined in pwd.h), which contains the following fields:-
2541 * char *pw_name; Username (in lower case)
2542 * char *pw_passwd; Hashed password
2543 * unsigned int pw_uid; UIC
2544 * unsigned int pw_gid; UIC group number
2545 * char *pw_unixdir; Default device/directory (VMS-style)
2546 * char *pw_gecos; Owner name
2547 * char *pw_dir; Default device/directory (Unix-style)
2548 * char *pw_shell; Default CLI name (eg. DCL)
2550 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2552 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2553 * not the UIC member number (eg. what's returned by getuid()),
2554 * getpwuid() can accept either as input (if uid is specified, the caller's
2555 * UIC group is used), though it won't recognise gid=0.
2557 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2558 * information about other users in your group or in other groups, respectively.
2559 * If the required privilege is not available, then these routines fill only
2560 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2563 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2566 /* sizes of various UAF record fields */
2567 #define UAI$S_USERNAME 12
2568 #define UAI$S_IDENT 31
2569 #define UAI$S_OWNER 31
2570 #define UAI$S_DEFDEV 31
2571 #define UAI$S_DEFDIR 63
2572 #define UAI$S_DEFCLI 31
2575 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2576 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2577 (uic).uic$v_group != UIC$K_WILD_GROUP)
2579 static char __empty[]= "";
2580 static struct passwd __passwd_empty=
2581 {(char *) __empty, (char *) __empty, 0, 0,
2582 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2583 static int contxt= 0;
2584 static struct passwd __pwdcache;
2585 static char __pw_namecache[UAI$S_IDENT+1];
2587 static char *_mystrtolower(char *str)
2589 if (str) for (; *str; ++str) *str= tolower(*str);
2594 * This routine does most of the work extracting the user information.
2596 static int fillpasswd (const char *name, struct passwd *pwd)
2599 unsigned char length;
2600 char pw_gecos[UAI$S_OWNER+1];
2602 static union uicdef uic;
2604 unsigned char length;
2605 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2608 unsigned char length;
2609 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2612 unsigned char length;
2613 char pw_shell[UAI$S_DEFCLI+1];
2615 static char pw_passwd[UAI$S_PWD+1];
2617 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2618 struct dsc$descriptor_s name_desc;
2619 unsigned long int sts;
2621 static struct itmlst_3 itmlst[]= {
2622 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2623 {sizeof(uic), UAI$_UIC, &uic, &luic},
2624 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2625 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2626 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2627 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2628 {0, 0, NULL, NULL}};
2630 name_desc.dsc$w_length= strlen(name);
2631 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2632 name_desc.dsc$b_class= DSC$K_CLASS_S;
2633 name_desc.dsc$a_pointer= (char *) name;
2635 /* Note that sys$getuai returns many fields as counted strings. */
2636 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2637 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2638 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2640 else { _ckvmssts(sts); }
2641 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2643 if ((int) owner.length < lowner) lowner= (int) owner.length;
2644 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2645 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2646 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2647 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2648 owner.pw_gecos[lowner]= '\0';
2649 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2650 defcli.pw_shell[ldefcli]= '\0';
2651 if (valid_uic(uic)) {
2652 pwd->pw_uid= uic.uic$l_uic;
2653 pwd->pw_gid= uic.uic$v_group;
2656 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2657 pwd->pw_passwd= pw_passwd;
2658 pwd->pw_gecos= owner.pw_gecos;
2659 pwd->pw_dir= defdev.pw_dir;
2660 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2661 pwd->pw_shell= defcli.pw_shell;
2662 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2664 ldir= strlen(pwd->pw_unixdir) - 1;
2665 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2668 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2669 _mystrtolower(pwd->pw_unixdir);
2674 * Get information for a named user.
2676 /*{{{struct passwd *getpwnam(char *name)*/
2677 struct passwd *my_getpwnam(char *name)
2679 struct dsc$descriptor_s name_desc;
2681 unsigned long int status, stat;
2683 __pwdcache = __passwd_empty;
2684 if (!fillpasswd(name, &__pwdcache)) {
2685 /* We still may be able to determine pw_uid and pw_gid */
2686 name_desc.dsc$w_length= strlen(name);
2687 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2688 name_desc.dsc$b_class= DSC$K_CLASS_S;
2689 name_desc.dsc$a_pointer= (char *) name;
2690 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2691 __pwdcache.pw_uid= uic.uic$l_uic;
2692 __pwdcache.pw_gid= uic.uic$v_group;
2695 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2696 set_vaxc_errno(stat);
2697 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2700 else { _ckvmssts(stat); }
2703 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2704 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2705 __pwdcache.pw_name= __pw_namecache;
2707 } /* end of my_getpwnam() */
2711 * Get information for a particular UIC or UID.
2712 * Called by my_getpwent with uid=-1 to list all users.
2714 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2715 struct passwd *my_getpwuid(Uid_t uid)
2717 const $DESCRIPTOR(name_desc,__pw_namecache);
2718 unsigned short lname;
2720 unsigned long int status;
2722 if (uid == (unsigned int) -1) {
2724 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2725 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2726 set_vaxc_errno(status);
2727 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2731 else { _ckvmssts(status); }
2732 } while (!valid_uic (uic));
2736 if (!uic.uic$v_group)
2737 uic.uic$v_group= getgid();
2739 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2740 else status = SS$_IVIDENT;
2741 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2742 status == RMS$_PRV) {
2743 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2746 else { _ckvmssts(status); }
2748 __pw_namecache[lname]= '\0';
2749 _mystrtolower(__pw_namecache);
2751 __pwdcache = __passwd_empty;
2752 __pwdcache.pw_name = __pw_namecache;
2754 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2755 The identifier's value is usually the UIC, but it doesn't have to be,
2756 so if we can, we let fillpasswd update this. */
2757 __pwdcache.pw_uid = uic.uic$l_uic;
2758 __pwdcache.pw_gid = uic.uic$v_group;
2760 fillpasswd(__pw_namecache, &__pwdcache);
2763 } /* end of my_getpwuid() */
2767 * Get information for next user.
2769 /*{{{struct passwd *my_getpwent()*/
2770 struct passwd *my_getpwent()
2772 return (my_getpwuid((unsigned int) -1));
2777 * Finish searching rights database for users.
2779 /*{{{void my_endpwent()*/
2783 _ckvmssts(sys$finish_rdb(&contxt));
2791 * If the CRTL has a real gmtime(), use it, else look for the logical
2792 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2793 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
2794 * to translate to the number of seconds which must be added to UTC
2795 * to get to the local time of the system.
2796 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
2799 /*{{{struct tm *my_gmtime(const time_t *time)*/
2800 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
2801 * so we can call the CRTL's routine to see if it works.
2805 my_gmtime(const time_t *time)
2807 static int gmtime_emulation_type;
2808 static time_t utc_offset_secs;
2812 if (gmtime_emulation_type == 0) {
2813 gmtime_emulation_type++;
2815 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
2816 gmtime_emulation_type++;
2817 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2818 gmtime_emulation_type++;
2820 utc_offset_secs = (time_t) atol(p);
2824 switch (gmtime_emulation_type) {
2826 return gmtime(time);
2828 when = *time - utc_offset_secs;
2829 return localtime(&when);
2831 warn("gmtime not supported on this system");
2834 } /* end of my_gmtime() */
2835 /* Reset definition for later calls */
2836 #define gmtime(t) my_gmtime(t)
2841 * flex_stat, flex_fstat
2842 * basic stat, but gets it right when asked to stat
2843 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2846 /* encode_dev packs a VMS device name string into an integer to allow
2847 * simple comparisons. This can be used, for example, to check whether two
2848 * files are located on the same device, by comparing their encoded device
2849 * names. Even a string comparison would not do, because stat() reuses the
2850 * device name buffer for each call; so without encode_dev, it would be
2851 * necessary to save the buffer and use strcmp (this would mean a number of
2852 * changes to the standard Perl code, to say nothing of what a Perl script
2855 * The device lock id, if it exists, should be unique (unless perhaps compared
2856 * with lock ids transferred from other nodes). We have a lock id if the disk is
2857 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2858 * device names. Thus we use the lock id in preference, and only if that isn't
2859 * available, do we try to pack the device name into an integer (flagged by
2860 * the sign bit (LOCKID_MASK) being set).
2862 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2863 * name and its encoded form, but it seems very unlikely that we will find
2864 * two files on different disks that share the same encoded device names,
2865 * and even more remote that they will share the same file id (if the test
2866 * is to check for the same file).
2868 * A better method might be to use sys$device_scan on the first call, and to
2869 * search for the device, returning an index into the cached array.
2870 * The number returned would be more intelligable.
2871 * This is probably not worth it, and anyway would take quite a bit longer
2872 * on the first call.
2874 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2875 static dev_t encode_dev (const char *dev)
2878 unsigned long int f;
2883 if (!dev || !dev[0]) return 0;
2887 struct dsc$descriptor_s dev_desc;
2888 unsigned long int status, lockid, item = DVI$_LOCKID;
2890 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2891 can try that first. */
2892 dev_desc.dsc$w_length = strlen (dev);
2893 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2894 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2895 dev_desc.dsc$a_pointer = (char *) dev;
2896 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2897 if (lockid) return (lockid & ~LOCKID_MASK);
2901 /* Otherwise we try to encode the device name */
2905 for (q = dev + strlen(dev); q--; q >= dev) {
2908 else if (isalpha (toupper (*q)))
2909 c= toupper (*q) - 'A' + (char)10;
2911 continue; /* Skip '$'s */
2913 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2915 enc += f * (unsigned long int) c;
2917 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2919 } /* end of encode_dev() */
2921 static char namecache[NAM$C_MAXRSS+1];
2924 is_null_device(name)
2927 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2928 The underscore prefix, controller letter, and unit number are
2929 independently optional; for our purposes, the colon punctuation
2930 is not. The colon can be trailed by optional directory and/or
2931 filename, but two consecutive colons indicates a nodename rather
2932 than a device. [pr] */
2933 if (*name == '_') ++name;
2934 if (tolower(*name++) != 'n') return 0;
2935 if (tolower(*name++) != 'l') return 0;
2936 if (tolower(*name) == 'a') ++name;
2937 if (*name == '0') ++name;
2938 return (*name++ == ':') && (*name != ':');
2941 /* Do the permissions allow some operation? Assumes statcache already set. */
2942 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2943 * subset of the applicable information.
2945 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2947 cando(I32 bit, I32 effective, struct stat *statbufp)
2949 if (statbufp == &statcache)
2950 return cando_by_name(bit,effective,namecache);
2952 char fname[NAM$C_MAXRSS+1];
2953 unsigned long int retsts;
2954 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2955 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2957 /* If the struct mystat is stale, we're OOL; stat() overwrites the
2958 device name on successive calls */
2959 devdsc.dsc$a_pointer = statbufp->st_devnam;
2960 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2961 namdsc.dsc$a_pointer = fname;
2962 namdsc.dsc$w_length = sizeof fname - 1;
2964 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
2965 &namdsc.dsc$w_length,0,0);
2967 fname[namdsc.dsc$w_length] = '\0';
2968 return cando_by_name(bit,effective,fname);
2970 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2971 warn("Can't get filespec - stale stat buffer?\n");
2975 return FALSE; /* Should never get to here */
2977 } /* end of cando() */
2981 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2983 cando_by_name(I32 bit, I32 effective, char *fname)
2985 static char usrname[L_cuserid];
2986 static struct dsc$descriptor_s usrdsc =
2987 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2988 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
2989 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2990 unsigned short int retlen;
2991 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2992 union prvdef curprv;
2993 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2994 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2995 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2998 if (!fname || !*fname) return FALSE;
2999 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3000 retlen = namdsc.dsc$w_length = strlen(vmsname);
3001 namdsc.dsc$a_pointer = vmsname;
3002 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3003 vmsname[retlen-1] == ':') {
3004 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3005 namdsc.dsc$w_length = strlen(fileified);
3006 namdsc.dsc$a_pointer = fileified;
3009 if (!usrdsc.dsc$w_length) {
3011 usrdsc.dsc$w_length = strlen(usrname);
3018 access = ARM$M_EXECUTE;
3023 access = ARM$M_READ;
3028 access = ARM$M_WRITE;
3033 access = ARM$M_DELETE;
3039 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3040 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
3041 retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
3042 if (retsts == SS$_NORMAL) {
3043 if (!privused) return TRUE;
3044 /* We can get access, but only by using privs. Do we have the
3045 necessary privs currently enabled? */
3046 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3047 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3048 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3049 !curprv.prv$v_bypass) return FALSE;
3050 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3051 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3052 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3057 return FALSE; /* Should never get here */
3059 } /* end of cando_by_name() */
3063 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3065 flex_fstat(int fd, struct stat *statbuf)
3067 char fspec[NAM$C_MAXRSS+1];
3069 if (!getname(fd,fspec,1)) return -1;
3070 return flex_stat(fspec,statbuf);
3072 } /* end of flex_fstat() */
3075 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3076 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3077 * 'struct stat' elsewhere in Perl would use our struct. We go back
3078 * to the system version here, since we're actually calling their
3083 flex_stat(char *fspec, struct mystat *statbufp)
3085 char fileified[NAM$C_MAXRSS+1];
3086 int retval,myretval;
3087 struct mystat tmpbuf;
3090 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3091 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3092 memset(statbufp,0,sizeof *statbufp);
3093 statbufp->st_dev = encode_dev("_NLA0:");
3094 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3095 statbufp->st_uid = 0x00010001;
3096 statbufp->st_gid = 0x0001;
3097 time((time_t *)&statbufp->st_mtime);
3098 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3102 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3104 myretval = stat(fileified,(stat_t *) &tmpbuf);
3106 retval = stat(fspec,(stat_t *) statbufp);
3112 else if (!retval) { /* Dir with same name. Substitute it. */
3113 statbufp->st_mode &= ~S_IFDIR;
3114 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3115 strcpy(namecache,fileified);
3118 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3121 } /* end of flex_stat() */
3122 /* Reset definition for later calls */
3126 /*{{{char *my_getlogin()*/
3127 /* VMS cuserid == Unix getlogin, except calling sequence */
3131 static char user[L_cuserid];
3132 return cuserid(user);
3137 /* rmscopy - copy a file using VMS RMS routines
3139 * Copies contents and attributes of spec_in to spec_out, except owner
3140 * and protection information. Name and type of spec_in are used as
3141 * defaults for spec_out. Returns 1 on success; returns 0 and sets
3142 * errno and vaxc$errno on failure.
3144 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3145 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3146 * <T.J.Adye@rl.ac.uk>. Permission is given to use and distribute this
3147 * code under the same terms as Perl itself. (See the GNU General Public
3148 * License or the Perl Artistic License supplied as part of the Perl
3151 /*{{{int rmscopy(char *src, char *dst)*/
3153 rmscopy(char *spec_in, char *spec_out)
3155 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3156 rsa[NAM$C_MAXRSS], ubf[32256];
3157 unsigned long int i, sts, sts2;
3158 struct FAB fab_in, fab_out;
3159 struct RAB rab_in, rab_out;
3161 struct XABDAT xabdat;
3162 struct XABFHC xabfhc;
3163 struct XABRDT xabrdt;
3164 struct XABSUM xabsum;
3166 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3167 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3168 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3172 fab_in = cc$rms_fab;
3173 fab_in.fab$l_fna = vmsin;
3174 fab_in.fab$b_fns = strlen(vmsin);
3175 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3176 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3177 fab_in.fab$l_fop = FAB$M_SQO;
3178 fab_in.fab$l_nam = &nam;
3179 fab_in.fab$l_xab = (void*) &xabdat;
3182 nam.nam$l_rsa = rsa;
3183 nam.nam$b_rss = sizeof(rsa);
3184 nam.nam$l_esa = esa;
3185 nam.nam$b_ess = sizeof (esa);
3186 nam.nam$b_esl = nam.nam$b_rsl = 0;
3188 xabdat = cc$rms_xabdat; /* To get creation date */
3189 xabdat.xab$l_nxt = (void*) &xabfhc;
3191 xabfhc = cc$rms_xabfhc; /* To get record length */
3192 xabfhc.xab$l_nxt = (void*) &xabsum;
3194 xabsum = cc$rms_xabsum; /* To get key and area information */
3196 if (!((sts = sys$open(&fab_in)) & 1)) {
3197 set_vaxc_errno(sts);
3201 set_errno(ENOENT); break;
3203 set_errno(ENODEV); break;
3205 set_errno(EINVAL); break;
3207 set_errno(EACCES); break;
3215 fab_out.fab$w_ifi = 0;
3216 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3217 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3218 fab_out.fab$l_fop = FAB$M_SQO;
3219 fab_out.fab$l_fna = vmsout;
3220 fab_out.fab$b_fns = strlen(vmsout);
3221 fab_out.fab$l_dna = nam.nam$l_name;
3222 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3223 if (!((sts = sys$create(&fab_out)) & 1)) {
3224 set_vaxc_errno(sts);
3227 set_errno(ENOENT); break;
3229 set_errno(ENODEV); break;
3231 set_errno(EINVAL); break;
3233 set_errno(EACCES); break;
3239 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3240 /* sys$close() will process xabrdt, not xabdat */
3241 xabrdt = cc$rms_xabrdt;
3242 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3243 fab_out.fab$l_xab = &xabrdt;
3245 rab_in = cc$rms_rab;
3246 rab_in.rab$l_fab = &fab_in;
3247 rab_in.rab$l_rop = RAB$M_BIO;
3248 rab_in.rab$l_ubf = ubf;
3249 rab_in.rab$w_usz = sizeof ubf;
3250 if (!((sts = sys$connect(&rab_in)) & 1)) {
3251 sys$close(&fab_in); sys$close(&fab_out);
3252 set_errno(EVMSERR); set_vaxc_errno(sts);
3256 rab_out = cc$rms_rab;
3257 rab_out.rab$l_fab = &fab_out;
3258 rab_out.rab$l_rbf = ubf;
3259 if (!((sts = sys$connect(&rab_out)) & 1)) {
3260 sys$close(&fab_in); sys$close(&fab_out);
3261 set_errno(EVMSERR); set_vaxc_errno(sts);
3265 while ((sts = sys$read(&rab_in))) { /* always true */
3266 if (sts == RMS$_EOF) break;
3267 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3268 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3269 sys$close(&fab_in); sys$close(&fab_out);
3270 set_errno(EVMSERR); set_vaxc_errno(sts);
3275 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3276 sys$close(&fab_in); sys$close(&fab_out);
3277 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3279 set_errno(EVMSERR); set_vaxc_errno(sts);
3285 } /* end of rmscopy() */
3289 /*** The following glue provides 'hooks' to make some of the routines
3290 * from this file available from Perl. These routines are sufficiently
3291 * basic, and are required sufficiently early in the build process,
3292 * that's it's nice to have them available to miniperl as well as the
3293 * full Perl, so they're set up here instead of in an extension. The
3294 * Perl code which handles importation of these names into a given
3295 * package lives in [.VMS]Filespec.pm in @INC.
3299 vmsify_fromperl(CV *cv)
3304 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3305 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3306 ST(0) = sv_newmortal();
3307 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3312 unixify_fromperl(CV *cv)
3317 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3318 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3319 ST(0) = sv_newmortal();
3320 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3325 fileify_fromperl(CV *cv)
3330 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3331 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3332 ST(0) = sv_newmortal();
3333 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3338 pathify_fromperl(CV *cv)
3343 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3344 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3345 ST(0) = sv_newmortal();
3346 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3351 vmspath_fromperl(CV *cv)
3356 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3357 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3358 ST(0) = sv_newmortal();
3359 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3364 unixpath_fromperl(CV *cv)
3369 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3370 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3371 ST(0) = sv_newmortal();
3372 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3377 candelete_fromperl(CV *cv)
3380 char fspec[NAM$C_MAXRSS+1], *fsp;
3384 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3386 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3387 if (SvTYPE(mysv) == SVt_PVGV) {
3388 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3389 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3396 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3397 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3403 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3408 rmscopy_fromperl(CV *cv)
3411 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3412 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3413 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3414 unsigned long int sts;
3418 if (items != 2) croak("Usage: File::Copy::rmscopy(from,to)");
3420 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3421 if (SvTYPE(mysv) == SVt_PVGV) {
3422 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3423 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3430 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3431 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3436 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3437 if (SvTYPE(mysv) == SVt_PVGV) {
3438 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3439 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3446 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3447 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3453 ST(0) = rmscopy(inp,outp) ? &sv_yes : &sv_no;
3460 char* file = __FILE__;
3462 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3463 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3464 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3465 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3466 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3467 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3468 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3469 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);