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 /* Older versions of ssdef.h don't have these */
37 #ifndef SS$_INVFILFOROP
38 # define SS$_INVFILFOROP 3930
40 #ifndef SS$_NOSUCHOBJECT
41 # define SS$_NOSUCHOBJECT 2696
44 /* Don't intercept calls to vfork, since my_vfork below needs to
45 * get to the underlying CRTL routine. */
46 #define __DONT_MASK_VFORK
51 /* gcc's header files don't #define direct access macros
52 * corresponding to VAXC's variant structs */
54 # define uic$v_format uic$r_uic_form.uic$v_format
55 # define uic$v_group uic$r_uic_form.uic$v_group
56 # define uic$v_member uic$r_uic_form.uic$v_member
57 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
58 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
59 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
60 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
65 unsigned short int buflen;
66 unsigned short int itmcode;
68 unsigned short int *retlen;
71 static char *__mystrtolower(char *str)
73 if (str) for (; *str; ++str) *str= tolower(*str);
78 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
80 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
81 unsigned short int eqvlen;
82 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
83 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
84 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
85 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
86 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
89 if (!lnm || idx > LNM$_MAX_INDEX) {
90 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
92 if (!eqv) eqv = __my_trnlnm_eqv;
93 lnmlst[1].bufadr = (void *)eqv;
94 lnmdsc.dsc$a_pointer = lnm;
95 lnmdsc.dsc$w_length = strlen(lnm);
96 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
97 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
98 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
100 else if (retsts & 1) {
104 _ckvmssts(retsts); /* Must be an error */
105 return 0; /* Not reached, assuming _ckvmssts() bails out */
107 } /* end of my_trnlnm */
110 * Translate a logical name. Substitute for CRTL getenv() to avoid
111 * memory leak, and to keep my_getenv() and my_setenv() in the same
112 * domain (mostly - my_getenv() need not return a translation from
113 * the process logical name table)
115 * Note: Uses static buffer -- not thread-safe!
117 /*{{{ char *my_getenv(char *lnm)*/
121 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
122 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
123 unsigned long int idx = 0;
125 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
127 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
128 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
129 return __my_getenv_eqv;
132 if ((cp2 = strchr(uplnm,';')) != NULL) {
134 idx = strtoul(cp2+1,NULL,0);
136 if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
137 return __my_getenv_eqv;
140 unsigned long int retsts;
141 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
142 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
143 DSC$K_CLASS_S, __my_getenv_eqv};
144 symdsc.dsc$w_length = cp1 - lnm;
145 symdsc.dsc$a_pointer = uplnm;
146 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
147 if (retsts == LIB$_INVSYMNAM) return Nullch;
148 if (retsts != LIB$_NOSUCHSYM) {
149 /* We want to return only logical names or CRTL Unix emulations */
150 if (retsts & 1) return Nullch;
153 /* Try for CRTL emulation of a Unix/POSIX name */
154 else return getenv(uplnm);
159 } /* end of my_getenv() */
162 /*{{{ void prime_env_iter() */
165 /* Fill the %ENV associative array with all logical names we can
166 * find, in preparation for iterating over it.
169 static int primed = 0; /* XXX Not thread-safe!!! */
170 HV *envhv = GvHVn(envgv);
172 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
174 SV *oldrs, *linesv, *eqvsv;
177 /* Perform a dummy fetch as an lval to insure that the hash table is
178 * set up. Otherwise, the hv_store() will turn into a nullop */
179 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
180 /* Also, set up the four "special" keys that the CRTL defines,
181 * whether or not underlying logical names exist. */
182 (void) hv_fetch(envhv,"HOME",4,TRUE);
183 (void) hv_fetch(envhv,"TERM",4,TRUE);
184 (void) hv_fetch(envhv,"PATH",4,TRUE);
185 (void) hv_fetch(envhv,"USER",4,TRUE);
187 /* Now, go get the logical names */
188 if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
189 _ckvmssts(vaxc$errno);
190 /* We use Perl's sv_gets to read from the pipe, since my_popen is
191 * tied to Perl's I/O layer, so it may not return a simple FILE * */
193 rs = newSVpv("\n",1);
194 linesv = newSVpv("",0);
196 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
198 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
202 while (*start != '"' && *start != '=' && *start) start++;
203 if (*start != '"') continue;
204 for (end = ++start; *end && *end != '"'; end++) ;
205 if (*end) *end = '\0';
207 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) _ckvmssts(vaxc$errno);
209 eqvsv = newSVpv(eqv,eqvlen);
210 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
213 } /* end of prime_env_iter */
217 /*{{{ void my_setenv(char *lnm, char *eqv)*/
219 my_setenv(char *lnm,char *eqv)
220 /* Define a supervisor-mode logical name in the process table.
221 * In the future we'll add tables, attribs, and acmodes,
222 * probably through a different call.
225 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
226 unsigned long int retsts, usermode = PSL$C_USER;
227 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
228 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
229 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
231 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
232 lnmdsc.dsc$w_length = cp1 - lnm;
234 if (!eqv || !*eqv) { /* we're deleting a logical name */
235 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
236 if (retsts == SS$_IVLOGNAM) return;
237 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
239 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
240 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
244 eqvdsc.dsc$w_length = strlen(eqv);
245 eqvdsc.dsc$a_pointer = eqv;
247 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
250 } /* end of my_setenv() */
254 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
255 /* my_crypt - VMS password hashing
256 * my_crypt() provides an interface compatible with the Unix crypt()
257 * C library function, and uses sys$hash_password() to perform VMS
258 * password hashing. The quadword hashed password value is returned
259 * as a NUL-terminated 8 character string. my_crypt() does not change
260 * the case of its string arguments; in order to match the behavior
261 * of LOGINOUT et al., alphabetic characters in both arguments must
262 * be upcased by the caller.
265 my_crypt(const char *textpasswd, const char *usrname)
267 # ifndef UAI$C_PREFERRED_ALGORITHM
268 # define UAI$C_PREFERRED_ALGORITHM 127
270 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
271 unsigned short int salt = 0;
272 unsigned long int sts;
274 unsigned short int dsc$w_length;
275 unsigned char dsc$b_type;
276 unsigned char dsc$b_class;
277 const char * dsc$a_pointer;
278 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
279 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
280 struct itmlst_3 uailst[3] = {
281 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
282 { sizeof salt, UAI$_SALT, &salt, 0},
283 { 0, 0, NULL, NULL}};
286 usrdsc.dsc$w_length = strlen(usrname);
287 usrdsc.dsc$a_pointer = usrname;
288 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
295 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
301 if (sts != RMS$_RNF) return NULL;
304 txtdsc.dsc$w_length = strlen(textpasswd);
305 txtdsc.dsc$a_pointer = textpasswd;
306 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
307 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
310 return (char *) hash;
312 } /* end of my_crypt() */
316 static char *do_fileify_dirspec(char *, char *, int);
317 static char *do_tovmsspec(char *, char *, int);
319 /*{{{int do_rmdir(char *name)*/
323 char dirfile[NAM$C_MAXRSS+1];
327 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
328 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
329 else retval = kill_file(dirfile);
332 } /* end of do_rmdir */
336 * Delete any file to which user has control access, regardless of whether
337 * delete access is explicitly allowed.
338 * Limitations: User must have write access to parent directory.
339 * Does not block signals or ASTs; if interrupted in midstream
340 * may leave file with an altered ACL.
343 /*{{{int kill_file(char *name)*/
345 kill_file(char *name)
347 char vmsname[NAM$C_MAXRSS+1];
348 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
349 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
350 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
352 unsigned char myace$b_length;
353 unsigned char myace$b_type;
354 unsigned short int myace$w_flags;
355 unsigned long int myace$l_access;
356 unsigned long int myace$l_ident;
357 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
358 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
359 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
361 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
362 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
363 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
364 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
365 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
366 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
368 if (!remove(name)) return 0; /* Can we just get rid of it? */
369 /* If not, can changing protections help? */
370 if (vaxc$errno != RMS$_PRV) return -1;
372 /* No, so we get our own UIC to use as a rights identifier,
373 * and the insert an ACE at the head of the ACL which allows us
374 * to delete the file.
376 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
377 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
378 fildsc.dsc$w_length = strlen(vmsname);
379 fildsc.dsc$a_pointer = vmsname;
381 newace.myace$l_ident = oldace.myace$l_ident;
382 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
387 case SS$_NOSUCHOBJECT:
388 set_errno(ENOENT); break;
390 set_errno(ENODEV); break;
392 case SS$_INVFILFOROP:
393 set_errno(EINVAL); break;
395 set_errno(EACCES); break;
399 set_vaxc_errno(aclsts);
402 /* Grab any existing ACEs with this identifier in case we fail */
403 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
404 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
405 || fndsts == SS$_NOMOREACE ) {
406 /* Add the new ACE . . . */
407 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
409 if ((rmsts = remove(name))) {
410 /* We blew it - dir with files in it, no write priv for
411 * parent directory, etc. Put things back the way they were. */
412 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
415 addlst[0].bufadr = &oldace;
416 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
423 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
424 /* We just deleted it, so of course it's not there. Some versions of
425 * VMS seem to return success on the unlock operation anyhow (after all
426 * the unlock is successful), but others don't.
428 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
429 if (aclsts & 1) aclsts = fndsts;
432 set_vaxc_errno(aclsts);
438 } /* end of kill_file() */
441 /* my_utime - update modification time of a file
442 * calling sequence is identical to POSIX utime(), but under
443 * VMS only the modification time is changed; ODS-2 does not
444 * maintain access times. Restrictions differ from the POSIX
445 * definition in that the time can be changed as long as the
446 * caller has permission to execute the necessary IO$_MODIFY $QIO;
447 * no separate checks are made to insure that the caller is the
448 * owner of the file or has special privs enabled.
449 * Code here is based on Joe Meadows' FILE utility.
452 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
453 * to VMS epoch (01-JAN-1858 00:00:00.00)
454 * in 100 ns intervals.
456 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
458 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
459 int my_utime(char *file, struct utimbuf *utimes)
462 long int bintime[2], len = 2, lowbit, unixtime,
463 secscale = 10000000; /* seconds --> 100 ns intervals */
464 unsigned long int chan, iosb[2], retsts;
465 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
466 struct FAB myfab = cc$rms_fab;
467 struct NAM mynam = cc$rms_nam;
468 #if defined (__DECC) && defined (__VAX)
469 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
470 * at least through VMS V6.1, which causes a type-conversion warning.
472 # pragma message save
473 # pragma message disable cvtdiftypes
475 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
477 #if defined (__DECC) && defined (__VAX)
478 /* This should be right after the declaration of myatr, but due
479 * to a bug in VAX DEC C, this takes effect a statement early.
481 # pragma message restore
483 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
484 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
485 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
487 if (file == NULL || *file == '\0') {
489 set_vaxc_errno(LIB$_INVARG);
492 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
494 if (utimes != NULL) {
495 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
496 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
497 * Since time_t is unsigned long int, and lib$emul takes a signed long int
498 * as input, we force the sign bit to be clear by shifting unixtime right
499 * one bit, then multiplying by an extra factor of 2 in lib$emul().
501 lowbit = (utimes->modtime & 1) ? secscale : 0;
502 unixtime = (long int) utimes->modtime;
503 unixtime >> 1; secscale << 1;
504 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
507 set_vaxc_errno(retsts);
510 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
513 set_vaxc_errno(retsts);
518 /* Just get the current time in VMS format directly */
519 retsts = sys$gettim(bintime);
522 set_vaxc_errno(retsts);
527 myfab.fab$l_fna = vmsspec;
528 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
529 myfab.fab$l_nam = &mynam;
530 mynam.nam$l_esa = esa;
531 mynam.nam$b_ess = (unsigned char) sizeof esa;
532 mynam.nam$l_rsa = rsa;
533 mynam.nam$b_rss = (unsigned char) sizeof rsa;
535 /* Look for the file to be affected, letting RMS parse the file
536 * specification for us as well. I have set errno using only
537 * values documented in the utime() man page for VMS POSIX.
539 retsts = sys$parse(&myfab,0,0);
541 set_vaxc_errno(retsts);
542 if (retsts == RMS$_PRV) set_errno(EACCES);
543 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
544 else set_errno(EVMSERR);
547 retsts = sys$search(&myfab,0,0);
549 set_vaxc_errno(retsts);
550 if (retsts == RMS$_PRV) set_errno(EACCES);
551 else if (retsts == RMS$_FNF) set_errno(ENOENT);
552 else set_errno(EVMSERR);
556 devdsc.dsc$w_length = mynam.nam$b_dev;
557 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
559 retsts = sys$assign(&devdsc,&chan,0,0);
561 set_vaxc_errno(retsts);
562 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
563 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
564 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
565 else set_errno(EVMSERR);
569 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
570 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
572 memset((void *) &myfib, 0, sizeof myfib);
574 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
575 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
576 /* This prevents the revision time of the file being reset to the current
577 * time as a result of our IO$_MODIFY $QIO. */
578 myfib.fib$l_acctl = FIB$M_NORECORD;
580 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
581 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
582 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
584 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
585 _ckvmssts(sys$dassgn(chan));
586 if (retsts & 1) retsts = iosb[0];
588 set_vaxc_errno(retsts);
589 if (retsts == SS$_NOPRIV) set_errno(EACCES);
590 else set_errno(EVMSERR);
595 } /* end of my_utime() */
599 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
601 static unsigned long int mbxbufsiz;
602 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
606 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
607 * preprocessor consant BUFSIZ from stdio.h as the size of the
610 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
611 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
613 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
615 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
616 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
618 } /* end of create_mbx() */
620 /*{{{ my_popen and my_pclose*/
623 struct pipe_details *next;
624 PerlIO *fp; /* stdio file pointer to pipe mailbox */
625 int pid; /* PID of subprocess */
626 int mode; /* == 'r' if pipe open for reading */
627 int done; /* subprocess has completed */
628 unsigned long int completion; /* termination status of subprocess */
631 struct exit_control_block
633 struct exit_control_block *flink;
634 unsigned long int (*exit_routine)();
635 unsigned long int arg_count;
636 unsigned long int *status_address;
637 unsigned long int exit_status;
640 static struct pipe_details *open_pipes = NULL;
641 static $DESCRIPTOR(nl_desc, "NL:");
642 static int waitpid_asleep = 0;
644 static unsigned long int
647 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
649 while (open_pipes != NULL) {
650 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
651 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
654 if (!open_pipes->done) /* We tried to be nice . . . */
655 _ckvmssts(sys$delprc(&open_pipes->pid,0));
656 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
661 static struct exit_control_block pipe_exitblock =
662 {(struct exit_control_block *) 0,
663 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
667 popen_completion_ast(struct pipe_details *thispipe)
669 thispipe->done = TRUE;
670 if (waitpid_asleep) {
676 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
678 my_popen(char *cmd, char *mode)
680 static int handler_set_up = FALSE;
682 unsigned short int chan;
683 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
684 struct pipe_details *info;
685 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
686 DSC$K_CLASS_S, mbxname},
687 cmddsc = {0, DSC$K_DTYPE_T,
691 cmddsc.dsc$w_length=strlen(cmd);
692 cmddsc.dsc$a_pointer=cmd;
693 if (cmddsc.dsc$w_length > 255) {
694 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
698 New(7001,info,1,struct pipe_details);
701 create_mbx(&chan,&namdsc);
703 /* open a FILE* onto it */
704 info->fp = PerlIO_open(mbxname, mode);
706 /* give up other channel onto it */
707 _ckvmssts(sys$dassgn(chan));
717 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
718 0 /* name */, &info->pid, &info->completion,
719 0, popen_completion_ast,info,0,0,0));
722 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
723 0 /* name */, &info->pid, &info->completion,
724 0, popen_completion_ast,info,0,0,0));
727 if (!handler_set_up) {
728 _ckvmssts(sys$dclexh(&pipe_exitblock));
729 handler_set_up = TRUE;
731 info->next=open_pipes; /* prepend to list */
734 forkprocess = info->pid;
739 /*{{{ I32 my_pclose(FILE *fp)*/
740 I32 my_pclose(FILE *fp)
742 struct pipe_details *info, *last = NULL;
743 unsigned long int retsts;
745 for (info = open_pipes; info != NULL; last = info, info = info->next)
746 if (info->fp == fp) break;
749 /* get here => no such pipe open */
750 croak("No such pipe open");
752 PerlIO_close(info->fp);
754 if (info->done) retsts = info->completion;
755 else waitpid(info->pid,(int *) &retsts,0);
757 /* remove from list of open pipes */
758 if (last) last->next = info->next;
759 else open_pipes = info->next;
764 } /* end of my_pclose() */
766 /* sort-of waitpid; use only with popen() */
767 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
769 waitpid(unsigned long int pid, int *statusp, int flags)
771 struct pipe_details *info;
773 for (info = open_pipes; info != NULL; info = info->next)
774 if (info->pid == pid) break;
776 if (info != NULL) { /* we know about this child */
777 while (!info->done) {
782 *statusp = info->completion;
785 else { /* we haven't heard of this child */
786 $DESCRIPTOR(intdsc,"0 00:00:01");
787 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
788 unsigned long int interval[2],sts;
791 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
792 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
793 if (ownerpid != mypid)
794 warn("pid %d not a child",pid);
797 _ckvmssts(sys$bintim(&intdsc,interval));
798 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
799 _ckvmssts(sys$schdwk(0,0,interval,0));
800 _ckvmssts(sys$hiber());
804 /* There's no easy way to find the termination status a child we're
805 * not aware of beforehand. If we're really interested in the future,
806 * we can go looking for a termination mailbox, or chase after the
807 * accounting record for the process.
813 } /* end of waitpid() */
818 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
820 my_gconvert(double val, int ndig, int trail, char *buf)
822 static char __gcvtbuf[DBL_DIG+1];
825 loc = buf ? buf : __gcvtbuf;
827 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
828 return gcvt(val,ndig,loc);
831 loc[0] = '0'; loc[1] = '\0';
839 ** The following routines are provided to make life easier when
840 ** converting among VMS-style and Unix-style directory specifications.
841 ** All will take input specifications in either VMS or Unix syntax. On
842 ** failure, all return NULL. If successful, the routines listed below
843 ** return a pointer to a buffer containing the appropriately
844 ** reformatted spec (and, therefore, subsequent calls to that routine
845 ** will clobber the result), while the routines of the same names with
846 ** a _ts suffix appended will return a pointer to a mallocd string
847 ** containing the appropriately reformatted spec.
848 ** In all cases, only explicit syntax is altered; no check is made that
849 ** the resulting string is valid or that the directory in question
852 ** fileify_dirspec() - convert a directory spec into the name of the
853 ** directory file (i.e. what you can stat() to see if it's a dir).
854 ** The style (VMS or Unix) of the result is the same as the style
855 ** of the parameter passed in.
856 ** pathify_dirspec() - convert a directory spec into a path (i.e.
857 ** what you prepend to a filename to indicate what directory it's in).
858 ** The style (VMS or Unix) of the result is the same as the style
859 ** of the parameter passed in.
860 ** tounixpath() - convert a directory spec into a Unix-style path.
861 ** tovmspath() - convert a directory spec into a VMS-style path.
862 ** tounixspec() - convert any file spec into a Unix-style file spec.
863 ** tovmsspec() - convert any file spec into a VMS-style spec.
865 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
866 ** Permission is given to distribute this code as part of the Perl
867 ** standard distribution under the terms of the GNU General Public
868 ** License or the Perl Artistic License. Copies of each may be
869 ** found in the Perl standard distribution.
872 static char *do_tounixspec(char *, char *, int);
874 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
875 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
877 static char __fileify_retbuf[NAM$C_MAXRSS+1];
878 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
879 char *retspec, *cp1, *cp2, *lastdir;
880 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
883 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
885 dirlen = strlen(dir);
886 if (dir[dirlen-1] == '/') --dirlen;
889 set_vaxc_errno(RMS$_DIR);
892 if (!strpbrk(dir+1,"/]>:")) {
893 strcpy(trndir,*dir == '/' ? dir + 1: dir);
894 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
896 dirlen = strlen(dir);
899 strncpy(trndir,dir,dirlen);
900 trndir[dirlen] = '\0';
903 /* If we were handed a rooted logical name or spec, treat it like a
904 * simple directory, so that
905 * $ Define myroot dev:[dir.]
906 * ... do_fileify_dirspec("myroot",buf,1) ...
907 * does something useful.
909 if (!strcmp(dir+dirlen-2,".]")) {
910 dir[--dirlen] = '\0';
914 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
915 /* If we've got an explicit filename, we can just shuffle the string. */
916 if (*(cp1+1)) hasfilename = 1;
917 /* Similarly, we can just back up a level if we've got multiple levels
918 of explicit directories in a VMS spec which ends with directories. */
920 for (cp2 = cp1; cp2 > dir; cp2--) {
922 *cp2 = *cp1; *cp1 = '\0';
926 if (*cp2 == '[' || *cp2 == '<') break;
931 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
933 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
934 return do_fileify_dirspec("[]",buf,ts);
935 else if (dir[1] == '.' &&
936 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
937 return do_fileify_dirspec("[-]",buf,ts);
939 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
940 dirlen -= 1; /* to last element */
941 lastdir = strrchr(dir,'/');
943 else if ((cp1 = strstr(dir,"/.")) != NULL) {
944 /* If we have "/." or "/..", VMSify it and let the VMS code
945 * below expand it, rather than repeating the code to handle
946 * relative components of a filespec here */
948 if (*(cp1+2) == '.') cp1++;
949 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
950 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
951 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
952 return do_tounixspec(trndir,buf,ts);
955 } while ((cp1 = strstr(cp1,"/.")) != NULL);
958 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
959 !(lastdir = cp1 = strrchr(dir,']')) &&
960 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
961 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
963 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
964 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
965 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
966 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
967 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
970 set_vaxc_errno(RMS$_DIR);
976 /* If we lead off with a device or rooted logical, add the MFD
977 if we're specifying a top-level directory. */
978 if (lastdir && *dir == '/') {
980 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
987 retlen = dirlen + (addmfd ? 13 : 6);
988 if (buf) retspec = buf;
989 else if (ts) New(7009,retspec,retlen+1,char);
990 else retspec = __fileify_retbuf;
992 dirlen = lastdir - dir;
993 memcpy(retspec,dir,dirlen);
994 strcpy(&retspec[dirlen],"/000000");
995 strcpy(&retspec[dirlen+7],lastdir);
998 memcpy(retspec,dir,dirlen);
999 retspec[dirlen] = '\0';
1001 /* We've picked up everything up to the directory file name.
1002 Now just add the type and version, and we're set. */
1003 strcat(retspec,".dir;1");
1006 else { /* VMS-style directory spec */
1007 char esa[NAM$C_MAXRSS+1], term, *cp;
1008 unsigned long int sts, cmplen, haslower = 0;
1009 struct FAB dirfab = cc$rms_fab;
1010 struct NAM savnam, dirnam = cc$rms_nam;
1012 dirfab.fab$b_fns = strlen(dir);
1013 dirfab.fab$l_fna = dir;
1014 dirfab.fab$l_nam = &dirnam;
1015 dirfab.fab$l_dna = ".DIR;1";
1016 dirfab.fab$b_dns = 6;
1017 dirnam.nam$b_ess = NAM$C_MAXRSS;
1018 dirnam.nam$l_esa = esa;
1020 for (cp = dir; *cp; cp++)
1021 if (islower(*cp)) { haslower = 1; break; }
1022 if (!((sts = sys$parse(&dirfab))&1)) {
1023 if (dirfab.fab$l_sts == RMS$_DIR) {
1024 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1025 sts = sys$parse(&dirfab) & 1;
1029 set_vaxc_errno(dirfab.fab$l_sts);
1035 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1036 /* Yes; fake the fnb bits so we'll check type below */
1037 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1040 if (dirfab.fab$l_sts != RMS$_FNF) {
1042 set_vaxc_errno(dirfab.fab$l_sts);
1045 dirnam = savnam; /* No; just work with potential name */
1048 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1049 cp1 = strchr(esa,']');
1050 if (!cp1) cp1 = strchr(esa,'>');
1051 if (cp1) { /* Should always be true */
1052 dirnam.nam$b_esl -= cp1 - esa - 1;
1053 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1056 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1057 /* Yep; check version while we're at it, if it's there. */
1058 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1059 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1060 /* Something other than .DIR[;1]. Bzzt. */
1062 set_vaxc_errno(RMS$_DIR);
1066 esa[dirnam.nam$b_esl] = '\0';
1067 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1068 /* They provided at least the name; we added the type, if necessary, */
1069 if (buf) retspec = buf; /* in sys$parse() */
1070 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1071 else retspec = __fileify_retbuf;
1072 strcpy(retspec,esa);
1075 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1076 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1078 dirnam.nam$b_esl -= 9;
1080 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1081 if (cp1 == NULL) return NULL; /* should never happen */
1084 retlen = strlen(esa);
1085 if ((cp1 = strrchr(esa,'.')) != NULL) {
1086 /* There's more than one directory in the path. Just roll back. */
1088 if (buf) retspec = buf;
1089 else if (ts) New(7011,retspec,retlen+7,char);
1090 else retspec = __fileify_retbuf;
1091 strcpy(retspec,esa);
1094 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1095 /* Go back and expand rooted logical name */
1096 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1097 if (!(sys$parse(&dirfab) & 1)) {
1099 set_vaxc_errno(dirfab.fab$l_sts);
1102 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1103 if (buf) retspec = buf;
1104 else if (ts) New(7012,retspec,retlen+16,char);
1105 else retspec = __fileify_retbuf;
1106 cp1 = strstr(esa,"][");
1108 memcpy(retspec,esa,dirlen);
1109 if (!strncmp(cp1+2,"000000]",7)) {
1110 retspec[dirlen-1] = '\0';
1111 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1112 if (*cp1 == '.') *cp1 = ']';
1114 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1115 memcpy(cp1+1,"000000]",7);
1119 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1120 retspec[retlen] = '\0';
1121 /* Convert last '.' to ']' */
1122 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1123 if (*cp1 == '.') *cp1 = ']';
1125 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1126 memcpy(cp1+1,"000000]",7);
1130 else { /* This is a top-level dir. Add the MFD to the path. */
1131 if (buf) retspec = buf;
1132 else if (ts) New(7012,retspec,retlen+16,char);
1133 else retspec = __fileify_retbuf;
1136 while (*cp1 != ':') *(cp2++) = *(cp1++);
1137 strcpy(cp2,":[000000]");
1142 /* We've set up the string up through the filename. Add the
1143 type and version, and we're done. */
1144 strcat(retspec,".DIR;1");
1146 /* $PARSE may have upcased filespec, so convert output to lower
1147 * case if input contained any lowercase characters. */
1148 if (haslower) __mystrtolower(retspec);
1151 } /* end of do_fileify_dirspec() */
1153 /* External entry points */
1154 char *fileify_dirspec(char *dir, char *buf)
1155 { return do_fileify_dirspec(dir,buf,0); }
1156 char *fileify_dirspec_ts(char *dir, char *buf)
1157 { return do_fileify_dirspec(dir,buf,1); }
1159 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1160 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1162 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1163 unsigned long int retlen;
1164 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1166 if (!dir || !*dir) {
1167 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1170 if (*dir) strcpy(trndir,dir);
1171 else getcwd(trndir,sizeof trndir - 1);
1173 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1174 STRLEN trnlen = strlen(trndir);
1176 /* Trap simple rooted lnms, and return lnm:[000000] */
1177 if (!strcmp(trndir+trnlen-2,".]")) {
1178 if (buf) retpath = buf;
1179 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1180 else retpath = __pathify_retbuf;
1181 strcpy(retpath,dir);
1182 strcat(retpath,":[000000]");
1188 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1189 if (*dir == '.' && (*(dir+1) == '\0' ||
1190 (*(dir+1) == '.' && *(dir+2) == '\0')))
1191 retlen = 2 + (*(dir+1) != '\0');
1193 if ( !(cp1 = strrchr(dir,'/')) &&
1194 !(cp1 = strrchr(dir,']')) &&
1195 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1196 if ((cp2 = strchr(cp1,'.')) != NULL) {
1198 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1199 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1200 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1201 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1202 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1203 (ver || *cp3)))))) {
1205 set_vaxc_errno(RMS$_DIR);
1208 retlen = cp2 - dir + 1;
1210 else { /* No file type present. Treat the filename as a directory. */
1211 retlen = strlen(dir) + 1;
1214 if (buf) retpath = buf;
1215 else if (ts) New(7013,retpath,retlen+1,char);
1216 else retpath = __pathify_retbuf;
1217 strncpy(retpath,dir,retlen-1);
1218 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1219 retpath[retlen-1] = '/'; /* with '/', add it. */
1220 retpath[retlen] = '\0';
1222 else retpath[retlen-1] = '\0';
1224 else { /* VMS-style directory spec */
1225 char esa[NAM$C_MAXRSS+1], *cp;
1226 unsigned long int sts, cmplen, haslower;
1227 struct FAB dirfab = cc$rms_fab;
1228 struct NAM savnam, dirnam = cc$rms_nam;
1230 /* If we've got an explicit filename, we can just shuffle the string. */
1231 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1232 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1233 if ((cp2 = strchr(cp1,'.')) != NULL) {
1235 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1236 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1237 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1238 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1239 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1240 (ver || *cp3)))))) {
1242 set_vaxc_errno(RMS$_DIR);
1246 else { /* No file type, so just draw name into directory part */
1247 for (cp2 = cp1; *cp2; cp2++) ;
1250 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1252 /* We've now got a VMS 'path'; fall through */
1254 dirfab.fab$b_fns = strlen(dir);
1255 dirfab.fab$l_fna = dir;
1256 if (dir[dirfab.fab$b_fns-1] == ']' ||
1257 dir[dirfab.fab$b_fns-1] == '>' ||
1258 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1259 if (buf) retpath = buf;
1260 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1261 else retpath = __pathify_retbuf;
1262 strcpy(retpath,dir);
1265 dirfab.fab$l_dna = ".DIR;1";
1266 dirfab.fab$b_dns = 6;
1267 dirfab.fab$l_nam = &dirnam;
1268 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1269 dirnam.nam$l_esa = esa;
1271 for (cp = dir; *cp; cp++)
1272 if (islower(*cp)) { haslower = 1; break; }
1274 if (!(sts = (sys$parse(&dirfab)&1))) {
1275 if (dirfab.fab$l_sts == RMS$_DIR) {
1276 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1277 sts = sys$parse(&dirfab) & 1;
1281 set_vaxc_errno(dirfab.fab$l_sts);
1287 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1288 if (dirfab.fab$l_sts != RMS$_FNF) {
1290 set_vaxc_errno(dirfab.fab$l_sts);
1293 dirnam = savnam; /* No; just work with potential name */
1296 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1297 /* Yep; check version while we're at it, if it's there. */
1298 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1299 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1300 /* Something other than .DIR[;1]. Bzzt. */
1302 set_vaxc_errno(RMS$_DIR);
1306 /* OK, the type was fine. Now pull any file name into the
1308 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1310 cp1 = strrchr(esa,'>');
1311 *dirnam.nam$l_type = '>';
1314 *(dirnam.nam$l_type + 1) = '\0';
1315 retlen = dirnam.nam$l_type - esa + 2;
1316 if (buf) retpath = buf;
1317 else if (ts) New(7014,retpath,retlen,char);
1318 else retpath = __pathify_retbuf;
1319 strcpy(retpath,esa);
1320 /* $PARSE may have upcased filespec, so convert output to lower
1321 * case if input contained any lowercase characters. */
1322 if (haslower) __mystrtolower(retpath);
1326 } /* end of do_pathify_dirspec() */
1328 /* External entry points */
1329 char *pathify_dirspec(char *dir, char *buf)
1330 { return do_pathify_dirspec(dir,buf,0); }
1331 char *pathify_dirspec_ts(char *dir, char *buf)
1332 { return do_pathify_dirspec(dir,buf,1); }
1334 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1335 static char *do_tounixspec(char *spec, char *buf, int ts)
1337 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1338 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1339 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1341 if (spec == NULL) return NULL;
1342 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1343 if (buf) rslt = buf;
1345 retlen = strlen(spec);
1346 cp1 = strchr(spec,'[');
1347 if (!cp1) cp1 = strchr(spec,'<');
1349 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1351 New(7015,rslt,retlen+2+2*dashes,char);
1353 else rslt = __tounixspec_retbuf;
1354 if (strchr(spec,'/') != NULL) {
1361 dirend = strrchr(spec,']');
1362 if (dirend == NULL) dirend = strrchr(spec,'>');
1363 if (dirend == NULL) dirend = strchr(spec,':');
1364 if (dirend == NULL) {
1368 if (*cp2 != '[' && *cp2 != '<') {
1371 else { /* the VMS spec begins with directories */
1373 if (*cp2 == ']' || *cp2 == '>') {
1377 else if ( *cp2 != '.' && *cp2 != '-') {
1378 *(cp1++) = '/'; /* add the implied device into the Unix spec */
1379 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1380 if (ts) Safefree(rslt);
1385 while (*cp3 != ':' && *cp3) cp3++;
1387 if (strchr(cp3,']') != NULL) break;
1388 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1390 while (*cp3) *(cp1++) = *(cp3++);
1393 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1394 int offset = cp1 - rslt;
1396 retlen = devlen + dirlen;
1397 Renew(rslt,retlen+1+2*dashes,char);
1398 cp1 = rslt + offset;
1401 else if (*cp2 == '.') cp2++;
1403 for (; cp2 <= dirend; cp2++) {
1406 if (*(cp2+1) == '[') cp2++;
1408 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1409 else if (*cp2 == '.') {
1411 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1412 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1413 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1414 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1415 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1418 else if (*cp2 == '-') {
1419 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1420 while (*cp2 == '-') {
1422 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1424 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1425 if (ts) Safefree(rslt); /* filespecs like */
1426 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1430 else *(cp1++) = *cp2;
1432 else *(cp1++) = *cp2;
1434 while (*cp2) *(cp1++) = *(cp2++);
1439 } /* end of do_tounixspec() */
1441 /* External entry points */
1442 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1443 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1445 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1446 static char *do_tovmsspec(char *path, char *buf, int ts) {
1447 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1448 char *rslt, *dirend;
1449 register char *cp1, *cp2;
1450 unsigned long int infront = 0, hasdir = 1;
1452 if (path == NULL) return NULL;
1453 if (buf) rslt = buf;
1454 else if (ts) New(7016,rslt,strlen(path)+9,char);
1455 else rslt = __tovmsspec_retbuf;
1456 if (strpbrk(path,"]:>") ||
1457 (dirend = strrchr(path,'/')) == NULL) {
1458 if (path[0] == '.') {
1459 if (path[1] == '\0') strcpy(rslt,"[]");
1460 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1461 else strcpy(rslt,path); /* probably garbage */
1463 else strcpy(rslt,path);
1466 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1467 if (!*(dirend+2)) dirend +=2;
1468 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1473 char trndev[NAM$C_MAXRSS+1];
1477 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1478 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1480 islnm = my_trnlnm(rslt,trndev,0);
1481 trnend = islnm ? strlen(trndev) - 1 : 0;
1482 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1483 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1484 /* If the first element of the path is a logical name, determine
1485 * whether it has to be translated so we can add more directories. */
1486 if (!islnm || rooted) {
1489 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1493 if (cp2 != dirend) {
1494 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1495 strcpy(rslt,trndev);
1496 cp1 = rslt + trnend;
1509 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1510 cp2 += 2; /* skip over "./" - it's redundant */
1511 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1513 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1514 *(cp1++) = '-'; /* "../" --> "-" */
1517 if (cp2 > dirend) cp2 = dirend;
1519 else *(cp1++) = '.';
1521 for (; cp2 < dirend; cp2++) {
1523 if (*(cp2-1) == '/') continue;
1524 if (*(cp1-1) != '.') *(cp1++) = '.';
1527 else if (!infront && *cp2 == '.') {
1528 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1529 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1530 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1531 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1532 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1533 else { /* back up over previous directory name */
1535 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1536 if (*(cp1-1) == '[') {
1537 memcpy(cp1,"000000.",7);
1542 if (cp2 == dirend) break;
1544 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1547 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1548 if (*cp2 == '.') *(cp1++) = '_';
1549 else *(cp1++) = *cp2;
1553 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1554 if (hasdir) *(cp1++) = ']';
1555 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1556 while (*cp2) *(cp1++) = *(cp2++);
1561 } /* end of do_tovmsspec() */
1563 /* External entry points */
1564 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1565 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1567 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1568 static char *do_tovmspath(char *path, char *buf, int ts) {
1569 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1571 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1573 if (path == NULL) return NULL;
1574 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1575 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1576 if (buf) return buf;
1578 vmslen = strlen(vmsified);
1579 New(7017,cp,vmslen+1,char);
1580 memcpy(cp,vmsified,vmslen);
1585 strcpy(__tovmspath_retbuf,vmsified);
1586 return __tovmspath_retbuf;
1589 } /* end of do_tovmspath() */
1591 /* External entry points */
1592 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1593 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1596 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1597 static char *do_tounixpath(char *path, char *buf, int ts) {
1598 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1600 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1602 if (path == NULL) return NULL;
1603 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1604 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1605 if (buf) return buf;
1607 unixlen = strlen(unixified);
1608 New(7017,cp,unixlen+1,char);
1609 memcpy(cp,unixified,unixlen);
1614 strcpy(__tounixpath_retbuf,unixified);
1615 return __tounixpath_retbuf;
1618 } /* end of do_tounixpath() */
1620 /* External entry points */
1621 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1622 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1625 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1627 *****************************************************************************
1629 * Copyright (C) 1989-1994 by *
1630 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1632 * Permission is hereby granted for the reproduction of this software, *
1633 * on condition that this copyright notice is included in the reproduction, *
1634 * and that such reproduction is not for purposes of profit or material *
1637 * 27-Aug-1994 Modified for inclusion in perl5 *
1638 * by Charles Bailey bailey@genetics.upenn.edu *
1639 *****************************************************************************
1643 * getredirection() is intended to aid in porting C programs
1644 * to VMS (Vax-11 C). The native VMS environment does not support
1645 * '>' and '<' I/O redirection, or command line wild card expansion,
1646 * or a command line pipe mechanism using the '|' AND background
1647 * command execution '&'. All of these capabilities are provided to any
1648 * C program which calls this procedure as the first thing in the
1650 * The piping mechanism will probably work with almost any 'filter' type
1651 * of program. With suitable modification, it may useful for other
1652 * portability problems as well.
1654 * Author: Mark Pizzolato mark@infocomm.com
1658 struct list_item *next;
1662 static void add_item(struct list_item **head,
1663 struct list_item **tail,
1667 static void expand_wild_cards(char *item,
1668 struct list_item **head,
1669 struct list_item **tail,
1672 static int background_process(int argc, char **argv);
1674 static void pipe_and_fork(char **cmargv);
1676 /*{{{ void getredirection(int *ac, char ***av)*/
1678 getredirection(int *ac, char ***av)
1680 * Process vms redirection arg's. Exit if any error is seen.
1681 * If getredirection() processes an argument, it is erased
1682 * from the vector. getredirection() returns a new argc and argv value.
1683 * In the event that a background command is requested (by a trailing "&"),
1684 * this routine creates a background subprocess, and simply exits the program.
1686 * Warning: do not try to simplify the code for vms. The code
1687 * presupposes that getredirection() is called before any data is
1688 * read from stdin or written to stdout.
1690 * Normal usage is as follows:
1696 * getredirection(&argc, &argv);
1700 int argc = *ac; /* Argument Count */
1701 char **argv = *av; /* Argument Vector */
1702 char *ap; /* Argument pointer */
1703 int j; /* argv[] index */
1704 int item_count = 0; /* Count of Items in List */
1705 struct list_item *list_head = 0; /* First Item in List */
1706 struct list_item *list_tail; /* Last Item in List */
1707 char *in = NULL; /* Input File Name */
1708 char *out = NULL; /* Output File Name */
1709 char *outmode = "w"; /* Mode to Open Output File */
1710 char *err = NULL; /* Error File Name */
1711 char *errmode = "w"; /* Mode to Open Error File */
1712 int cmargc = 0; /* Piped Command Arg Count */
1713 char **cmargv = NULL;/* Piped Command Arg Vector */
1716 * First handle the case where the last thing on the line ends with
1717 * a '&'. This indicates the desire for the command to be run in a
1718 * subprocess, so we satisfy that desire.
1721 if (0 == strcmp("&", ap))
1722 exit(background_process(--argc, argv));
1723 if (*ap && '&' == ap[strlen(ap)-1])
1725 ap[strlen(ap)-1] = '\0';
1726 exit(background_process(argc, argv));
1729 * Now we handle the general redirection cases that involve '>', '>>',
1730 * '<', and pipes '|'.
1732 for (j = 0; j < argc; ++j)
1734 if (0 == strcmp("<", argv[j]))
1738 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1739 exit(LIB$_WRONUMARG);
1744 if ('<' == *(ap = argv[j]))
1749 if (0 == strcmp(">", ap))
1753 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1754 exit(LIB$_WRONUMARG);
1773 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1774 exit(LIB$_WRONUMARG);
1778 if (('2' == *ap) && ('>' == ap[1]))
1795 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1796 exit(LIB$_WRONUMARG);
1800 if (0 == strcmp("|", argv[j]))
1804 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1805 exit(LIB$_WRONUMARG);
1807 cmargc = argc-(j+1);
1808 cmargv = &argv[j+1];
1812 if ('|' == *(ap = argv[j]))
1820 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1823 * Allocate and fill in the new argument vector, Some Unix's terminate
1824 * the list with an extra null pointer.
1826 New(7002, argv, item_count+1, char *);
1828 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1829 argv[j] = list_head->value;
1835 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1836 exit(LIB$_INVARGORD);
1838 pipe_and_fork(cmargv);
1841 /* Check for input from a pipe (mailbox) */
1843 if (in == NULL && 1 == isapipe(0))
1845 char mbxname[L_tmpnam];
1847 long int dvi_item = DVI$_DEVBUFSIZ;
1848 $DESCRIPTOR(mbxnam, "");
1849 $DESCRIPTOR(mbxdevnam, "");
1851 /* Input from a pipe, reopen it in binary mode to disable */
1852 /* carriage control processing. */
1854 PerlIO_getname(stdin, mbxname);
1855 mbxnam.dsc$a_pointer = mbxname;
1856 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1857 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1858 mbxdevnam.dsc$a_pointer = mbxname;
1859 mbxdevnam.dsc$w_length = sizeof(mbxname);
1860 dvi_item = DVI$_DEVNAM;
1861 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1862 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1865 freopen(mbxname, "rb", stdin);
1868 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1872 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1874 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1877 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1879 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
1884 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1886 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
1890 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1895 #ifdef ARGPROC_DEBUG
1896 PerlIO_printf(Perl_debug_log, "Arglist:\n");
1897 for (j = 0; j < *ac; ++j)
1898 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1900 /* Clear errors we may have hit expanding wildcards, so they don't
1901 show up in Perl's $! later */
1902 set_errno(0); set_vaxc_errno(1);
1903 } /* end of getredirection() */
1906 static void add_item(struct list_item **head,
1907 struct list_item **tail,
1913 New(7003,*head,1,struct list_item);
1917 New(7004,(*tail)->next,1,struct list_item);
1918 *tail = (*tail)->next;
1920 (*tail)->value = value;
1924 static void expand_wild_cards(char *item,
1925 struct list_item **head,
1926 struct list_item **tail,
1930 unsigned long int context = 0;
1936 char vmsspec[NAM$C_MAXRSS+1];
1937 $DESCRIPTOR(filespec, "");
1938 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1939 $DESCRIPTOR(resultspec, "");
1940 unsigned long int zero = 0, sts;
1942 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
1944 add_item(head, tail, item, count);
1947 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1948 resultspec.dsc$b_class = DSC$K_CLASS_D;
1949 resultspec.dsc$a_pointer = NULL;
1950 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1951 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1952 if (!isunix || !filespec.dsc$a_pointer)
1953 filespec.dsc$a_pointer = item;
1954 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1956 * Only return version specs, if the caller specified a version
1958 had_version = strchr(item, ';');
1960 * Only return device and directory specs, if the caller specifed either.
1962 had_device = strchr(item, ':');
1963 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1965 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1966 &defaultspec, 0, 0, &zero))))
1971 New(7005,string,resultspec.dsc$w_length+1,char);
1972 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1973 string[resultspec.dsc$w_length] = '\0';
1974 if (NULL == had_version)
1975 *((char *)strrchr(string, ';')) = '\0';
1976 if ((!had_directory) && (had_device == NULL))
1978 if (NULL == (devdir = strrchr(string, ']')))
1979 devdir = strrchr(string, '>');
1980 strcpy(string, devdir + 1);
1983 * Be consistent with what the C RTL has already done to the rest of
1984 * the argv items and lowercase all of these names.
1986 for (c = string; *c; ++c)
1989 if (isunix) trim_unixpath(string,item);
1990 add_item(head, tail, string, count);
1993 if (sts != RMS$_NMF)
1995 set_vaxc_errno(sts);
2001 set_errno(ENOENT); break;
2003 set_errno(ENODEV); break;
2005 set_errno(EINVAL); break;
2007 set_errno(EACCES); break;
2009 _ckvmssts_noperl(sts);
2013 add_item(head, tail, item, count);
2014 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2015 _ckvmssts_noperl(lib$find_file_end(&context));
2018 static int child_st[2];/* Event Flag set when child process completes */
2020 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2022 static unsigned long int exit_handler(int *status)
2026 if (0 == child_st[0])
2028 #ifdef ARGPROC_DEBUG
2029 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2031 fflush(stdout); /* Have to flush pipe for binary data to */
2032 /* terminate properly -- <tp@mccall.com> */
2033 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2034 sys$dassgn(child_chan);
2036 sys$synch(0, child_st);
2041 static void sig_child(int chan)
2043 #ifdef ARGPROC_DEBUG
2044 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2046 if (child_st[0] == 0)
2050 static struct exit_control_block exit_block =
2055 &exit_block.exit_status,
2059 static void pipe_and_fork(char **cmargv)
2062 $DESCRIPTOR(cmddsc, "");
2063 static char mbxname[64];
2064 $DESCRIPTOR(mbxdsc, mbxname);
2066 unsigned long int zero = 0, one = 1;
2068 strcpy(subcmd, cmargv[0]);
2069 for (j = 1; NULL != cmargv[j]; ++j)
2071 strcat(subcmd, " \"");
2072 strcat(subcmd, cmargv[j]);
2073 strcat(subcmd, "\"");
2075 cmddsc.dsc$a_pointer = subcmd;
2076 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2078 create_mbx(&child_chan,&mbxdsc);
2079 #ifdef ARGPROC_DEBUG
2080 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2081 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2083 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2084 0, &pid, child_st, &zero, sig_child,
2086 #ifdef ARGPROC_DEBUG
2087 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2089 sys$dclexh(&exit_block);
2090 if (NULL == freopen(mbxname, "wb", stdout))
2092 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2096 static int background_process(int argc, char **argv)
2098 char command[2048] = "$";
2099 $DESCRIPTOR(value, "");
2100 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2101 static $DESCRIPTOR(null, "NLA0:");
2102 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2104 $DESCRIPTOR(pidstr, "");
2106 unsigned long int flags = 17, one = 1, retsts;
2108 strcat(command, argv[0]);
2111 strcat(command, " \"");
2112 strcat(command, *(++argv));
2113 strcat(command, "\"");
2115 value.dsc$a_pointer = command;
2116 value.dsc$w_length = strlen(value.dsc$a_pointer);
2117 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2118 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2119 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2120 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2123 _ckvmssts_noperl(retsts);
2125 #ifdef ARGPROC_DEBUG
2126 PerlIO_printf(Perl_debug_log, "%s\n", command);
2128 sprintf(pidstring, "%08X", pid);
2129 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2130 pidstr.dsc$a_pointer = pidstring;
2131 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2132 lib$set_symbol(&pidsymbol, &pidstr);
2136 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2139 * Trim Unix-style prefix off filespec, so it looks like what a shell
2140 * glob expansion would return (i.e. from specified prefix on, not
2141 * full path). Note that returned filespec is Unix-style, regardless
2142 * of whether input filespec was VMS-style or Unix-style.
2144 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2145 * determine prefix (both may be in VMS or Unix syntax).
2147 * Returns !=0 on success, with trimmed filespec replacing contents of
2148 * fspec, and 0 on failure, with contents of fpsec unchanged.
2150 /*{{{int trim_unixpath(char *fspec, char *wildspec)*/
2152 trim_unixpath(char *fspec, char *wildspec)
2154 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2155 *template, *base, *cp1, *cp2;
2156 register int tmplen, reslen = 0;
2158 if (!wildspec || !fspec) return 0;
2159 if (strpbrk(wildspec,"]>:") != NULL) {
2160 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2161 else template = unixified;
2163 else template = wildspec;
2164 if (strpbrk(fspec,"]>:") != NULL) {
2165 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2166 else base = unixified;
2167 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2168 * check to see that final result fits into (isn't longer than) fspec */
2169 reslen = strlen(fspec);
2173 /* No prefix or absolute path on wildcard, so nothing to remove */
2174 if (!*template || *template == '/') {
2175 if (base == fspec) return 1;
2176 tmplen = strlen(unixified);
2177 if (tmplen > reslen) return 0; /* not enough space */
2178 /* Copy unixified resultant, including trailing NUL */
2179 memmove(fspec,unixified,tmplen+1);
2183 /* Find prefix to template consisting of path elements without wildcards */
2184 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2185 for (cp1 = template; *cp1; cp1++) ;
2186 else while (cp1 > template && *cp1 != '/') cp1--;
2187 for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
2189 /* Wildcard was in first element, so we don't have a reliable string to
2190 * match against. Guess where to trim resultant filespec by counting
2191 * directory levels in the Unix template. (We could do this instead of
2192 * string matching in all cases, since Unix doesn't have a ... wildcard
2193 * that can expand into multiple levels of subdirectory, but we try for
2194 * the string match so our caller can interpret foo/.../bar.* as
2195 * [.foo...]bar.* if it wants, and only get burned if there was a
2196 * wildcard in the first word (in which case, caveat caller). */
2197 if (cp1 == template) {
2199 for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
2200 /* need to back one more '/' than in template, to pick up leading dirname */
2202 while (cp2 > base) {
2203 if (*cp2 == '/') subdirs--;
2204 if (!subdirs) break; /* quit without decrement when we hit last '/' */
2207 /* ran out of directories on resultant; allow for already trimmed
2208 * resultant, which hits start of string looking for leading '/' */
2209 if (subdirs && (cp2 != base || subdirs != 1)) return 0;
2210 /* Move past leading '/', if there is one */
2211 base = cp2 + (*cp2 == '/' ? 1 : 0);
2212 tmplen = strlen(base);
2213 if (reslen && tmplen > reslen) return 0; /* not enough space */
2214 memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
2217 /* We have a prefix string of complete directory names, so we
2218 * try to find it on the resultant filespec */
2220 tmplen = cp1 - template;
2221 if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
2222 if (reslen) { /* we converted to Unix syntax; copy result over */
2223 tmplen = cp2 - base;
2224 if (tmplen > reslen) return 0; /* not enough space */
2225 memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
2229 for ( ; cp2 - base > tmplen; base++) {
2230 if (*base != '/') continue;
2231 if (!memcmp(base + 1,template,tmplen)) break;
2234 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2235 base++; /* Move past leading '/' */
2236 if (reslen && cp2 - base > reslen) return 0; /* not enough space */
2237 /* Copy down remaining portion of filespec, including trailing NUL */
2238 memmove(fspec,base,cp2 - base + 1);
2242 } /* end of trim_unixpath() */
2247 * VMS readdir() routines.
2248 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2249 * This code has no copyright.
2251 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2252 * Minor modifications to original routines.
2255 /* Number of elements in vms_versions array */
2256 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2259 * Open a directory, return a handle for later use.
2261 /*{{{ DIR *opendir(char*name) */
2266 char dir[NAM$C_MAXRSS+1];
2268 /* Get memory for the handle, and the pattern. */
2270 if (do_tovmspath(name,dir,0) == NULL) {
2271 Safefree((char *)dd);
2274 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2276 /* Fill in the fields; mainly playing with the descriptor. */
2277 (void)sprintf(dd->pattern, "%s*.*",dir);
2280 dd->vms_wantversions = 0;
2281 dd->pat.dsc$a_pointer = dd->pattern;
2282 dd->pat.dsc$w_length = strlen(dd->pattern);
2283 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2284 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2287 } /* end of opendir() */
2291 * Set the flag to indicate we want versions or not.
2293 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2295 vmsreaddirversions(DIR *dd, int flag)
2297 dd->vms_wantversions = flag;
2302 * Free up an opened directory.
2304 /*{{{ void closedir(DIR *dd)*/
2308 (void)lib$find_file_end(&dd->context);
2309 Safefree(dd->pattern);
2310 Safefree((char *)dd);
2315 * Collect all the version numbers for the current file.
2321 struct dsc$descriptor_s pat;
2322 struct dsc$descriptor_s res;
2324 char *p, *text, buff[sizeof dd->entry.d_name];
2326 unsigned long context, tmpsts;
2328 /* Convenient shorthand. */
2331 /* Add the version wildcard, ignoring the "*.*" put on before */
2332 i = strlen(dd->pattern);
2333 New(7008,text,i + e->d_namlen + 3,char);
2334 (void)strcpy(text, dd->pattern);
2335 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2337 /* Set up the pattern descriptor. */
2338 pat.dsc$a_pointer = text;
2339 pat.dsc$w_length = i + e->d_namlen - 1;
2340 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2341 pat.dsc$b_class = DSC$K_CLASS_S;
2343 /* Set up result descriptor. */
2344 res.dsc$a_pointer = buff;
2345 res.dsc$w_length = sizeof buff - 2;
2346 res.dsc$b_dtype = DSC$K_DTYPE_T;
2347 res.dsc$b_class = DSC$K_CLASS_S;
2349 /* Read files, collecting versions. */
2350 for (context = 0, e->vms_verscount = 0;
2351 e->vms_verscount < VERSIZE(e);
2352 e->vms_verscount++) {
2353 tmpsts = lib$find_file(&pat, &res, &context);
2354 if (tmpsts == RMS$_NMF || context == 0) break;
2356 buff[sizeof buff - 1] = '\0';
2357 if ((p = strchr(buff, ';')))
2358 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2360 e->vms_versions[e->vms_verscount] = -1;
2363 _ckvmssts(lib$find_file_end(&context));
2366 } /* end of collectversions() */
2369 * Read the next entry from the directory.
2371 /*{{{ struct dirent *readdir(DIR *dd)*/
2375 struct dsc$descriptor_s res;
2376 char *p, buff[sizeof dd->entry.d_name];
2377 unsigned long int tmpsts;
2379 /* Set up result descriptor, and get next file. */
2380 res.dsc$a_pointer = buff;
2381 res.dsc$w_length = sizeof buff - 2;
2382 res.dsc$b_dtype = DSC$K_DTYPE_T;
2383 res.dsc$b_class = DSC$K_CLASS_S;
2384 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2385 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2386 if (!(tmpsts & 1)) {
2387 set_vaxc_errno(tmpsts);
2390 set_errno(EACCES); break;
2392 set_errno(ENODEV); break;
2395 set_errno(ENOENT); break;
2402 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2403 buff[sizeof buff - 1] = '\0';
2404 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2407 /* Skip any directory component and just copy the name. */
2408 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2409 else (void)strcpy(dd->entry.d_name, buff);
2411 /* Clobber the version. */
2412 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2414 dd->entry.d_namlen = strlen(dd->entry.d_name);
2415 dd->entry.vms_verscount = 0;
2416 if (dd->vms_wantversions) collectversions(dd);
2419 } /* end of readdir() */
2423 * Return something that can be used in a seekdir later.
2425 /*{{{ long telldir(DIR *dd)*/
2434 * Return to a spot where we used to be. Brute force.
2436 /*{{{ void seekdir(DIR *dd,long count)*/
2438 seekdir(DIR *dd, long count)
2440 int vms_wantversions;
2442 /* If we haven't done anything yet... */
2446 /* Remember some state, and clear it. */
2447 vms_wantversions = dd->vms_wantversions;
2448 dd->vms_wantversions = 0;
2449 _ckvmssts(lib$find_file_end(&dd->context));
2452 /* The increment is in readdir(). */
2453 for (dd->count = 0; dd->count < count; )
2456 dd->vms_wantversions = vms_wantversions;
2458 } /* end of seekdir() */
2461 /* VMS subprocess management
2463 * my_vfork() - just a vfork(), after setting a flag to record that
2464 * the current script is trying a Unix-style fork/exec.
2466 * vms_do_aexec() and vms_do_exec() are called in response to the
2467 * perl 'exec' function. If this follows a vfork call, then they
2468 * call out the the regular perl routines in doio.c which do an
2469 * execvp (for those who really want to try this under VMS).
2470 * Otherwise, they do exactly what the perl docs say exec should
2471 * do - terminate the current script and invoke a new command
2472 * (See below for notes on command syntax.)
2474 * do_aspawn() and do_spawn() implement the VMS side of the perl
2475 * 'system' function.
2477 * Note on command arguments to perl 'exec' and 'system': When handled
2478 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2479 * are concatenated to form a DCL command string. If the first arg
2480 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2481 * the the command string is hrnded off to DCL directly. Otherwise,
2482 * the first token of the command is taken as the filespec of an image
2483 * to run. The filespec is expanded using a default type of '.EXE' and
2484 * the process defaults for device, directory, etc., and the resultant
2485 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2486 * the command string as parameters. This is perhaps a bit compicated,
2487 * but I hope it will form a happy medium between what VMS folks expect
2488 * from lib$spawn and what Unix folks expect from exec.
2491 static int vfork_called;
2493 /*{{{int my_vfork()*/
2503 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2511 if (VMScmd.dsc$a_pointer) {
2512 Safefree(VMScmd.dsc$a_pointer);
2513 VMScmd.dsc$w_length = 0;
2514 VMScmd.dsc$a_pointer = Nullch;
2519 setup_argstr(SV *really, SV **mark, SV **sp)
2521 char *junk, *tmps = Nullch;
2522 register size_t cmdlen = 0;
2528 tmps = SvPV(really,rlen);
2535 for (idx++; idx <= sp; idx++) {
2537 junk = SvPVx(*idx,rlen);
2538 cmdlen += rlen ? rlen + 1 : 0;
2541 New(401,Cmd,cmdlen+1,char);
2543 if (tmps && *tmps) {
2548 while (++mark <= sp) {
2551 strcat(Cmd,SvPVx(*mark,na));
2556 } /* end of setup_argstr() */
2559 static unsigned long int
2560 setup_cmddsc(char *cmd, int check_img)
2562 char resspec[NAM$C_MAXRSS+1];
2563 $DESCRIPTOR(defdsc,".EXE");
2564 $DESCRIPTOR(resdsc,resspec);
2565 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2566 unsigned long int cxt = 0, flags = 1, retsts;
2567 register char *s, *rest, *cp;
2568 register int isdcl = 0;
2571 while (*s && isspace(*s)) s++;
2573 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2574 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2575 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2576 if (*cp == ':' || *cp == '[' || *cp == '<') {
2584 if (isdcl) { /* It's a DCL command, just do it. */
2585 VMScmd.dsc$w_length = strlen(cmd);
2587 VMScmd.dsc$a_pointer = Cmd;
2588 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2590 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2592 else { /* assume first token is an image spec */
2594 while (*s && !isspace(*s)) s++;
2596 imgdsc.dsc$a_pointer = cmd;
2597 imgdsc.dsc$w_length = s - cmd;
2598 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2599 if (!(retsts & 1)) {
2600 /* just hand off status values likely to be due to user error */
2601 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2602 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2603 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2604 else { _ckvmssts(retsts); }
2607 _ckvmssts(lib$find_file_end(&cxt));
2609 while (*s && !isspace(*s)) s++;
2611 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2612 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2613 strcat(VMScmd.dsc$a_pointer,resspec);
2614 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2615 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2619 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2621 } /* end of setup_cmddsc() */
2624 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2626 vms_do_aexec(SV *really,SV **mark,SV **sp)
2629 if (vfork_called) { /* this follows a vfork - act Unixish */
2631 if (vfork_called < 0) {
2632 warn("Internal inconsistency in tracking vforks");
2635 else return do_aexec(really,mark,sp);
2637 /* no vfork - act VMSish */
2638 return vms_do_exec(setup_argstr(really,mark,sp));
2643 } /* end of vms_do_aexec() */
2646 /* {{{bool vms_do_exec(char *cmd) */
2648 vms_do_exec(char *cmd)
2651 if (vfork_called) { /* this follows a vfork - act Unixish */
2653 if (vfork_called < 0) {
2654 warn("Internal inconsistency in tracking vforks");
2657 else return do_exec(cmd);
2660 { /* no vfork - act VMSish */
2661 unsigned long int retsts;
2663 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2664 retsts = lib$do_command(&VMScmd);
2667 set_vaxc_errno(retsts);
2669 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2675 } /* end of vms_do_exec() */
2678 unsigned long int do_spawn(char *);
2680 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2682 do_aspawn(SV *really,SV **mark,SV **sp)
2684 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2687 } /* end of do_aspawn() */
2690 /* {{{unsigned long int do_spawn(char *cmd) */
2694 unsigned long int substs, hadcmd = 1;
2696 if (!cmd || !*cmd) {
2698 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2700 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2701 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2706 set_vaxc_errno(substs);
2708 warn("Can't spawn \"%s\": %s",
2709 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2714 } /* end of do_spawn() */
2718 * A simple fwrite replacement which outputs itmsz*nitm chars without
2719 * introducing record boundaries every itmsz chars.
2721 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2723 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2725 register char *cp, *end;
2727 end = (char *)src + itmsz * nitm;
2729 while ((char *)src <= end) {
2730 for (cp = src; cp <= end; cp++) if (!*cp) break;
2731 if (fputs(src,dest) == EOF) return EOF;
2733 if (fputc('\0',dest) == EOF) return EOF;
2739 } /* end of my_fwrite() */
2743 * Here are replacements for the following Unix routines in the VMS environment:
2744 * getpwuid Get information for a particular UIC or UID
2745 * getpwnam Get information for a named user
2746 * getpwent Get information for each user in the rights database
2747 * setpwent Reset search to the start of the rights database
2748 * endpwent Finish searching for users in the rights database
2750 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2751 * (defined in pwd.h), which contains the following fields:-
2753 * char *pw_name; Username (in lower case)
2754 * char *pw_passwd; Hashed password
2755 * unsigned int pw_uid; UIC
2756 * unsigned int pw_gid; UIC group number
2757 * char *pw_unixdir; Default device/directory (VMS-style)
2758 * char *pw_gecos; Owner name
2759 * char *pw_dir; Default device/directory (Unix-style)
2760 * char *pw_shell; Default CLI name (eg. DCL)
2762 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2764 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2765 * not the UIC member number (eg. what's returned by getuid()),
2766 * getpwuid() can accept either as input (if uid is specified, the caller's
2767 * UIC group is used), though it won't recognise gid=0.
2769 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2770 * information about other users in your group or in other groups, respectively.
2771 * If the required privilege is not available, then these routines fill only
2772 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2775 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2778 /* sizes of various UAF record fields */
2779 #define UAI$S_USERNAME 12
2780 #define UAI$S_IDENT 31
2781 #define UAI$S_OWNER 31
2782 #define UAI$S_DEFDEV 31
2783 #define UAI$S_DEFDIR 63
2784 #define UAI$S_DEFCLI 31
2787 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2788 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2789 (uic).uic$v_group != UIC$K_WILD_GROUP)
2791 static char __empty[]= "";
2792 static struct passwd __passwd_empty=
2793 {(char *) __empty, (char *) __empty, 0, 0,
2794 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2795 static int contxt= 0;
2796 static struct passwd __pwdcache;
2797 static char __pw_namecache[UAI$S_IDENT+1];
2800 * This routine does most of the work extracting the user information.
2802 static int fillpasswd (const char *name, struct passwd *pwd)
2805 unsigned char length;
2806 char pw_gecos[UAI$S_OWNER+1];
2808 static union uicdef uic;
2810 unsigned char length;
2811 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2814 unsigned char length;
2815 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2818 unsigned char length;
2819 char pw_shell[UAI$S_DEFCLI+1];
2821 static char pw_passwd[UAI$S_PWD+1];
2823 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2824 struct dsc$descriptor_s name_desc;
2825 unsigned long int sts;
2827 static struct itmlst_3 itmlst[]= {
2828 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2829 {sizeof(uic), UAI$_UIC, &uic, &luic},
2830 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2831 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2832 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2833 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2834 {0, 0, NULL, NULL}};
2836 name_desc.dsc$w_length= strlen(name);
2837 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2838 name_desc.dsc$b_class= DSC$K_CLASS_S;
2839 name_desc.dsc$a_pointer= (char *) name;
2841 /* Note that sys$getuai returns many fields as counted strings. */
2842 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2843 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2844 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2846 else { _ckvmssts(sts); }
2847 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2849 if ((int) owner.length < lowner) lowner= (int) owner.length;
2850 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2851 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2852 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2853 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2854 owner.pw_gecos[lowner]= '\0';
2855 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2856 defcli.pw_shell[ldefcli]= '\0';
2857 if (valid_uic(uic)) {
2858 pwd->pw_uid= uic.uic$l_uic;
2859 pwd->pw_gid= uic.uic$v_group;
2862 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2863 pwd->pw_passwd= pw_passwd;
2864 pwd->pw_gecos= owner.pw_gecos;
2865 pwd->pw_dir= defdev.pw_dir;
2866 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2867 pwd->pw_shell= defcli.pw_shell;
2868 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2870 ldir= strlen(pwd->pw_unixdir) - 1;
2871 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2874 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2875 __mystrtolower(pwd->pw_unixdir);
2880 * Get information for a named user.
2882 /*{{{struct passwd *getpwnam(char *name)*/
2883 struct passwd *my_getpwnam(char *name)
2885 struct dsc$descriptor_s name_desc;
2887 unsigned long int status, stat;
2889 __pwdcache = __passwd_empty;
2890 if (!fillpasswd(name, &__pwdcache)) {
2891 /* We still may be able to determine pw_uid and pw_gid */
2892 name_desc.dsc$w_length= strlen(name);
2893 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2894 name_desc.dsc$b_class= DSC$K_CLASS_S;
2895 name_desc.dsc$a_pointer= (char *) name;
2896 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2897 __pwdcache.pw_uid= uic.uic$l_uic;
2898 __pwdcache.pw_gid= uic.uic$v_group;
2901 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2902 set_vaxc_errno(stat);
2903 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2906 else { _ckvmssts(stat); }
2909 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2910 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2911 __pwdcache.pw_name= __pw_namecache;
2913 } /* end of my_getpwnam() */
2917 * Get information for a particular UIC or UID.
2918 * Called by my_getpwent with uid=-1 to list all users.
2920 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2921 struct passwd *my_getpwuid(Uid_t uid)
2923 const $DESCRIPTOR(name_desc,__pw_namecache);
2924 unsigned short lname;
2926 unsigned long int status;
2928 if (uid == (unsigned int) -1) {
2930 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2931 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2932 set_vaxc_errno(status);
2933 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2937 else { _ckvmssts(status); }
2938 } while (!valid_uic (uic));
2942 if (!uic.uic$v_group)
2943 uic.uic$v_group= getgid();
2945 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2946 else status = SS$_IVIDENT;
2947 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2948 status == RMS$_PRV) {
2949 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2952 else { _ckvmssts(status); }
2954 __pw_namecache[lname]= '\0';
2955 __mystrtolower(__pw_namecache);
2957 __pwdcache = __passwd_empty;
2958 __pwdcache.pw_name = __pw_namecache;
2960 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2961 The identifier's value is usually the UIC, but it doesn't have to be,
2962 so if we can, we let fillpasswd update this. */
2963 __pwdcache.pw_uid = uic.uic$l_uic;
2964 __pwdcache.pw_gid = uic.uic$v_group;
2966 fillpasswd(__pw_namecache, &__pwdcache);
2969 } /* end of my_getpwuid() */
2973 * Get information for next user.
2975 /*{{{struct passwd *my_getpwent()*/
2976 struct passwd *my_getpwent()
2978 return (my_getpwuid((unsigned int) -1));
2983 * Finish searching rights database for users.
2985 /*{{{void my_endpwent()*/
2989 _ckvmssts(sys$finish_rdb(&contxt));
2997 * If the CRTL has a real gmtime(), use it, else look for the logical
2998 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2999 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
3000 * to translate to the number of seconds which must be added to UTC
3001 * to get to the local time of the system.
3002 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3005 /*{{{struct tm *my_gmtime(const time_t *time)*/
3006 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
3007 * so we can call the CRTL's routine to see if it works.
3011 my_gmtime(const time_t *time)
3013 static int gmtime_emulation_type;
3014 static time_t utc_offset_secs;
3018 if (gmtime_emulation_type == 0) {
3019 gmtime_emulation_type++;
3021 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
3022 gmtime_emulation_type++;
3023 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
3024 gmtime_emulation_type++;
3026 utc_offset_secs = (time_t) atol(p);
3030 switch (gmtime_emulation_type) {
3032 return gmtime(time);
3034 when = *time - utc_offset_secs;
3035 return localtime(&when);
3037 warn("gmtime not supported on this system");
3040 } /* end of my_gmtime() */
3041 /* Reset definition for later calls */
3042 #define gmtime(t) my_gmtime(t)
3047 * flex_stat, flex_fstat
3048 * basic stat, but gets it right when asked to stat
3049 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3052 /* encode_dev packs a VMS device name string into an integer to allow
3053 * simple comparisons. This can be used, for example, to check whether two
3054 * files are located on the same device, by comparing their encoded device
3055 * names. Even a string comparison would not do, because stat() reuses the
3056 * device name buffer for each call; so without encode_dev, it would be
3057 * necessary to save the buffer and use strcmp (this would mean a number of
3058 * changes to the standard Perl code, to say nothing of what a Perl script
3061 * The device lock id, if it exists, should be unique (unless perhaps compared
3062 * with lock ids transferred from other nodes). We have a lock id if the disk is
3063 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3064 * device names. Thus we use the lock id in preference, and only if that isn't
3065 * available, do we try to pack the device name into an integer (flagged by
3066 * the sign bit (LOCKID_MASK) being set).
3068 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3069 * name and its encoded form, but it seems very unlikely that we will find
3070 * two files on different disks that share the same encoded device names,
3071 * and even more remote that they will share the same file id (if the test
3072 * is to check for the same file).
3074 * A better method might be to use sys$device_scan on the first call, and to
3075 * search for the device, returning an index into the cached array.
3076 * The number returned would be more intelligable.
3077 * This is probably not worth it, and anyway would take quite a bit longer
3078 * on the first call.
3080 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3081 static dev_t encode_dev (const char *dev)
3084 unsigned long int f;
3089 if (!dev || !dev[0]) return 0;
3093 struct dsc$descriptor_s dev_desc;
3094 unsigned long int status, lockid, item = DVI$_LOCKID;
3096 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3097 can try that first. */
3098 dev_desc.dsc$w_length = strlen (dev);
3099 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3100 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3101 dev_desc.dsc$a_pointer = (char *) dev;
3102 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3103 if (lockid) return (lockid & ~LOCKID_MASK);
3107 /* Otherwise we try to encode the device name */
3111 for (q = dev + strlen(dev); q--; q >= dev) {
3114 else if (isalpha (toupper (*q)))
3115 c= toupper (*q) - 'A' + (char)10;
3117 continue; /* Skip '$'s */
3119 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3121 enc += f * (unsigned long int) c;
3123 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3125 } /* end of encode_dev() */
3127 static char namecache[NAM$C_MAXRSS+1];
3130 is_null_device(name)
3133 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3134 The underscore prefix, controller letter, and unit number are
3135 independently optional; for our purposes, the colon punctuation
3136 is not. The colon can be trailed by optional directory and/or
3137 filename, but two consecutive colons indicates a nodename rather
3138 than a device. [pr] */
3139 if (*name == '_') ++name;
3140 if (tolower(*name++) != 'n') return 0;
3141 if (tolower(*name++) != 'l') return 0;
3142 if (tolower(*name) == 'a') ++name;
3143 if (*name == '0') ++name;
3144 return (*name++ == ':') && (*name != ':');
3147 /* Do the permissions allow some operation? Assumes statcache already set. */
3148 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3149 * subset of the applicable information.
3151 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3153 cando(I32 bit, I32 effective, struct stat *statbufp)
3155 if (statbufp == &statcache)
3156 return cando_by_name(bit,effective,namecache);
3158 char fname[NAM$C_MAXRSS+1];
3159 unsigned long int retsts;
3160 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3161 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3163 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3164 device name on successive calls */
3165 devdsc.dsc$a_pointer = statbufp->st_devnam;
3166 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3167 namdsc.dsc$a_pointer = fname;
3168 namdsc.dsc$w_length = sizeof fname - 1;
3170 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3171 &namdsc.dsc$w_length,0,0);
3173 fname[namdsc.dsc$w_length] = '\0';
3174 return cando_by_name(bit,effective,fname);
3176 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3177 warn("Can't get filespec - stale stat buffer?\n");
3181 return FALSE; /* Should never get to here */
3183 } /* end of cando() */
3187 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3189 cando_by_name(I32 bit, I32 effective, char *fname)
3191 static char usrname[L_cuserid];
3192 static struct dsc$descriptor_s usrdsc =
3193 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3194 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3195 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3196 unsigned short int retlen;
3197 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3198 union prvdef curprv;
3199 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3200 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3201 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3204 if (!fname || !*fname) return FALSE;
3205 /* Make sure we expand logical names, since sys$check_access doesn't */
3206 if (!strpbrk(fname,"/]>:")) {
3207 strcpy(fileified,fname);
3208 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3211 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3212 retlen = namdsc.dsc$w_length = strlen(vmsname);
3213 namdsc.dsc$a_pointer = vmsname;
3214 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3215 vmsname[retlen-1] == ':') {
3216 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3217 namdsc.dsc$w_length = strlen(fileified);
3218 namdsc.dsc$a_pointer = fileified;
3221 if (!usrdsc.dsc$w_length) {
3223 usrdsc.dsc$w_length = strlen(usrname);
3230 access = ARM$M_EXECUTE;
3235 access = ARM$M_READ;
3240 access = ARM$M_WRITE;
3245 access = ARM$M_DELETE;
3251 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3252 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3253 retsts == RMS$_FNF || retsts == RMS$_DIR ||
3254 retsts == RMS$_DEV) {
3255 set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts);
3258 if (retsts == SS$_NORMAL) {
3259 if (!privused) return TRUE;
3260 /* We can get access, but only by using privs. Do we have the
3261 necessary privs currently enabled? */
3262 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3263 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3264 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3265 !curprv.prv$v_bypass) return FALSE;
3266 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3267 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3268 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3273 return FALSE; /* Should never get here */
3275 } /* end of cando_by_name() */
3279 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3282 flex_fstat(int fd, struct mystat *statbufp)
3284 if (!fstat(fd,(stat_t *) statbufp)) {
3285 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3290 } /* end of flex_fstat() */
3293 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3294 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3295 * 'struct stat' elsewhere in Perl would use our struct. We go back
3296 * to the system version here, since we're actually calling their
3300 flex_stat(char *fspec, struct mystat *statbufp)
3302 char fileified[NAM$C_MAXRSS+1];
3303 int retval,myretval;
3304 struct mystat tmpbuf;
3307 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3308 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3309 memset(statbufp,0,sizeof *statbufp);
3310 statbufp->st_dev = encode_dev("_NLA0:");
3311 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3312 statbufp->st_uid = 0x00010001;
3313 statbufp->st_gid = 0x0001;
3314 time((time_t *)&statbufp->st_mtime);
3315 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3319 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3321 myretval = stat(fileified,(stat_t *) &tmpbuf);
3323 retval = stat(fspec,(stat_t *) statbufp);
3329 else if (!retval) { /* Dir with same name. Substitute it. */
3330 statbufp->st_mode &= ~S_IFDIR;
3331 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3332 strcpy(namecache,fileified);
3335 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3338 } /* end of flex_stat() */
3339 /* Reset definition for later calls */
3343 /* Insures that no carriage-control translation will be done on a file. */
3344 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3346 my_binmode(FILE *fp, char iotype)
3348 char filespec[NAM$C_MAXRSS], *acmode;
3351 if (!fgetname(fp,filespec)) return NULL;
3352 if (fgetpos(fp,&pos) == -1) return NULL;
3354 case '<': case 'r': acmode = "rb"; break;
3355 case '>': case 'w': acmode = "wb"; break;
3356 case '+': case '|': case 's': acmode = "rb+"; break;
3357 case 'a': acmode = "ab"; break;
3358 case '-': acmode = fileno(fp) ? "wb" : "rb"; break;
3360 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3361 if (fsetpos(fp,&pos) == -1) return NULL;
3362 } /* end of my_binmode() */
3366 /*{{{char *my_getlogin()*/
3367 /* VMS cuserid == Unix getlogin, except calling sequence */
3371 static char user[L_cuserid];
3372 return cuserid(user);
3377 /* rmscopy - copy a file using VMS RMS routines
3379 * Copies contents and attributes of spec_in to spec_out, except owner
3380 * and protection information. Name and type of spec_in are used as
3381 * defaults for spec_out. The third parameter specifies whether rmscopy()
3382 * should try to propagate timestamps from the input file to the output file.
3383 * If it is less than 0, no timestamps are preserved. If it is 0, then
3384 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3385 * propagated to the output file at creation iff the output file specification
3386 * did not contain an explicit name or type, and the revision date is always
3387 * updated at the end of the copy operation. If it is greater than 0, then
3388 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3389 * other than the revision date should be propagated, and bit 1 indicates
3390 * that the revision date should be propagated.
3392 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3394 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3395 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3396 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3397 * as part of the Perl standard distribution under the terms of the
3398 * GNU General Public License or the Perl Artistic License. Copies
3399 * of each may be found in the Perl standard distribution.
3401 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3403 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3405 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3406 rsa[NAM$C_MAXRSS], ubf[32256];
3407 unsigned long int i, sts, sts2;
3408 struct FAB fab_in, fab_out;
3409 struct RAB rab_in, rab_out;
3411 struct XABDAT xabdat;
3412 struct XABFHC xabfhc;
3413 struct XABRDT xabrdt;
3414 struct XABSUM xabsum;
3416 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3417 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3418 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3422 fab_in = cc$rms_fab;
3423 fab_in.fab$l_fna = vmsin;
3424 fab_in.fab$b_fns = strlen(vmsin);
3425 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3426 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3427 fab_in.fab$l_fop = FAB$M_SQO;
3428 fab_in.fab$l_nam = &nam;
3429 fab_in.fab$l_xab = (void *) &xabdat;
3432 nam.nam$l_rsa = rsa;
3433 nam.nam$b_rss = sizeof(rsa);
3434 nam.nam$l_esa = esa;
3435 nam.nam$b_ess = sizeof (esa);
3436 nam.nam$b_esl = nam.nam$b_rsl = 0;
3438 xabdat = cc$rms_xabdat; /* To get creation date */
3439 xabdat.xab$l_nxt = (void *) &xabfhc;
3441 xabfhc = cc$rms_xabfhc; /* To get record length */
3442 xabfhc.xab$l_nxt = (void *) &xabsum;
3444 xabsum = cc$rms_xabsum; /* To get key and area information */
3446 if (!((sts = sys$open(&fab_in)) & 1)) {
3447 set_vaxc_errno(sts);
3451 set_errno(ENOENT); break;
3453 set_errno(ENODEV); break;
3455 set_errno(EINVAL); break;
3457 set_errno(EACCES); break;
3465 fab_out.fab$w_ifi = 0;
3466 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3467 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3468 fab_out.fab$l_fop = FAB$M_SQO;
3469 fab_out.fab$l_fna = vmsout;
3470 fab_out.fab$b_fns = strlen(vmsout);
3471 fab_out.fab$l_dna = nam.nam$l_name;
3472 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3474 if (preserve_dates == 0) { /* Act like DCL COPY */
3475 nam.nam$b_nop = NAM$M_SYNCHK;
3476 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3477 if (!((sts = sys$parse(&fab_out)) & 1)) {
3478 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3479 set_vaxc_errno(sts);
3482 fab_out.fab$l_xab = (void *) &xabdat;
3483 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3485 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3486 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3487 preserve_dates =0; /* bitmask from this point forward */
3489 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3490 if (!((sts = sys$create(&fab_out)) & 1)) {
3491 set_vaxc_errno(sts);
3494 set_errno(ENOENT); break;
3496 set_errno(ENODEV); break;
3498 set_errno(EINVAL); break;
3500 set_errno(EACCES); break;
3506 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3507 if (preserve_dates & 2) {
3508 /* sys$close() will process xabrdt, not xabdat */
3509 xabrdt = cc$rms_xabrdt;
3511 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3513 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3514 * is unsigned long[2], while DECC & VAXC use a struct */
3515 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3517 fab_out.fab$l_xab = (void *) &xabrdt;
3520 rab_in = cc$rms_rab;
3521 rab_in.rab$l_fab = &fab_in;
3522 rab_in.rab$l_rop = RAB$M_BIO;
3523 rab_in.rab$l_ubf = ubf;
3524 rab_in.rab$w_usz = sizeof ubf;
3525 if (!((sts = sys$connect(&rab_in)) & 1)) {
3526 sys$close(&fab_in); sys$close(&fab_out);
3527 set_errno(EVMSERR); set_vaxc_errno(sts);
3531 rab_out = cc$rms_rab;
3532 rab_out.rab$l_fab = &fab_out;
3533 rab_out.rab$l_rbf = ubf;
3534 if (!((sts = sys$connect(&rab_out)) & 1)) {
3535 sys$close(&fab_in); sys$close(&fab_out);
3536 set_errno(EVMSERR); set_vaxc_errno(sts);
3540 while ((sts = sys$read(&rab_in))) { /* always true */
3541 if (sts == RMS$_EOF) break;
3542 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3543 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3544 sys$close(&fab_in); sys$close(&fab_out);
3545 set_errno(EVMSERR); set_vaxc_errno(sts);
3550 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3551 sys$close(&fab_in); sys$close(&fab_out);
3552 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3554 set_errno(EVMSERR); set_vaxc_errno(sts);
3560 } /* end of rmscopy() */
3564 /*** The following glue provides 'hooks' to make some of the routines
3565 * from this file available from Perl. These routines are sufficiently
3566 * basic, and are required sufficiently early in the build process,
3567 * that's it's nice to have them available to miniperl as well as the
3568 * full Perl, so they're set up here instead of in an extension. The
3569 * Perl code which handles importation of these names into a given
3570 * package lives in [.VMS]Filespec.pm in @INC.
3574 rmsexpand_fromperl(CV *cv)
3577 char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
3578 struct FAB myfab = cc$rms_fab;
3579 struct NAM mynam = cc$rms_nam;
3581 unsigned long int retsts, haslower = 0;
3583 if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3585 myfab.fab$l_fna = SvPV(ST(0),speclen);
3586 myfab.fab$b_fns = speclen;
3587 myfab.fab$l_nam = &mynam;
3590 myfab.fab$l_dna = SvPV(ST(1),speclen);
3591 myfab.fab$b_dns = speclen;
3594 mynam.nam$l_esa = esa;
3595 mynam.nam$b_ess = sizeof esa;
3596 mynam.nam$l_rsa = rsa;
3597 mynam.nam$b_rss = sizeof rsa;
3599 retsts = sys$parse(&myfab,0,0);
3600 if (!(retsts & 1)) {
3601 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
3602 retsts == RMS$_DEV || retsts == RMS$_DEV) {
3603 mynam.nam$b_nop |= NAM$M_SYNCHK;
3604 retsts = sys$parse(&myfab,0,0);
3605 if (retsts & 1) goto expanded;
3607 set_vaxc_errno(retsts);
3608 if (retsts == RMS$_PRV) set_errno(EACCES);
3609 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3610 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3611 else set_errno(EVMSERR);
3614 retsts = sys$search(&myfab,0,0);
3615 if (!(retsts & 1) && retsts != RMS$_FNF) {
3616 set_vaxc_errno(retsts);
3617 if (retsts == RMS$_PRV) set_errno(EACCES);
3618 else set_errno(EVMSERR);
3622 /* If the input filespec contained any lowercase characters,
3623 * downcase the result for compatibility with Unix-minded code. */
3625 for (out = myfab.fab$l_fna; *out; out++)
3626 if (islower(*out)) { haslower = 1; break; }
3627 if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
3628 else { out = esa; speclen = mynam.nam$b_esl; }
3629 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
3630 (items == 1 || !strchr(myfab.fab$l_dna,';')))
3631 speclen = mynam.nam$l_ver - out;
3632 /* If we just had a directory spec on input, $PARSE "helpfully"
3633 * adds an empty name and type for us */
3634 if (mynam.nam$l_name == mynam.nam$l_type &&
3635 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3636 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3637 speclen = mynam.nam$l_name - out;
3638 out[speclen] = '\0';
3639 if (haslower) __mystrtolower(out);
3641 ST(0) = sv_2mortal(newSVpv(out, speclen));
3646 vmsify_fromperl(CV *cv)
3651 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3652 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3653 ST(0) = sv_newmortal();
3654 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3659 unixify_fromperl(CV *cv)
3664 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3665 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3666 ST(0) = sv_newmortal();
3667 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3672 fileify_fromperl(CV *cv)
3677 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3678 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3679 ST(0) = sv_newmortal();
3680 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3685 pathify_fromperl(CV *cv)
3690 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3691 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3692 ST(0) = sv_newmortal();
3693 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3698 vmspath_fromperl(CV *cv)
3703 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3704 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3705 ST(0) = sv_newmortal();
3706 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3711 unixpath_fromperl(CV *cv)
3716 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3717 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3718 ST(0) = sv_newmortal();
3719 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3724 candelete_fromperl(CV *cv)
3727 char fspec[NAM$C_MAXRSS+1], *fsp;
3731 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3733 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3734 if (SvTYPE(mysv) == SVt_PVGV) {
3735 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3736 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3743 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3744 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3750 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3755 rmscopy_fromperl(CV *cv)
3758 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3760 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3761 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3762 unsigned long int sts;
3766 if (items < 2 || items > 3)
3767 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3769 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3770 if (SvTYPE(mysv) == SVt_PVGV) {
3771 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3772 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3779 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3780 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3785 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3786 if (SvTYPE(mysv) == SVt_PVGV) {
3787 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3788 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3795 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3796 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3801 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3803 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3810 char* file = __FILE__;
3812 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
3813 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3814 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3815 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3816 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3817 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3818 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3819 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3820 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);