3 * VMS-specific routines for perl5
5 * Last revised: 18-Jul-1996 by Charles Bailey bailey@genetics.upenn.edu
14 #include <climsgdef.h>
23 #include <lib$routines.h>
36 #ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
37 # define SS$_NOSUCHOBJECT 2696
40 /* Don't intercept calls to vfork, since my_vfork below needs to
41 * get to the underlying CRTL routine. */
42 #define __DONT_MASK_VFORK
47 /* gcc's header files don't #define direct access macros
48 * corresponding to VAXC's variant structs */
50 # define uic$v_format uic$r_uic_form.uic$v_format
51 # define uic$v_group uic$r_uic_form.uic$v_group
52 # define uic$v_member uic$r_uic_form.uic$v_member
53 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
54 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
55 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
56 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
61 unsigned short int buflen;
62 unsigned short int itmcode;
64 unsigned short int *retlen;
67 static char *__mystrtolower(char *str)
69 if (str) for (; *str; ++str) *str= tolower(*str);
74 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
76 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
77 unsigned short int eqvlen;
78 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
79 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
80 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
81 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
82 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
85 if (!lnm || idx > LNM$_MAX_INDEX) {
86 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
88 if (!eqv) eqv = __my_trnlnm_eqv;
89 lnmlst[1].bufadr = (void *)eqv;
90 lnmdsc.dsc$a_pointer = lnm;
91 lnmdsc.dsc$w_length = strlen(lnm);
92 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
93 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
94 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
96 else if (retsts & 1) {
100 _ckvmssts(retsts); /* Must be an error */
101 return 0; /* Not reached, assuming _ckvmssts() bails out */
103 } /* end of my_trnlnm */
106 * Translate a logical name. Substitute for CRTL getenv() to avoid
107 * memory leak, and to keep my_getenv() and my_setenv() in the same
108 * domain (mostly - my_getenv() need not return a translation from
109 * the process logical name table)
111 * Note: Uses static buffer -- not thread-safe!
113 /*{{{ char *my_getenv(char *lnm)*/
117 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
118 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
119 unsigned long int idx = 0;
121 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
123 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
124 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
125 return __my_getenv_eqv;
128 if ((cp2 = strchr(uplnm,';')) != NULL) {
130 idx = strtoul(cp2+1,NULL,0);
132 if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
133 return __my_getenv_eqv;
136 unsigned long int retsts;
137 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
138 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
139 DSC$K_CLASS_S, __my_getenv_eqv};
140 symdsc.dsc$w_length = cp1 - lnm;
141 symdsc.dsc$a_pointer = uplnm;
142 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
143 if (retsts == LIB$_INVSYMNAM) return Nullch;
144 if (retsts != LIB$_NOSUCHSYM) {
145 /* We want to return only logical names or CRTL Unix emulations */
146 if (retsts & 1) return Nullch;
149 /* Try for CRTL emulation of a Unix/POSIX name */
150 else return getenv(lnm);
155 } /* end of my_getenv() */
158 /*{{{ void my_setenv(char *lnm, char *eqv)*/
160 my_setenv(char *lnm,char *eqv)
161 /* Define a supervisor-mode logical name in the process table.
162 * In the future we'll add tables, attribs, and acmodes,
163 * probably through a different call.
166 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
167 unsigned long int retsts, usermode = PSL$C_USER;
168 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
169 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
170 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
172 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
173 lnmdsc.dsc$w_length = cp1 - lnm;
175 if (!eqv || !*eqv) { /* we're deleting a logical name */
176 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
177 if (retsts == SS$_IVLOGNAM) return;
178 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
180 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
181 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
185 eqvdsc.dsc$w_length = strlen(eqv);
186 eqvdsc.dsc$a_pointer = eqv;
188 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
191 } /* end of my_setenv() */
195 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
196 /* my_crypt - VMS password hashing
197 * my_crypt() provides an interface compatible with the Unix crypt()
198 * C library function, and uses sys$hash_password() to perform VMS
199 * password hashing. The quadword hashed password value is returned
200 * as a NUL-terminated 8 character string. my_crypt() does not change
201 * the case of its string arguments; in order to match the behavior
202 * of LOGINOUT et al., alphabetic characters in both arguments must
203 * be upcased by the caller.
206 my_crypt(const char *textpasswd, const char *usrname)
208 # ifndef UAI$C_PREFERRED_ALGORITHM
209 # define UAI$C_PREFERRED_ALGORITHM 127
211 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
212 unsigned short int salt = 0;
213 unsigned long int sts;
215 unsigned short int dsc$w_length;
216 unsigned char dsc$b_type;
217 unsigned char dsc$b_class;
218 const char * dsc$a_pointer;
219 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
220 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
221 struct itmlst_3 uailst[3] = {
222 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
223 { sizeof salt, UAI$_SALT, &salt, 0},
224 { 0, 0, NULL, NULL}};
227 usrdsc.dsc$w_length = strlen(usrname);
228 usrdsc.dsc$a_pointer = usrname;
229 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
236 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
242 if (sts != RMS$_RNF) return NULL;
245 txtdsc.dsc$w_length = strlen(textpasswd);
246 txtdsc.dsc$a_pointer = textpasswd;
247 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
248 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
251 return (char *) hash;
253 } /* end of my_crypt() */
257 static char *do_fileify_dirspec(char *, char *, int);
258 static char *do_tovmsspec(char *, char *, int);
260 /*{{{int do_rmdir(char *name)*/
264 char dirfile[NAM$C_MAXRSS+1];
268 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
269 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
270 else retval = kill_file(dirfile);
273 } /* end of do_rmdir */
277 * Delete any file to which user has control access, regardless of whether
278 * delete access is explicitly allowed.
279 * Limitations: User must have write access to parent directory.
280 * Does not block signals or ASTs; if interrupted in midstream
281 * may leave file with an altered ACL.
284 /*{{{int kill_file(char *name)*/
286 kill_file(char *name)
288 char vmsname[NAM$C_MAXRSS+1];
289 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
290 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
291 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
293 unsigned char myace$b_length;
294 unsigned char myace$b_type;
295 unsigned short int myace$w_flags;
296 unsigned long int myace$l_access;
297 unsigned long int myace$l_ident;
298 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
299 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
300 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
302 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
303 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
304 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
305 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
306 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
307 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
309 if (!remove(name)) return 0; /* Can we just get rid of it? */
311 /* No, so we get our own UIC to use as a rights identifier,
312 * and the insert an ACE at the head of the ACL which allows us
313 * to delete the file.
315 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
316 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
317 fildsc.dsc$w_length = strlen(vmsname);
318 fildsc.dsc$a_pointer = vmsname;
320 newace.myace$l_ident = oldace.myace$l_ident;
321 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
323 set_vaxc_errno(aclsts);
326 /* Grab any existing ACEs with this identifier in case we fail */
327 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
328 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
329 || fndsts == SS$_NOMOREACE ) {
330 /* Add the new ACE . . . */
331 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
333 if ((rmsts = remove(name))) {
334 /* We blew it - dir with files in it, no write priv for
335 * parent directory, etc. Put things back the way they were. */
336 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
339 addlst[0].bufadr = &oldace;
340 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
347 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
348 /* We just deleted it, so of course it's not there. Some versions of
349 * VMS seem to return success on the unlock operation anyhow (after all
350 * the unlock is successful), but others don't.
352 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
353 if (aclsts & 1) aclsts = fndsts;
356 set_vaxc_errno(aclsts);
362 } /* end of kill_file() */
365 /* my_utime - update modification time of a file
366 * calling sequence is identical to POSIX utime(), but under
367 * VMS only the modification time is changed; ODS-2 does not
368 * maintain access times. Restrictions differ from the POSIX
369 * definition in that the time can be changed as long as the
370 * caller has permission to execute the necessary IO$_MODIFY $QIO;
371 * no separate checks are made to insure that the caller is the
372 * owner of the file or has special privs enabled.
373 * Code here is based on Joe Meadows' FILE utility.
376 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
377 * to VMS epoch (01-JAN-1858 00:00:00.00)
378 * in 100 ns intervals.
380 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
382 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
383 int my_utime(char *file, struct utimbuf *utimes)
386 long int bintime[2], len = 2, lowbit, unixtime,
387 secscale = 10000000; /* seconds --> 100 ns intervals */
388 unsigned long int chan, iosb[2], retsts;
389 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
390 struct FAB myfab = cc$rms_fab;
391 struct NAM mynam = cc$rms_nam;
392 #if defined (__DECC) && defined (__VAX)
393 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
394 * at least through VMS V6.1, which causes a type-conversion warning.
396 # pragma message save
397 # pragma message disable cvtdiftypes
399 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
401 #if defined (__DECC) && defined (__VAX)
402 /* This should be right after the declaration of myatr, but due
403 * to a bug in VAX DEC C, this takes effect a statement early.
405 # pragma message restore
407 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
408 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
409 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
411 if (file == NULL || *file == '\0') {
413 set_vaxc_errno(LIB$_INVARG);
416 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
418 if (utimes != NULL) {
419 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
420 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
421 * Since time_t is unsigned long int, and lib$emul takes a signed long int
422 * as input, we force the sign bit to be clear by shifting unixtime right
423 * one bit, then multiplying by an extra factor of 2 in lib$emul().
425 lowbit = (utimes->modtime & 1) ? secscale : 0;
426 unixtime = (long int) utimes->modtime;
427 unixtime >> 1; secscale << 1;
428 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
431 set_vaxc_errno(retsts);
434 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
437 set_vaxc_errno(retsts);
442 /* Just get the current time in VMS format directly */
443 retsts = sys$gettim(bintime);
446 set_vaxc_errno(retsts);
451 myfab.fab$l_fna = vmsspec;
452 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
453 myfab.fab$l_nam = &mynam;
454 mynam.nam$l_esa = esa;
455 mynam.nam$b_ess = (unsigned char) sizeof esa;
456 mynam.nam$l_rsa = rsa;
457 mynam.nam$b_rss = (unsigned char) sizeof rsa;
459 /* Look for the file to be affected, letting RMS parse the file
460 * specification for us as well. I have set errno using only
461 * values documented in the utime() man page for VMS POSIX.
463 retsts = sys$parse(&myfab,0,0);
465 set_vaxc_errno(retsts);
466 if (retsts == RMS$_PRV) set_errno(EACCES);
467 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
468 else set_errno(EVMSERR);
471 retsts = sys$search(&myfab,0,0);
473 set_vaxc_errno(retsts);
474 if (retsts == RMS$_PRV) set_errno(EACCES);
475 else if (retsts == RMS$_FNF) set_errno(ENOENT);
476 else set_errno(EVMSERR);
480 devdsc.dsc$w_length = mynam.nam$b_dev;
481 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
483 retsts = sys$assign(&devdsc,&chan,0,0);
485 set_vaxc_errno(retsts);
486 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
487 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
488 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
489 else set_errno(EVMSERR);
493 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
494 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
496 memset((void *) &myfib, 0, sizeof myfib);
498 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
499 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
500 /* This prevents the revision time of the file being reset to the current
501 * time as a result of our IO$_MODIFY $QIO. */
502 myfib.fib$l_acctl = FIB$M_NORECORD;
504 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
505 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
506 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
508 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
509 _ckvmssts(sys$dassgn(chan));
510 if (retsts & 1) retsts = iosb[0];
512 set_vaxc_errno(retsts);
513 if (retsts == SS$_NOPRIV) set_errno(EACCES);
514 else set_errno(EVMSERR);
519 } /* end of my_utime() */
523 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
525 static unsigned long int mbxbufsiz;
526 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
530 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
531 * preprocessor consant BUFSIZ from stdio.h as the size of the
534 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
535 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
537 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
539 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
540 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
542 } /* end of create_mbx() */
544 /*{{{ my_popen and my_pclose*/
547 struct pipe_details *next;
548 FILE *fp; /* stdio file pointer to pipe mailbox */
549 int pid; /* PID of subprocess */
550 int mode; /* == 'r' if pipe open for reading */
551 int done; /* subprocess has completed */
552 unsigned long int completion; /* termination status of subprocess */
555 struct exit_control_block
557 struct exit_control_block *flink;
558 unsigned long int (*exit_routine)();
559 unsigned long int arg_count;
560 unsigned long int *status_address;
561 unsigned long int exit_status;
564 static struct pipe_details *open_pipes = NULL;
565 static $DESCRIPTOR(nl_desc, "NL:");
566 static int waitpid_asleep = 0;
568 static unsigned long int
571 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
573 while (open_pipes != NULL) {
574 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
575 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
578 if (!open_pipes->done) /* We tried to be nice . . . */
579 _ckvmssts(sys$delprc(&open_pipes->pid,0));
580 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
585 static struct exit_control_block pipe_exitblock =
586 {(struct exit_control_block *) 0,
587 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
591 popen_completion_ast(struct pipe_details *thispipe)
593 thispipe->done = TRUE;
594 if (waitpid_asleep) {
600 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
602 my_popen(char *cmd, char *mode)
604 static int handler_set_up = FALSE;
606 unsigned short int chan;
607 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
608 struct pipe_details *info;
609 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
610 DSC$K_CLASS_S, mbxname},
611 cmddsc = {0, DSC$K_DTYPE_T,
615 cmddsc.dsc$w_length=strlen(cmd);
616 cmddsc.dsc$a_pointer=cmd;
617 if (cmddsc.dsc$w_length > 255) {
618 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
622 New(7001,info,1,struct pipe_details);
625 create_mbx(&chan,&namdsc);
627 /* open a FILE* onto it */
628 info->fp=fopen(mbxname, mode);
630 /* give up other channel onto it */
631 _ckvmssts(sys$dassgn(chan));
641 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
642 0 /* name */, &info->pid, &info->completion,
643 0, popen_completion_ast,info,0,0,0));
646 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
647 0 /* name */, &info->pid, &info->completion,
648 0, popen_completion_ast,info,0,0,0));
651 if (!handler_set_up) {
652 _ckvmssts(sys$dclexh(&pipe_exitblock));
653 handler_set_up = TRUE;
655 info->next=open_pipes; /* prepend to list */
658 forkprocess = info->pid;
663 /*{{{ I32 my_pclose(FILE *fp)*/
664 I32 my_pclose(FILE *fp)
666 struct pipe_details *info, *last = NULL;
667 unsigned long int retsts;
669 for (info = open_pipes; info != NULL; last = info, info = info->next)
670 if (info->fp == fp) break;
673 /* get here => no such pipe open */
674 croak("No such pipe open");
678 if (info->done) retsts = info->completion;
679 else waitpid(info->pid,(int *) &retsts,0);
681 /* remove from list of open pipes */
682 if (last) last->next = info->next;
683 else open_pipes = info->next;
688 } /* end of my_pclose() */
690 /* sort-of waitpid; use only with popen() */
691 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
693 waitpid(unsigned long int pid, int *statusp, int flags)
695 struct pipe_details *info;
697 for (info = open_pipes; info != NULL; info = info->next)
698 if (info->pid == pid) break;
700 if (info != NULL) { /* we know about this child */
701 while (!info->done) {
706 *statusp = info->completion;
709 else { /* we haven't heard of this child */
710 $DESCRIPTOR(intdsc,"0 00:00:01");
711 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
712 unsigned long int interval[2],sts;
715 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
716 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
717 if (ownerpid != mypid)
718 warn("pid %d not a child",pid);
721 _ckvmssts(sys$bintim(&intdsc,interval));
722 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
723 _ckvmssts(sys$schdwk(0,0,interval,0));
724 _ckvmssts(sys$hiber());
728 /* There's no easy way to find the termination status a child we're
729 * not aware of beforehand. If we're really interested in the future,
730 * we can go looking for a termination mailbox, or chase after the
731 * accounting record for the process.
737 } /* end of waitpid() */
742 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
744 my_gconvert(double val, int ndig, int trail, char *buf)
746 static char __gcvtbuf[DBL_DIG+1];
749 loc = buf ? buf : __gcvtbuf;
751 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
752 return gcvt(val,ndig,loc);
755 loc[0] = '0'; loc[1] = '\0';
763 ** The following routines are provided to make life easier when
764 ** converting among VMS-style and Unix-style directory specifications.
765 ** All will take input specifications in either VMS or Unix syntax. On
766 ** failure, all return NULL. If successful, the routines listed below
767 ** return a pointer to a buffer containing the appropriately
768 ** reformatted spec (and, therefore, subsequent calls to that routine
769 ** will clobber the result), while the routines of the same names with
770 ** a _ts suffix appended will return a pointer to a mallocd string
771 ** containing the appropriately reformatted spec.
772 ** In all cases, only explicit syntax is altered; no check is made that
773 ** the resulting string is valid or that the directory in question
776 ** fileify_dirspec() - convert a directory spec into the name of the
777 ** directory file (i.e. what you can stat() to see if it's a dir).
778 ** The style (VMS or Unix) of the result is the same as the style
779 ** of the parameter passed in.
780 ** pathify_dirspec() - convert a directory spec into a path (i.e.
781 ** what you prepend to a filename to indicate what directory it's in).
782 ** The style (VMS or Unix) of the result is the same as the style
783 ** of the parameter passed in.
784 ** tounixpath() - convert a directory spec into a Unix-style path.
785 ** tovmspath() - convert a directory spec into a VMS-style path.
786 ** tounixspec() - convert any file spec into a Unix-style file spec.
787 ** tovmsspec() - convert any file spec into a VMS-style spec.
789 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
790 ** Permission is given to distribute this code as part of the Perl
791 ** standard distribution under the terms of the GNU General Public
792 ** License or the Perl Artistic License. Copies of each may be
793 ** found in the Perl standard distribution.
796 static char *do_tounixspec(char *, char *, int);
798 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
799 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
801 static char __fileify_retbuf[NAM$C_MAXRSS+1];
802 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
803 char *retspec, *cp1, *cp2, *lastdir;
804 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
807 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
809 dirlen = strlen(dir);
810 if (dir[dirlen-1] == '/') --dirlen;
813 set_vaxc_errno(RMS$_DIR);
816 if (!strpbrk(dir+1,"/]>:")) {
817 strcpy(trndir,*dir == '/' ? dir + 1: dir);
818 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
820 dirlen = strlen(dir);
823 strncpy(trndir,dir,dirlen);
824 trndir[dirlen] = '\0';
827 /* If we were handed a rooted logical name or spec, treat it like a
828 * simple directory, so that
829 * $ Define myroot dev:[dir.]
830 * ... do_fileify_dirspec("myroot",buf,1) ...
831 * does something useful.
833 if (!strcmp(dir+dirlen-2,".]")) {
834 dir[--dirlen] = '\0';
838 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
839 /* If we've got an explicit filename, we can just shuffle the string. */
840 if (*(cp1+1)) hasfilename = 1;
841 /* Similarly, we can just back up a level if we've got multiple levels
842 of explicit directories in a VMS spec which ends with directories. */
844 for (cp2 = cp1; cp2 > dir; cp2--) {
846 *cp2 = *cp1; *cp1 = '\0';
850 if (*cp2 == '[' || *cp2 == '<') break;
855 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
857 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
858 return do_fileify_dirspec("[]",buf,ts);
859 else if (dir[1] == '.' &&
860 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
861 return do_fileify_dirspec("[-]",buf,ts);
863 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
864 dirlen -= 1; /* to last element */
865 lastdir = strrchr(dir,'/');
867 else if ((cp1 = strstr(dir,"/.")) != NULL) {
868 /* If we have "/." or "/..", VMSify it and let the VMS code
869 * below expand it, rather than repeating the code to handle
870 * relative components of a filespec here */
872 if (*(cp1+2) == '.') cp1++;
873 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
874 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
875 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
876 return do_tounixspec(trndir,buf,ts);
879 } while ((cp1 = strstr(cp1,"/.")) != NULL);
882 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
883 !(lastdir = cp1 = strrchr(dir,']')) &&
884 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
885 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
887 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
888 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
889 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
890 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
891 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
894 set_vaxc_errno(RMS$_DIR);
900 /* If we lead off with a device or rooted logical, add the MFD
901 if we're specifying a top-level directory. */
902 if (lastdir && *dir == '/') {
904 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
911 retlen = dirlen + (addmfd ? 13 : 6);
912 if (buf) retspec = buf;
913 else if (ts) New(7009,retspec,retlen+1,char);
914 else retspec = __fileify_retbuf;
916 dirlen = lastdir - dir;
917 memcpy(retspec,dir,dirlen);
918 strcpy(&retspec[dirlen],"/000000");
919 strcpy(&retspec[dirlen+7],lastdir);
922 memcpy(retspec,dir,dirlen);
923 retspec[dirlen] = '\0';
925 /* We've picked up everything up to the directory file name.
926 Now just add the type and version, and we're set. */
927 strcat(retspec,".dir;1");
930 else { /* VMS-style directory spec */
931 char esa[NAM$C_MAXRSS+1], term, *cp;
932 unsigned long int sts, cmplen, haslower = 0;
933 struct FAB dirfab = cc$rms_fab;
934 struct NAM savnam, dirnam = cc$rms_nam;
936 dirfab.fab$b_fns = strlen(dir);
937 dirfab.fab$l_fna = dir;
938 dirfab.fab$l_nam = &dirnam;
939 dirfab.fab$l_dna = ".DIR;1";
940 dirfab.fab$b_dns = 6;
941 dirnam.nam$b_ess = NAM$C_MAXRSS;
942 dirnam.nam$l_esa = esa;
944 for (cp = dir; *cp; cp++)
945 if (islower(*cp)) { haslower = 1; break; }
946 if (!((sts = sys$parse(&dirfab))&1)) {
947 if (dirfab.fab$l_sts == RMS$_DIR) {
948 dirnam.nam$b_nop |= NAM$M_SYNCHK;
949 sts = sys$parse(&dirfab) & 1;
953 set_vaxc_errno(dirfab.fab$l_sts);
959 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
960 /* Yes; fake the fnb bits so we'll check type below */
961 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
964 if (dirfab.fab$l_sts != RMS$_FNF) {
966 set_vaxc_errno(dirfab.fab$l_sts);
969 dirnam = savnam; /* No; just work with potential name */
972 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
973 cp1 = strchr(esa,']');
974 if (!cp1) cp1 = strchr(esa,'>');
975 if (cp1) { /* Should always be true */
976 dirnam.nam$b_esl -= cp1 - esa - 1;
977 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
980 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
981 /* Yep; check version while we're at it, if it's there. */
982 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
983 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
984 /* Something other than .DIR[;1]. Bzzt. */
986 set_vaxc_errno(RMS$_DIR);
990 esa[dirnam.nam$b_esl] = '\0';
991 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
992 /* They provided at least the name; we added the type, if necessary, */
993 if (buf) retspec = buf; /* in sys$parse() */
994 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
995 else retspec = __fileify_retbuf;
999 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1000 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1002 dirnam.nam$b_esl -= 9;
1004 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1005 if (cp1 == NULL) return NULL; /* should never happen */
1008 retlen = strlen(esa);
1009 if ((cp1 = strrchr(esa,'.')) != NULL) {
1010 /* There's more than one directory in the path. Just roll back. */
1012 if (buf) retspec = buf;
1013 else if (ts) New(7011,retspec,retlen+7,char);
1014 else retspec = __fileify_retbuf;
1015 strcpy(retspec,esa);
1018 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1019 /* Go back and expand rooted logical name */
1020 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1021 if (!(sys$parse(&dirfab) & 1)) {
1023 set_vaxc_errno(dirfab.fab$l_sts);
1026 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1027 if (buf) retspec = buf;
1028 else if (ts) New(7012,retspec,retlen+16,char);
1029 else retspec = __fileify_retbuf;
1030 cp1 = strstr(esa,"][");
1032 memcpy(retspec,esa,dirlen);
1033 if (!strncmp(cp1+2,"000000]",7)) {
1034 retspec[dirlen-1] = '\0';
1035 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1036 if (*cp1 == '.') *cp1 = ']';
1038 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1039 memcpy(cp1+1,"000000]",7);
1043 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1044 retspec[retlen] = '\0';
1045 /* Convert last '.' to ']' */
1046 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1047 if (*cp1 == '.') *cp1 = ']';
1049 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1050 memcpy(cp1+1,"000000]",7);
1054 else { /* This is a top-level dir. Add the MFD to the path. */
1055 if (buf) retspec = buf;
1056 else if (ts) New(7012,retspec,retlen+16,char);
1057 else retspec = __fileify_retbuf;
1060 while (*cp1 != ':') *(cp2++) = *(cp1++);
1061 strcpy(cp2,":[000000]");
1066 /* We've set up the string up through the filename. Add the
1067 type and version, and we're done. */
1068 strcat(retspec,".DIR;1");
1070 /* $PARSE may have upcased filespec, so convert output to lower
1071 * case if input contained any lowercase characters. */
1072 if (haslower) __mystrtolower(retspec);
1075 } /* end of do_fileify_dirspec() */
1077 /* External entry points */
1078 char *fileify_dirspec(char *dir, char *buf)
1079 { return do_fileify_dirspec(dir,buf,0); }
1080 char *fileify_dirspec_ts(char *dir, char *buf)
1081 { return do_fileify_dirspec(dir,buf,1); }
1083 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1084 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1086 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1087 unsigned long int retlen;
1088 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1090 if (!dir || !*dir) {
1091 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1094 if (*dir) strcpy(trndir,dir);
1095 else getcwd(trndir,sizeof trndir - 1);
1097 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1098 STRLEN trnlen = strlen(trndir);
1100 /* Trap simple rooted lnms, and return lnm:[000000] */
1101 if (!strcmp(trndir+trnlen-2,".]")) {
1102 if (buf) retpath = buf;
1103 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1104 else retpath = __pathify_retbuf;
1105 strcpy(retpath,dir);
1106 strcat(retpath,":[000000]");
1112 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1113 if (*dir == '.' && (*(dir+1) == '\0' ||
1114 (*(dir+1) == '.' && *(dir+2) == '\0')))
1115 retlen = 2 + (*(dir+1) != '\0');
1117 if ( !(cp1 = strrchr(dir,'/')) &&
1118 !(cp1 = strrchr(dir,']')) &&
1119 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1120 if ((cp2 = strchr(cp1,'.')) != NULL) {
1122 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1123 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1124 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1125 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1126 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1127 (ver || *cp3)))))) {
1129 set_vaxc_errno(RMS$_DIR);
1132 retlen = cp2 - dir + 1;
1134 else { /* No file type present. Treat the filename as a directory. */
1135 retlen = strlen(dir) + 1;
1138 if (buf) retpath = buf;
1139 else if (ts) New(7013,retpath,retlen+1,char);
1140 else retpath = __pathify_retbuf;
1141 strncpy(retpath,dir,retlen-1);
1142 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1143 retpath[retlen-1] = '/'; /* with '/', add it. */
1144 retpath[retlen] = '\0';
1146 else retpath[retlen-1] = '\0';
1148 else { /* VMS-style directory spec */
1149 char esa[NAM$C_MAXRSS+1], *cp;
1150 unsigned long int sts, cmplen, haslower;
1151 struct FAB dirfab = cc$rms_fab;
1152 struct NAM savnam, dirnam = cc$rms_nam;
1154 /* If we've got an explicit filename, we can just shuffle the string. */
1155 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1156 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1157 if ((cp2 = strchr(cp1,'.')) != NULL) {
1159 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1160 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1161 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1162 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1163 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1164 (ver || *cp3)))))) {
1166 set_vaxc_errno(RMS$_DIR);
1170 else { /* No file type, so just draw name into directory part */
1171 for (cp2 = cp1; *cp2; cp2++) ;
1174 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1176 /* We've now got a VMS 'path'; fall through */
1178 dirfab.fab$b_fns = strlen(dir);
1179 dirfab.fab$l_fna = dir;
1180 if (dir[dirfab.fab$b_fns-1] == ']' ||
1181 dir[dirfab.fab$b_fns-1] == '>' ||
1182 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1183 if (buf) retpath = buf;
1184 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1185 else retpath = __pathify_retbuf;
1186 strcpy(retpath,dir);
1189 dirfab.fab$l_dna = ".DIR;1";
1190 dirfab.fab$b_dns = 6;
1191 dirfab.fab$l_nam = &dirnam;
1192 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1193 dirnam.nam$l_esa = esa;
1195 for (cp = dir; *cp; cp++)
1196 if (islower(*cp)) { haslower = 1; break; }
1198 if (!(sts = (sys$parse(&dirfab)&1))) {
1199 if (dirfab.fab$l_sts == RMS$_DIR) {
1200 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1201 sts = sys$parse(&dirfab) & 1;
1205 set_vaxc_errno(dirfab.fab$l_sts);
1211 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1212 if (dirfab.fab$l_sts != RMS$_FNF) {
1214 set_vaxc_errno(dirfab.fab$l_sts);
1217 dirnam = savnam; /* No; just work with potential name */
1220 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1221 /* Yep; check version while we're at it, if it's there. */
1222 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1223 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1224 /* Something other than .DIR[;1]. Bzzt. */
1226 set_vaxc_errno(RMS$_DIR);
1230 /* OK, the type was fine. Now pull any file name into the
1232 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1234 cp1 = strrchr(esa,'>');
1235 *dirnam.nam$l_type = '>';
1238 *(dirnam.nam$l_type + 1) = '\0';
1239 retlen = dirnam.nam$l_type - esa + 2;
1240 if (buf) retpath = buf;
1241 else if (ts) New(7014,retpath,retlen,char);
1242 else retpath = __pathify_retbuf;
1243 strcpy(retpath,esa);
1244 /* $PARSE may have upcased filespec, so convert output to lower
1245 * case if input contained any lowercase characters. */
1246 if (haslower) __mystrtolower(retpath);
1250 } /* end of do_pathify_dirspec() */
1252 /* External entry points */
1253 char *pathify_dirspec(char *dir, char *buf)
1254 { return do_pathify_dirspec(dir,buf,0); }
1255 char *pathify_dirspec_ts(char *dir, char *buf)
1256 { return do_pathify_dirspec(dir,buf,1); }
1258 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1259 static char *do_tounixspec(char *spec, char *buf, int ts)
1261 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1262 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1263 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1265 if (spec == NULL) return NULL;
1266 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1267 if (buf) rslt = buf;
1269 retlen = strlen(spec);
1270 cp1 = strchr(spec,'[');
1271 if (!cp1) cp1 = strchr(spec,'<');
1273 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1275 New(7015,rslt,retlen+2+2*dashes,char);
1277 else rslt = __tounixspec_retbuf;
1278 if (strchr(spec,'/') != NULL) {
1285 dirend = strrchr(spec,']');
1286 if (dirend == NULL) dirend = strrchr(spec,'>');
1287 if (dirend == NULL) dirend = strchr(spec,':');
1288 if (dirend == NULL) {
1292 if (*cp2 != '[' && *cp2 != '<') {
1295 else { /* the VMS spec begins with directories */
1297 if (*cp2 == ']' || *cp2 == '>') {
1301 else if ( *cp2 != '.' && *cp2 != '-') {
1302 *(cp1++) = '/'; /* add the implied device into the Unix spec */
1303 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1304 if (ts) Safefree(rslt);
1309 while (*cp3 != ':' && *cp3) cp3++;
1311 if (strchr(cp3,']') != NULL) break;
1312 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1314 while (*cp3) *(cp1++) = *(cp3++);
1317 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1318 int offset = cp1 - rslt;
1320 retlen = devlen + dirlen;
1321 Renew(rslt,retlen+1+2*dashes,char);
1322 cp1 = rslt + offset;
1325 else if (*cp2 == '.') cp2++;
1327 for (; cp2 <= dirend; cp2++) {
1330 if (*(cp2+1) == '[') cp2++;
1332 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1333 else if (*cp2 == '.') {
1335 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1336 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1337 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1338 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1339 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1342 else if (*cp2 == '-') {
1343 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1344 while (*cp2 == '-') {
1346 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1348 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1349 if (ts) Safefree(rslt); /* filespecs like */
1350 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1354 else *(cp1++) = *cp2;
1356 else *(cp1++) = *cp2;
1358 while (*cp2) *(cp1++) = *(cp2++);
1363 } /* end of do_tounixspec() */
1365 /* External entry points */
1366 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1367 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1369 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1370 static char *do_tovmsspec(char *path, char *buf, int ts) {
1371 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1372 char *rslt, *dirend;
1373 register char *cp1, *cp2;
1374 unsigned long int infront = 0, hasdir = 1;
1376 if (path == NULL) return NULL;
1377 if (buf) rslt = buf;
1378 else if (ts) New(7016,rslt,strlen(path)+9,char);
1379 else rslt = __tovmsspec_retbuf;
1380 if (strpbrk(path,"]:>") ||
1381 (dirend = strrchr(path,'/')) == NULL) {
1382 if (path[0] == '.') {
1383 if (path[1] == '\0') strcpy(rslt,"[]");
1384 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1385 else strcpy(rslt,path); /* probably garbage */
1387 else strcpy(rslt,path);
1390 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1391 if (!*(dirend+2)) dirend +=2;
1392 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1397 char trndev[NAM$C_MAXRSS+1];
1401 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1402 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1404 islnm = my_trnlnm(rslt,trndev,0);
1405 trnend = islnm ? strlen(trndev) - 1 : 0;
1406 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1407 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1408 /* If the first element of the path is a logical name, determine
1409 * whether it has to be translated so we can add more directories. */
1410 if (!islnm || rooted) {
1413 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1417 if (cp2 != dirend) {
1418 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1419 strcpy(rslt,trndev);
1420 cp1 = rslt + trnend;
1433 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1434 cp2 += 2; /* skip over "./" - it's redundant */
1435 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1437 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1438 *(cp1++) = '-'; /* "../" --> "-" */
1441 if (cp2 > dirend) cp2 = dirend;
1443 else *(cp1++) = '.';
1445 for (; cp2 < dirend; cp2++) {
1447 if (*(cp2-1) == '/') continue;
1448 if (*(cp1-1) != '.') *(cp1++) = '.';
1451 else if (!infront && *cp2 == '.') {
1452 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1453 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1454 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1455 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1456 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1457 else { /* back up over previous directory name */
1459 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1460 if (*(cp1-1) == '[') {
1461 memcpy(cp1,"000000.",7);
1466 if (cp2 == dirend) break;
1468 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1471 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1472 if (*cp2 == '.') *(cp1++) = '_';
1473 else *(cp1++) = *cp2;
1477 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1478 if (hasdir) *(cp1++) = ']';
1479 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1480 while (*cp2) *(cp1++) = *(cp2++);
1485 } /* end of do_tovmsspec() */
1487 /* External entry points */
1488 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1489 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1491 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1492 static char *do_tovmspath(char *path, char *buf, int ts) {
1493 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1495 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1497 if (path == NULL) return NULL;
1498 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1499 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1500 if (buf) return buf;
1502 vmslen = strlen(vmsified);
1503 New(7017,cp,vmslen+1,char);
1504 memcpy(cp,vmsified,vmslen);
1509 strcpy(__tovmspath_retbuf,vmsified);
1510 return __tovmspath_retbuf;
1513 } /* end of do_tovmspath() */
1515 /* External entry points */
1516 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1517 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1520 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1521 static char *do_tounixpath(char *path, char *buf, int ts) {
1522 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1524 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1526 if (path == NULL) return NULL;
1527 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1528 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1529 if (buf) return buf;
1531 unixlen = strlen(unixified);
1532 New(7017,cp,unixlen+1,char);
1533 memcpy(cp,unixified,unixlen);
1538 strcpy(__tounixpath_retbuf,unixified);
1539 return __tounixpath_retbuf;
1542 } /* end of do_tounixpath() */
1544 /* External entry points */
1545 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1546 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1549 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1551 *****************************************************************************
1553 * Copyright (C) 1989-1994 by *
1554 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1556 * Permission is hereby granted for the reproduction of this software, *
1557 * on condition that this copyright notice is included in the reproduction, *
1558 * and that such reproduction is not for purposes of profit or material *
1561 * 27-Aug-1994 Modified for inclusion in perl5 *
1562 * by Charles Bailey bailey@genetics.upenn.edu *
1563 *****************************************************************************
1567 * getredirection() is intended to aid in porting C programs
1568 * to VMS (Vax-11 C). The native VMS environment does not support
1569 * '>' and '<' I/O redirection, or command line wild card expansion,
1570 * or a command line pipe mechanism using the '|' AND background
1571 * command execution '&'. All of these capabilities are provided to any
1572 * C program which calls this procedure as the first thing in the
1574 * The piping mechanism will probably work with almost any 'filter' type
1575 * of program. With suitable modification, it may useful for other
1576 * portability problems as well.
1578 * Author: Mark Pizzolato mark@infocomm.com
1582 struct list_item *next;
1586 static void add_item(struct list_item **head,
1587 struct list_item **tail,
1591 static void expand_wild_cards(char *item,
1592 struct list_item **head,
1593 struct list_item **tail,
1596 static int background_process(int argc, char **argv);
1598 static void pipe_and_fork(char **cmargv);
1600 /*{{{ void getredirection(int *ac, char ***av)*/
1602 getredirection(int *ac, char ***av)
1604 * Process vms redirection arg's. Exit if any error is seen.
1605 * If getredirection() processes an argument, it is erased
1606 * from the vector. getredirection() returns a new argc and argv value.
1607 * In the event that a background command is requested (by a trailing "&"),
1608 * this routine creates a background subprocess, and simply exits the program.
1610 * Warning: do not try to simplify the code for vms. The code
1611 * presupposes that getredirection() is called before any data is
1612 * read from stdin or written to stdout.
1614 * Normal usage is as follows:
1620 * getredirection(&argc, &argv);
1624 int argc = *ac; /* Argument Count */
1625 char **argv = *av; /* Argument Vector */
1626 char *ap; /* Argument pointer */
1627 int j; /* argv[] index */
1628 int item_count = 0; /* Count of Items in List */
1629 struct list_item *list_head = 0; /* First Item in List */
1630 struct list_item *list_tail; /* Last Item in List */
1631 char *in = NULL; /* Input File Name */
1632 char *out = NULL; /* Output File Name */
1633 char *outmode = "w"; /* Mode to Open Output File */
1634 char *err = NULL; /* Error File Name */
1635 char *errmode = "w"; /* Mode to Open Error File */
1636 int cmargc = 0; /* Piped Command Arg Count */
1637 char **cmargv = NULL;/* Piped Command Arg Vector */
1640 * First handle the case where the last thing on the line ends with
1641 * a '&'. This indicates the desire for the command to be run in a
1642 * subprocess, so we satisfy that desire.
1645 if (0 == strcmp("&", ap))
1646 exit(background_process(--argc, argv));
1647 if (*ap && '&' == ap[strlen(ap)-1])
1649 ap[strlen(ap)-1] = '\0';
1650 exit(background_process(argc, argv));
1653 * Now we handle the general redirection cases that involve '>', '>>',
1654 * '<', and pipes '|'.
1656 for (j = 0; j < argc; ++j)
1658 if (0 == strcmp("<", argv[j]))
1662 fprintf(Perl_debug_log,"No input file after < on command line");
1663 exit(LIB$_WRONUMARG);
1668 if ('<' == *(ap = argv[j]))
1673 if (0 == strcmp(">", ap))
1677 fprintf(Perl_debug_log,"No output file after > on command line");
1678 exit(LIB$_WRONUMARG);
1697 fprintf(Perl_debug_log,"No output file after > or >> on command line");
1698 exit(LIB$_WRONUMARG);
1702 if (('2' == *ap) && ('>' == ap[1]))
1719 fprintf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1720 exit(LIB$_WRONUMARG);
1724 if (0 == strcmp("|", argv[j]))
1728 fprintf(Perl_debug_log,"No command into which to pipe on command line");
1729 exit(LIB$_WRONUMARG);
1731 cmargc = argc-(j+1);
1732 cmargv = &argv[j+1];
1736 if ('|' == *(ap = argv[j]))
1744 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1747 * Allocate and fill in the new argument vector, Some Unix's terminate
1748 * the list with an extra null pointer.
1750 New(7002, argv, item_count+1, char *);
1752 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1753 argv[j] = list_head->value;
1759 fprintf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1760 exit(LIB$_INVARGORD);
1762 pipe_and_fork(cmargv);
1765 /* Check for input from a pipe (mailbox) */
1767 if (in == NULL && 1 == isapipe(0))
1769 char mbxname[L_tmpnam];
1771 long int dvi_item = DVI$_DEVBUFSIZ;
1772 $DESCRIPTOR(mbxnam, "");
1773 $DESCRIPTOR(mbxdevnam, "");
1775 /* Input from a pipe, reopen it in binary mode to disable */
1776 /* carriage control processing. */
1778 fgetname(stdin, mbxname,1);
1779 mbxnam.dsc$a_pointer = mbxname;
1780 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1781 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1782 mbxdevnam.dsc$a_pointer = mbxname;
1783 mbxdevnam.dsc$w_length = sizeof(mbxname);
1784 dvi_item = DVI$_DEVNAM;
1785 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1786 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1789 freopen(mbxname, "rb", stdin);
1792 fprintf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1796 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1798 fprintf(Perl_debug_log,"Can't open input file %s as stdin",in);
1801 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1803 fprintf(Perl_debug_log,"Can't open output file %s as stdout",out);
1808 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1810 fprintf(Perl_debug_log,"Can't open error file %s as stderr",err);
1814 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1819 #ifdef ARGPROC_DEBUG
1820 fprintf(Perl_debug_log, "Arglist:\n");
1821 for (j = 0; j < *ac; ++j)
1822 fprintf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1824 /* Clear errors we may have hit expanding wildcards, so they don't
1825 show up in Perl's $! later */
1826 set_errno(0); set_vaxc_errno(1);
1827 } /* end of getredirection() */
1830 static void add_item(struct list_item **head,
1831 struct list_item **tail,
1837 New(7003,*head,1,struct list_item);
1841 New(7004,(*tail)->next,1,struct list_item);
1842 *tail = (*tail)->next;
1844 (*tail)->value = value;
1848 static void expand_wild_cards(char *item,
1849 struct list_item **head,
1850 struct list_item **tail,
1854 unsigned long int context = 0;
1860 char vmsspec[NAM$C_MAXRSS+1];
1861 $DESCRIPTOR(filespec, "");
1862 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1863 $DESCRIPTOR(resultspec, "");
1864 unsigned long int zero = 0, sts;
1866 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
1868 add_item(head, tail, item, count);
1871 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1872 resultspec.dsc$b_class = DSC$K_CLASS_D;
1873 resultspec.dsc$a_pointer = NULL;
1874 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1875 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1876 if (!isunix || !filespec.dsc$a_pointer)
1877 filespec.dsc$a_pointer = item;
1878 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1880 * Only return version specs, if the caller specified a version
1882 had_version = strchr(item, ';');
1884 * Only return device and directory specs, if the caller specifed either.
1886 had_device = strchr(item, ':');
1887 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1889 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1890 &defaultspec, 0, 0, &zero))))
1895 New(7005,string,resultspec.dsc$w_length+1,char);
1896 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1897 string[resultspec.dsc$w_length] = '\0';
1898 if (NULL == had_version)
1899 *((char *)strrchr(string, ';')) = '\0';
1900 if ((!had_directory) && (had_device == NULL))
1902 if (NULL == (devdir = strrchr(string, ']')))
1903 devdir = strrchr(string, '>');
1904 strcpy(string, devdir + 1);
1907 * Be consistent with what the C RTL has already done to the rest of
1908 * the argv items and lowercase all of these names.
1910 for (c = string; *c; ++c)
1913 if (isunix) trim_unixpath(string,item);
1914 add_item(head, tail, string, count);
1917 if (sts != RMS$_NMF)
1919 set_vaxc_errno(sts);
1925 set_errno(ENOENT); break;
1927 set_errno(ENODEV); break;
1929 set_errno(EINVAL); break;
1931 set_errno(EACCES); break;
1933 _ckvmssts_noperl(sts);
1937 add_item(head, tail, item, count);
1938 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
1939 _ckvmssts_noperl(lib$find_file_end(&context));
1942 static int child_st[2];/* Event Flag set when child process completes */
1944 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
1946 static unsigned long int exit_handler(int *status)
1950 if (0 == child_st[0])
1952 #ifdef ARGPROC_DEBUG
1953 fprintf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
1955 fflush(stdout); /* Have to flush pipe for binary data to */
1956 /* terminate properly -- <tp@mccall.com> */
1957 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1958 sys$dassgn(child_chan);
1960 sys$synch(0, child_st);
1965 static void sig_child(int chan)
1967 #ifdef ARGPROC_DEBUG
1968 fprintf(Perl_debug_log, "Child Completion AST\n");
1970 if (child_st[0] == 0)
1974 static struct exit_control_block exit_block =
1979 &exit_block.exit_status,
1983 static void pipe_and_fork(char **cmargv)
1986 $DESCRIPTOR(cmddsc, "");
1987 static char mbxname[64];
1988 $DESCRIPTOR(mbxdsc, mbxname);
1990 unsigned long int zero = 0, one = 1;
1992 strcpy(subcmd, cmargv[0]);
1993 for (j = 1; NULL != cmargv[j]; ++j)
1995 strcat(subcmd, " \"");
1996 strcat(subcmd, cmargv[j]);
1997 strcat(subcmd, "\"");
1999 cmddsc.dsc$a_pointer = subcmd;
2000 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2002 create_mbx(&child_chan,&mbxdsc);
2003 #ifdef ARGPROC_DEBUG
2004 fprintf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2005 fprintf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2007 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2008 0, &pid, child_st, &zero, sig_child,
2010 #ifdef ARGPROC_DEBUG
2011 fprintf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2013 sys$dclexh(&exit_block);
2014 if (NULL == freopen(mbxname, "wb", stdout))
2016 fprintf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2020 static int background_process(int argc, char **argv)
2022 char command[2048] = "$";
2023 $DESCRIPTOR(value, "");
2024 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2025 static $DESCRIPTOR(null, "NLA0:");
2026 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2028 $DESCRIPTOR(pidstr, "");
2030 unsigned long int flags = 17, one = 1, retsts;
2032 strcat(command, argv[0]);
2035 strcat(command, " \"");
2036 strcat(command, *(++argv));
2037 strcat(command, "\"");
2039 value.dsc$a_pointer = command;
2040 value.dsc$w_length = strlen(value.dsc$a_pointer);
2041 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2042 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2043 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2044 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2047 _ckvmssts_noperl(retsts);
2049 #ifdef ARGPROC_DEBUG
2050 fprintf(Perl_debug_log, "%s\n", command);
2052 sprintf(pidstring, "%08X", pid);
2053 fprintf(Perl_debug_log, "%s\n", pidstring);
2054 pidstr.dsc$a_pointer = pidstring;
2055 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2056 lib$set_symbol(&pidsymbol, &pidstr);
2060 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2063 * Trim Unix-style prefix off filespec, so it looks like what a shell
2064 * glob expansion would return (i.e. from specified prefix on, not
2065 * full path). Note that returned filespec is Unix-style, regardless
2066 * of whether input filespec was VMS-style or Unix-style.
2068 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2069 * determine prefix (both may be in VMS or Unix syntax).
2071 * Returns !=0 on success, with trimmed filespec replacing contents of
2072 * fspec, and 0 on failure, with contents of fpsec unchanged.
2074 /*{{{int trim_unixpath(char *fspec, char *wildspec)*/
2076 trim_unixpath(char *fspec, char *wildspec)
2078 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2079 *template, *base, *cp1, *cp2;
2080 register int tmplen, reslen = 0;
2082 if (!wildspec || !fspec) return 0;
2083 if (strpbrk(wildspec,"]>:") != NULL) {
2084 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2085 else template = unixified;
2087 else template = wildspec;
2088 if (strpbrk(fspec,"]>:") != NULL) {
2089 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2090 else base = unixified;
2091 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2092 * check to see that final result fits into (isn't longer than) fspec */
2093 reslen = strlen(fspec);
2097 /* No prefix or absolute path on wildcard, so nothing to remove */
2098 if (!*template || *template == '/') {
2099 if (base == fspec) return 1;
2100 tmplen = strlen(unixified);
2101 if (tmplen > reslen) return 0; /* not enough space */
2102 /* Copy unixified resultant, including trailing NUL */
2103 memmove(fspec,unixified,tmplen+1);
2107 /* Find prefix to template consisting of path elements without wildcards */
2108 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2109 for (cp1 = template; *cp1; cp1++) ;
2110 else while (cp1 > template && *cp1 != '/') cp1--;
2111 for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
2113 /* Wildcard was in first element, so we don't have a reliable string to
2114 * match against. Guess where to trim resultant filespec by counting
2115 * directory levels in the Unix template. (We could do this instead of
2116 * string matching in all cases, since Unix doesn't have a ... wildcard
2117 * that can expand into multiple levels of subdirectory, but we try for
2118 * the string match so our caller can interpret foo/.../bar.* as
2119 * [.foo...]bar.* if it wants, and only get burned if there was a
2120 * wildcard in the first word (in which case, caveat caller). */
2121 if (cp1 == template) {
2123 for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
2124 /* need to back one more '/' than in template, to pick up leading dirname */
2126 while (cp2 > base) {
2127 if (*cp2 == '/') subdirs--;
2128 if (!subdirs) break; /* quit without decrement when we hit last '/' */
2131 /* ran out of directories on resultant; allow for already trimmed
2132 * resultant, which hits start of string looking for leading '/' */
2133 if (subdirs && (cp2 != base || subdirs != 1)) return 0;
2134 /* Move past leading '/', if there is one */
2135 base = cp2 + (*cp2 == '/' ? 1 : 0);
2136 tmplen = strlen(base);
2137 if (reslen && tmplen > reslen) return 0; /* not enough space */
2138 memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
2141 /* We have a prefix string of complete directory names, so we
2142 * try to find it on the resultant filespec */
2144 tmplen = cp1 - template;
2145 if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
2146 if (reslen) { /* we converted to Unix syntax; copy result over */
2147 tmplen = cp2 - base;
2148 if (tmplen > reslen) return 0; /* not enough space */
2149 memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
2153 for ( ; cp2 - base > tmplen; base++) {
2154 if (*base != '/') continue;
2155 if (!memcmp(base + 1,template,tmplen)) break;
2158 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2159 base++; /* Move past leading '/' */
2160 if (reslen && cp2 - base > reslen) return 0; /* not enough space */
2161 /* Copy down remaining portion of filespec, including trailing NUL */
2162 memmove(fspec,base,cp2 - base + 1);
2166 } /* end of trim_unixpath() */
2171 * VMS readdir() routines.
2172 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2173 * This code has no copyright.
2175 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2176 * Minor modifications to original routines.
2179 /* Number of elements in vms_versions array */
2180 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2183 * Open a directory, return a handle for later use.
2185 /*{{{ DIR *opendir(char*name) */
2190 char dir[NAM$C_MAXRSS+1];
2192 /* Get memory for the handle, and the pattern. */
2194 if (do_tovmspath(name,dir,0) == NULL) {
2195 Safefree((char *)dd);
2198 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2200 /* Fill in the fields; mainly playing with the descriptor. */
2201 (void)sprintf(dd->pattern, "%s*.*",dir);
2204 dd->vms_wantversions = 0;
2205 dd->pat.dsc$a_pointer = dd->pattern;
2206 dd->pat.dsc$w_length = strlen(dd->pattern);
2207 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2208 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2211 } /* end of opendir() */
2215 * Set the flag to indicate we want versions or not.
2217 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2219 vmsreaddirversions(DIR *dd, int flag)
2221 dd->vms_wantversions = flag;
2226 * Free up an opened directory.
2228 /*{{{ void closedir(DIR *dd)*/
2232 (void)lib$find_file_end(&dd->context);
2233 Safefree(dd->pattern);
2234 Safefree((char *)dd);
2239 * Collect all the version numbers for the current file.
2245 struct dsc$descriptor_s pat;
2246 struct dsc$descriptor_s res;
2248 char *p, *text, buff[sizeof dd->entry.d_name];
2250 unsigned long context, tmpsts;
2252 /* Convenient shorthand. */
2255 /* Add the version wildcard, ignoring the "*.*" put on before */
2256 i = strlen(dd->pattern);
2257 New(7008,text,i + e->d_namlen + 3,char);
2258 (void)strcpy(text, dd->pattern);
2259 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2261 /* Set up the pattern descriptor. */
2262 pat.dsc$a_pointer = text;
2263 pat.dsc$w_length = i + e->d_namlen - 1;
2264 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2265 pat.dsc$b_class = DSC$K_CLASS_S;
2267 /* Set up result descriptor. */
2268 res.dsc$a_pointer = buff;
2269 res.dsc$w_length = sizeof buff - 2;
2270 res.dsc$b_dtype = DSC$K_DTYPE_T;
2271 res.dsc$b_class = DSC$K_CLASS_S;
2273 /* Read files, collecting versions. */
2274 for (context = 0, e->vms_verscount = 0;
2275 e->vms_verscount < VERSIZE(e);
2276 e->vms_verscount++) {
2277 tmpsts = lib$find_file(&pat, &res, &context);
2278 if (tmpsts == RMS$_NMF || context == 0) break;
2280 buff[sizeof buff - 1] = '\0';
2281 if ((p = strchr(buff, ';')))
2282 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2284 e->vms_versions[e->vms_verscount] = -1;
2287 _ckvmssts(lib$find_file_end(&context));
2290 } /* end of collectversions() */
2293 * Read the next entry from the directory.
2295 /*{{{ struct dirent *readdir(DIR *dd)*/
2299 struct dsc$descriptor_s res;
2300 char *p, buff[sizeof dd->entry.d_name];
2301 unsigned long int tmpsts;
2303 /* Set up result descriptor, and get next file. */
2304 res.dsc$a_pointer = buff;
2305 res.dsc$w_length = sizeof buff - 2;
2306 res.dsc$b_dtype = DSC$K_DTYPE_T;
2307 res.dsc$b_class = DSC$K_CLASS_S;
2308 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2309 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2310 if (!(tmpsts & 1)) {
2311 set_vaxc_errno(tmpsts);
2314 set_errno(EACCES); break;
2316 set_errno(ENODEV); break;
2319 set_errno(ENOENT); break;
2326 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2327 buff[sizeof buff - 1] = '\0';
2328 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2331 /* Skip any directory component and just copy the name. */
2332 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2333 else (void)strcpy(dd->entry.d_name, buff);
2335 /* Clobber the version. */
2336 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2338 dd->entry.d_namlen = strlen(dd->entry.d_name);
2339 dd->entry.vms_verscount = 0;
2340 if (dd->vms_wantversions) collectversions(dd);
2343 } /* end of readdir() */
2347 * Return something that can be used in a seekdir later.
2349 /*{{{ long telldir(DIR *dd)*/
2358 * Return to a spot where we used to be. Brute force.
2360 /*{{{ void seekdir(DIR *dd,long count)*/
2362 seekdir(DIR *dd, long count)
2364 int vms_wantversions;
2366 /* If we haven't done anything yet... */
2370 /* Remember some state, and clear it. */
2371 vms_wantversions = dd->vms_wantversions;
2372 dd->vms_wantversions = 0;
2373 _ckvmssts(lib$find_file_end(&dd->context));
2376 /* The increment is in readdir(). */
2377 for (dd->count = 0; dd->count < count; )
2380 dd->vms_wantversions = vms_wantversions;
2382 } /* end of seekdir() */
2385 /* VMS subprocess management
2387 * my_vfork() - just a vfork(), after setting a flag to record that
2388 * the current script is trying a Unix-style fork/exec.
2390 * vms_do_aexec() and vms_do_exec() are called in response to the
2391 * perl 'exec' function. If this follows a vfork call, then they
2392 * call out the the regular perl routines in doio.c which do an
2393 * execvp (for those who really want to try this under VMS).
2394 * Otherwise, they do exactly what the perl docs say exec should
2395 * do - terminate the current script and invoke a new command
2396 * (See below for notes on command syntax.)
2398 * do_aspawn() and do_spawn() implement the VMS side of the perl
2399 * 'system' function.
2401 * Note on command arguments to perl 'exec' and 'system': When handled
2402 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2403 * are concatenated to form a DCL command string. If the first arg
2404 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2405 * the the command string is hrnded off to DCL directly. Otherwise,
2406 * the first token of the command is taken as the filespec of an image
2407 * to run. The filespec is expanded using a default type of '.EXE' and
2408 * the process defaults for device, directory, etc., and the resultant
2409 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2410 * the command string as parameters. This is perhaps a bit compicated,
2411 * but I hope it will form a happy medium between what VMS folks expect
2412 * from lib$spawn and what Unix folks expect from exec.
2415 static int vfork_called;
2417 /*{{{int my_vfork()*/
2427 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2435 if (VMScmd.dsc$a_pointer) {
2436 Safefree(VMScmd.dsc$a_pointer);
2437 VMScmd.dsc$w_length = 0;
2438 VMScmd.dsc$a_pointer = Nullch;
2443 setup_argstr(SV *really, SV **mark, SV **sp)
2445 char *junk, *tmps = Nullch;
2446 register size_t cmdlen = 0;
2452 tmps = SvPV(really,rlen);
2459 for (idx++; idx <= sp; idx++) {
2461 junk = SvPVx(*idx,rlen);
2462 cmdlen += rlen ? rlen + 1 : 0;
2465 New(401,Cmd,cmdlen+1,char);
2467 if (tmps && *tmps) {
2472 while (++mark <= sp) {
2475 strcat(Cmd,SvPVx(*mark,na));
2480 } /* end of setup_argstr() */
2483 static unsigned long int
2484 setup_cmddsc(char *cmd, int check_img)
2486 char resspec[NAM$C_MAXRSS+1];
2487 $DESCRIPTOR(defdsc,".EXE");
2488 $DESCRIPTOR(resdsc,resspec);
2489 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2490 unsigned long int cxt = 0, flags = 1, retsts;
2491 register char *s, *rest, *cp;
2492 register int isdcl = 0;
2495 while (*s && isspace(*s)) s++;
2497 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2498 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2499 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2500 if (*cp == ':' || *cp == '[' || *cp == '<') {
2508 if (isdcl) { /* It's a DCL command, just do it. */
2509 VMScmd.dsc$w_length = strlen(cmd);
2511 VMScmd.dsc$a_pointer = Cmd;
2512 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2514 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2516 else { /* assume first token is an image spec */
2518 while (*s && !isspace(*s)) s++;
2520 imgdsc.dsc$a_pointer = cmd;
2521 imgdsc.dsc$w_length = s - cmd;
2522 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2523 if (!(retsts & 1)) {
2524 /* just hand off status values likely to be due to user error */
2525 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2526 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2527 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2528 else { _ckvmssts(retsts); }
2531 _ckvmssts(lib$find_file_end(&cxt));
2533 while (*s && !isspace(*s)) s++;
2535 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2536 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2537 strcat(VMScmd.dsc$a_pointer,resspec);
2538 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2539 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2543 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2545 } /* end of setup_cmddsc() */
2548 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2550 vms_do_aexec(SV *really,SV **mark,SV **sp)
2553 if (vfork_called) { /* this follows a vfork - act Unixish */
2555 if (vfork_called < 0) {
2556 warn("Internal inconsistency in tracking vforks");
2559 else return do_aexec(really,mark,sp);
2561 /* no vfork - act VMSish */
2562 return vms_do_exec(setup_argstr(really,mark,sp));
2567 } /* end of vms_do_aexec() */
2570 /* {{{bool vms_do_exec(char *cmd) */
2572 vms_do_exec(char *cmd)
2575 if (vfork_called) { /* this follows a vfork - act Unixish */
2577 if (vfork_called < 0) {
2578 warn("Internal inconsistency in tracking vforks");
2581 else return do_exec(cmd);
2584 { /* no vfork - act VMSish */
2585 unsigned long int retsts;
2587 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2588 retsts = lib$do_command(&VMScmd);
2591 set_vaxc_errno(retsts);
2593 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2599 } /* end of vms_do_exec() */
2602 unsigned long int do_spawn(char *);
2604 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2606 do_aspawn(SV *really,SV **mark,SV **sp)
2608 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2611 } /* end of do_aspawn() */
2614 /* {{{unsigned long int do_spawn(char *cmd) */
2618 unsigned long int substs, hadcmd = 1;
2620 if (!cmd || !*cmd) {
2622 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2624 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2625 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2630 set_vaxc_errno(substs);
2632 warn("Can't spawn \"%s\": %s",
2633 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2638 } /* end of do_spawn() */
2642 * A simple fwrite replacement which outputs itmsz*nitm chars without
2643 * introducing record boundaries every itmsz chars.
2645 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2647 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2649 register char *cp, *end;
2651 end = (char *)src + itmsz * nitm;
2653 while ((char *)src <= end) {
2654 for (cp = src; cp <= end; cp++) if (!*cp) break;
2655 if (fputs(src,dest) == EOF) return EOF;
2657 if (fputc('\0',dest) == EOF) return EOF;
2663 } /* end of my_fwrite() */
2667 * Here are replacements for the following Unix routines in the VMS environment:
2668 * getpwuid Get information for a particular UIC or UID
2669 * getpwnam Get information for a named user
2670 * getpwent Get information for each user in the rights database
2671 * setpwent Reset search to the start of the rights database
2672 * endpwent Finish searching for users in the rights database
2674 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2675 * (defined in pwd.h), which contains the following fields:-
2677 * char *pw_name; Username (in lower case)
2678 * char *pw_passwd; Hashed password
2679 * unsigned int pw_uid; UIC
2680 * unsigned int pw_gid; UIC group number
2681 * char *pw_unixdir; Default device/directory (VMS-style)
2682 * char *pw_gecos; Owner name
2683 * char *pw_dir; Default device/directory (Unix-style)
2684 * char *pw_shell; Default CLI name (eg. DCL)
2686 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2688 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2689 * not the UIC member number (eg. what's returned by getuid()),
2690 * getpwuid() can accept either as input (if uid is specified, the caller's
2691 * UIC group is used), though it won't recognise gid=0.
2693 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2694 * information about other users in your group or in other groups, respectively.
2695 * If the required privilege is not available, then these routines fill only
2696 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2699 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2702 /* sizes of various UAF record fields */
2703 #define UAI$S_USERNAME 12
2704 #define UAI$S_IDENT 31
2705 #define UAI$S_OWNER 31
2706 #define UAI$S_DEFDEV 31
2707 #define UAI$S_DEFDIR 63
2708 #define UAI$S_DEFCLI 31
2711 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2712 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2713 (uic).uic$v_group != UIC$K_WILD_GROUP)
2715 static char __empty[]= "";
2716 static struct passwd __passwd_empty=
2717 {(char *) __empty, (char *) __empty, 0, 0,
2718 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2719 static int contxt= 0;
2720 static struct passwd __pwdcache;
2721 static char __pw_namecache[UAI$S_IDENT+1];
2724 * This routine does most of the work extracting the user information.
2726 static int fillpasswd (const char *name, struct passwd *pwd)
2729 unsigned char length;
2730 char pw_gecos[UAI$S_OWNER+1];
2732 static union uicdef uic;
2734 unsigned char length;
2735 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2738 unsigned char length;
2739 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2742 unsigned char length;
2743 char pw_shell[UAI$S_DEFCLI+1];
2745 static char pw_passwd[UAI$S_PWD+1];
2747 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2748 struct dsc$descriptor_s name_desc;
2749 unsigned long int sts;
2751 static struct itmlst_3 itmlst[]= {
2752 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2753 {sizeof(uic), UAI$_UIC, &uic, &luic},
2754 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2755 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2756 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2757 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2758 {0, 0, NULL, NULL}};
2760 name_desc.dsc$w_length= strlen(name);
2761 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2762 name_desc.dsc$b_class= DSC$K_CLASS_S;
2763 name_desc.dsc$a_pointer= (char *) name;
2765 /* Note that sys$getuai returns many fields as counted strings. */
2766 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2767 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2768 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2770 else { _ckvmssts(sts); }
2771 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2773 if ((int) owner.length < lowner) lowner= (int) owner.length;
2774 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2775 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2776 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2777 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2778 owner.pw_gecos[lowner]= '\0';
2779 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2780 defcli.pw_shell[ldefcli]= '\0';
2781 if (valid_uic(uic)) {
2782 pwd->pw_uid= uic.uic$l_uic;
2783 pwd->pw_gid= uic.uic$v_group;
2786 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2787 pwd->pw_passwd= pw_passwd;
2788 pwd->pw_gecos= owner.pw_gecos;
2789 pwd->pw_dir= defdev.pw_dir;
2790 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2791 pwd->pw_shell= defcli.pw_shell;
2792 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2794 ldir= strlen(pwd->pw_unixdir) - 1;
2795 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2798 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2799 __mystrtolower(pwd->pw_unixdir);
2804 * Get information for a named user.
2806 /*{{{struct passwd *getpwnam(char *name)*/
2807 struct passwd *my_getpwnam(char *name)
2809 struct dsc$descriptor_s name_desc;
2811 unsigned long int status, stat;
2813 __pwdcache = __passwd_empty;
2814 if (!fillpasswd(name, &__pwdcache)) {
2815 /* We still may be able to determine pw_uid and pw_gid */
2816 name_desc.dsc$w_length= strlen(name);
2817 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2818 name_desc.dsc$b_class= DSC$K_CLASS_S;
2819 name_desc.dsc$a_pointer= (char *) name;
2820 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2821 __pwdcache.pw_uid= uic.uic$l_uic;
2822 __pwdcache.pw_gid= uic.uic$v_group;
2825 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2826 set_vaxc_errno(stat);
2827 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2830 else { _ckvmssts(stat); }
2833 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2834 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2835 __pwdcache.pw_name= __pw_namecache;
2837 } /* end of my_getpwnam() */
2841 * Get information for a particular UIC or UID.
2842 * Called by my_getpwent with uid=-1 to list all users.
2844 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2845 struct passwd *my_getpwuid(Uid_t uid)
2847 const $DESCRIPTOR(name_desc,__pw_namecache);
2848 unsigned short lname;
2850 unsigned long int status;
2852 if (uid == (unsigned int) -1) {
2854 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2855 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2856 set_vaxc_errno(status);
2857 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2861 else { _ckvmssts(status); }
2862 } while (!valid_uic (uic));
2866 if (!uic.uic$v_group)
2867 uic.uic$v_group= getgid();
2869 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2870 else status = SS$_IVIDENT;
2871 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2872 status == RMS$_PRV) {
2873 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2876 else { _ckvmssts(status); }
2878 __pw_namecache[lname]= '\0';
2879 __mystrtolower(__pw_namecache);
2881 __pwdcache = __passwd_empty;
2882 __pwdcache.pw_name = __pw_namecache;
2884 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2885 The identifier's value is usually the UIC, but it doesn't have to be,
2886 so if we can, we let fillpasswd update this. */
2887 __pwdcache.pw_uid = uic.uic$l_uic;
2888 __pwdcache.pw_gid = uic.uic$v_group;
2890 fillpasswd(__pw_namecache, &__pwdcache);
2893 } /* end of my_getpwuid() */
2897 * Get information for next user.
2899 /*{{{struct passwd *my_getpwent()*/
2900 struct passwd *my_getpwent()
2902 return (my_getpwuid((unsigned int) -1));
2907 * Finish searching rights database for users.
2909 /*{{{void my_endpwent()*/
2913 _ckvmssts(sys$finish_rdb(&contxt));
2921 * If the CRTL has a real gmtime(), use it, else look for the logical
2922 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2923 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
2924 * to translate to the number of seconds which must be added to UTC
2925 * to get to the local time of the system.
2926 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
2929 /*{{{struct tm *my_gmtime(const time_t *time)*/
2930 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
2931 * so we can call the CRTL's routine to see if it works.
2935 my_gmtime(const time_t *time)
2937 static int gmtime_emulation_type;
2938 static time_t utc_offset_secs;
2942 if (gmtime_emulation_type == 0) {
2943 gmtime_emulation_type++;
2945 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
2946 gmtime_emulation_type++;
2947 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2948 gmtime_emulation_type++;
2950 utc_offset_secs = (time_t) atol(p);
2954 switch (gmtime_emulation_type) {
2956 return gmtime(time);
2958 when = *time - utc_offset_secs;
2959 return localtime(&when);
2961 warn("gmtime not supported on this system");
2964 } /* end of my_gmtime() */
2965 /* Reset definition for later calls */
2966 #define gmtime(t) my_gmtime(t)
2971 * flex_stat, flex_fstat
2972 * basic stat, but gets it right when asked to stat
2973 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2976 /* encode_dev packs a VMS device name string into an integer to allow
2977 * simple comparisons. This can be used, for example, to check whether two
2978 * files are located on the same device, by comparing their encoded device
2979 * names. Even a string comparison would not do, because stat() reuses the
2980 * device name buffer for each call; so without encode_dev, it would be
2981 * necessary to save the buffer and use strcmp (this would mean a number of
2982 * changes to the standard Perl code, to say nothing of what a Perl script
2985 * The device lock id, if it exists, should be unique (unless perhaps compared
2986 * with lock ids transferred from other nodes). We have a lock id if the disk is
2987 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2988 * device names. Thus we use the lock id in preference, and only if that isn't
2989 * available, do we try to pack the device name into an integer (flagged by
2990 * the sign bit (LOCKID_MASK) being set).
2992 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2993 * name and its encoded form, but it seems very unlikely that we will find
2994 * two files on different disks that share the same encoded device names,
2995 * and even more remote that they will share the same file id (if the test
2996 * is to check for the same file).
2998 * A better method might be to use sys$device_scan on the first call, and to
2999 * search for the device, returning an index into the cached array.
3000 * The number returned would be more intelligable.
3001 * This is probably not worth it, and anyway would take quite a bit longer
3002 * on the first call.
3004 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3005 static dev_t encode_dev (const char *dev)
3008 unsigned long int f;
3013 if (!dev || !dev[0]) return 0;
3017 struct dsc$descriptor_s dev_desc;
3018 unsigned long int status, lockid, item = DVI$_LOCKID;
3020 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3021 can try that first. */
3022 dev_desc.dsc$w_length = strlen (dev);
3023 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3024 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3025 dev_desc.dsc$a_pointer = (char *) dev;
3026 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3027 if (lockid) return (lockid & ~LOCKID_MASK);
3031 /* Otherwise we try to encode the device name */
3035 for (q = dev + strlen(dev); q--; q >= dev) {
3038 else if (isalpha (toupper (*q)))
3039 c= toupper (*q) - 'A' + (char)10;
3041 continue; /* Skip '$'s */
3043 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3045 enc += f * (unsigned long int) c;
3047 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3049 } /* end of encode_dev() */
3051 static char namecache[NAM$C_MAXRSS+1];
3054 is_null_device(name)
3057 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3058 The underscore prefix, controller letter, and unit number are
3059 independently optional; for our purposes, the colon punctuation
3060 is not. The colon can be trailed by optional directory and/or
3061 filename, but two consecutive colons indicates a nodename rather
3062 than a device. [pr] */
3063 if (*name == '_') ++name;
3064 if (tolower(*name++) != 'n') return 0;
3065 if (tolower(*name++) != 'l') return 0;
3066 if (tolower(*name) == 'a') ++name;
3067 if (*name == '0') ++name;
3068 return (*name++ == ':') && (*name != ':');
3071 /* Do the permissions allow some operation? Assumes statcache already set. */
3072 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3073 * subset of the applicable information.
3075 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3077 cando(I32 bit, I32 effective, struct stat *statbufp)
3079 if (statbufp == &statcache)
3080 return cando_by_name(bit,effective,namecache);
3082 char fname[NAM$C_MAXRSS+1];
3083 unsigned long int retsts;
3084 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3085 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3087 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3088 device name on successive calls */
3089 devdsc.dsc$a_pointer = statbufp->st_devnam;
3090 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3091 namdsc.dsc$a_pointer = fname;
3092 namdsc.dsc$w_length = sizeof fname - 1;
3094 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3095 &namdsc.dsc$w_length,0,0);
3097 fname[namdsc.dsc$w_length] = '\0';
3098 return cando_by_name(bit,effective,fname);
3100 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3101 warn("Can't get filespec - stale stat buffer?\n");
3105 return FALSE; /* Should never get to here */
3107 } /* end of cando() */
3111 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3113 cando_by_name(I32 bit, I32 effective, char *fname)
3115 static char usrname[L_cuserid];
3116 static struct dsc$descriptor_s usrdsc =
3117 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3118 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3119 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3120 unsigned short int retlen;
3121 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3122 union prvdef curprv;
3123 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3124 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3125 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3128 if (!fname || !*fname) return FALSE;
3129 /* Make sure we expand logical names, since sys$check_access doesn't */
3130 if (!strpbrk(fname,"/]>:")) {
3131 strcpy(fileified,fname);
3132 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3135 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3136 retlen = namdsc.dsc$w_length = strlen(vmsname);
3137 namdsc.dsc$a_pointer = vmsname;
3138 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3139 vmsname[retlen-1] == ':') {
3140 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3141 namdsc.dsc$w_length = strlen(fileified);
3142 namdsc.dsc$a_pointer = fileified;
3145 if (!usrdsc.dsc$w_length) {
3147 usrdsc.dsc$w_length = strlen(usrname);
3154 access = ARM$M_EXECUTE;
3159 access = ARM$M_READ;
3164 access = ARM$M_WRITE;
3169 access = ARM$M_DELETE;
3175 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3176 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3177 retsts == RMS$_FNF || retsts == RMS$_DIR ||
3178 retsts == RMS$_DEV) {
3179 set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts);
3182 if (retsts == SS$_NORMAL) {
3183 if (!privused) return TRUE;
3184 /* We can get access, but only by using privs. Do we have the
3185 necessary privs currently enabled? */
3186 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3187 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3188 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3189 !curprv.prv$v_bypass) return FALSE;
3190 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3191 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3192 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3197 return FALSE; /* Should never get here */
3199 } /* end of cando_by_name() */
3203 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3206 flex_fstat(int fd, struct mystat *statbufp)
3208 if (!fstat(fd,(stat_t *) statbufp)) {
3209 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3214 } /* end of flex_fstat() */
3217 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3218 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3219 * 'struct stat' elsewhere in Perl would use our struct. We go back
3220 * to the system version here, since we're actually calling their
3224 flex_stat(char *fspec, struct mystat *statbufp)
3226 char fileified[NAM$C_MAXRSS+1];
3227 int retval,myretval;
3228 struct mystat tmpbuf;
3231 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3232 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3233 memset(statbufp,0,sizeof *statbufp);
3234 statbufp->st_dev = encode_dev("_NLA0:");
3235 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3236 statbufp->st_uid = 0x00010001;
3237 statbufp->st_gid = 0x0001;
3238 time((time_t *)&statbufp->st_mtime);
3239 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3243 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3245 myretval = stat(fileified,(stat_t *) &tmpbuf);
3247 retval = stat(fspec,(stat_t *) statbufp);
3253 else if (!retval) { /* Dir with same name. Substitute it. */
3254 statbufp->st_mode &= ~S_IFDIR;
3255 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3256 strcpy(namecache,fileified);
3259 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3262 } /* end of flex_stat() */
3263 /* Reset definition for later calls */
3267 /* Insures that no carriage-control translation will be done on a file. */
3268 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3270 my_binmode(FILE *fp, char iotype)
3272 char filespec[NAM$C_MAXRSS], *acmode;
3275 if (!fgetname(fp,filespec)) return NULL;
3276 if (fgetpos(fp,&pos) == -1) return NULL;
3278 case '<': case 'r': acmode = "rb"; break;
3279 case '>': case 'w': acmode = "wb"; break;
3280 case '+': case '|': case 's': acmode = "rb+"; break;
3281 case 'a': acmode = "ab"; break;
3282 case '-': acmode = fileno(fp) ? "wb" : "rb"; break;
3284 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3285 if (fsetpos(fp,&pos) == -1) return NULL;
3286 } /* end of my_binmode() */
3290 /*{{{char *my_getlogin()*/
3291 /* VMS cuserid == Unix getlogin, except calling sequence */
3295 static char user[L_cuserid];
3296 return cuserid(user);
3301 /* rmscopy - copy a file using VMS RMS routines
3303 * Copies contents and attributes of spec_in to spec_out, except owner
3304 * and protection information. Name and type of spec_in are used as
3305 * defaults for spec_out. The third parameter specifies whether rmscopy()
3306 * should try to propagate timestamps from the input file to the output file.
3307 * If it is less than 0, no timestamps are preserved. If it is 0, then
3308 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3309 * propagated to the output file at creation iff the output file specification
3310 * did not contain an explicit name or type, and the revision date is always
3311 * updated at the end of the copy operation. If it is greater than 0, then
3312 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3313 * other than the revision date should be propagated, and bit 1 indicates
3314 * that the revision date should be propagated.
3316 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3318 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3319 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3320 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3321 * as part of the Perl standard distribution under the terms of the
3322 * GNU General Public License or the Perl Artistic License. Copies
3323 * of each may be found in the Perl standard distribution.
3325 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3327 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3329 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3330 rsa[NAM$C_MAXRSS], ubf[32256];
3331 unsigned long int i, sts, sts2;
3332 struct FAB fab_in, fab_out;
3333 struct RAB rab_in, rab_out;
3335 struct XABDAT xabdat;
3336 struct XABFHC xabfhc;
3337 struct XABRDT xabrdt;
3338 struct XABSUM xabsum;
3340 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3341 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3342 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3346 fab_in = cc$rms_fab;
3347 fab_in.fab$l_fna = vmsin;
3348 fab_in.fab$b_fns = strlen(vmsin);
3349 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3350 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3351 fab_in.fab$l_fop = FAB$M_SQO;
3352 fab_in.fab$l_nam = &nam;
3353 fab_in.fab$l_xab = (void *) &xabdat;
3356 nam.nam$l_rsa = rsa;
3357 nam.nam$b_rss = sizeof(rsa);
3358 nam.nam$l_esa = esa;
3359 nam.nam$b_ess = sizeof (esa);
3360 nam.nam$b_esl = nam.nam$b_rsl = 0;
3362 xabdat = cc$rms_xabdat; /* To get creation date */
3363 xabdat.xab$l_nxt = (void *) &xabfhc;
3365 xabfhc = cc$rms_xabfhc; /* To get record length */
3366 xabfhc.xab$l_nxt = (void *) &xabsum;
3368 xabsum = cc$rms_xabsum; /* To get key and area information */
3370 if (!((sts = sys$open(&fab_in)) & 1)) {
3371 set_vaxc_errno(sts);
3375 set_errno(ENOENT); break;
3377 set_errno(ENODEV); break;
3379 set_errno(EINVAL); break;
3381 set_errno(EACCES); break;
3389 fab_out.fab$w_ifi = 0;
3390 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3391 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3392 fab_out.fab$l_fop = FAB$M_SQO;
3393 fab_out.fab$l_fna = vmsout;
3394 fab_out.fab$b_fns = strlen(vmsout);
3395 fab_out.fab$l_dna = nam.nam$l_name;
3396 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3398 if (preserve_dates == 0) { /* Act like DCL COPY */
3399 nam.nam$b_nop = NAM$M_SYNCHK;
3400 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3401 if (!((sts = sys$parse(&fab_out)) & 1)) {
3402 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3403 set_vaxc_errno(sts);
3406 fab_out.fab$l_xab = (void *) &xabdat;
3407 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3409 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3410 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3411 preserve_dates =0; /* bitmask from this point forward */
3413 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3414 if (!((sts = sys$create(&fab_out)) & 1)) {
3415 set_vaxc_errno(sts);
3418 set_errno(ENOENT); break;
3420 set_errno(ENODEV); break;
3422 set_errno(EINVAL); break;
3424 set_errno(EACCES); break;
3430 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3431 if (preserve_dates & 2) {
3432 /* sys$close() will process xabrdt, not xabdat */
3433 xabrdt = cc$rms_xabrdt;
3435 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3437 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3438 * is unsigned long[2], while DECC & VAXC use a struct */
3439 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3441 fab_out.fab$l_xab = (void *) &xabrdt;
3444 rab_in = cc$rms_rab;
3445 rab_in.rab$l_fab = &fab_in;
3446 rab_in.rab$l_rop = RAB$M_BIO;
3447 rab_in.rab$l_ubf = ubf;
3448 rab_in.rab$w_usz = sizeof ubf;
3449 if (!((sts = sys$connect(&rab_in)) & 1)) {
3450 sys$close(&fab_in); sys$close(&fab_out);
3451 set_errno(EVMSERR); set_vaxc_errno(sts);
3455 rab_out = cc$rms_rab;
3456 rab_out.rab$l_fab = &fab_out;
3457 rab_out.rab$l_rbf = ubf;
3458 if (!((sts = sys$connect(&rab_out)) & 1)) {
3459 sys$close(&fab_in); sys$close(&fab_out);
3460 set_errno(EVMSERR); set_vaxc_errno(sts);
3464 while ((sts = sys$read(&rab_in))) { /* always true */
3465 if (sts == RMS$_EOF) break;
3466 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3467 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3468 sys$close(&fab_in); sys$close(&fab_out);
3469 set_errno(EVMSERR); set_vaxc_errno(sts);
3474 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3475 sys$close(&fab_in); sys$close(&fab_out);
3476 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3478 set_errno(EVMSERR); set_vaxc_errno(sts);
3484 } /* end of rmscopy() */
3488 /*** The following glue provides 'hooks' to make some of the routines
3489 * from this file available from Perl. These routines are sufficiently
3490 * basic, and are required sufficiently early in the build process,
3491 * that's it's nice to have them available to miniperl as well as the
3492 * full Perl, so they're set up here instead of in an extension. The
3493 * Perl code which handles importation of these names into a given
3494 * package lives in [.VMS]Filespec.pm in @INC.
3498 rmsexpand_fromperl(CV *cv)
3501 char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
3502 struct FAB myfab = cc$rms_fab;
3503 struct NAM mynam = cc$rms_nam;
3505 unsigned long int retsts, haslower = 0;
3507 if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3509 myfab.fab$l_fna = SvPV(ST(0),speclen);
3510 myfab.fab$b_fns = speclen;
3511 myfab.fab$l_nam = &mynam;
3514 myfab.fab$l_dna = SvPV(ST(1),speclen);
3515 myfab.fab$b_dns = speclen;
3518 mynam.nam$l_esa = esa;
3519 mynam.nam$b_ess = sizeof esa;
3520 mynam.nam$l_rsa = rsa;
3521 mynam.nam$b_rss = sizeof rsa;
3523 retsts = sys$parse(&myfab,0,0);
3524 if (!(retsts & 1)) {
3525 if (retsts == RMS$_DNF) {
3526 mynam.nam$b_nop |= NAM$M_SYNCHK;
3527 retsts = sys$parse(&myfab,0,0);
3528 if (retsts & 1) goto expanded;
3530 set_vaxc_errno(retsts);
3531 if (retsts == RMS$_PRV) set_errno(EACCES);
3532 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3533 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3534 else set_errno(EVMSERR);
3537 retsts = sys$search(&myfab,0,0);
3538 if (!(retsts & 1) && retsts != RMS$_FNF) {
3539 set_vaxc_errno(retsts);
3540 if (retsts == RMS$_PRV) set_errno(EACCES);
3541 else set_errno(EVMSERR);
3545 /* If the input filespec contained any lowercase characters,
3546 * downcase the result for compatibility with Unix-minded code. */
3548 for (out = myfab.fab$l_fna; *out; out++)
3549 if (islower(*out)) { haslower = 1; break; }
3550 if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
3551 else { out = esa; speclen = mynam.nam$b_esl; }
3552 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER))
3553 speclen = mynam.nam$l_type - out;
3554 out[speclen] = '\0';
3555 if (haslower) __mystrtolower(out);
3557 ST(0) = sv_2mortal(newSVpv(out, speclen));
3561 vmsify_fromperl(CV *cv)
3566 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3567 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3568 ST(0) = sv_newmortal();
3569 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3574 unixify_fromperl(CV *cv)
3579 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3580 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3581 ST(0) = sv_newmortal();
3582 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3587 fileify_fromperl(CV *cv)
3592 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3593 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3594 ST(0) = sv_newmortal();
3595 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3600 pathify_fromperl(CV *cv)
3605 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3606 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3607 ST(0) = sv_newmortal();
3608 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3613 vmspath_fromperl(CV *cv)
3618 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3619 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3620 ST(0) = sv_newmortal();
3621 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3626 unixpath_fromperl(CV *cv)
3631 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3632 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3633 ST(0) = sv_newmortal();
3634 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3639 candelete_fromperl(CV *cv)
3642 char fspec[NAM$C_MAXRSS+1], *fsp;
3646 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3648 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3649 if (SvTYPE(mysv) == SVt_PVGV) {
3650 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3651 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3658 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3659 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3665 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3670 rmscopy_fromperl(CV *cv)
3673 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3675 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3676 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3677 unsigned long int sts;
3681 if (items < 2 || items > 3)
3682 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3684 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3685 if (SvTYPE(mysv) == SVt_PVGV) {
3686 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3687 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3694 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3695 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3700 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3701 if (SvTYPE(mysv) == SVt_PVGV) {
3702 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3703 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3710 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3711 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3716 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3718 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3725 char* file = __FILE__;
3727 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$");
3728 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3729 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3730 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3731 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3732 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3733 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3734 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3735 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);