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+1+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) {
1213 else { /* the VMS spec begins with directories */
1216 while (*cp2 == '-') {
1217 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1220 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1221 if (ts) Safefree(rslt); /* filespecs like */
1222 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1227 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
1229 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1230 if (ts) Safefree(rslt);
1235 while (*cp3 != ':' && *cp3) cp3++;
1237 if (strchr(cp3,']') != NULL) break;
1238 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1240 while (*cp3) *(cp1++) = *(cp3++);
1243 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1244 int offset = cp1 - rslt;
1246 retlen = devlen + dirlen;
1247 Renew(rslt,retlen+1+2*dashes,char);
1248 cp1 = rslt + offset;
1253 for (; cp2 <= dirend; cp2++) {
1256 if (*(cp2+1) == '[') cp2++;
1258 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1259 else if (*cp2 == '.') {
1261 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1262 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1263 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1264 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1265 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1268 else if (*cp2 == '-') {
1269 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1270 while (*cp2 == '-') {
1272 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1274 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1275 if (ts) Safefree(rslt); /* filespecs like */
1276 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
1281 else *(cp1++) = *cp2;
1283 else *(cp1++) = *cp2;
1285 while (*cp2) *(cp1++) = *(cp2++);
1290 } /* end of do_tounixspec() */
1292 /* External entry points */
1293 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1294 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1296 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1297 static char *do_tovmsspec(char *path, char *buf, int ts) {
1298 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1299 char *rslt, *dirend;
1300 register char *cp1, *cp2;
1301 unsigned long int infront = 0, hasdir = 1;
1303 if (path == NULL) return NULL;
1304 if (buf) rslt = buf;
1305 else if (ts) New(7016,rslt,strlen(path)+9,char);
1306 else rslt = __tovmsspec_retbuf;
1307 if (strpbrk(path,"]:>") ||
1308 (dirend = strrchr(path,'/')) == NULL) {
1309 if (path[0] == '.') {
1310 if (path[1] == '\0') strcpy(rslt,"[]");
1311 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1312 else strcpy(rslt,path); /* probably garbage */
1314 else strcpy(rslt,path);
1317 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1318 if (!*(dirend+2)) dirend +=2;
1319 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1324 char trndev[NAM$C_MAXRSS+1];
1328 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1330 islnm = my_trnlnm(rslt,trndev,0);
1331 trnend = islnm ? strlen(trndev) - 1 : 0;
1332 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1333 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1334 /* If the first element of the path is a logical name, determine
1335 * whether it has to be translated so we can add more directories. */
1336 if (!islnm || rooted) {
1339 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1343 if (cp2 != dirend) {
1344 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1345 strcpy(rslt,trndev);
1346 cp1 = rslt + trnend;
1359 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1360 cp2 += 2; /* skip over "./" - it's redundant */
1361 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1363 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1364 *(cp1++) = '-'; /* "../" --> "-" */
1367 if (cp2 > dirend) cp2 = dirend;
1369 else *(cp1++) = '.';
1371 for (; cp2 < dirend; cp2++) {
1373 if (*(cp1-1) != '.') *(cp1++) = '.';
1376 else if (!infront && *cp2 == '.') {
1377 if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1378 else if (*(cp2+1) == '\0') { cp2++; break; }
1379 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1380 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1381 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1382 else { /* back up over previous directory name */
1384 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1385 if (*(cp1-1) == '[') {
1386 memcpy(cp1,"000000.",7);
1391 if (cp2 == dirend) {
1392 if (*(cp1-1) == '.') cp1--;
1396 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1399 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1400 if (*cp2 == '/') *(cp1++) = '.';
1401 else if (*cp2 == '.') *(cp1++) = '_';
1402 else *(cp1++) = *cp2;
1406 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1407 if (hasdir) *(cp1++) = ']';
1408 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1409 while (*cp2) *(cp1++) = *(cp2++);
1414 } /* end of do_tovmsspec() */
1416 /* External entry points */
1417 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1418 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1420 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1421 static char *do_tovmspath(char *path, char *buf, int ts) {
1422 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1424 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1426 if (path == NULL) return NULL;
1427 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1428 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1429 if (buf) return buf;
1431 vmslen = strlen(vmsified);
1432 New(7017,cp,vmslen+1,char);
1433 memcpy(cp,vmsified,vmslen);
1438 strcpy(__tovmspath_retbuf,vmsified);
1439 return __tovmspath_retbuf;
1442 } /* end of do_tovmspath() */
1444 /* External entry points */
1445 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1446 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1449 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1450 static char *do_tounixpath(char *path, char *buf, int ts) {
1451 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1453 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1455 if (path == NULL) return NULL;
1456 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1457 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1458 if (buf) return buf;
1460 unixlen = strlen(unixified);
1461 New(7017,cp,unixlen+1,char);
1462 memcpy(cp,unixified,unixlen);
1467 strcpy(__tounixpath_retbuf,unixified);
1468 return __tounixpath_retbuf;
1471 } /* end of do_tounixpath() */
1473 /* External entry points */
1474 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1475 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1478 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1480 *****************************************************************************
1482 * Copyright (C) 1989-1994 by *
1483 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1485 * Permission is hereby granted for the reproduction of this software, *
1486 * on condition that this copyright notice is included in the reproduction, *
1487 * and that such reproduction is not for purposes of profit or material *
1490 * 27-Aug-1994 Modified for inclusion in perl5 *
1491 * by Charles Bailey bailey@genetics.upenn.edu *
1492 *****************************************************************************
1496 * getredirection() is intended to aid in porting C programs
1497 * to VMS (Vax-11 C). The native VMS environment does not support
1498 * '>' and '<' I/O redirection, or command line wild card expansion,
1499 * or a command line pipe mechanism using the '|' AND background
1500 * command execution '&'. All of these capabilities are provided to any
1501 * C program which calls this procedure as the first thing in the
1503 * The piping mechanism will probably work with almost any 'filter' type
1504 * of program. With suitable modification, it may useful for other
1505 * portability problems as well.
1507 * Author: Mark Pizzolato mark@infocomm.com
1511 struct list_item *next;
1515 static void add_item(struct list_item **head,
1516 struct list_item **tail,
1520 static void expand_wild_cards(char *item,
1521 struct list_item **head,
1522 struct list_item **tail,
1525 static int background_process(int argc, char **argv);
1527 static void pipe_and_fork(char **cmargv);
1529 /*{{{ void getredirection(int *ac, char ***av)*/
1531 getredirection(int *ac, char ***av)
1533 * Process vms redirection arg's. Exit if any error is seen.
1534 * If getredirection() processes an argument, it is erased
1535 * from the vector. getredirection() returns a new argc and argv value.
1536 * In the event that a background command is requested (by a trailing "&"),
1537 * this routine creates a background subprocess, and simply exits the program.
1539 * Warning: do not try to simplify the code for vms. The code
1540 * presupposes that getredirection() is called before any data is
1541 * read from stdin or written to stdout.
1543 * Normal usage is as follows:
1549 * getredirection(&argc, &argv);
1553 int argc = *ac; /* Argument Count */
1554 char **argv = *av; /* Argument Vector */
1555 char *ap; /* Argument pointer */
1556 int j; /* argv[] index */
1557 int item_count = 0; /* Count of Items in List */
1558 struct list_item *list_head = 0; /* First Item in List */
1559 struct list_item *list_tail; /* Last Item in List */
1560 char *in = NULL; /* Input File Name */
1561 char *out = NULL; /* Output File Name */
1562 char *outmode = "w"; /* Mode to Open Output File */
1563 char *err = NULL; /* Error File Name */
1564 char *errmode = "w"; /* Mode to Open Error File */
1565 int cmargc = 0; /* Piped Command Arg Count */
1566 char **cmargv = NULL;/* Piped Command Arg Vector */
1569 * First handle the case where the last thing on the line ends with
1570 * a '&'. This indicates the desire for the command to be run in a
1571 * subprocess, so we satisfy that desire.
1574 if (0 == strcmp("&", ap))
1575 exit(background_process(--argc, argv));
1576 if (*ap && '&' == ap[strlen(ap)-1])
1578 ap[strlen(ap)-1] = '\0';
1579 exit(background_process(argc, argv));
1582 * Now we handle the general redirection cases that involve '>', '>>',
1583 * '<', and pipes '|'.
1585 for (j = 0; j < argc; ++j)
1587 if (0 == strcmp("<", argv[j]))
1591 fprintf(stderr,"No input file after < on command line");
1592 exit(LIB$_WRONUMARG);
1597 if ('<' == *(ap = argv[j]))
1602 if (0 == strcmp(">", ap))
1606 fprintf(stderr,"No output file after > on command line");
1607 exit(LIB$_WRONUMARG);
1626 fprintf(stderr,"No output file after > or >> on command line");
1627 exit(LIB$_WRONUMARG);
1631 if (('2' == *ap) && ('>' == ap[1]))
1648 fprintf(stderr,"No output file after 2> or 2>> on command line");
1649 exit(LIB$_WRONUMARG);
1653 if (0 == strcmp("|", argv[j]))
1657 fprintf(stderr,"No command into which to pipe on command line");
1658 exit(LIB$_WRONUMARG);
1660 cmargc = argc-(j+1);
1661 cmargv = &argv[j+1];
1665 if ('|' == *(ap = argv[j]))
1673 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1676 * Allocate and fill in the new argument vector, Some Unix's terminate
1677 * the list with an extra null pointer.
1679 New(7002, argv, item_count+1, char *);
1681 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1682 argv[j] = list_head->value;
1688 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1689 exit(LIB$_INVARGORD);
1691 pipe_and_fork(cmargv);
1694 /* Check for input from a pipe (mailbox) */
1696 if (1 == isapipe(0))
1698 char mbxname[L_tmpnam];
1700 long int dvi_item = DVI$_DEVBUFSIZ;
1701 $DESCRIPTOR(mbxnam, "");
1702 $DESCRIPTOR(mbxdevnam, "");
1704 /* Input from a pipe, reopen it in binary mode to disable */
1705 /* carriage control processing. */
1709 fprintf(stderr,"'|' and '<' may not both be specified on command line");
1710 exit(LIB$_INVARGORD);
1712 fgetname(stdin, mbxname,1);
1713 mbxnam.dsc$a_pointer = mbxname;
1714 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1715 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1716 mbxdevnam.dsc$a_pointer = mbxname;
1717 mbxdevnam.dsc$w_length = sizeof(mbxname);
1718 dvi_item = DVI$_DEVNAM;
1719 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1720 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1723 freopen(mbxname, "rb", stdin);
1726 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1730 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1732 fprintf(stderr,"Can't open input file %s as stdin",in);
1735 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1737 fprintf(stderr,"Can't open output file %s as stdout",out);
1742 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1744 fprintf(stderr,"Can't open error file %s as stderr",err);
1748 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1753 #ifdef ARGPROC_DEBUG
1754 fprintf(stderr, "Arglist:\n");
1755 for (j = 0; j < *ac; ++j)
1756 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1758 } /* end of getredirection() */
1761 static void add_item(struct list_item **head,
1762 struct list_item **tail,
1768 New(7003,*head,1,struct list_item);
1772 New(7004,(*tail)->next,1,struct list_item);
1773 *tail = (*tail)->next;
1775 (*tail)->value = value;
1779 static void expand_wild_cards(char *item,
1780 struct list_item **head,
1781 struct list_item **tail,
1785 unsigned long int context = 0;
1791 char vmsspec[NAM$C_MAXRSS+1];
1792 $DESCRIPTOR(filespec, "");
1793 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1794 $DESCRIPTOR(resultspec, "");
1795 unsigned long int zero = 0, sts;
1797 if (strcspn(item, "*%") == strlen(item))
1799 add_item(head, tail, item, count);
1802 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1803 resultspec.dsc$b_class = DSC$K_CLASS_D;
1804 resultspec.dsc$a_pointer = NULL;
1805 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1806 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1807 if (!isunix || !filespec.dsc$a_pointer)
1808 filespec.dsc$a_pointer = item;
1809 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1811 * Only return version specs, if the caller specified a version
1813 had_version = strchr(item, ';');
1815 * Only return device and directory specs, if the caller specifed either.
1817 had_device = strchr(item, ':');
1818 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1820 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1821 &defaultspec, 0, 0, &zero))))
1826 New(7005,string,resultspec.dsc$w_length+1,char);
1827 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1828 string[resultspec.dsc$w_length] = '\0';
1829 if (NULL == had_version)
1830 *((char *)strrchr(string, ';')) = '\0';
1831 if ((!had_directory) && (had_device == NULL))
1833 if (NULL == (devdir = strrchr(string, ']')))
1834 devdir = strrchr(string, '>');
1835 strcpy(string, devdir + 1);
1838 * Be consistent with what the C RTL has already done to the rest of
1839 * the argv items and lowercase all of these names.
1841 for (c = string; *c; ++c)
1844 if (isunix) trim_unixpath(item,string);
1845 add_item(head, tail, string, count);
1848 if (sts != RMS$_NMF)
1850 set_vaxc_errno(sts);
1855 set_errno(ENOENT); break;
1857 set_errno(ENODEV); break;
1859 set_errno(EINVAL); break;
1861 set_errno(EACCES); break;
1867 add_item(head, tail, item, count);
1868 _ckvmssts(lib$sfree1_dd(&resultspec));
1869 _ckvmssts(lib$find_file_end(&context));
1872 static int child_st[2];/* Event Flag set when child process completes */
1874 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
1876 static unsigned long int exit_handler(int *status)
1880 if (0 == child_st[0])
1882 #ifdef ARGPROC_DEBUG
1883 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1885 fflush(stdout); /* Have to flush pipe for binary data to */
1886 /* terminate properly -- <tp@mccall.com> */
1887 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1888 sys$dassgn(child_chan);
1890 sys$synch(0, child_st);
1895 static void sig_child(int chan)
1897 #ifdef ARGPROC_DEBUG
1898 fprintf(stderr, "Child Completion AST\n");
1900 if (child_st[0] == 0)
1904 static struct exit_control_block exit_block =
1909 &exit_block.exit_status,
1913 static void pipe_and_fork(char **cmargv)
1916 $DESCRIPTOR(cmddsc, "");
1917 static char mbxname[64];
1918 $DESCRIPTOR(mbxdsc, mbxname);
1920 unsigned long int zero = 0, one = 1;
1922 strcpy(subcmd, cmargv[0]);
1923 for (j = 1; NULL != cmargv[j]; ++j)
1925 strcat(subcmd, " \"");
1926 strcat(subcmd, cmargv[j]);
1927 strcat(subcmd, "\"");
1929 cmddsc.dsc$a_pointer = subcmd;
1930 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1932 create_mbx(&child_chan,&mbxdsc);
1933 #ifdef ARGPROC_DEBUG
1934 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1935 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1937 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1938 0, &pid, child_st, &zero, sig_child,
1940 #ifdef ARGPROC_DEBUG
1941 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1943 sys$dclexh(&exit_block);
1944 if (NULL == freopen(mbxname, "wb", stdout))
1946 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1950 static int background_process(int argc, char **argv)
1952 char command[2048] = "$";
1953 $DESCRIPTOR(value, "");
1954 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1955 static $DESCRIPTOR(null, "NLA0:");
1956 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1958 $DESCRIPTOR(pidstr, "");
1960 unsigned long int flags = 17, one = 1, retsts;
1962 strcat(command, argv[0]);
1965 strcat(command, " \"");
1966 strcat(command, *(++argv));
1967 strcat(command, "\"");
1969 value.dsc$a_pointer = command;
1970 value.dsc$w_length = strlen(value.dsc$a_pointer);
1971 _ckvmssts(lib$set_symbol(&cmd, &value));
1972 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1973 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1974 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1979 #ifdef ARGPROC_DEBUG
1980 fprintf(stderr, "%s\n", command);
1982 sprintf(pidstring, "%08X", pid);
1983 fprintf(stderr, "%s\n", pidstring);
1984 pidstr.dsc$a_pointer = pidstring;
1985 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1986 lib$set_symbol(&pidsymbol, &pidstr);
1990 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1993 * Trim Unix-style prefix off filespec, so it looks like what a shell
1994 * glob expansion would return (i.e. from specified prefix on, not
1995 * full path). Note that returned filespec is Unix-style, regardless
1996 * of whether input filespec was VMS-style or Unix-style.
1998 * Returns !=0 on success, 0 on failure.
2000 /*{{{int trim_unixpath(char *template, char *fspec)*/
2002 trim_unixpath(char *template, char *fspec)
2004 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
2005 register int tmplen;
2007 if (strpbrk(fspec,"]>:") != NULL) {
2008 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2009 else base = unixified;
2012 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
2014 /* Find prefix to template consisting of path elements without wildcards */
2015 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2016 for (cp1 = template; *cp1; cp1++) ;
2017 else while (cp1 >= template && *cp1 != '/') cp1--;
2018 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
2019 tmplen = cp1 - template;
2021 /* Try to find template prefix on filespec */
2022 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
2023 for (; cp2 - base > tmplen; base++) {
2024 if (*base != '/') continue;
2025 if (!memcmp(base + 1,template,tmplen)) break;
2027 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2028 base++; /* Move past leading '/' */
2029 /* Copy down remaining portion of filespec, including trailing NUL */
2030 memmove(fspec,base,cp2 - base + 1);
2033 } /* end of trim_unixpath() */
2038 * VMS readdir() routines.
2039 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2040 * This code has no copyright.
2042 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2043 * Minor modifications to original routines.
2046 /* Number of elements in vms_versions array */
2047 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2050 * Open a directory, return a handle for later use.
2052 /*{{{ DIR *opendir(char*name) */
2057 char dir[NAM$C_MAXRSS+1];
2059 /* Get memory for the handle, and the pattern. */
2061 if (do_tovmspath(name,dir,0) == NULL) {
2062 Safefree((char *)dd);
2065 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2067 /* Fill in the fields; mainly playing with the descriptor. */
2068 (void)sprintf(dd->pattern, "%s*.*",dir);
2071 dd->vms_wantversions = 0;
2072 dd->pat.dsc$a_pointer = dd->pattern;
2073 dd->pat.dsc$w_length = strlen(dd->pattern);
2074 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2075 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2078 } /* end of opendir() */
2082 * Set the flag to indicate we want versions or not.
2084 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2086 vmsreaddirversions(DIR *dd, int flag)
2088 dd->vms_wantversions = flag;
2093 * Free up an opened directory.
2095 /*{{{ void closedir(DIR *dd)*/
2099 (void)lib$find_file_end(&dd->context);
2100 Safefree(dd->pattern);
2101 Safefree((char *)dd);
2106 * Collect all the version numbers for the current file.
2112 struct dsc$descriptor_s pat;
2113 struct dsc$descriptor_s res;
2115 char *p, *text, buff[sizeof dd->entry.d_name];
2117 unsigned long context, tmpsts;
2119 /* Convenient shorthand. */
2122 /* Add the version wildcard, ignoring the "*.*" put on before */
2123 i = strlen(dd->pattern);
2124 New(7008,text,i + e->d_namlen + 3,char);
2125 (void)strcpy(text, dd->pattern);
2126 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2128 /* Set up the pattern descriptor. */
2129 pat.dsc$a_pointer = text;
2130 pat.dsc$w_length = i + e->d_namlen - 1;
2131 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2132 pat.dsc$b_class = DSC$K_CLASS_S;
2134 /* Set up result descriptor. */
2135 res.dsc$a_pointer = buff;
2136 res.dsc$w_length = sizeof buff - 2;
2137 res.dsc$b_dtype = DSC$K_DTYPE_T;
2138 res.dsc$b_class = DSC$K_CLASS_S;
2140 /* Read files, collecting versions. */
2141 for (context = 0, e->vms_verscount = 0;
2142 e->vms_verscount < VERSIZE(e);
2143 e->vms_verscount++) {
2144 tmpsts = lib$find_file(&pat, &res, &context);
2145 if (tmpsts == RMS$_NMF || context == 0) break;
2147 buff[sizeof buff - 1] = '\0';
2148 if ((p = strchr(buff, ';')))
2149 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2151 e->vms_versions[e->vms_verscount] = -1;
2154 _ckvmssts(lib$find_file_end(&context));
2157 } /* end of collectversions() */
2160 * Read the next entry from the directory.
2162 /*{{{ struct dirent *readdir(DIR *dd)*/
2166 struct dsc$descriptor_s res;
2167 char *p, buff[sizeof dd->entry.d_name];
2168 unsigned long int tmpsts;
2170 /* Set up result descriptor, and get next file. */
2171 res.dsc$a_pointer = buff;
2172 res.dsc$w_length = sizeof buff - 2;
2173 res.dsc$b_dtype = DSC$K_DTYPE_T;
2174 res.dsc$b_class = DSC$K_CLASS_S;
2175 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2176 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2177 if (!(tmpsts & 1)) {
2178 set_vaxc_errno(tmpsts);
2181 set_errno(EACCES); break;
2183 set_errno(ENODEV); break;
2186 set_errno(ENOENT); break;
2193 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2194 buff[sizeof buff - 1] = '\0';
2195 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2198 /* Skip any directory component and just copy the name. */
2199 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2200 else (void)strcpy(dd->entry.d_name, buff);
2202 /* Clobber the version. */
2203 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2205 dd->entry.d_namlen = strlen(dd->entry.d_name);
2206 dd->entry.vms_verscount = 0;
2207 if (dd->vms_wantversions) collectversions(dd);
2210 } /* end of readdir() */
2214 * Return something that can be used in a seekdir later.
2216 /*{{{ long telldir(DIR *dd)*/
2225 * Return to a spot where we used to be. Brute force.
2227 /*{{{ void seekdir(DIR *dd,long count)*/
2229 seekdir(DIR *dd, long count)
2231 int vms_wantversions;
2233 /* If we haven't done anything yet... */
2237 /* Remember some state, and clear it. */
2238 vms_wantversions = dd->vms_wantversions;
2239 dd->vms_wantversions = 0;
2240 _ckvmssts(lib$find_file_end(&dd->context));
2243 /* The increment is in readdir(). */
2244 for (dd->count = 0; dd->count < count; )
2247 dd->vms_wantversions = vms_wantversions;
2249 } /* end of seekdir() */
2252 /* VMS subprocess management
2254 * my_vfork() - just a vfork(), after setting a flag to record that
2255 * the current script is trying a Unix-style fork/exec.
2257 * vms_do_aexec() and vms_do_exec() are called in response to the
2258 * perl 'exec' function. If this follows a vfork call, then they
2259 * call out the the regular perl routines in doio.c which do an
2260 * execvp (for those who really want to try this under VMS).
2261 * Otherwise, they do exactly what the perl docs say exec should
2262 * do - terminate the current script and invoke a new command
2263 * (See below for notes on command syntax.)
2265 * do_aspawn() and do_spawn() implement the VMS side of the perl
2266 * 'system' function.
2268 * Note on command arguments to perl 'exec' and 'system': When handled
2269 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2270 * are concatenated to form a DCL command string. If the first arg
2271 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2272 * the the command string is hrnded off to DCL directly. Otherwise,
2273 * the first token of the command is taken as the filespec of an image
2274 * to run. The filespec is expanded using a default type of '.EXE' and
2275 * the process defaults for device, directory, etc., and the resultant
2276 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2277 * the command string as parameters. This is perhaps a bit compicated,
2278 * but I hope it will form a happy medium between what VMS folks expect
2279 * from lib$spawn and what Unix folks expect from exec.
2282 static int vfork_called;
2284 /*{{{int my_vfork()*/
2294 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2302 if (VMScmd.dsc$a_pointer) {
2303 Safefree(VMScmd.dsc$a_pointer);
2304 VMScmd.dsc$w_length = 0;
2305 VMScmd.dsc$a_pointer = Nullch;
2310 setup_argstr(SV *really, SV **mark, SV **sp)
2312 char *junk, *tmps = Nullch;
2313 register size_t cmdlen = 0;
2319 tmps = SvPV(really,rlen);
2326 for (idx++; idx <= sp; idx++) {
2328 junk = SvPVx(*idx,rlen);
2329 cmdlen += rlen ? rlen + 1 : 0;
2332 New(401,Cmd,cmdlen+1,char);
2334 if (tmps && *tmps) {
2339 while (++mark <= sp) {
2342 strcat(Cmd,SvPVx(*mark,na));
2347 } /* end of setup_argstr() */
2350 static unsigned long int
2351 setup_cmddsc(char *cmd, int check_img)
2353 char resspec[NAM$C_MAXRSS+1];
2354 $DESCRIPTOR(defdsc,".EXE");
2355 $DESCRIPTOR(resdsc,resspec);
2356 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2357 unsigned long int cxt = 0, flags = 1, retsts;
2358 register char *s, *rest, *cp;
2359 register int isdcl = 0;
2362 while (*s && isspace(*s)) s++;
2364 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2365 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2366 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2367 if (*cp == ':' || *cp == '[' || *cp == '<') {
2375 if (isdcl) { /* It's a DCL command, just do it. */
2376 VMScmd.dsc$w_length = strlen(cmd);
2378 VMScmd.dsc$a_pointer = Cmd;
2379 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2381 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2383 else { /* assume first token is an image spec */
2385 while (*s && !isspace(*s)) s++;
2387 imgdsc.dsc$a_pointer = cmd;
2388 imgdsc.dsc$w_length = s - cmd;
2389 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2390 if (!(retsts & 1)) {
2391 /* just hand off status values likely to be due to user error */
2392 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2393 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2394 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2395 else { _ckvmssts(retsts); }
2398 _ckvmssts(lib$find_file_end(&cxt));
2400 while (*s && !isspace(*s)) s++;
2402 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2403 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2404 strcat(VMScmd.dsc$a_pointer,resspec);
2405 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2406 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2411 } /* end of setup_cmddsc() */
2413 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2415 vms_do_aexec(SV *really,SV **mark,SV **sp)
2418 if (vfork_called) { /* this follows a vfork - act Unixish */
2420 if (vfork_called < 0) {
2421 warn("Internal inconsistency in tracking vforks");
2424 else return do_aexec(really,mark,sp);
2426 /* no vfork - act VMSish */
2427 return vms_do_exec(setup_argstr(really,mark,sp));
2432 } /* end of vms_do_aexec() */
2435 /* {{{bool vms_do_exec(char *cmd) */
2437 vms_do_exec(char *cmd)
2440 if (vfork_called) { /* this follows a vfork - act Unixish */
2442 if (vfork_called < 0) {
2443 warn("Internal inconsistency in tracking vforks");
2446 else return do_exec(cmd);
2449 { /* no vfork - act VMSish */
2450 unsigned long int retsts;
2452 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2453 retsts = lib$do_command(&VMScmd);
2456 set_vaxc_errno(retsts);
2458 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2464 } /* end of vms_do_exec() */
2467 unsigned long int do_spawn(char *);
2469 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2471 do_aspawn(SV *really,SV **mark,SV **sp)
2473 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2476 } /* end of do_aspawn() */
2479 /* {{{unsigned long int do_spawn(char *cmd) */
2483 unsigned long int substs, hadcmd = 1;
2485 if (!cmd || !*cmd) {
2487 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2489 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2490 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2495 set_vaxc_errno(substs);
2497 warn("Can't exec \"%s\": %s",
2498 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2503 } /* end of do_spawn() */
2507 * A simple fwrite replacement which outputs itmsz*nitm chars without
2508 * introducing record boundaries every itmsz chars.
2510 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2512 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2514 register char *cp, *end;
2516 end = (char *)src + itmsz * nitm;
2518 while ((char *)src <= end) {
2519 for (cp = src; cp <= end; cp++) if (!*cp) break;
2520 if (fputs(src,dest) == EOF) return EOF;
2522 if (fputc('\0',dest) == EOF) return EOF;
2528 } /* end of my_fwrite() */
2532 * Here are replacements for the following Unix routines in the VMS environment:
2533 * getpwuid Get information for a particular UIC or UID
2534 * getpwnam Get information for a named user
2535 * getpwent Get information for each user in the rights database
2536 * setpwent Reset search to the start of the rights database
2537 * endpwent Finish searching for users in the rights database
2539 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2540 * (defined in pwd.h), which contains the following fields:-
2542 * char *pw_name; Username (in lower case)
2543 * char *pw_passwd; Hashed password
2544 * unsigned int pw_uid; UIC
2545 * unsigned int pw_gid; UIC group number
2546 * char *pw_unixdir; Default device/directory (VMS-style)
2547 * char *pw_gecos; Owner name
2548 * char *pw_dir; Default device/directory (Unix-style)
2549 * char *pw_shell; Default CLI name (eg. DCL)
2551 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2553 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2554 * not the UIC member number (eg. what's returned by getuid()),
2555 * getpwuid() can accept either as input (if uid is specified, the caller's
2556 * UIC group is used), though it won't recognise gid=0.
2558 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2559 * information about other users in your group or in other groups, respectively.
2560 * If the required privilege is not available, then these routines fill only
2561 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2564 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2567 /* sizes of various UAF record fields */
2568 #define UAI$S_USERNAME 12
2569 #define UAI$S_IDENT 31
2570 #define UAI$S_OWNER 31
2571 #define UAI$S_DEFDEV 31
2572 #define UAI$S_DEFDIR 63
2573 #define UAI$S_DEFCLI 31
2576 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2577 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2578 (uic).uic$v_group != UIC$K_WILD_GROUP)
2580 static char __empty[]= "";
2581 static struct passwd __passwd_empty=
2582 {(char *) __empty, (char *) __empty, 0, 0,
2583 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2584 static int contxt= 0;
2585 static struct passwd __pwdcache;
2586 static char __pw_namecache[UAI$S_IDENT+1];
2588 static char *_mystrtolower(char *str)
2590 if (str) for (; *str; ++str) *str= tolower(*str);
2595 * This routine does most of the work extracting the user information.
2597 static int fillpasswd (const char *name, struct passwd *pwd)
2600 unsigned char length;
2601 char pw_gecos[UAI$S_OWNER+1];
2603 static union uicdef uic;
2605 unsigned char length;
2606 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2609 unsigned char length;
2610 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2613 unsigned char length;
2614 char pw_shell[UAI$S_DEFCLI+1];
2616 static char pw_passwd[UAI$S_PWD+1];
2618 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2619 struct dsc$descriptor_s name_desc;
2620 unsigned long int sts;
2622 static struct itmlst_3 itmlst[]= {
2623 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2624 {sizeof(uic), UAI$_UIC, &uic, &luic},
2625 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2626 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2627 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2628 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2629 {0, 0, NULL, NULL}};
2631 name_desc.dsc$w_length= strlen(name);
2632 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2633 name_desc.dsc$b_class= DSC$K_CLASS_S;
2634 name_desc.dsc$a_pointer= (char *) name;
2636 /* Note that sys$getuai returns many fields as counted strings. */
2637 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2638 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2639 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2641 else { _ckvmssts(sts); }
2642 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2644 if ((int) owner.length < lowner) lowner= (int) owner.length;
2645 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2646 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2647 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2648 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2649 owner.pw_gecos[lowner]= '\0';
2650 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2651 defcli.pw_shell[ldefcli]= '\0';
2652 if (valid_uic(uic)) {
2653 pwd->pw_uid= uic.uic$l_uic;
2654 pwd->pw_gid= uic.uic$v_group;
2657 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2658 pwd->pw_passwd= pw_passwd;
2659 pwd->pw_gecos= owner.pw_gecos;
2660 pwd->pw_dir= defdev.pw_dir;
2661 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2662 pwd->pw_shell= defcli.pw_shell;
2663 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2665 ldir= strlen(pwd->pw_unixdir) - 1;
2666 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2669 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2670 _mystrtolower(pwd->pw_unixdir);
2675 * Get information for a named user.
2677 /*{{{struct passwd *getpwnam(char *name)*/
2678 struct passwd *my_getpwnam(char *name)
2680 struct dsc$descriptor_s name_desc;
2682 unsigned long int status, stat;
2684 __pwdcache = __passwd_empty;
2685 if (!fillpasswd(name, &__pwdcache)) {
2686 /* We still may be able to determine pw_uid and pw_gid */
2687 name_desc.dsc$w_length= strlen(name);
2688 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2689 name_desc.dsc$b_class= DSC$K_CLASS_S;
2690 name_desc.dsc$a_pointer= (char *) name;
2691 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2692 __pwdcache.pw_uid= uic.uic$l_uic;
2693 __pwdcache.pw_gid= uic.uic$v_group;
2696 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2697 set_vaxc_errno(stat);
2698 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2701 else { _ckvmssts(stat); }
2704 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2705 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2706 __pwdcache.pw_name= __pw_namecache;
2708 } /* end of my_getpwnam() */
2712 * Get information for a particular UIC or UID.
2713 * Called by my_getpwent with uid=-1 to list all users.
2715 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2716 struct passwd *my_getpwuid(Uid_t uid)
2718 const $DESCRIPTOR(name_desc,__pw_namecache);
2719 unsigned short lname;
2721 unsigned long int status;
2723 if (uid == (unsigned int) -1) {
2725 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2726 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2727 set_vaxc_errno(status);
2728 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2732 else { _ckvmssts(status); }
2733 } while (!valid_uic (uic));
2737 if (!uic.uic$v_group)
2738 uic.uic$v_group= getgid();
2740 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2741 else status = SS$_IVIDENT;
2742 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2743 status == RMS$_PRV) {
2744 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2747 else { _ckvmssts(status); }
2749 __pw_namecache[lname]= '\0';
2750 _mystrtolower(__pw_namecache);
2752 __pwdcache = __passwd_empty;
2753 __pwdcache.pw_name = __pw_namecache;
2755 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2756 The identifier's value is usually the UIC, but it doesn't have to be,
2757 so if we can, we let fillpasswd update this. */
2758 __pwdcache.pw_uid = uic.uic$l_uic;
2759 __pwdcache.pw_gid = uic.uic$v_group;
2761 fillpasswd(__pw_namecache, &__pwdcache);
2764 } /* end of my_getpwuid() */
2768 * Get information for next user.
2770 /*{{{struct passwd *my_getpwent()*/
2771 struct passwd *my_getpwent()
2773 return (my_getpwuid((unsigned int) -1));
2778 * Finish searching rights database for users.
2780 /*{{{void my_endpwent()*/
2784 _ckvmssts(sys$finish_rdb(&contxt));
2792 * If the CRTL has a real gmtime(), use it, else look for the logical
2793 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2794 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
2795 * to translate to the number of seconds which must be added to UTC
2796 * to get to the local time of the system.
2797 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
2800 /*{{{struct tm *my_gmtime(const time_t *time)*/
2801 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
2802 * so we can call the CRTL's routine to see if it works.
2806 my_gmtime(const time_t *time)
2808 static int gmtime_emulation_type;
2809 static time_t utc_offset_secs;
2813 if (gmtime_emulation_type == 0) {
2814 gmtime_emulation_type++;
2816 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
2817 gmtime_emulation_type++;
2818 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2819 gmtime_emulation_type++;
2821 utc_offset_secs = (time_t) atol(p);
2825 switch (gmtime_emulation_type) {
2827 return gmtime(time);
2829 when = *time - utc_offset_secs;
2830 return localtime(&when);
2832 warn("gmtime not supported on this system");
2835 } /* end of my_gmtime() */
2836 /* Reset definition for later calls */
2837 #define gmtime(t) my_gmtime(t)
2842 * flex_stat, flex_fstat
2843 * basic stat, but gets it right when asked to stat
2844 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2847 /* encode_dev packs a VMS device name string into an integer to allow
2848 * simple comparisons. This can be used, for example, to check whether two
2849 * files are located on the same device, by comparing their encoded device
2850 * names. Even a string comparison would not do, because stat() reuses the
2851 * device name buffer for each call; so without encode_dev, it would be
2852 * necessary to save the buffer and use strcmp (this would mean a number of
2853 * changes to the standard Perl code, to say nothing of what a Perl script
2856 * The device lock id, if it exists, should be unique (unless perhaps compared
2857 * with lock ids transferred from other nodes). We have a lock id if the disk is
2858 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2859 * device names. Thus we use the lock id in preference, and only if that isn't
2860 * available, do we try to pack the device name into an integer (flagged by
2861 * the sign bit (LOCKID_MASK) being set).
2863 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2864 * name and its encoded form, but it seems very unlikely that we will find
2865 * two files on different disks that share the same encoded device names,
2866 * and even more remote that they will share the same file id (if the test
2867 * is to check for the same file).
2869 * A better method might be to use sys$device_scan on the first call, and to
2870 * search for the device, returning an index into the cached array.
2871 * The number returned would be more intelligable.
2872 * This is probably not worth it, and anyway would take quite a bit longer
2873 * on the first call.
2875 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2876 static dev_t encode_dev (const char *dev)
2879 unsigned long int f;
2884 if (!dev || !dev[0]) return 0;
2888 struct dsc$descriptor_s dev_desc;
2889 unsigned long int status, lockid, item = DVI$_LOCKID;
2891 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2892 can try that first. */
2893 dev_desc.dsc$w_length = strlen (dev);
2894 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2895 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2896 dev_desc.dsc$a_pointer = (char *) dev;
2897 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2898 if (lockid) return (lockid & ~LOCKID_MASK);
2902 /* Otherwise we try to encode the device name */
2906 for (q = dev + strlen(dev); q--; q >= dev) {
2909 else if (isalpha (toupper (*q)))
2910 c= toupper (*q) - 'A' + (char)10;
2912 continue; /* Skip '$'s */
2914 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2916 enc += f * (unsigned long int) c;
2918 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2920 } /* end of encode_dev() */
2922 static char namecache[NAM$C_MAXRSS+1];
2925 is_null_device(name)
2928 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2929 The underscore prefix, controller letter, and unit number are
2930 independently optional; for our purposes, the colon punctuation
2931 is not. The colon can be trailed by optional directory and/or
2932 filename, but two consecutive colons indicates a nodename rather
2933 than a device. [pr] */
2934 if (*name == '_') ++name;
2935 if (tolower(*name++) != 'n') return 0;
2936 if (tolower(*name++) != 'l') return 0;
2937 if (tolower(*name) == 'a') ++name;
2938 if (*name == '0') ++name;
2939 return (*name++ == ':') && (*name != ':');
2942 /* Do the permissions allow some operation? Assumes statcache already set. */
2943 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
2944 * subset of the applicable information.
2946 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
2948 cando(I32 bit, I32 effective, struct stat *statbufp)
2950 if (statbufp == &statcache)
2951 return cando_by_name(bit,effective,namecache);
2953 char fname[NAM$C_MAXRSS+1];
2954 unsigned long int retsts;
2955 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
2956 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2958 /* If the struct mystat is stale, we're OOL; stat() overwrites the
2959 device name on successive calls */
2960 devdsc.dsc$a_pointer = statbufp->st_devnam;
2961 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
2962 namdsc.dsc$a_pointer = fname;
2963 namdsc.dsc$w_length = sizeof fname - 1;
2965 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
2966 &namdsc.dsc$w_length,0,0);
2968 fname[namdsc.dsc$w_length] = '\0';
2969 return cando_by_name(bit,effective,fname);
2971 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
2972 warn("Can't get filespec - stale stat buffer?\n");
2976 return FALSE; /* Should never get to here */
2978 } /* end of cando() */
2982 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
2984 cando_by_name(I32 bit, I32 effective, char *fname)
2986 static char usrname[L_cuserid];
2987 static struct dsc$descriptor_s usrdsc =
2988 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
2990 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
2991 unsigned short int retlen;
2992 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2993 union prvdef curprv;
2994 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
2995 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
2996 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
2999 if (!fname || !*fname) return FALSE;
3000 if (!usrdsc.dsc$w_length) {
3002 usrdsc.dsc$w_length = strlen(usrname);
3004 namdsc.dsc$w_length = strlen(fname);
3005 namdsc.dsc$a_pointer = fname;
3010 access = ARM$M_EXECUTE;
3015 access = ARM$M_READ;
3020 access = ARM$M_WRITE;
3025 access = ARM$M_DELETE;
3031 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3032 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
3033 retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
3034 if (retsts == SS$_NORMAL) {
3035 if (!privused) return TRUE;
3036 /* We can get access, but only by using privs. Do we have the
3037 necessary privs currently enabled? */
3038 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3039 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3040 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3041 !curprv.prv$v_bypass) return FALSE;
3042 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3043 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3044 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3049 return FALSE; /* Should never get here */
3051 } /* end of cando_by_name() */
3055 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3057 flex_fstat(int fd, struct stat *statbuf)
3059 char fspec[NAM$C_MAXRSS+1];
3061 if (!getname(fd,fspec,1)) return -1;
3062 return flex_stat(fspec,statbuf);
3064 } /* end of flex_fstat() */
3067 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3068 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3069 * 'struct stat' elsewhere in Perl would use our struct. We go back
3070 * to the system version here, since we're actually calling their
3075 flex_stat(char *fspec, struct mystat *statbufp)
3077 char fileified[NAM$C_MAXRSS+1];
3078 int retval,myretval;
3079 struct mystat tmpbuf;
3082 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3083 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3084 memset(statbufp,0,sizeof *statbufp);
3085 statbufp->st_dev = encode_dev("_NLA0:");
3086 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3087 statbufp->st_uid = 0x00010001;
3088 statbufp->st_gid = 0x0001;
3089 time((time_t *)&statbufp->st_mtime);
3090 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3094 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3096 myretval = stat(fileified,(stat_t *) &tmpbuf);
3098 retval = stat(fspec,(stat_t *) statbufp);
3104 else if (!retval) { /* Dir with same name. Substitute it. */
3105 statbufp->st_mode &= ~S_IFDIR;
3106 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3107 strcpy(namecache,fileified);
3110 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3113 } /* end of flex_stat() */
3114 /* Reset definition for later calls */
3118 /*{{{char *my_getlogin()*/
3119 /* VMS cuserid == Unix getlogin, except calling sequence */
3123 static char user[L_cuserid];
3124 return cuserid(user);
3129 /*** The following glue provides 'hooks' to make some of the routines
3130 * from this file available from Perl. These routines are sufficiently
3131 * basic, and are required sufficiently early in the build process,
3132 * that's it's nice to have them available to miniperl as well as the
3133 * full Perl, so they're set up here instead of in an extension. The
3134 * Perl code which handles importation of these names into a given
3135 * package lives in [.VMS]Filespec.pm in @INC.
3139 vmsify_fromperl(CV *cv)
3144 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3145 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3146 ST(0) = sv_newmortal();
3147 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3152 unixify_fromperl(CV *cv)
3157 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3158 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3159 ST(0) = sv_newmortal();
3160 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3165 fileify_fromperl(CV *cv)
3170 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3171 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3172 ST(0) = sv_newmortal();
3173 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3178 pathify_fromperl(CV *cv)
3183 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3184 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3185 ST(0) = sv_newmortal();
3186 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3191 vmspath_fromperl(CV *cv)
3196 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3197 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3198 ST(0) = sv_newmortal();
3199 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3204 unixpath_fromperl(CV *cv)
3209 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3210 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3211 ST(0) = sv_newmortal();
3212 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3217 candelete_fromperl(CV *cv)
3220 char vmsspec[NAM$C_MAXRSS+1];
3222 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3223 if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf))
3225 else ST(0) = &sv_no;
3232 char* file = __FILE__;
3234 newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
3235 newXS("VMS::Filespec::unixify",unixify_fromperl,file);
3236 newXS("VMS::Filespec::pathify",pathify_fromperl,file);
3237 newXS("VMS::Filespec::fileify",fileify_fromperl,file);
3238 newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
3239 newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
3240 newXS("VMS::Filespec::candelete",candelete_fromperl,file);