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;
126 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
128 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
129 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
130 return __my_getenv_eqv;
133 if ((cp2 = strchr(uplnm,';')) != NULL) {
135 idx = strtoul(cp2+1,NULL,0);
137 trnsuccess = my_trnlnm(uplnm,__my_getenv_eqv,idx);
138 /* If we had a translation index, we're only interested in lnms */
139 if (!trnsuccess && cp2 != NULL) return Nullch;
140 if (trnsuccess) return __my_getenv_eqv;
142 unsigned long int retsts;
143 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
144 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
145 DSC$K_CLASS_S, __my_getenv_eqv};
146 symdsc.dsc$w_length = cp1 - lnm;
147 symdsc.dsc$a_pointer = uplnm;
148 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
149 if (retsts == LIB$_INVSYMNAM) return Nullch;
150 if (retsts != LIB$_NOSUCHSYM) {
151 /* We want to return only logical names or CRTL Unix emulations */
152 if (retsts & 1) return Nullch;
155 /* Try for CRTL emulation of a Unix/POSIX name */
156 else return getenv(uplnm);
161 } /* end of my_getenv() */
164 /*{{{ void prime_env_iter() */
167 /* Fill the %ENV associative array with all logical names we can
168 * find, in preparation for iterating over it.
171 static int primed = 0; /* XXX Not thread-safe!!! */
172 HV *envhv = GvHVn(envgv);
174 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
176 SV *oldrs, *linesv, *eqvsv;
179 /* Perform a dummy fetch as an lval to insure that the hash table is
180 * set up. Otherwise, the hv_store() will turn into a nullop */
181 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
182 /* Also, set up the four "special" keys that the CRTL defines,
183 * whether or not underlying logical names exist. */
184 (void) hv_fetch(envhv,"HOME",4,TRUE);
185 (void) hv_fetch(envhv,"TERM",4,TRUE);
186 (void) hv_fetch(envhv,"PATH",4,TRUE);
187 (void) hv_fetch(envhv,"USER",4,TRUE);
189 /* Now, go get the logical names */
190 if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
191 _ckvmssts(vaxc$errno);
192 /* We use Perl's sv_gets to read from the pipe, since my_popen is
193 * tied to Perl's I/O layer, so it may not return a simple FILE * */
195 rs = newSVpv("\n",1);
196 linesv = newSVpv("",0);
198 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
200 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
204 while (*start != '"' && *start != '=' && *start) start++;
205 if (*start != '"') continue;
206 for (end = ++start; *end && *end != '"'; end++) ;
207 if (*end) *end = '\0';
209 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
210 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
212 warn("Ill-formed logical name |%s| in prime_env_iter",start);
215 else _ckvmssts(vaxc$errno);
218 eqvsv = newSVpv(eqv,eqvlen);
219 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
222 } /* end of prime_env_iter */
226 /*{{{ void my_setenv(char *lnm, char *eqv)*/
228 my_setenv(char *lnm,char *eqv)
229 /* Define a supervisor-mode logical name in the process table.
230 * In the future we'll add tables, attribs, and acmodes,
231 * probably through a different call.
234 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
235 unsigned long int retsts, usermode = PSL$C_USER;
236 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
237 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
238 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
240 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
241 lnmdsc.dsc$w_length = cp1 - lnm;
243 if (!eqv || !*eqv) { /* we're deleting a logical name */
244 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
245 if (retsts == SS$_IVLOGNAM) return;
246 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
248 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
249 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
253 eqvdsc.dsc$w_length = strlen(eqv);
254 eqvdsc.dsc$a_pointer = eqv;
256 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
259 } /* end of my_setenv() */
263 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
264 /* my_crypt - VMS password hashing
265 * my_crypt() provides an interface compatible with the Unix crypt()
266 * C library function, and uses sys$hash_password() to perform VMS
267 * password hashing. The quadword hashed password value is returned
268 * as a NUL-terminated 8 character string. my_crypt() does not change
269 * the case of its string arguments; in order to match the behavior
270 * of LOGINOUT et al., alphabetic characters in both arguments must
271 * be upcased by the caller.
274 my_crypt(const char *textpasswd, const char *usrname)
276 # ifndef UAI$C_PREFERRED_ALGORITHM
277 # define UAI$C_PREFERRED_ALGORITHM 127
279 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
280 unsigned short int salt = 0;
281 unsigned long int sts;
283 unsigned short int dsc$w_length;
284 unsigned char dsc$b_type;
285 unsigned char dsc$b_class;
286 const char * dsc$a_pointer;
287 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
288 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
289 struct itmlst_3 uailst[3] = {
290 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
291 { sizeof salt, UAI$_SALT, &salt, 0},
292 { 0, 0, NULL, NULL}};
295 usrdsc.dsc$w_length = strlen(usrname);
296 usrdsc.dsc$a_pointer = usrname;
297 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
304 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
310 if (sts != RMS$_RNF) return NULL;
313 txtdsc.dsc$w_length = strlen(textpasswd);
314 txtdsc.dsc$a_pointer = textpasswd;
315 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
316 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
319 return (char *) hash;
321 } /* end of my_crypt() */
325 static char *do_fileify_dirspec(char *, char *, int);
326 static char *do_tovmsspec(char *, char *, int);
328 /*{{{int do_rmdir(char *name)*/
332 char dirfile[NAM$C_MAXRSS+1];
336 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
337 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
338 else retval = kill_file(dirfile);
341 } /* end of do_rmdir */
345 * Delete any file to which user has control access, regardless of whether
346 * delete access is explicitly allowed.
347 * Limitations: User must have write access to parent directory.
348 * Does not block signals or ASTs; if interrupted in midstream
349 * may leave file with an altered ACL.
352 /*{{{int kill_file(char *name)*/
354 kill_file(char *name)
356 char vmsname[NAM$C_MAXRSS+1];
357 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
358 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
359 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
361 unsigned char myace$b_length;
362 unsigned char myace$b_type;
363 unsigned short int myace$w_flags;
364 unsigned long int myace$l_access;
365 unsigned long int myace$l_ident;
366 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
367 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
368 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
370 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
371 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
372 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
373 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
374 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
375 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
377 if (!remove(name)) return 0; /* Can we just get rid of it? */
378 /* If not, can changing protections help? */
379 if (vaxc$errno != RMS$_PRV) return -1;
381 /* No, so we get our own UIC to use as a rights identifier,
382 * and the insert an ACE at the head of the ACL which allows us
383 * to delete the file.
385 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
386 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
387 fildsc.dsc$w_length = strlen(vmsname);
388 fildsc.dsc$a_pointer = vmsname;
390 newace.myace$l_ident = oldace.myace$l_ident;
391 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
396 case SS$_NOSUCHOBJECT:
397 set_errno(ENOENT); break;
399 set_errno(ENODEV); break;
401 case SS$_INVFILFOROP:
402 set_errno(EINVAL); break;
404 set_errno(EACCES); break;
408 set_vaxc_errno(aclsts);
411 /* Grab any existing ACEs with this identifier in case we fail */
412 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
413 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
414 || fndsts == SS$_NOMOREACE ) {
415 /* Add the new ACE . . . */
416 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
418 if ((rmsts = remove(name))) {
419 /* We blew it - dir with files in it, no write priv for
420 * parent directory, etc. Put things back the way they were. */
421 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
424 addlst[0].bufadr = &oldace;
425 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
432 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
433 /* We just deleted it, so of course it's not there. Some versions of
434 * VMS seem to return success on the unlock operation anyhow (after all
435 * the unlock is successful), but others don't.
437 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
438 if (aclsts & 1) aclsts = fndsts;
441 set_vaxc_errno(aclsts);
447 } /* end of kill_file() */
450 /* my_utime - update modification time of a file
451 * calling sequence is identical to POSIX utime(), but under
452 * VMS only the modification time is changed; ODS-2 does not
453 * maintain access times. Restrictions differ from the POSIX
454 * definition in that the time can be changed as long as the
455 * caller has permission to execute the necessary IO$_MODIFY $QIO;
456 * no separate checks are made to insure that the caller is the
457 * owner of the file or has special privs enabled.
458 * Code here is based on Joe Meadows' FILE utility.
461 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
462 * to VMS epoch (01-JAN-1858 00:00:00.00)
463 * in 100 ns intervals.
465 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
467 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
468 int my_utime(char *file, struct utimbuf *utimes)
471 long int bintime[2], len = 2, lowbit, unixtime,
472 secscale = 10000000; /* seconds --> 100 ns intervals */
473 unsigned long int chan, iosb[2], retsts;
474 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
475 struct FAB myfab = cc$rms_fab;
476 struct NAM mynam = cc$rms_nam;
477 #if defined (__DECC) && defined (__VAX)
478 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
479 * at least through VMS V6.1, which causes a type-conversion warning.
481 # pragma message save
482 # pragma message disable cvtdiftypes
484 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
486 #if defined (__DECC) && defined (__VAX)
487 /* This should be right after the declaration of myatr, but due
488 * to a bug in VAX DEC C, this takes effect a statement early.
490 # pragma message restore
492 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
493 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
494 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
496 if (file == NULL || *file == '\0') {
498 set_vaxc_errno(LIB$_INVARG);
501 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
503 if (utimes != NULL) {
504 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
505 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
506 * Since time_t is unsigned long int, and lib$emul takes a signed long int
507 * as input, we force the sign bit to be clear by shifting unixtime right
508 * one bit, then multiplying by an extra factor of 2 in lib$emul().
510 lowbit = (utimes->modtime & 1) ? secscale : 0;
511 unixtime = (long int) utimes->modtime;
512 unixtime >> 1; secscale << 1;
513 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
516 set_vaxc_errno(retsts);
519 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
522 set_vaxc_errno(retsts);
527 /* Just get the current time in VMS format directly */
528 retsts = sys$gettim(bintime);
531 set_vaxc_errno(retsts);
536 myfab.fab$l_fna = vmsspec;
537 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
538 myfab.fab$l_nam = &mynam;
539 mynam.nam$l_esa = esa;
540 mynam.nam$b_ess = (unsigned char) sizeof esa;
541 mynam.nam$l_rsa = rsa;
542 mynam.nam$b_rss = (unsigned char) sizeof rsa;
544 /* Look for the file to be affected, letting RMS parse the file
545 * specification for us as well. I have set errno using only
546 * values documented in the utime() man page for VMS POSIX.
548 retsts = sys$parse(&myfab,0,0);
550 set_vaxc_errno(retsts);
551 if (retsts == RMS$_PRV) set_errno(EACCES);
552 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
553 else set_errno(EVMSERR);
556 retsts = sys$search(&myfab,0,0);
558 set_vaxc_errno(retsts);
559 if (retsts == RMS$_PRV) set_errno(EACCES);
560 else if (retsts == RMS$_FNF) set_errno(ENOENT);
561 else set_errno(EVMSERR);
565 devdsc.dsc$w_length = mynam.nam$b_dev;
566 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
568 retsts = sys$assign(&devdsc,&chan,0,0);
570 set_vaxc_errno(retsts);
571 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
572 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
573 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
574 else set_errno(EVMSERR);
578 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
579 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
581 memset((void *) &myfib, 0, sizeof myfib);
583 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
584 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
585 /* This prevents the revision time of the file being reset to the current
586 * time as a result of our IO$_MODIFY $QIO. */
587 myfib.fib$l_acctl = FIB$M_NORECORD;
589 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
590 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
591 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
593 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
594 _ckvmssts(sys$dassgn(chan));
595 if (retsts & 1) retsts = iosb[0];
597 set_vaxc_errno(retsts);
598 if (retsts == SS$_NOPRIV) set_errno(EACCES);
599 else set_errno(EVMSERR);
604 } /* end of my_utime() */
608 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
610 static unsigned long int mbxbufsiz;
611 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
615 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
616 * preprocessor consant BUFSIZ from stdio.h as the size of the
619 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
620 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
622 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
624 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
625 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
627 } /* end of create_mbx() */
629 /*{{{ my_popen and my_pclose*/
632 struct pipe_details *next;
633 PerlIO *fp; /* stdio file pointer to pipe mailbox */
634 int pid; /* PID of subprocess */
635 int mode; /* == 'r' if pipe open for reading */
636 int done; /* subprocess has completed */
637 unsigned long int completion; /* termination status of subprocess */
640 struct exit_control_block
642 struct exit_control_block *flink;
643 unsigned long int (*exit_routine)();
644 unsigned long int arg_count;
645 unsigned long int *status_address;
646 unsigned long int exit_status;
649 static struct pipe_details *open_pipes = NULL;
650 static $DESCRIPTOR(nl_desc, "NL:");
651 static int waitpid_asleep = 0;
653 static unsigned long int
656 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
658 while (open_pipes != NULL) {
659 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
660 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
663 if (!open_pipes->done) /* We tried to be nice . . . */
664 _ckvmssts(sys$delprc(&open_pipes->pid,0));
665 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
670 static struct exit_control_block pipe_exitblock =
671 {(struct exit_control_block *) 0,
672 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
676 popen_completion_ast(struct pipe_details *thispipe)
678 thispipe->done = TRUE;
679 if (waitpid_asleep) {
685 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
687 my_popen(char *cmd, char *mode)
689 static int handler_set_up = FALSE;
691 unsigned short int chan;
692 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
693 struct pipe_details *info;
694 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
695 DSC$K_CLASS_S, mbxname},
696 cmddsc = {0, DSC$K_DTYPE_T,
700 cmddsc.dsc$w_length=strlen(cmd);
701 cmddsc.dsc$a_pointer=cmd;
702 if (cmddsc.dsc$w_length > 255) {
703 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
707 New(7001,info,1,struct pipe_details);
710 create_mbx(&chan,&namdsc);
712 /* open a FILE* onto it */
713 info->fp = PerlIO_open(mbxname, mode);
715 /* give up other channel onto it */
716 _ckvmssts(sys$dassgn(chan));
726 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
727 0 /* name */, &info->pid, &info->completion,
728 0, popen_completion_ast,info,0,0,0));
731 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
732 0 /* name */, &info->pid, &info->completion,
733 0, popen_completion_ast,info,0,0,0));
736 if (!handler_set_up) {
737 _ckvmssts(sys$dclexh(&pipe_exitblock));
738 handler_set_up = TRUE;
740 info->next=open_pipes; /* prepend to list */
743 forkprocess = info->pid;
748 /*{{{ I32 my_pclose(FILE *fp)*/
749 I32 my_pclose(FILE *fp)
751 struct pipe_details *info, *last = NULL;
752 unsigned long int retsts;
754 for (info = open_pipes; info != NULL; last = info, info = info->next)
755 if (info->fp == fp) break;
758 /* get here => no such pipe open */
759 croak("No such pipe open");
761 PerlIO_close(info->fp);
763 if (info->done) retsts = info->completion;
764 else waitpid(info->pid,(int *) &retsts,0);
766 /* remove from list of open pipes */
767 if (last) last->next = info->next;
768 else open_pipes = info->next;
773 } /* end of my_pclose() */
775 /* sort-of waitpid; use only with popen() */
776 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
778 waitpid(unsigned long int pid, int *statusp, int flags)
780 struct pipe_details *info;
782 for (info = open_pipes; info != NULL; info = info->next)
783 if (info->pid == pid) break;
785 if (info != NULL) { /* we know about this child */
786 while (!info->done) {
791 *statusp = info->completion;
794 else { /* we haven't heard of this child */
795 $DESCRIPTOR(intdsc,"0 00:00:01");
796 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
797 unsigned long int interval[2],sts;
800 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
801 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
802 if (ownerpid != mypid)
803 warn("pid %d not a child",pid);
806 _ckvmssts(sys$bintim(&intdsc,interval));
807 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
808 _ckvmssts(sys$schdwk(0,0,interval,0));
809 _ckvmssts(sys$hiber());
813 /* There's no easy way to find the termination status a child we're
814 * not aware of beforehand. If we're really interested in the future,
815 * we can go looking for a termination mailbox, or chase after the
816 * accounting record for the process.
822 } /* end of waitpid() */
827 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
829 my_gconvert(double val, int ndig, int trail, char *buf)
831 static char __gcvtbuf[DBL_DIG+1];
834 loc = buf ? buf : __gcvtbuf;
836 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
837 return gcvt(val,ndig,loc);
840 loc[0] = '0'; loc[1] = '\0';
848 ** The following routines are provided to make life easier when
849 ** converting among VMS-style and Unix-style directory specifications.
850 ** All will take input specifications in either VMS or Unix syntax. On
851 ** failure, all return NULL. If successful, the routines listed below
852 ** return a pointer to a buffer containing the appropriately
853 ** reformatted spec (and, therefore, subsequent calls to that routine
854 ** will clobber the result), while the routines of the same names with
855 ** a _ts suffix appended will return a pointer to a mallocd string
856 ** containing the appropriately reformatted spec.
857 ** In all cases, only explicit syntax is altered; no check is made that
858 ** the resulting string is valid or that the directory in question
861 ** fileify_dirspec() - convert a directory spec into the name of the
862 ** directory file (i.e. what you can stat() to see if it's a dir).
863 ** The style (VMS or Unix) of the result is the same as the style
864 ** of the parameter passed in.
865 ** pathify_dirspec() - convert a directory spec into a path (i.e.
866 ** what you prepend to a filename to indicate what directory it's in).
867 ** The style (VMS or Unix) of the result is the same as the style
868 ** of the parameter passed in.
869 ** tounixpath() - convert a directory spec into a Unix-style path.
870 ** tovmspath() - convert a directory spec into a VMS-style path.
871 ** tounixspec() - convert any file spec into a Unix-style file spec.
872 ** tovmsspec() - convert any file spec into a VMS-style spec.
874 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
875 ** Permission is given to distribute this code as part of the Perl
876 ** standard distribution under the terms of the GNU General Public
877 ** License or the Perl Artistic License. Copies of each may be
878 ** found in the Perl standard distribution.
881 static char *do_tounixspec(char *, char *, int);
883 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
884 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
886 static char __fileify_retbuf[NAM$C_MAXRSS+1];
887 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
888 char *retspec, *cp1, *cp2, *lastdir;
889 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
892 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
894 dirlen = strlen(dir);
895 if (dir[dirlen-1] == '/') --dirlen;
898 set_vaxc_errno(RMS$_DIR);
901 if (!strpbrk(dir+1,"/]>:")) {
902 strcpy(trndir,*dir == '/' ? dir + 1: dir);
903 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
905 dirlen = strlen(dir);
908 strncpy(trndir,dir,dirlen);
909 trndir[dirlen] = '\0';
912 /* If we were handed a rooted logical name or spec, treat it like a
913 * simple directory, so that
914 * $ Define myroot dev:[dir.]
915 * ... do_fileify_dirspec("myroot",buf,1) ...
916 * does something useful.
918 if (!strcmp(dir+dirlen-2,".]")) {
919 dir[--dirlen] = '\0';
923 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
924 /* If we've got an explicit filename, we can just shuffle the string. */
925 if (*(cp1+1)) hasfilename = 1;
926 /* Similarly, we can just back up a level if we've got multiple levels
927 of explicit directories in a VMS spec which ends with directories. */
929 for (cp2 = cp1; cp2 > dir; cp2--) {
931 *cp2 = *cp1; *cp1 = '\0';
935 if (*cp2 == '[' || *cp2 == '<') break;
940 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
942 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
943 return do_fileify_dirspec("[]",buf,ts);
944 else if (dir[1] == '.' &&
945 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
946 return do_fileify_dirspec("[-]",buf,ts);
948 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
949 dirlen -= 1; /* to last element */
950 lastdir = strrchr(dir,'/');
952 else if ((cp1 = strstr(dir,"/.")) != NULL) {
953 /* If we have "/." or "/..", VMSify it and let the VMS code
954 * below expand it, rather than repeating the code to handle
955 * relative components of a filespec here */
957 if (*(cp1+2) == '.') cp1++;
958 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
959 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
960 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
961 return do_tounixspec(trndir,buf,ts);
964 } while ((cp1 = strstr(cp1,"/.")) != NULL);
967 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
968 !(lastdir = cp1 = strrchr(dir,']')) &&
969 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
970 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
972 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
973 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
974 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
975 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
976 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
979 set_vaxc_errno(RMS$_DIR);
985 /* If we lead off with a device or rooted logical, add the MFD
986 if we're specifying a top-level directory. */
987 if (lastdir && *dir == '/') {
989 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
996 retlen = dirlen + (addmfd ? 13 : 6);
997 if (buf) retspec = buf;
998 else if (ts) New(7009,retspec,retlen+1,char);
999 else retspec = __fileify_retbuf;
1001 dirlen = lastdir - dir;
1002 memcpy(retspec,dir,dirlen);
1003 strcpy(&retspec[dirlen],"/000000");
1004 strcpy(&retspec[dirlen+7],lastdir);
1007 memcpy(retspec,dir,dirlen);
1008 retspec[dirlen] = '\0';
1010 /* We've picked up everything up to the directory file name.
1011 Now just add the type and version, and we're set. */
1012 strcat(retspec,".dir;1");
1015 else { /* VMS-style directory spec */
1016 char esa[NAM$C_MAXRSS+1], term, *cp;
1017 unsigned long int sts, cmplen, haslower = 0;
1018 struct FAB dirfab = cc$rms_fab;
1019 struct NAM savnam, dirnam = cc$rms_nam;
1021 dirfab.fab$b_fns = strlen(dir);
1022 dirfab.fab$l_fna = dir;
1023 dirfab.fab$l_nam = &dirnam;
1024 dirfab.fab$l_dna = ".DIR;1";
1025 dirfab.fab$b_dns = 6;
1026 dirnam.nam$b_ess = NAM$C_MAXRSS;
1027 dirnam.nam$l_esa = esa;
1029 for (cp = dir; *cp; cp++)
1030 if (islower(*cp)) { haslower = 1; break; }
1031 if (!((sts = sys$parse(&dirfab))&1)) {
1032 if (dirfab.fab$l_sts == RMS$_DIR) {
1033 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1034 sts = sys$parse(&dirfab) & 1;
1038 set_vaxc_errno(dirfab.fab$l_sts);
1044 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1045 /* Yes; fake the fnb bits so we'll check type below */
1046 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1049 if (dirfab.fab$l_sts != RMS$_FNF) {
1051 set_vaxc_errno(dirfab.fab$l_sts);
1054 dirnam = savnam; /* No; just work with potential name */
1057 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1058 cp1 = strchr(esa,']');
1059 if (!cp1) cp1 = strchr(esa,'>');
1060 if (cp1) { /* Should always be true */
1061 dirnam.nam$b_esl -= cp1 - esa - 1;
1062 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1065 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1066 /* Yep; check version while we're at it, if it's there. */
1067 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1068 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1069 /* Something other than .DIR[;1]. Bzzt. */
1071 set_vaxc_errno(RMS$_DIR);
1075 esa[dirnam.nam$b_esl] = '\0';
1076 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1077 /* They provided at least the name; we added the type, if necessary, */
1078 if (buf) retspec = buf; /* in sys$parse() */
1079 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1080 else retspec = __fileify_retbuf;
1081 strcpy(retspec,esa);
1084 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1085 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1087 dirnam.nam$b_esl -= 9;
1089 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1090 if (cp1 == NULL) return NULL; /* should never happen */
1093 retlen = strlen(esa);
1094 if ((cp1 = strrchr(esa,'.')) != NULL) {
1095 /* There's more than one directory in the path. Just roll back. */
1097 if (buf) retspec = buf;
1098 else if (ts) New(7011,retspec,retlen+7,char);
1099 else retspec = __fileify_retbuf;
1100 strcpy(retspec,esa);
1103 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1104 /* Go back and expand rooted logical name */
1105 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1106 if (!(sys$parse(&dirfab) & 1)) {
1108 set_vaxc_errno(dirfab.fab$l_sts);
1111 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1112 if (buf) retspec = buf;
1113 else if (ts) New(7012,retspec,retlen+16,char);
1114 else retspec = __fileify_retbuf;
1115 cp1 = strstr(esa,"][");
1117 memcpy(retspec,esa,dirlen);
1118 if (!strncmp(cp1+2,"000000]",7)) {
1119 retspec[dirlen-1] = '\0';
1120 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1121 if (*cp1 == '.') *cp1 = ']';
1123 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1124 memcpy(cp1+1,"000000]",7);
1128 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1129 retspec[retlen] = '\0';
1130 /* Convert last '.' to ']' */
1131 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1132 if (*cp1 == '.') *cp1 = ']';
1134 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1135 memcpy(cp1+1,"000000]",7);
1139 else { /* This is a top-level dir. Add the MFD to the path. */
1140 if (buf) retspec = buf;
1141 else if (ts) New(7012,retspec,retlen+16,char);
1142 else retspec = __fileify_retbuf;
1145 while (*cp1 != ':') *(cp2++) = *(cp1++);
1146 strcpy(cp2,":[000000]");
1151 /* We've set up the string up through the filename. Add the
1152 type and version, and we're done. */
1153 strcat(retspec,".DIR;1");
1155 /* $PARSE may have upcased filespec, so convert output to lower
1156 * case if input contained any lowercase characters. */
1157 if (haslower) __mystrtolower(retspec);
1160 } /* end of do_fileify_dirspec() */
1162 /* External entry points */
1163 char *fileify_dirspec(char *dir, char *buf)
1164 { return do_fileify_dirspec(dir,buf,0); }
1165 char *fileify_dirspec_ts(char *dir, char *buf)
1166 { return do_fileify_dirspec(dir,buf,1); }
1168 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1169 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1171 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1172 unsigned long int retlen;
1173 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1175 if (!dir || !*dir) {
1176 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1179 if (*dir) strcpy(trndir,dir);
1180 else getcwd(trndir,sizeof trndir - 1);
1182 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1183 STRLEN trnlen = strlen(trndir);
1185 /* Trap simple rooted lnms, and return lnm:[000000] */
1186 if (!strcmp(trndir+trnlen-2,".]")) {
1187 if (buf) retpath = buf;
1188 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1189 else retpath = __pathify_retbuf;
1190 strcpy(retpath,dir);
1191 strcat(retpath,":[000000]");
1197 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1198 if (*dir == '.' && (*(dir+1) == '\0' ||
1199 (*(dir+1) == '.' && *(dir+2) == '\0')))
1200 retlen = 2 + (*(dir+1) != '\0');
1202 if ( !(cp1 = strrchr(dir,'/')) &&
1203 !(cp1 = strrchr(dir,']')) &&
1204 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1205 if ((cp2 = strchr(cp1,'.')) != NULL) {
1207 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1208 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1209 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1210 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1211 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1212 (ver || *cp3)))))) {
1214 set_vaxc_errno(RMS$_DIR);
1217 retlen = cp2 - dir + 1;
1219 else { /* No file type present. Treat the filename as a directory. */
1220 retlen = strlen(dir) + 1;
1223 if (buf) retpath = buf;
1224 else if (ts) New(7013,retpath,retlen+1,char);
1225 else retpath = __pathify_retbuf;
1226 strncpy(retpath,dir,retlen-1);
1227 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1228 retpath[retlen-1] = '/'; /* with '/', add it. */
1229 retpath[retlen] = '\0';
1231 else retpath[retlen-1] = '\0';
1233 else { /* VMS-style directory spec */
1234 char esa[NAM$C_MAXRSS+1], *cp;
1235 unsigned long int sts, cmplen, haslower;
1236 struct FAB dirfab = cc$rms_fab;
1237 struct NAM savnam, dirnam = cc$rms_nam;
1239 /* If we've got an explicit filename, we can just shuffle the string. */
1240 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1241 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1242 if ((cp2 = strchr(cp1,'.')) != NULL) {
1244 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1245 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1246 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1247 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1248 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1249 (ver || *cp3)))))) {
1251 set_vaxc_errno(RMS$_DIR);
1255 else { /* No file type, so just draw name into directory part */
1256 for (cp2 = cp1; *cp2; cp2++) ;
1259 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1261 /* We've now got a VMS 'path'; fall through */
1263 dirfab.fab$b_fns = strlen(dir);
1264 dirfab.fab$l_fna = dir;
1265 if (dir[dirfab.fab$b_fns-1] == ']' ||
1266 dir[dirfab.fab$b_fns-1] == '>' ||
1267 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1268 if (buf) retpath = buf;
1269 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1270 else retpath = __pathify_retbuf;
1271 strcpy(retpath,dir);
1274 dirfab.fab$l_dna = ".DIR;1";
1275 dirfab.fab$b_dns = 6;
1276 dirfab.fab$l_nam = &dirnam;
1277 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1278 dirnam.nam$l_esa = esa;
1280 for (cp = dir; *cp; cp++)
1281 if (islower(*cp)) { haslower = 1; break; }
1283 if (!(sts = (sys$parse(&dirfab)&1))) {
1284 if (dirfab.fab$l_sts == RMS$_DIR) {
1285 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1286 sts = sys$parse(&dirfab) & 1;
1290 set_vaxc_errno(dirfab.fab$l_sts);
1296 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1297 if (dirfab.fab$l_sts != RMS$_FNF) {
1299 set_vaxc_errno(dirfab.fab$l_sts);
1302 dirnam = savnam; /* No; just work with potential name */
1305 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1306 /* Yep; check version while we're at it, if it's there. */
1307 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1308 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1309 /* Something other than .DIR[;1]. Bzzt. */
1311 set_vaxc_errno(RMS$_DIR);
1315 /* OK, the type was fine. Now pull any file name into the
1317 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1319 cp1 = strrchr(esa,'>');
1320 *dirnam.nam$l_type = '>';
1323 *(dirnam.nam$l_type + 1) = '\0';
1324 retlen = dirnam.nam$l_type - esa + 2;
1325 if (buf) retpath = buf;
1326 else if (ts) New(7014,retpath,retlen,char);
1327 else retpath = __pathify_retbuf;
1328 strcpy(retpath,esa);
1329 /* $PARSE may have upcased filespec, so convert output to lower
1330 * case if input contained any lowercase characters. */
1331 if (haslower) __mystrtolower(retpath);
1335 } /* end of do_pathify_dirspec() */
1337 /* External entry points */
1338 char *pathify_dirspec(char *dir, char *buf)
1339 { return do_pathify_dirspec(dir,buf,0); }
1340 char *pathify_dirspec_ts(char *dir, char *buf)
1341 { return do_pathify_dirspec(dir,buf,1); }
1343 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1344 static char *do_tounixspec(char *spec, char *buf, int ts)
1346 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1347 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1348 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1350 if (spec == NULL) return NULL;
1351 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1352 if (buf) rslt = buf;
1354 retlen = strlen(spec);
1355 cp1 = strchr(spec,'[');
1356 if (!cp1) cp1 = strchr(spec,'<');
1358 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1360 New(7015,rslt,retlen+2+2*dashes,char);
1362 else rslt = __tounixspec_retbuf;
1363 if (strchr(spec,'/') != NULL) {
1370 dirend = strrchr(spec,']');
1371 if (dirend == NULL) dirend = strrchr(spec,'>');
1372 if (dirend == NULL) dirend = strchr(spec,':');
1373 if (dirend == NULL) {
1377 if (*cp2 != '[' && *cp2 != '<') {
1380 else { /* the VMS spec begins with directories */
1382 if (*cp2 == ']' || *cp2 == '>') {
1386 else if ( *cp2 != '.' && *cp2 != '-') {
1387 *(cp1++) = '/'; /* add the implied device into the Unix spec */
1388 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1389 if (ts) Safefree(rslt);
1394 while (*cp3 != ':' && *cp3) cp3++;
1396 if (strchr(cp3,']') != NULL) break;
1397 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1399 while (*cp3) *(cp1++) = *(cp3++);
1402 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1403 int offset = cp1 - rslt;
1405 retlen = devlen + dirlen;
1406 Renew(rslt,retlen+1+2*dashes,char);
1407 cp1 = rslt + offset;
1410 else if (*cp2 == '.') cp2++;
1412 for (; cp2 <= dirend; cp2++) {
1415 if (*(cp2+1) == '[') cp2++;
1417 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1418 else if (*cp2 == '.') {
1420 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1421 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1422 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1423 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1424 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1427 else if (*cp2 == '-') {
1428 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1429 while (*cp2 == '-') {
1431 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1433 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1434 if (ts) Safefree(rslt); /* filespecs like */
1435 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1439 else *(cp1++) = *cp2;
1441 else *(cp1++) = *cp2;
1443 while (*cp2) *(cp1++) = *(cp2++);
1448 } /* end of do_tounixspec() */
1450 /* External entry points */
1451 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1452 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1454 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1455 static char *do_tovmsspec(char *path, char *buf, int ts) {
1456 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1457 char *rslt, *dirend;
1458 register char *cp1, *cp2;
1459 unsigned long int infront = 0, hasdir = 1;
1461 if (path == NULL) return NULL;
1462 if (buf) rslt = buf;
1463 else if (ts) New(7016,rslt,strlen(path)+9,char);
1464 else rslt = __tovmsspec_retbuf;
1465 if (strpbrk(path,"]:>") ||
1466 (dirend = strrchr(path,'/')) == NULL) {
1467 if (path[0] == '.') {
1468 if (path[1] == '\0') strcpy(rslt,"[]");
1469 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1470 else strcpy(rslt,path); /* probably garbage */
1472 else strcpy(rslt,path);
1475 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1476 if (!*(dirend+2)) dirend +=2;
1477 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1482 char trndev[NAM$C_MAXRSS+1];
1486 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1487 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1489 islnm = my_trnlnm(rslt,trndev,0);
1490 trnend = islnm ? strlen(trndev) - 1 : 0;
1491 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1492 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1493 /* If the first element of the path is a logical name, determine
1494 * whether it has to be translated so we can add more directories. */
1495 if (!islnm || rooted) {
1498 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1502 if (cp2 != dirend) {
1503 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1504 strcpy(rslt,trndev);
1505 cp1 = rslt + trnend;
1518 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1519 cp2 += 2; /* skip over "./" - it's redundant */
1520 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1522 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1523 *(cp1++) = '-'; /* "../" --> "-" */
1526 if (cp2 > dirend) cp2 = dirend;
1528 else *(cp1++) = '.';
1530 for (; cp2 < dirend; cp2++) {
1532 if (*(cp2-1) == '/') continue;
1533 if (*(cp1-1) != '.') *(cp1++) = '.';
1536 else if (!infront && *cp2 == '.') {
1537 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1538 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1539 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1540 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1541 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1542 else { /* back up over previous directory name */
1544 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1545 if (*(cp1-1) == '[') {
1546 memcpy(cp1,"000000.",7);
1551 if (cp2 == dirend) break;
1553 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1556 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1557 if (*cp2 == '.') *(cp1++) = '_';
1558 else *(cp1++) = *cp2;
1562 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1563 if (hasdir) *(cp1++) = ']';
1564 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1565 while (*cp2) *(cp1++) = *(cp2++);
1570 } /* end of do_tovmsspec() */
1572 /* External entry points */
1573 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1574 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1576 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1577 static char *do_tovmspath(char *path, char *buf, int ts) {
1578 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1580 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1582 if (path == NULL) return NULL;
1583 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1584 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1585 if (buf) return buf;
1587 vmslen = strlen(vmsified);
1588 New(7017,cp,vmslen+1,char);
1589 memcpy(cp,vmsified,vmslen);
1594 strcpy(__tovmspath_retbuf,vmsified);
1595 return __tovmspath_retbuf;
1598 } /* end of do_tovmspath() */
1600 /* External entry points */
1601 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1602 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1605 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1606 static char *do_tounixpath(char *path, char *buf, int ts) {
1607 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1609 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1611 if (path == NULL) return NULL;
1612 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1613 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1614 if (buf) return buf;
1616 unixlen = strlen(unixified);
1617 New(7017,cp,unixlen+1,char);
1618 memcpy(cp,unixified,unixlen);
1623 strcpy(__tounixpath_retbuf,unixified);
1624 return __tounixpath_retbuf;
1627 } /* end of do_tounixpath() */
1629 /* External entry points */
1630 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1631 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1634 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1636 *****************************************************************************
1638 * Copyright (C) 1989-1994 by *
1639 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1641 * Permission is hereby granted for the reproduction of this software, *
1642 * on condition that this copyright notice is included in the reproduction, *
1643 * and that such reproduction is not for purposes of profit or material *
1646 * 27-Aug-1994 Modified for inclusion in perl5 *
1647 * by Charles Bailey bailey@genetics.upenn.edu *
1648 *****************************************************************************
1652 * getredirection() is intended to aid in porting C programs
1653 * to VMS (Vax-11 C). The native VMS environment does not support
1654 * '>' and '<' I/O redirection, or command line wild card expansion,
1655 * or a command line pipe mechanism using the '|' AND background
1656 * command execution '&'. All of these capabilities are provided to any
1657 * C program which calls this procedure as the first thing in the
1659 * The piping mechanism will probably work with almost any 'filter' type
1660 * of program. With suitable modification, it may useful for other
1661 * portability problems as well.
1663 * Author: Mark Pizzolato mark@infocomm.com
1667 struct list_item *next;
1671 static void add_item(struct list_item **head,
1672 struct list_item **tail,
1676 static void expand_wild_cards(char *item,
1677 struct list_item **head,
1678 struct list_item **tail,
1681 static int background_process(int argc, char **argv);
1683 static void pipe_and_fork(char **cmargv);
1685 /*{{{ void getredirection(int *ac, char ***av)*/
1687 getredirection(int *ac, char ***av)
1689 * Process vms redirection arg's. Exit if any error is seen.
1690 * If getredirection() processes an argument, it is erased
1691 * from the vector. getredirection() returns a new argc and argv value.
1692 * In the event that a background command is requested (by a trailing "&"),
1693 * this routine creates a background subprocess, and simply exits the program.
1695 * Warning: do not try to simplify the code for vms. The code
1696 * presupposes that getredirection() is called before any data is
1697 * read from stdin or written to stdout.
1699 * Normal usage is as follows:
1705 * getredirection(&argc, &argv);
1709 int argc = *ac; /* Argument Count */
1710 char **argv = *av; /* Argument Vector */
1711 char *ap; /* Argument pointer */
1712 int j; /* argv[] index */
1713 int item_count = 0; /* Count of Items in List */
1714 struct list_item *list_head = 0; /* First Item in List */
1715 struct list_item *list_tail; /* Last Item in List */
1716 char *in = NULL; /* Input File Name */
1717 char *out = NULL; /* Output File Name */
1718 char *outmode = "w"; /* Mode to Open Output File */
1719 char *err = NULL; /* Error File Name */
1720 char *errmode = "w"; /* Mode to Open Error File */
1721 int cmargc = 0; /* Piped Command Arg Count */
1722 char **cmargv = NULL;/* Piped Command Arg Vector */
1725 * First handle the case where the last thing on the line ends with
1726 * a '&'. This indicates the desire for the command to be run in a
1727 * subprocess, so we satisfy that desire.
1730 if (0 == strcmp("&", ap))
1731 exit(background_process(--argc, argv));
1732 if (*ap && '&' == ap[strlen(ap)-1])
1734 ap[strlen(ap)-1] = '\0';
1735 exit(background_process(argc, argv));
1738 * Now we handle the general redirection cases that involve '>', '>>',
1739 * '<', and pipes '|'.
1741 for (j = 0; j < argc; ++j)
1743 if (0 == strcmp("<", argv[j]))
1747 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1748 exit(LIB$_WRONUMARG);
1753 if ('<' == *(ap = argv[j]))
1758 if (0 == strcmp(">", ap))
1762 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1763 exit(LIB$_WRONUMARG);
1782 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1783 exit(LIB$_WRONUMARG);
1787 if (('2' == *ap) && ('>' == ap[1]))
1804 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1805 exit(LIB$_WRONUMARG);
1809 if (0 == strcmp("|", argv[j]))
1813 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1814 exit(LIB$_WRONUMARG);
1816 cmargc = argc-(j+1);
1817 cmargv = &argv[j+1];
1821 if ('|' == *(ap = argv[j]))
1829 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1832 * Allocate and fill in the new argument vector, Some Unix's terminate
1833 * the list with an extra null pointer.
1835 New(7002, argv, item_count+1, char *);
1837 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1838 argv[j] = list_head->value;
1844 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1845 exit(LIB$_INVARGORD);
1847 pipe_and_fork(cmargv);
1850 /* Check for input from a pipe (mailbox) */
1852 if (in == NULL && 1 == isapipe(0))
1854 char mbxname[L_tmpnam];
1856 long int dvi_item = DVI$_DEVBUFSIZ;
1857 $DESCRIPTOR(mbxnam, "");
1858 $DESCRIPTOR(mbxdevnam, "");
1860 /* Input from a pipe, reopen it in binary mode to disable */
1861 /* carriage control processing. */
1863 PerlIO_getname(stdin, mbxname);
1864 mbxnam.dsc$a_pointer = mbxname;
1865 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1866 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1867 mbxdevnam.dsc$a_pointer = mbxname;
1868 mbxdevnam.dsc$w_length = sizeof(mbxname);
1869 dvi_item = DVI$_DEVNAM;
1870 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1871 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1874 freopen(mbxname, "rb", stdin);
1877 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1881 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1883 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1886 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1888 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
1893 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1895 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
1899 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
1904 #ifdef ARGPROC_DEBUG
1905 PerlIO_printf(Perl_debug_log, "Arglist:\n");
1906 for (j = 0; j < *ac; ++j)
1907 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
1909 /* Clear errors we may have hit expanding wildcards, so they don't
1910 show up in Perl's $! later */
1911 set_errno(0); set_vaxc_errno(1);
1912 } /* end of getredirection() */
1915 static void add_item(struct list_item **head,
1916 struct list_item **tail,
1922 New(7003,*head,1,struct list_item);
1926 New(7004,(*tail)->next,1,struct list_item);
1927 *tail = (*tail)->next;
1929 (*tail)->value = value;
1933 static void expand_wild_cards(char *item,
1934 struct list_item **head,
1935 struct list_item **tail,
1939 unsigned long int context = 0;
1945 char vmsspec[NAM$C_MAXRSS+1];
1946 $DESCRIPTOR(filespec, "");
1947 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1948 $DESCRIPTOR(resultspec, "");
1949 unsigned long int zero = 0, sts;
1951 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
1953 add_item(head, tail, item, count);
1956 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1957 resultspec.dsc$b_class = DSC$K_CLASS_D;
1958 resultspec.dsc$a_pointer = NULL;
1959 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1960 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1961 if (!isunix || !filespec.dsc$a_pointer)
1962 filespec.dsc$a_pointer = item;
1963 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1965 * Only return version specs, if the caller specified a version
1967 had_version = strchr(item, ';');
1969 * Only return device and directory specs, if the caller specifed either.
1971 had_device = strchr(item, ':');
1972 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1974 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1975 &defaultspec, 0, 0, &zero))))
1980 New(7005,string,resultspec.dsc$w_length+1,char);
1981 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1982 string[resultspec.dsc$w_length] = '\0';
1983 if (NULL == had_version)
1984 *((char *)strrchr(string, ';')) = '\0';
1985 if ((!had_directory) && (had_device == NULL))
1987 if (NULL == (devdir = strrchr(string, ']')))
1988 devdir = strrchr(string, '>');
1989 strcpy(string, devdir + 1);
1992 * Be consistent with what the C RTL has already done to the rest of
1993 * the argv items and lowercase all of these names.
1995 for (c = string; *c; ++c)
1998 if (isunix) trim_unixpath(string,item);
1999 add_item(head, tail, string, count);
2002 if (sts != RMS$_NMF)
2004 set_vaxc_errno(sts);
2010 set_errno(ENOENT); break;
2012 set_errno(ENODEV); break;
2014 set_errno(EINVAL); break;
2016 set_errno(EACCES); break;
2018 _ckvmssts_noperl(sts);
2022 add_item(head, tail, item, count);
2023 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2024 _ckvmssts_noperl(lib$find_file_end(&context));
2027 static int child_st[2];/* Event Flag set when child process completes */
2029 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2031 static unsigned long int exit_handler(int *status)
2035 if (0 == child_st[0])
2037 #ifdef ARGPROC_DEBUG
2038 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2040 fflush(stdout); /* Have to flush pipe for binary data to */
2041 /* terminate properly -- <tp@mccall.com> */
2042 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2043 sys$dassgn(child_chan);
2045 sys$synch(0, child_st);
2050 static void sig_child(int chan)
2052 #ifdef ARGPROC_DEBUG
2053 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2055 if (child_st[0] == 0)
2059 static struct exit_control_block exit_block =
2064 &exit_block.exit_status,
2068 static void pipe_and_fork(char **cmargv)
2071 $DESCRIPTOR(cmddsc, "");
2072 static char mbxname[64];
2073 $DESCRIPTOR(mbxdsc, mbxname);
2075 unsigned long int zero = 0, one = 1;
2077 strcpy(subcmd, cmargv[0]);
2078 for (j = 1; NULL != cmargv[j]; ++j)
2080 strcat(subcmd, " \"");
2081 strcat(subcmd, cmargv[j]);
2082 strcat(subcmd, "\"");
2084 cmddsc.dsc$a_pointer = subcmd;
2085 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2087 create_mbx(&child_chan,&mbxdsc);
2088 #ifdef ARGPROC_DEBUG
2089 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2090 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2092 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2093 0, &pid, child_st, &zero, sig_child,
2095 #ifdef ARGPROC_DEBUG
2096 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2098 sys$dclexh(&exit_block);
2099 if (NULL == freopen(mbxname, "wb", stdout))
2101 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2105 static int background_process(int argc, char **argv)
2107 char command[2048] = "$";
2108 $DESCRIPTOR(value, "");
2109 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2110 static $DESCRIPTOR(null, "NLA0:");
2111 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2113 $DESCRIPTOR(pidstr, "");
2115 unsigned long int flags = 17, one = 1, retsts;
2117 strcat(command, argv[0]);
2120 strcat(command, " \"");
2121 strcat(command, *(++argv));
2122 strcat(command, "\"");
2124 value.dsc$a_pointer = command;
2125 value.dsc$w_length = strlen(value.dsc$a_pointer);
2126 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2127 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2128 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2129 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2132 _ckvmssts_noperl(retsts);
2134 #ifdef ARGPROC_DEBUG
2135 PerlIO_printf(Perl_debug_log, "%s\n", command);
2137 sprintf(pidstring, "%08X", pid);
2138 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2139 pidstr.dsc$a_pointer = pidstring;
2140 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2141 lib$set_symbol(&pidsymbol, &pidstr);
2145 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2148 * Trim Unix-style prefix off filespec, so it looks like what a shell
2149 * glob expansion would return (i.e. from specified prefix on, not
2150 * full path). Note that returned filespec is Unix-style, regardless
2151 * of whether input filespec was VMS-style or Unix-style.
2153 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2154 * determine prefix (both may be in VMS or Unix syntax).
2156 * Returns !=0 on success, with trimmed filespec replacing contents of
2157 * fspec, and 0 on failure, with contents of fpsec unchanged.
2159 /*{{{int trim_unixpath(char *fspec, char *wildspec)*/
2161 trim_unixpath(char *fspec, char *wildspec)
2163 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2164 *template, *base, *cp1, *cp2;
2165 register int tmplen, reslen = 0;
2167 if (!wildspec || !fspec) return 0;
2168 if (strpbrk(wildspec,"]>:") != NULL) {
2169 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2170 else template = unixified;
2172 else template = wildspec;
2173 if (strpbrk(fspec,"]>:") != NULL) {
2174 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2175 else base = unixified;
2176 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2177 * check to see that final result fits into (isn't longer than) fspec */
2178 reslen = strlen(fspec);
2182 /* No prefix or absolute path on wildcard, so nothing to remove */
2183 if (!*template || *template == '/') {
2184 if (base == fspec) return 1;
2185 tmplen = strlen(unixified);
2186 if (tmplen > reslen) return 0; /* not enough space */
2187 /* Copy unixified resultant, including trailing NUL */
2188 memmove(fspec,unixified,tmplen+1);
2192 /* Find prefix to template consisting of path elements without wildcards */
2193 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2194 for (cp1 = template; *cp1; cp1++) ;
2195 else while (cp1 > template && *cp1 != '/') cp1--;
2196 for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
2198 /* Wildcard was in first element, so we don't have a reliable string to
2199 * match against. Guess where to trim resultant filespec by counting
2200 * directory levels in the Unix template. (We could do this instead of
2201 * string matching in all cases, since Unix doesn't have a ... wildcard
2202 * that can expand into multiple levels of subdirectory, but we try for
2203 * the string match so our caller can interpret foo/.../bar.* as
2204 * [.foo...]bar.* if it wants, and only get burned if there was a
2205 * wildcard in the first word (in which case, caveat caller). */
2206 if (cp1 == template) {
2208 for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
2209 /* need to back one more '/' than in template, to pick up leading dirname */
2211 while (cp2 > base) {
2212 if (*cp2 == '/') subdirs--;
2213 if (!subdirs) break; /* quit without decrement when we hit last '/' */
2216 /* ran out of directories on resultant; allow for already trimmed
2217 * resultant, which hits start of string looking for leading '/' */
2218 if (subdirs && (cp2 != base || subdirs != 1)) return 0;
2219 /* Move past leading '/', if there is one */
2220 base = cp2 + (*cp2 == '/' ? 1 : 0);
2221 tmplen = strlen(base);
2222 if (reslen && tmplen > reslen) return 0; /* not enough space */
2223 memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
2226 /* We have a prefix string of complete directory names, so we
2227 * try to find it on the resultant filespec */
2229 tmplen = cp1 - template;
2230 if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
2231 if (reslen) { /* we converted to Unix syntax; copy result over */
2232 tmplen = cp2 - base;
2233 if (tmplen > reslen) return 0; /* not enough space */
2234 memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
2238 for ( ; cp2 - base > tmplen; base++) {
2239 if (*base != '/') continue;
2240 if (!memcmp(base + 1,template,tmplen)) break;
2243 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2244 base++; /* Move past leading '/' */
2245 if (reslen && cp2 - base > reslen) return 0; /* not enough space */
2246 /* Copy down remaining portion of filespec, including trailing NUL */
2247 memmove(fspec,base,cp2 - base + 1);
2251 } /* end of trim_unixpath() */
2256 * VMS readdir() routines.
2257 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2258 * This code has no copyright.
2260 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2261 * Minor modifications to original routines.
2264 /* Number of elements in vms_versions array */
2265 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2268 * Open a directory, return a handle for later use.
2270 /*{{{ DIR *opendir(char*name) */
2275 char dir[NAM$C_MAXRSS+1];
2277 /* Get memory for the handle, and the pattern. */
2279 if (do_tovmspath(name,dir,0) == NULL) {
2280 Safefree((char *)dd);
2283 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2285 /* Fill in the fields; mainly playing with the descriptor. */
2286 (void)sprintf(dd->pattern, "%s*.*",dir);
2289 dd->vms_wantversions = 0;
2290 dd->pat.dsc$a_pointer = dd->pattern;
2291 dd->pat.dsc$w_length = strlen(dd->pattern);
2292 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2293 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2296 } /* end of opendir() */
2300 * Set the flag to indicate we want versions or not.
2302 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2304 vmsreaddirversions(DIR *dd, int flag)
2306 dd->vms_wantversions = flag;
2311 * Free up an opened directory.
2313 /*{{{ void closedir(DIR *dd)*/
2317 (void)lib$find_file_end(&dd->context);
2318 Safefree(dd->pattern);
2319 Safefree((char *)dd);
2324 * Collect all the version numbers for the current file.
2330 struct dsc$descriptor_s pat;
2331 struct dsc$descriptor_s res;
2333 char *p, *text, buff[sizeof dd->entry.d_name];
2335 unsigned long context, tmpsts;
2337 /* Convenient shorthand. */
2340 /* Add the version wildcard, ignoring the "*.*" put on before */
2341 i = strlen(dd->pattern);
2342 New(7008,text,i + e->d_namlen + 3,char);
2343 (void)strcpy(text, dd->pattern);
2344 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2346 /* Set up the pattern descriptor. */
2347 pat.dsc$a_pointer = text;
2348 pat.dsc$w_length = i + e->d_namlen - 1;
2349 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2350 pat.dsc$b_class = DSC$K_CLASS_S;
2352 /* Set up result descriptor. */
2353 res.dsc$a_pointer = buff;
2354 res.dsc$w_length = sizeof buff - 2;
2355 res.dsc$b_dtype = DSC$K_DTYPE_T;
2356 res.dsc$b_class = DSC$K_CLASS_S;
2358 /* Read files, collecting versions. */
2359 for (context = 0, e->vms_verscount = 0;
2360 e->vms_verscount < VERSIZE(e);
2361 e->vms_verscount++) {
2362 tmpsts = lib$find_file(&pat, &res, &context);
2363 if (tmpsts == RMS$_NMF || context == 0) break;
2365 buff[sizeof buff - 1] = '\0';
2366 if ((p = strchr(buff, ';')))
2367 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2369 e->vms_versions[e->vms_verscount] = -1;
2372 _ckvmssts(lib$find_file_end(&context));
2375 } /* end of collectversions() */
2378 * Read the next entry from the directory.
2380 /*{{{ struct dirent *readdir(DIR *dd)*/
2384 struct dsc$descriptor_s res;
2385 char *p, buff[sizeof dd->entry.d_name];
2386 unsigned long int tmpsts;
2388 /* Set up result descriptor, and get next file. */
2389 res.dsc$a_pointer = buff;
2390 res.dsc$w_length = sizeof buff - 2;
2391 res.dsc$b_dtype = DSC$K_DTYPE_T;
2392 res.dsc$b_class = DSC$K_CLASS_S;
2393 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2394 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2395 if (!(tmpsts & 1)) {
2396 set_vaxc_errno(tmpsts);
2399 set_errno(EACCES); break;
2401 set_errno(ENODEV); break;
2404 set_errno(ENOENT); break;
2411 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2412 buff[sizeof buff - 1] = '\0';
2413 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2416 /* Skip any directory component and just copy the name. */
2417 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2418 else (void)strcpy(dd->entry.d_name, buff);
2420 /* Clobber the version. */
2421 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2423 dd->entry.d_namlen = strlen(dd->entry.d_name);
2424 dd->entry.vms_verscount = 0;
2425 if (dd->vms_wantversions) collectversions(dd);
2428 } /* end of readdir() */
2432 * Return something that can be used in a seekdir later.
2434 /*{{{ long telldir(DIR *dd)*/
2443 * Return to a spot where we used to be. Brute force.
2445 /*{{{ void seekdir(DIR *dd,long count)*/
2447 seekdir(DIR *dd, long count)
2449 int vms_wantversions;
2451 /* If we haven't done anything yet... */
2455 /* Remember some state, and clear it. */
2456 vms_wantversions = dd->vms_wantversions;
2457 dd->vms_wantversions = 0;
2458 _ckvmssts(lib$find_file_end(&dd->context));
2461 /* The increment is in readdir(). */
2462 for (dd->count = 0; dd->count < count; )
2465 dd->vms_wantversions = vms_wantversions;
2467 } /* end of seekdir() */
2470 /* VMS subprocess management
2472 * my_vfork() - just a vfork(), after setting a flag to record that
2473 * the current script is trying a Unix-style fork/exec.
2475 * vms_do_aexec() and vms_do_exec() are called in response to the
2476 * perl 'exec' function. If this follows a vfork call, then they
2477 * call out the the regular perl routines in doio.c which do an
2478 * execvp (for those who really want to try this under VMS).
2479 * Otherwise, they do exactly what the perl docs say exec should
2480 * do - terminate the current script and invoke a new command
2481 * (See below for notes on command syntax.)
2483 * do_aspawn() and do_spawn() implement the VMS side of the perl
2484 * 'system' function.
2486 * Note on command arguments to perl 'exec' and 'system': When handled
2487 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2488 * are concatenated to form a DCL command string. If the first arg
2489 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2490 * the the command string is hrnded off to DCL directly. Otherwise,
2491 * the first token of the command is taken as the filespec of an image
2492 * to run. The filespec is expanded using a default type of '.EXE' and
2493 * the process defaults for device, directory, etc., and the resultant
2494 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2495 * the command string as parameters. This is perhaps a bit compicated,
2496 * but I hope it will form a happy medium between what VMS folks expect
2497 * from lib$spawn and what Unix folks expect from exec.
2500 static int vfork_called;
2502 /*{{{int my_vfork()*/
2512 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2520 if (VMScmd.dsc$a_pointer) {
2521 Safefree(VMScmd.dsc$a_pointer);
2522 VMScmd.dsc$w_length = 0;
2523 VMScmd.dsc$a_pointer = Nullch;
2528 setup_argstr(SV *really, SV **mark, SV **sp)
2530 char *junk, *tmps = Nullch;
2531 register size_t cmdlen = 0;
2537 tmps = SvPV(really,rlen);
2544 for (idx++; idx <= sp; idx++) {
2546 junk = SvPVx(*idx,rlen);
2547 cmdlen += rlen ? rlen + 1 : 0;
2550 New(401,Cmd,cmdlen+1,char);
2552 if (tmps && *tmps) {
2557 while (++mark <= sp) {
2560 strcat(Cmd,SvPVx(*mark,na));
2565 } /* end of setup_argstr() */
2568 static unsigned long int
2569 setup_cmddsc(char *cmd, int check_img)
2571 char resspec[NAM$C_MAXRSS+1];
2572 $DESCRIPTOR(defdsc,".EXE");
2573 $DESCRIPTOR(resdsc,resspec);
2574 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2575 unsigned long int cxt = 0, flags = 1, retsts;
2576 register char *s, *rest, *cp;
2577 register int isdcl = 0;
2580 while (*s && isspace(*s)) s++;
2582 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2583 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2584 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2585 if (*cp == ':' || *cp == '[' || *cp == '<') {
2593 if (isdcl) { /* It's a DCL command, just do it. */
2594 VMScmd.dsc$w_length = strlen(cmd);
2596 VMScmd.dsc$a_pointer = Cmd;
2597 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2599 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2601 else { /* assume first token is an image spec */
2603 while (*s && !isspace(*s)) s++;
2605 imgdsc.dsc$a_pointer = cmd;
2606 imgdsc.dsc$w_length = s - cmd;
2607 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2608 if (!(retsts & 1)) {
2609 /* just hand off status values likely to be due to user error */
2610 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2611 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2612 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2613 else { _ckvmssts(retsts); }
2616 _ckvmssts(lib$find_file_end(&cxt));
2618 while (*s && !isspace(*s)) s++;
2620 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2621 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2622 strcat(VMScmd.dsc$a_pointer,resspec);
2623 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2624 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2628 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2630 } /* end of setup_cmddsc() */
2633 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2635 vms_do_aexec(SV *really,SV **mark,SV **sp)
2638 if (vfork_called) { /* this follows a vfork - act Unixish */
2640 if (vfork_called < 0) {
2641 warn("Internal inconsistency in tracking vforks");
2644 else return do_aexec(really,mark,sp);
2646 /* no vfork - act VMSish */
2647 return vms_do_exec(setup_argstr(really,mark,sp));
2652 } /* end of vms_do_aexec() */
2655 /* {{{bool vms_do_exec(char *cmd) */
2657 vms_do_exec(char *cmd)
2660 if (vfork_called) { /* this follows a vfork - act Unixish */
2662 if (vfork_called < 0) {
2663 warn("Internal inconsistency in tracking vforks");
2666 else return do_exec(cmd);
2669 { /* no vfork - act VMSish */
2670 unsigned long int retsts;
2672 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2673 retsts = lib$do_command(&VMScmd);
2676 set_vaxc_errno(retsts);
2678 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2684 } /* end of vms_do_exec() */
2687 unsigned long int do_spawn(char *);
2689 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2691 do_aspawn(SV *really,SV **mark,SV **sp)
2693 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2696 } /* end of do_aspawn() */
2699 /* {{{unsigned long int do_spawn(char *cmd) */
2703 unsigned long int substs, hadcmd = 1;
2705 if (!cmd || !*cmd) {
2707 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2709 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2710 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2715 set_vaxc_errno(substs);
2717 warn("Can't spawn \"%s\": %s",
2718 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2723 } /* end of do_spawn() */
2727 * A simple fwrite replacement which outputs itmsz*nitm chars without
2728 * introducing record boundaries every itmsz chars.
2730 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2732 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2734 register char *cp, *end;
2736 end = (char *)src + itmsz * nitm;
2738 while ((char *)src <= end) {
2739 for (cp = src; cp <= end; cp++) if (!*cp) break;
2740 if (fputs(src,dest) == EOF) return EOF;
2742 if (fputc('\0',dest) == EOF) return EOF;
2748 } /* end of my_fwrite() */
2752 * Here are replacements for the following Unix routines in the VMS environment:
2753 * getpwuid Get information for a particular UIC or UID
2754 * getpwnam Get information for a named user
2755 * getpwent Get information for each user in the rights database
2756 * setpwent Reset search to the start of the rights database
2757 * endpwent Finish searching for users in the rights database
2759 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2760 * (defined in pwd.h), which contains the following fields:-
2762 * char *pw_name; Username (in lower case)
2763 * char *pw_passwd; Hashed password
2764 * unsigned int pw_uid; UIC
2765 * unsigned int pw_gid; UIC group number
2766 * char *pw_unixdir; Default device/directory (VMS-style)
2767 * char *pw_gecos; Owner name
2768 * char *pw_dir; Default device/directory (Unix-style)
2769 * char *pw_shell; Default CLI name (eg. DCL)
2771 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2773 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2774 * not the UIC member number (eg. what's returned by getuid()),
2775 * getpwuid() can accept either as input (if uid is specified, the caller's
2776 * UIC group is used), though it won't recognise gid=0.
2778 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2779 * information about other users in your group or in other groups, respectively.
2780 * If the required privilege is not available, then these routines fill only
2781 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2784 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2787 /* sizes of various UAF record fields */
2788 #define UAI$S_USERNAME 12
2789 #define UAI$S_IDENT 31
2790 #define UAI$S_OWNER 31
2791 #define UAI$S_DEFDEV 31
2792 #define UAI$S_DEFDIR 63
2793 #define UAI$S_DEFCLI 31
2796 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2797 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2798 (uic).uic$v_group != UIC$K_WILD_GROUP)
2800 static char __empty[]= "";
2801 static struct passwd __passwd_empty=
2802 {(char *) __empty, (char *) __empty, 0, 0,
2803 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2804 static int contxt= 0;
2805 static struct passwd __pwdcache;
2806 static char __pw_namecache[UAI$S_IDENT+1];
2809 * This routine does most of the work extracting the user information.
2811 static int fillpasswd (const char *name, struct passwd *pwd)
2814 unsigned char length;
2815 char pw_gecos[UAI$S_OWNER+1];
2817 static union uicdef uic;
2819 unsigned char length;
2820 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2823 unsigned char length;
2824 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2827 unsigned char length;
2828 char pw_shell[UAI$S_DEFCLI+1];
2830 static char pw_passwd[UAI$S_PWD+1];
2832 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2833 struct dsc$descriptor_s name_desc;
2834 unsigned long int sts;
2836 static struct itmlst_3 itmlst[]= {
2837 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2838 {sizeof(uic), UAI$_UIC, &uic, &luic},
2839 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2840 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2841 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2842 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2843 {0, 0, NULL, NULL}};
2845 name_desc.dsc$w_length= strlen(name);
2846 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2847 name_desc.dsc$b_class= DSC$K_CLASS_S;
2848 name_desc.dsc$a_pointer= (char *) name;
2850 /* Note that sys$getuai returns many fields as counted strings. */
2851 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2852 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2853 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2855 else { _ckvmssts(sts); }
2856 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2858 if ((int) owner.length < lowner) lowner= (int) owner.length;
2859 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2860 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2861 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2862 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2863 owner.pw_gecos[lowner]= '\0';
2864 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2865 defcli.pw_shell[ldefcli]= '\0';
2866 if (valid_uic(uic)) {
2867 pwd->pw_uid= uic.uic$l_uic;
2868 pwd->pw_gid= uic.uic$v_group;
2871 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2872 pwd->pw_passwd= pw_passwd;
2873 pwd->pw_gecos= owner.pw_gecos;
2874 pwd->pw_dir= defdev.pw_dir;
2875 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2876 pwd->pw_shell= defcli.pw_shell;
2877 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2879 ldir= strlen(pwd->pw_unixdir) - 1;
2880 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2883 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2884 __mystrtolower(pwd->pw_unixdir);
2889 * Get information for a named user.
2891 /*{{{struct passwd *getpwnam(char *name)*/
2892 struct passwd *my_getpwnam(char *name)
2894 struct dsc$descriptor_s name_desc;
2896 unsigned long int status, stat;
2898 __pwdcache = __passwd_empty;
2899 if (!fillpasswd(name, &__pwdcache)) {
2900 /* We still may be able to determine pw_uid and pw_gid */
2901 name_desc.dsc$w_length= strlen(name);
2902 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2903 name_desc.dsc$b_class= DSC$K_CLASS_S;
2904 name_desc.dsc$a_pointer= (char *) name;
2905 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2906 __pwdcache.pw_uid= uic.uic$l_uic;
2907 __pwdcache.pw_gid= uic.uic$v_group;
2910 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2911 set_vaxc_errno(stat);
2912 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2915 else { _ckvmssts(stat); }
2918 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2919 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2920 __pwdcache.pw_name= __pw_namecache;
2922 } /* end of my_getpwnam() */
2926 * Get information for a particular UIC or UID.
2927 * Called by my_getpwent with uid=-1 to list all users.
2929 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2930 struct passwd *my_getpwuid(Uid_t uid)
2932 const $DESCRIPTOR(name_desc,__pw_namecache);
2933 unsigned short lname;
2935 unsigned long int status;
2937 if (uid == (unsigned int) -1) {
2939 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2940 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2941 set_vaxc_errno(status);
2942 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2946 else { _ckvmssts(status); }
2947 } while (!valid_uic (uic));
2951 if (!uic.uic$v_group)
2952 uic.uic$v_group= getgid();
2954 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2955 else status = SS$_IVIDENT;
2956 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2957 status == RMS$_PRV) {
2958 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2961 else { _ckvmssts(status); }
2963 __pw_namecache[lname]= '\0';
2964 __mystrtolower(__pw_namecache);
2966 __pwdcache = __passwd_empty;
2967 __pwdcache.pw_name = __pw_namecache;
2969 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2970 The identifier's value is usually the UIC, but it doesn't have to be,
2971 so if we can, we let fillpasswd update this. */
2972 __pwdcache.pw_uid = uic.uic$l_uic;
2973 __pwdcache.pw_gid = uic.uic$v_group;
2975 fillpasswd(__pw_namecache, &__pwdcache);
2978 } /* end of my_getpwuid() */
2982 * Get information for next user.
2984 /*{{{struct passwd *my_getpwent()*/
2985 struct passwd *my_getpwent()
2987 return (my_getpwuid((unsigned int) -1));
2992 * Finish searching rights database for users.
2994 /*{{{void my_endpwent()*/
2998 _ckvmssts(sys$finish_rdb(&contxt));
3006 * If the CRTL has a real gmtime(), use it, else look for the logical
3007 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
3008 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
3009 * to translate to the number of seconds which must be added to UTC
3010 * to get to the local time of the system.
3011 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3014 /*{{{struct tm *my_gmtime(const time_t *time)*/
3015 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
3016 * so we can call the CRTL's routine to see if it works.
3020 my_gmtime(const time_t *time)
3022 static int gmtime_emulation_type;
3023 static time_t utc_offset_secs;
3027 if (gmtime_emulation_type == 0) {
3028 gmtime_emulation_type++;
3030 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
3031 gmtime_emulation_type++;
3032 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
3033 gmtime_emulation_type++;
3035 utc_offset_secs = (time_t) atol(p);
3039 switch (gmtime_emulation_type) {
3041 return gmtime(time);
3043 when = *time - utc_offset_secs;
3044 return localtime(&when);
3046 warn("gmtime not supported on this system");
3049 } /* end of my_gmtime() */
3050 /* Reset definition for later calls */
3051 #define gmtime(t) my_gmtime(t)
3056 * flex_stat, flex_fstat
3057 * basic stat, but gets it right when asked to stat
3058 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3061 /* encode_dev packs a VMS device name string into an integer to allow
3062 * simple comparisons. This can be used, for example, to check whether two
3063 * files are located on the same device, by comparing their encoded device
3064 * names. Even a string comparison would not do, because stat() reuses the
3065 * device name buffer for each call; so without encode_dev, it would be
3066 * necessary to save the buffer and use strcmp (this would mean a number of
3067 * changes to the standard Perl code, to say nothing of what a Perl script
3070 * The device lock id, if it exists, should be unique (unless perhaps compared
3071 * with lock ids transferred from other nodes). We have a lock id if the disk is
3072 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3073 * device names. Thus we use the lock id in preference, and only if that isn't
3074 * available, do we try to pack the device name into an integer (flagged by
3075 * the sign bit (LOCKID_MASK) being set).
3077 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3078 * name and its encoded form, but it seems very unlikely that we will find
3079 * two files on different disks that share the same encoded device names,
3080 * and even more remote that they will share the same file id (if the test
3081 * is to check for the same file).
3083 * A better method might be to use sys$device_scan on the first call, and to
3084 * search for the device, returning an index into the cached array.
3085 * The number returned would be more intelligable.
3086 * This is probably not worth it, and anyway would take quite a bit longer
3087 * on the first call.
3089 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3090 static dev_t encode_dev (const char *dev)
3093 unsigned long int f;
3098 if (!dev || !dev[0]) return 0;
3102 struct dsc$descriptor_s dev_desc;
3103 unsigned long int status, lockid, item = DVI$_LOCKID;
3105 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3106 can try that first. */
3107 dev_desc.dsc$w_length = strlen (dev);
3108 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3109 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3110 dev_desc.dsc$a_pointer = (char *) dev;
3111 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3112 if (lockid) return (lockid & ~LOCKID_MASK);
3116 /* Otherwise we try to encode the device name */
3120 for (q = dev + strlen(dev); q--; q >= dev) {
3123 else if (isalpha (toupper (*q)))
3124 c= toupper (*q) - 'A' + (char)10;
3126 continue; /* Skip '$'s */
3128 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3130 enc += f * (unsigned long int) c;
3132 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3134 } /* end of encode_dev() */
3136 static char namecache[NAM$C_MAXRSS+1];
3139 is_null_device(name)
3142 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3143 The underscore prefix, controller letter, and unit number are
3144 independently optional; for our purposes, the colon punctuation
3145 is not. The colon can be trailed by optional directory and/or
3146 filename, but two consecutive colons indicates a nodename rather
3147 than a device. [pr] */
3148 if (*name == '_') ++name;
3149 if (tolower(*name++) != 'n') return 0;
3150 if (tolower(*name++) != 'l') return 0;
3151 if (tolower(*name) == 'a') ++name;
3152 if (*name == '0') ++name;
3153 return (*name++ == ':') && (*name != ':');
3156 /* Do the permissions allow some operation? Assumes statcache already set. */
3157 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3158 * subset of the applicable information.
3160 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3162 cando(I32 bit, I32 effective, struct stat *statbufp)
3164 if (statbufp == &statcache)
3165 return cando_by_name(bit,effective,namecache);
3167 char fname[NAM$C_MAXRSS+1];
3168 unsigned long int retsts;
3169 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3170 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3172 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3173 device name on successive calls */
3174 devdsc.dsc$a_pointer = statbufp->st_devnam;
3175 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3176 namdsc.dsc$a_pointer = fname;
3177 namdsc.dsc$w_length = sizeof fname - 1;
3179 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3180 &namdsc.dsc$w_length,0,0);
3182 fname[namdsc.dsc$w_length] = '\0';
3183 return cando_by_name(bit,effective,fname);
3185 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3186 warn("Can't get filespec - stale stat buffer?\n");
3190 return FALSE; /* Should never get to here */
3192 } /* end of cando() */
3196 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3198 cando_by_name(I32 bit, I32 effective, char *fname)
3200 static char usrname[L_cuserid];
3201 static struct dsc$descriptor_s usrdsc =
3202 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3203 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3204 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3205 unsigned short int retlen;
3206 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3207 union prvdef curprv;
3208 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3209 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3210 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3213 if (!fname || !*fname) return FALSE;
3214 /* Make sure we expand logical names, since sys$check_access doesn't */
3215 if (!strpbrk(fname,"/]>:")) {
3216 strcpy(fileified,fname);
3217 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3220 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3221 retlen = namdsc.dsc$w_length = strlen(vmsname);
3222 namdsc.dsc$a_pointer = vmsname;
3223 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3224 vmsname[retlen-1] == ':') {
3225 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3226 namdsc.dsc$w_length = strlen(fileified);
3227 namdsc.dsc$a_pointer = fileified;
3230 if (!usrdsc.dsc$w_length) {
3232 usrdsc.dsc$w_length = strlen(usrname);
3239 access = ARM$M_EXECUTE;
3244 access = ARM$M_READ;
3249 access = ARM$M_WRITE;
3254 access = ARM$M_DELETE;
3260 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3261 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3262 retsts == RMS$_FNF || retsts == RMS$_DIR ||
3263 retsts == RMS$_DEV) {
3264 set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts);
3267 if (retsts == SS$_NORMAL) {
3268 if (!privused) return TRUE;
3269 /* We can get access, but only by using privs. Do we have the
3270 necessary privs currently enabled? */
3271 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3272 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3273 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3274 !curprv.prv$v_bypass) return FALSE;
3275 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3276 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3277 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3282 return FALSE; /* Should never get here */
3284 } /* end of cando_by_name() */
3288 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3291 flex_fstat(int fd, struct mystat *statbufp)
3293 if (!fstat(fd,(stat_t *) statbufp)) {
3294 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3299 } /* end of flex_fstat() */
3302 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3303 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3304 * 'struct stat' elsewhere in Perl would use our struct. We go back
3305 * to the system version here, since we're actually calling their
3309 flex_stat(char *fspec, struct mystat *statbufp)
3311 char fileified[NAM$C_MAXRSS+1];
3312 int retval,myretval;
3313 struct mystat tmpbuf;
3316 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3317 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3318 memset(statbufp,0,sizeof *statbufp);
3319 statbufp->st_dev = encode_dev("_NLA0:");
3320 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3321 statbufp->st_uid = 0x00010001;
3322 statbufp->st_gid = 0x0001;
3323 time((time_t *)&statbufp->st_mtime);
3324 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3328 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3330 myretval = stat(fileified,(stat_t *) &tmpbuf);
3332 retval = stat(fspec,(stat_t *) statbufp);
3338 else if (!retval) { /* Dir with same name. Substitute it. */
3339 statbufp->st_mode &= ~S_IFDIR;
3340 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3341 strcpy(namecache,fileified);
3344 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3347 } /* end of flex_stat() */
3348 /* Reset definition for later calls */
3352 /* Insures that no carriage-control translation will be done on a file. */
3353 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3355 my_binmode(FILE *fp, char iotype)
3357 char filespec[NAM$C_MAXRSS], *acmode;
3360 if (!fgetname(fp,filespec)) return NULL;
3361 if (fgetpos(fp,&pos) == -1) return NULL;
3363 case '<': case 'r': acmode = "rb"; break;
3364 case '>': case 'w': acmode = "wb"; break;
3365 case '+': case '|': case 's': acmode = "rb+"; break;
3366 case 'a': acmode = "ab"; break;
3367 case '-': acmode = fileno(fp) ? "wb" : "rb"; break;
3369 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3370 if (fsetpos(fp,&pos) == -1) return NULL;
3371 } /* end of my_binmode() */
3375 /*{{{char *my_getlogin()*/
3376 /* VMS cuserid == Unix getlogin, except calling sequence */
3380 static char user[L_cuserid];
3381 return cuserid(user);
3386 /* rmscopy - copy a file using VMS RMS routines
3388 * Copies contents and attributes of spec_in to spec_out, except owner
3389 * and protection information. Name and type of spec_in are used as
3390 * defaults for spec_out. The third parameter specifies whether rmscopy()
3391 * should try to propagate timestamps from the input file to the output file.
3392 * If it is less than 0, no timestamps are preserved. If it is 0, then
3393 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3394 * propagated to the output file at creation iff the output file specification
3395 * did not contain an explicit name or type, and the revision date is always
3396 * updated at the end of the copy operation. If it is greater than 0, then
3397 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3398 * other than the revision date should be propagated, and bit 1 indicates
3399 * that the revision date should be propagated.
3401 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3403 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3404 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3405 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3406 * as part of the Perl standard distribution under the terms of the
3407 * GNU General Public License or the Perl Artistic License. Copies
3408 * of each may be found in the Perl standard distribution.
3410 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3412 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3414 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3415 rsa[NAM$C_MAXRSS], ubf[32256];
3416 unsigned long int i, sts, sts2;
3417 struct FAB fab_in, fab_out;
3418 struct RAB rab_in, rab_out;
3420 struct XABDAT xabdat;
3421 struct XABFHC xabfhc;
3422 struct XABRDT xabrdt;
3423 struct XABSUM xabsum;
3425 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3426 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3427 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3431 fab_in = cc$rms_fab;
3432 fab_in.fab$l_fna = vmsin;
3433 fab_in.fab$b_fns = strlen(vmsin);
3434 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3435 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3436 fab_in.fab$l_fop = FAB$M_SQO;
3437 fab_in.fab$l_nam = &nam;
3438 fab_in.fab$l_xab = (void *) &xabdat;
3441 nam.nam$l_rsa = rsa;
3442 nam.nam$b_rss = sizeof(rsa);
3443 nam.nam$l_esa = esa;
3444 nam.nam$b_ess = sizeof (esa);
3445 nam.nam$b_esl = nam.nam$b_rsl = 0;
3447 xabdat = cc$rms_xabdat; /* To get creation date */
3448 xabdat.xab$l_nxt = (void *) &xabfhc;
3450 xabfhc = cc$rms_xabfhc; /* To get record length */
3451 xabfhc.xab$l_nxt = (void *) &xabsum;
3453 xabsum = cc$rms_xabsum; /* To get key and area information */
3455 if (!((sts = sys$open(&fab_in)) & 1)) {
3456 set_vaxc_errno(sts);
3460 set_errno(ENOENT); break;
3462 set_errno(ENODEV); break;
3464 set_errno(EINVAL); break;
3466 set_errno(EACCES); break;
3474 fab_out.fab$w_ifi = 0;
3475 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3476 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3477 fab_out.fab$l_fop = FAB$M_SQO;
3478 fab_out.fab$l_fna = vmsout;
3479 fab_out.fab$b_fns = strlen(vmsout);
3480 fab_out.fab$l_dna = nam.nam$l_name;
3481 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3483 if (preserve_dates == 0) { /* Act like DCL COPY */
3484 nam.nam$b_nop = NAM$M_SYNCHK;
3485 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3486 if (!((sts = sys$parse(&fab_out)) & 1)) {
3487 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3488 set_vaxc_errno(sts);
3491 fab_out.fab$l_xab = (void *) &xabdat;
3492 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3494 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3495 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3496 preserve_dates =0; /* bitmask from this point forward */
3498 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3499 if (!((sts = sys$create(&fab_out)) & 1)) {
3500 set_vaxc_errno(sts);
3503 set_errno(ENOENT); break;
3505 set_errno(ENODEV); break;
3507 set_errno(EINVAL); break;
3509 set_errno(EACCES); break;
3515 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3516 if (preserve_dates & 2) {
3517 /* sys$close() will process xabrdt, not xabdat */
3518 xabrdt = cc$rms_xabrdt;
3520 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3522 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3523 * is unsigned long[2], while DECC & VAXC use a struct */
3524 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3526 fab_out.fab$l_xab = (void *) &xabrdt;
3529 rab_in = cc$rms_rab;
3530 rab_in.rab$l_fab = &fab_in;
3531 rab_in.rab$l_rop = RAB$M_BIO;
3532 rab_in.rab$l_ubf = ubf;
3533 rab_in.rab$w_usz = sizeof ubf;
3534 if (!((sts = sys$connect(&rab_in)) & 1)) {
3535 sys$close(&fab_in); sys$close(&fab_out);
3536 set_errno(EVMSERR); set_vaxc_errno(sts);
3540 rab_out = cc$rms_rab;
3541 rab_out.rab$l_fab = &fab_out;
3542 rab_out.rab$l_rbf = ubf;
3543 if (!((sts = sys$connect(&rab_out)) & 1)) {
3544 sys$close(&fab_in); sys$close(&fab_out);
3545 set_errno(EVMSERR); set_vaxc_errno(sts);
3549 while ((sts = sys$read(&rab_in))) { /* always true */
3550 if (sts == RMS$_EOF) break;
3551 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3552 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3553 sys$close(&fab_in); sys$close(&fab_out);
3554 set_errno(EVMSERR); set_vaxc_errno(sts);
3559 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3560 sys$close(&fab_in); sys$close(&fab_out);
3561 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3563 set_errno(EVMSERR); set_vaxc_errno(sts);
3569 } /* end of rmscopy() */
3573 /*** The following glue provides 'hooks' to make some of the routines
3574 * from this file available from Perl. These routines are sufficiently
3575 * basic, and are required sufficiently early in the build process,
3576 * that's it's nice to have them available to miniperl as well as the
3577 * full Perl, so they're set up here instead of in an extension. The
3578 * Perl code which handles importation of these names into a given
3579 * package lives in [.VMS]Filespec.pm in @INC.
3583 rmsexpand_fromperl(CV *cv)
3586 char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
3587 struct FAB myfab = cc$rms_fab;
3588 struct NAM mynam = cc$rms_nam;
3590 unsigned long int retsts, haslower = 0;
3592 if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3594 myfab.fab$l_fna = SvPV(ST(0),speclen);
3595 myfab.fab$b_fns = speclen;
3596 myfab.fab$l_nam = &mynam;
3599 myfab.fab$l_dna = SvPV(ST(1),speclen);
3600 myfab.fab$b_dns = speclen;
3603 mynam.nam$l_esa = esa;
3604 mynam.nam$b_ess = sizeof esa;
3605 mynam.nam$l_rsa = rsa;
3606 mynam.nam$b_rss = sizeof rsa;
3608 retsts = sys$parse(&myfab,0,0);
3609 if (!(retsts & 1)) {
3610 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
3611 retsts == RMS$_DEV || retsts == RMS$_DEV) {
3612 mynam.nam$b_nop |= NAM$M_SYNCHK;
3613 retsts = sys$parse(&myfab,0,0);
3614 if (retsts & 1) goto expanded;
3616 set_vaxc_errno(retsts);
3617 if (retsts == RMS$_PRV) set_errno(EACCES);
3618 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3619 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3620 else set_errno(EVMSERR);
3623 retsts = sys$search(&myfab,0,0);
3624 if (!(retsts & 1) && retsts != RMS$_FNF) {
3625 set_vaxc_errno(retsts);
3626 if (retsts == RMS$_PRV) set_errno(EACCES);
3627 else set_errno(EVMSERR);
3631 /* If the input filespec contained any lowercase characters,
3632 * downcase the result for compatibility with Unix-minded code. */
3634 for (out = myfab.fab$l_fna; *out; out++)
3635 if (islower(*out)) { haslower = 1; break; }
3636 if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
3637 else { out = esa; speclen = mynam.nam$b_esl; }
3638 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
3639 (items == 1 || !strchr(myfab.fab$l_dna,';')))
3640 speclen = mynam.nam$l_ver - out;
3641 /* If we just had a directory spec on input, $PARSE "helpfully"
3642 * adds an empty name and type for us */
3643 if (mynam.nam$l_name == mynam.nam$l_type &&
3644 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
3645 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
3646 speclen = mynam.nam$l_name - out;
3647 out[speclen] = '\0';
3648 if (haslower) __mystrtolower(out);
3650 ST(0) = sv_2mortal(newSVpv(out, speclen));
3655 vmsify_fromperl(CV *cv)
3660 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3661 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3662 ST(0) = sv_newmortal();
3663 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3668 unixify_fromperl(CV *cv)
3673 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3674 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3675 ST(0) = sv_newmortal();
3676 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3681 fileify_fromperl(CV *cv)
3686 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3687 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3688 ST(0) = sv_newmortal();
3689 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3694 pathify_fromperl(CV *cv)
3699 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3700 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3701 ST(0) = sv_newmortal();
3702 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3707 vmspath_fromperl(CV *cv)
3712 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3713 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3714 ST(0) = sv_newmortal();
3715 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3720 unixpath_fromperl(CV *cv)
3725 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3726 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3727 ST(0) = sv_newmortal();
3728 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3733 candelete_fromperl(CV *cv)
3736 char fspec[NAM$C_MAXRSS+1], *fsp;
3740 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3742 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3743 if (SvTYPE(mysv) == SVt_PVGV) {
3744 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3745 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3752 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3753 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3759 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3764 rmscopy_fromperl(CV *cv)
3767 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3769 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3770 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3771 unsigned long int sts;
3775 if (items < 2 || items > 3)
3776 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3778 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3779 if (SvTYPE(mysv) == SVt_PVGV) {
3780 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3781 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3788 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3789 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3794 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3795 if (SvTYPE(mysv) == SVt_PVGV) {
3796 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3797 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3804 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3805 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3810 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3812 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3819 char* file = __FILE__;
3821 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
3822 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3823 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3824 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3825 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3826 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3827 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3828 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3829 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);