3 * VMS-specific routines for perl5
5 * Last revised: 14-Oct-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+1], *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_rmsexpand(char *, char *, int, char *, unsigned);
326 static char *do_fileify_dirspec(char *, char *, int);
327 static char *do_tovmsspec(char *, char *, int);
329 /*{{{int do_rmdir(char *name)*/
333 char dirfile[NAM$C_MAXRSS+1];
337 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
338 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
339 else retval = kill_file(dirfile);
342 } /* end of do_rmdir */
346 * Delete any file to which user has control access, regardless of whether
347 * delete access is explicitly allowed.
348 * Limitations: User must have write access to parent directory.
349 * Does not block signals or ASTs; if interrupted in midstream
350 * may leave file with an altered ACL.
353 /*{{{int kill_file(char *name)*/
355 kill_file(char *name)
357 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
358 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
359 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
360 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
362 unsigned char myace$b_length;
363 unsigned char myace$b_type;
364 unsigned short int myace$w_flags;
365 unsigned long int myace$l_access;
366 unsigned long int myace$l_ident;
367 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
368 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
369 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
371 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
372 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
373 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
374 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
375 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
376 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
378 /* Expand the input spec using RMS, since the CRTL remove() and
379 * system services won't do this by themselves, so we may miss
380 * a file "hiding" behind a logical name or search list. */
381 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
382 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
383 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
384 /* If not, can changing protections help? */
385 if (vaxc$errno != RMS$_PRV) return -1;
387 /* No, so we get our own UIC to use as a rights identifier,
388 * and the insert an ACE at the head of the ACL which allows us
389 * to delete the file.
391 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
392 fildsc.dsc$w_length = strlen(rspec);
393 fildsc.dsc$a_pointer = rspec;
395 newace.myace$l_ident = oldace.myace$l_ident;
396 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
401 case SS$_NOSUCHOBJECT:
402 set_errno(ENOENT); break;
404 set_errno(ENODEV); break;
406 case SS$_INVFILFOROP:
407 set_errno(EINVAL); break;
409 set_errno(EACCES); break;
413 set_vaxc_errno(aclsts);
416 /* Grab any existing ACEs with this identifier in case we fail */
417 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
418 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
419 || fndsts == SS$_NOMOREACE ) {
420 /* Add the new ACE . . . */
421 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
423 if ((rmsts = remove(name))) {
424 /* We blew it - dir with files in it, no write priv for
425 * parent directory, etc. Put things back the way they were. */
426 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
429 addlst[0].bufadr = &oldace;
430 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
437 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
438 /* We just deleted it, so of course it's not there. Some versions of
439 * VMS seem to return success on the unlock operation anyhow (after all
440 * the unlock is successful), but others don't.
442 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
443 if (aclsts & 1) aclsts = fndsts;
446 set_vaxc_errno(aclsts);
452 } /* end of kill_file() */
455 /* my_utime - update modification time of a file
456 * calling sequence is identical to POSIX utime(), but under
457 * VMS only the modification time is changed; ODS-2 does not
458 * maintain access times. Restrictions differ from the POSIX
459 * definition in that the time can be changed as long as the
460 * caller has permission to execute the necessary IO$_MODIFY $QIO;
461 * no separate checks are made to insure that the caller is the
462 * owner of the file or has special privs enabled.
463 * Code here is based on Joe Meadows' FILE utility.
466 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
467 * to VMS epoch (01-JAN-1858 00:00:00.00)
468 * in 100 ns intervals.
470 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
472 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
473 int my_utime(char *file, struct utimbuf *utimes)
476 long int bintime[2], len = 2, lowbit, unixtime,
477 secscale = 10000000; /* seconds --> 100 ns intervals */
478 unsigned long int chan, iosb[2], retsts;
479 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
480 struct FAB myfab = cc$rms_fab;
481 struct NAM mynam = cc$rms_nam;
482 #if defined (__DECC) && defined (__VAX)
483 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
484 * at least through VMS V6.1, which causes a type-conversion warning.
486 # pragma message save
487 # pragma message disable cvtdiftypes
489 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
491 #if defined (__DECC) && defined (__VAX)
492 /* This should be right after the declaration of myatr, but due
493 * to a bug in VAX DEC C, this takes effect a statement early.
495 # pragma message restore
497 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
498 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
499 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
501 if (file == NULL || *file == '\0') {
503 set_vaxc_errno(LIB$_INVARG);
506 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
508 if (utimes != NULL) {
509 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
510 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
511 * Since time_t is unsigned long int, and lib$emul takes a signed long int
512 * as input, we force the sign bit to be clear by shifting unixtime right
513 * one bit, then multiplying by an extra factor of 2 in lib$emul().
515 lowbit = (utimes->modtime & 1) ? secscale : 0;
516 unixtime = (long int) utimes->modtime;
517 unixtime >> 1; secscale << 1;
518 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
521 set_vaxc_errno(retsts);
524 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
527 set_vaxc_errno(retsts);
532 /* Just get the current time in VMS format directly */
533 retsts = sys$gettim(bintime);
536 set_vaxc_errno(retsts);
541 myfab.fab$l_fna = vmsspec;
542 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
543 myfab.fab$l_nam = &mynam;
544 mynam.nam$l_esa = esa;
545 mynam.nam$b_ess = (unsigned char) sizeof esa;
546 mynam.nam$l_rsa = rsa;
547 mynam.nam$b_rss = (unsigned char) sizeof rsa;
549 /* Look for the file to be affected, letting RMS parse the file
550 * specification for us as well. I have set errno using only
551 * values documented in the utime() man page for VMS POSIX.
553 retsts = sys$parse(&myfab,0,0);
555 set_vaxc_errno(retsts);
556 if (retsts == RMS$_PRV) set_errno(EACCES);
557 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
558 else set_errno(EVMSERR);
561 retsts = sys$search(&myfab,0,0);
563 set_vaxc_errno(retsts);
564 if (retsts == RMS$_PRV) set_errno(EACCES);
565 else if (retsts == RMS$_FNF) set_errno(ENOENT);
566 else set_errno(EVMSERR);
570 devdsc.dsc$w_length = mynam.nam$b_dev;
571 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
573 retsts = sys$assign(&devdsc,&chan,0,0);
575 set_vaxc_errno(retsts);
576 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
577 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
578 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
579 else set_errno(EVMSERR);
583 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
584 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
586 memset((void *) &myfib, 0, sizeof myfib);
588 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
589 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
590 /* This prevents the revision time of the file being reset to the current
591 * time as a result of our IO$_MODIFY $QIO. */
592 myfib.fib$l_acctl = FIB$M_NORECORD;
594 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
595 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
596 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
598 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
599 _ckvmssts(sys$dassgn(chan));
600 if (retsts & 1) retsts = iosb[0];
602 set_vaxc_errno(retsts);
603 if (retsts == SS$_NOPRIV) set_errno(EACCES);
604 else set_errno(EVMSERR);
609 } /* end of my_utime() */
613 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
615 static unsigned long int mbxbufsiz;
616 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
620 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
621 * preprocessor consant BUFSIZ from stdio.h as the size of the
624 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
625 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
627 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
629 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
630 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
632 } /* end of create_mbx() */
634 /*{{{ my_popen and my_pclose*/
637 struct pipe_details *next;
638 PerlIO *fp; /* stdio file pointer to pipe mailbox */
639 int pid; /* PID of subprocess */
640 int mode; /* == 'r' if pipe open for reading */
641 int done; /* subprocess has completed */
642 unsigned long int completion; /* termination status of subprocess */
645 struct exit_control_block
647 struct exit_control_block *flink;
648 unsigned long int (*exit_routine)();
649 unsigned long int arg_count;
650 unsigned long int *status_address;
651 unsigned long int exit_status;
654 static struct pipe_details *open_pipes = NULL;
655 static $DESCRIPTOR(nl_desc, "NL:");
656 static int waitpid_asleep = 0;
658 static unsigned long int
661 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
663 while (open_pipes != NULL) {
664 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
665 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
668 if (!open_pipes->done) /* We tried to be nice . . . */
669 _ckvmssts(sys$delprc(&open_pipes->pid,0));
670 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
675 static struct exit_control_block pipe_exitblock =
676 {(struct exit_control_block *) 0,
677 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
681 popen_completion_ast(struct pipe_details *thispipe)
683 thispipe->done = TRUE;
684 if (waitpid_asleep) {
690 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
692 my_popen(char *cmd, char *mode)
694 static int handler_set_up = FALSE;
696 unsigned short int chan;
697 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
698 struct pipe_details *info;
699 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
700 DSC$K_CLASS_S, mbxname},
701 cmddsc = {0, DSC$K_DTYPE_T,
705 cmddsc.dsc$w_length=strlen(cmd);
706 cmddsc.dsc$a_pointer=cmd;
707 if (cmddsc.dsc$w_length > 255) {
708 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
712 New(7001,info,1,struct pipe_details);
715 create_mbx(&chan,&namdsc);
717 /* open a FILE* onto it */
718 info->fp = PerlIO_open(mbxname, mode);
720 /* give up other channel onto it */
721 _ckvmssts(sys$dassgn(chan));
731 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
732 0 /* name */, &info->pid, &info->completion,
733 0, popen_completion_ast,info,0,0,0));
736 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
737 0 /* name */, &info->pid, &info->completion,
738 0, popen_completion_ast,info,0,0,0));
741 if (!handler_set_up) {
742 _ckvmssts(sys$dclexh(&pipe_exitblock));
743 handler_set_up = TRUE;
745 info->next=open_pipes; /* prepend to list */
748 forkprocess = info->pid;
753 /*{{{ I32 my_pclose(FILE *fp)*/
754 I32 my_pclose(FILE *fp)
756 struct pipe_details *info, *last = NULL;
757 unsigned long int retsts;
759 for (info = open_pipes; info != NULL; last = info, info = info->next)
760 if (info->fp == fp) break;
763 /* get here => no such pipe open */
764 croak("No such pipe open");
766 /* If we were writing to a subprocess, insure that someone reading from
767 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
768 * produce an EOF record in the mailbox. */
769 if (info->mode != 'r') {
770 char devnam[NAM$C_MAXRSS+1], *cp;
771 unsigned long int chan, iosb[2], retsts, retsts2;
772 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
774 if (fgetname(info->fp,devnam)) {
775 /* It oughta be a mailbox, so fgetname should give just the device
776 * name, but just in case . . . */
777 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
778 devdsc.dsc$w_length = strlen(devnam);
779 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
780 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
781 if (retsts & 1) retsts = iosb[0];
782 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
783 if (retsts & 1) retsts = retsts2;
786 else _ckvmssts(vaxc$errno); /* Should never happen */
788 PerlIO_close(info->fp);
790 if (info->done) retsts = info->completion;
791 else waitpid(info->pid,(int *) &retsts,0);
793 /* remove from list of open pipes */
794 if (last) last->next = info->next;
795 else open_pipes = info->next;
800 } /* end of my_pclose() */
802 /* sort-of waitpid; use only with popen() */
803 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
805 waitpid(unsigned long int pid, int *statusp, int flags)
807 struct pipe_details *info;
809 for (info = open_pipes; info != NULL; info = info->next)
810 if (info->pid == pid) break;
812 if (info != NULL) { /* we know about this child */
813 while (!info->done) {
818 *statusp = info->completion;
821 else { /* we haven't heard of this child */
822 $DESCRIPTOR(intdsc,"0 00:00:01");
823 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
824 unsigned long int interval[2],sts;
827 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
828 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
829 if (ownerpid != mypid)
830 warn("pid %d not a child",pid);
833 _ckvmssts(sys$bintim(&intdsc,interval));
834 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
835 _ckvmssts(sys$schdwk(0,0,interval,0));
836 _ckvmssts(sys$hiber());
840 /* There's no easy way to find the termination status a child we're
841 * not aware of beforehand. If we're really interested in the future,
842 * we can go looking for a termination mailbox, or chase after the
843 * accounting record for the process.
849 } /* end of waitpid() */
854 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
856 my_gconvert(double val, int ndig, int trail, char *buf)
858 static char __gcvtbuf[DBL_DIG+1];
861 loc = buf ? buf : __gcvtbuf;
863 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
864 return gcvt(val,ndig,loc);
867 loc[0] = '0'; loc[1] = '\0';
875 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
876 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
877 * to expand file specification. Allows for a single default file
878 * specification and a simple mask of options. If outbuf is non-NULL,
879 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
880 * the resultant file specification is placed. If outbuf is NULL, the
881 * resultant file specification is placed into a static buffer.
882 * The third argument, if non-NULL, is taken to be a default file
883 * specification string. The fourth argument is unused at present.
884 * rmesexpand() returns the address of the resultant string if
885 * successful, and NULL on error.
888 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
890 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
891 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
892 struct FAB myfab = cc$rms_fab;
893 struct NAM mynam = cc$rms_nam;
895 unsigned long int retsts, haslower = 0;
897 if (!filespec || !*filespec) {
898 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
902 if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
903 else outbuf = __rmsexpand_retbuf;
906 myfab.fab$l_fna = filespec;
907 myfab.fab$b_fns = strlen(filespec);
908 myfab.fab$l_nam = &mynam;
910 if (defspec && *defspec) {
911 myfab.fab$l_dna = defspec;
912 myfab.fab$b_dns = strlen(defspec);
915 mynam.nam$l_esa = esa;
916 mynam.nam$b_ess = sizeof esa;
917 mynam.nam$l_rsa = outbuf;
918 mynam.nam$b_rss = NAM$C_MAXRSS;
920 retsts = sys$parse(&myfab,0,0);
922 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
923 retsts == RMS$_DEV || retsts == RMS$_DEV) {
924 mynam.nam$b_nop |= NAM$M_SYNCHK;
925 retsts = sys$parse(&myfab,0,0);
926 if (retsts & 1) goto expanded;
928 if (out) Safefree(out);
929 set_vaxc_errno(retsts);
930 if (retsts == RMS$_PRV) set_errno(EACCES);
931 else if (retsts == RMS$_DEV) set_errno(ENODEV);
932 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
933 else set_errno(EVMSERR);
936 retsts = sys$search(&myfab,0,0);
937 if (!(retsts & 1) && retsts != RMS$_FNF) {
938 if (out) Safefree(out);
939 set_vaxc_errno(retsts);
940 if (retsts == RMS$_PRV) set_errno(EACCES);
941 else set_errno(EVMSERR);
945 /* If the input filespec contained any lowercase characters,
946 * downcase the result for compatibility with Unix-minded code. */
948 for (out = myfab.fab$l_fna; *out; out++)
949 if (islower(*out)) { haslower = 1; break; }
950 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
951 else { out = esa; speclen = mynam.nam$b_esl; }
952 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
953 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
954 speclen = mynam.nam$l_ver - out;
955 /* If we just had a directory spec on input, $PARSE "helpfully"
956 * adds an empty name and type for us */
957 if (mynam.nam$l_name == mynam.nam$l_type &&
958 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
959 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
960 speclen = mynam.nam$l_name - out;
962 if (haslower) __mystrtolower(out);
964 /* Have we been working with an expanded, but not resultant, spec? */
965 if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
969 /* External entry points */
970 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
971 { return do_rmsexpand(spec,buf,0,def,opt); }
972 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
973 { return do_rmsexpand(spec,buf,1,def,opt); }
977 ** The following routines are provided to make life easier when
978 ** converting among VMS-style and Unix-style directory specifications.
979 ** All will take input specifications in either VMS or Unix syntax. On
980 ** failure, all return NULL. If successful, the routines listed below
981 ** return a pointer to a buffer containing the appropriately
982 ** reformatted spec (and, therefore, subsequent calls to that routine
983 ** will clobber the result), while the routines of the same names with
984 ** a _ts suffix appended will return a pointer to a mallocd string
985 ** containing the appropriately reformatted spec.
986 ** In all cases, only explicit syntax is altered; no check is made that
987 ** the resulting string is valid or that the directory in question
990 ** fileify_dirspec() - convert a directory spec into the name of the
991 ** directory file (i.e. what you can stat() to see if it's a dir).
992 ** The style (VMS or Unix) of the result is the same as the style
993 ** of the parameter passed in.
994 ** pathify_dirspec() - convert a directory spec into a path (i.e.
995 ** what you prepend to a filename to indicate what directory it's in).
996 ** The style (VMS or Unix) of the result is the same as the style
997 ** of the parameter passed in.
998 ** tounixpath() - convert a directory spec into a Unix-style path.
999 ** tovmspath() - convert a directory spec into a VMS-style path.
1000 ** tounixspec() - convert any file spec into a Unix-style file spec.
1001 ** tovmsspec() - convert any file spec into a VMS-style spec.
1003 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
1004 ** Permission is given to distribute this code as part of the Perl
1005 ** standard distribution under the terms of the GNU General Public
1006 ** License or the Perl Artistic License. Copies of each may be
1007 ** found in the Perl standard distribution.
1010 static char *do_tounixspec(char *, char *, int);
1012 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1013 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1015 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1016 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1017 char *retspec, *cp1, *cp2, *lastdir;
1018 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
1020 if (!dir || !*dir) {
1021 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1023 dirlen = strlen(dir);
1024 if (dir[dirlen-1] == '/') --dirlen;
1027 set_vaxc_errno(RMS$_DIR);
1030 if (!strpbrk(dir+1,"/]>:")) {
1031 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1032 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1034 dirlen = strlen(dir);
1037 strncpy(trndir,dir,dirlen);
1038 trndir[dirlen] = '\0';
1041 /* If we were handed a rooted logical name or spec, treat it like a
1042 * simple directory, so that
1043 * $ Define myroot dev:[dir.]
1044 * ... do_fileify_dirspec("myroot",buf,1) ...
1045 * does something useful.
1047 if (!strcmp(dir+dirlen-2,".]")) {
1048 dir[--dirlen] = '\0';
1049 dir[dirlen-1] = ']';
1052 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1053 /* If we've got an explicit filename, we can just shuffle the string. */
1054 if (*(cp1+1)) hasfilename = 1;
1055 /* Similarly, we can just back up a level if we've got multiple levels
1056 of explicit directories in a VMS spec which ends with directories. */
1058 for (cp2 = cp1; cp2 > dir; cp2--) {
1060 *cp2 = *cp1; *cp1 = '\0';
1064 if (*cp2 == '[' || *cp2 == '<') break;
1069 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1070 if (dir[0] == '.') {
1071 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1072 return do_fileify_dirspec("[]",buf,ts);
1073 else if (dir[1] == '.' &&
1074 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1075 return do_fileify_dirspec("[-]",buf,ts);
1077 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1078 dirlen -= 1; /* to last element */
1079 lastdir = strrchr(dir,'/');
1081 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1082 /* If we have "/." or "/..", VMSify it and let the VMS code
1083 * below expand it, rather than repeating the code to handle
1084 * relative components of a filespec here */
1086 if (*(cp1+2) == '.') cp1++;
1087 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1088 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1089 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1090 return do_tounixspec(trndir,buf,ts);
1093 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1096 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1097 !(lastdir = cp1 = strrchr(dir,']')) &&
1098 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1099 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1101 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1102 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1103 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1104 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1105 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1106 (ver || *cp3)))))) {
1108 set_vaxc_errno(RMS$_DIR);
1114 /* If we lead off with a device or rooted logical, add the MFD
1115 if we're specifying a top-level directory. */
1116 if (lastdir && *dir == '/') {
1118 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1125 retlen = dirlen + (addmfd ? 13 : 6);
1126 if (buf) retspec = buf;
1127 else if (ts) New(7009,retspec,retlen+1,char);
1128 else retspec = __fileify_retbuf;
1130 dirlen = lastdir - dir;
1131 memcpy(retspec,dir,dirlen);
1132 strcpy(&retspec[dirlen],"/000000");
1133 strcpy(&retspec[dirlen+7],lastdir);
1136 memcpy(retspec,dir,dirlen);
1137 retspec[dirlen] = '\0';
1139 /* We've picked up everything up to the directory file name.
1140 Now just add the type and version, and we're set. */
1141 strcat(retspec,".dir;1");
1144 else { /* VMS-style directory spec */
1145 char esa[NAM$C_MAXRSS+1], term, *cp;
1146 unsigned long int sts, cmplen, haslower = 0;
1147 struct FAB dirfab = cc$rms_fab;
1148 struct NAM savnam, dirnam = cc$rms_nam;
1150 dirfab.fab$b_fns = strlen(dir);
1151 dirfab.fab$l_fna = dir;
1152 dirfab.fab$l_nam = &dirnam;
1153 dirfab.fab$l_dna = ".DIR;1";
1154 dirfab.fab$b_dns = 6;
1155 dirnam.nam$b_ess = NAM$C_MAXRSS;
1156 dirnam.nam$l_esa = esa;
1158 for (cp = dir; *cp; cp++)
1159 if (islower(*cp)) { haslower = 1; break; }
1160 if (!((sts = sys$parse(&dirfab))&1)) {
1161 if (dirfab.fab$l_sts == RMS$_DIR) {
1162 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1163 sts = sys$parse(&dirfab) & 1;
1167 set_vaxc_errno(dirfab.fab$l_sts);
1173 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1174 /* Yes; fake the fnb bits so we'll check type below */
1175 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1178 if (dirfab.fab$l_sts != RMS$_FNF) {
1180 set_vaxc_errno(dirfab.fab$l_sts);
1183 dirnam = savnam; /* No; just work with potential name */
1186 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1187 cp1 = strchr(esa,']');
1188 if (!cp1) cp1 = strchr(esa,'>');
1189 if (cp1) { /* Should always be true */
1190 dirnam.nam$b_esl -= cp1 - esa - 1;
1191 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1194 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1195 /* Yep; check version while we're at it, if it's there. */
1196 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1197 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1198 /* Something other than .DIR[;1]. Bzzt. */
1200 set_vaxc_errno(RMS$_DIR);
1204 esa[dirnam.nam$b_esl] = '\0';
1205 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1206 /* They provided at least the name; we added the type, if necessary, */
1207 if (buf) retspec = buf; /* in sys$parse() */
1208 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1209 else retspec = __fileify_retbuf;
1210 strcpy(retspec,esa);
1213 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1214 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1216 dirnam.nam$b_esl -= 9;
1218 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1219 if (cp1 == NULL) return NULL; /* should never happen */
1222 retlen = strlen(esa);
1223 if ((cp1 = strrchr(esa,'.')) != NULL) {
1224 /* There's more than one directory in the path. Just roll back. */
1226 if (buf) retspec = buf;
1227 else if (ts) New(7011,retspec,retlen+7,char);
1228 else retspec = __fileify_retbuf;
1229 strcpy(retspec,esa);
1232 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1233 /* Go back and expand rooted logical name */
1234 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1235 if (!(sys$parse(&dirfab) & 1)) {
1237 set_vaxc_errno(dirfab.fab$l_sts);
1240 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1241 if (buf) retspec = buf;
1242 else if (ts) New(7012,retspec,retlen+16,char);
1243 else retspec = __fileify_retbuf;
1244 cp1 = strstr(esa,"][");
1246 memcpy(retspec,esa,dirlen);
1247 if (!strncmp(cp1+2,"000000]",7)) {
1248 retspec[dirlen-1] = '\0';
1249 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1250 if (*cp1 == '.') *cp1 = ']';
1252 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1253 memcpy(cp1+1,"000000]",7);
1257 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1258 retspec[retlen] = '\0';
1259 /* Convert last '.' to ']' */
1260 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1261 if (*cp1 == '.') *cp1 = ']';
1263 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1264 memcpy(cp1+1,"000000]",7);
1268 else { /* This is a top-level dir. Add the MFD to the path. */
1269 if (buf) retspec = buf;
1270 else if (ts) New(7012,retspec,retlen+16,char);
1271 else retspec = __fileify_retbuf;
1274 while (*cp1 != ':') *(cp2++) = *(cp1++);
1275 strcpy(cp2,":[000000]");
1280 /* We've set up the string up through the filename. Add the
1281 type and version, and we're done. */
1282 strcat(retspec,".DIR;1");
1284 /* $PARSE may have upcased filespec, so convert output to lower
1285 * case if input contained any lowercase characters. */
1286 if (haslower) __mystrtolower(retspec);
1289 } /* end of do_fileify_dirspec() */
1291 /* External entry points */
1292 char *fileify_dirspec(char *dir, char *buf)
1293 { return do_fileify_dirspec(dir,buf,0); }
1294 char *fileify_dirspec_ts(char *dir, char *buf)
1295 { return do_fileify_dirspec(dir,buf,1); }
1297 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1298 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1300 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1301 unsigned long int retlen;
1302 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1304 if (!dir || !*dir) {
1305 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1308 if (*dir) strcpy(trndir,dir);
1309 else getcwd(trndir,sizeof trndir - 1);
1311 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1312 STRLEN trnlen = strlen(trndir);
1314 /* Trap simple rooted lnms, and return lnm:[000000] */
1315 if (!strcmp(trndir+trnlen-2,".]")) {
1316 if (buf) retpath = buf;
1317 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1318 else retpath = __pathify_retbuf;
1319 strcpy(retpath,dir);
1320 strcat(retpath,":[000000]");
1326 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1327 if (*dir == '.' && (*(dir+1) == '\0' ||
1328 (*(dir+1) == '.' && *(dir+2) == '\0')))
1329 retlen = 2 + (*(dir+1) != '\0');
1331 if ( !(cp1 = strrchr(dir,'/')) &&
1332 !(cp1 = strrchr(dir,']')) &&
1333 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1334 if ((cp2 = strchr(cp1,'.')) != NULL) {
1336 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1337 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1338 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1339 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1340 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1341 (ver || *cp3)))))) {
1343 set_vaxc_errno(RMS$_DIR);
1346 retlen = cp2 - dir + 1;
1348 else { /* No file type present. Treat the filename as a directory. */
1349 retlen = strlen(dir) + 1;
1352 if (buf) retpath = buf;
1353 else if (ts) New(7013,retpath,retlen+1,char);
1354 else retpath = __pathify_retbuf;
1355 strncpy(retpath,dir,retlen-1);
1356 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1357 retpath[retlen-1] = '/'; /* with '/', add it. */
1358 retpath[retlen] = '\0';
1360 else retpath[retlen-1] = '\0';
1362 else { /* VMS-style directory spec */
1363 char esa[NAM$C_MAXRSS+1], *cp;
1364 unsigned long int sts, cmplen, haslower;
1365 struct FAB dirfab = cc$rms_fab;
1366 struct NAM savnam, dirnam = cc$rms_nam;
1368 /* If we've got an explicit filename, we can just shuffle the string. */
1369 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1370 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1371 if ((cp2 = strchr(cp1,'.')) != NULL) {
1373 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1374 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1375 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1376 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1377 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1378 (ver || *cp3)))))) {
1380 set_vaxc_errno(RMS$_DIR);
1384 else { /* No file type, so just draw name into directory part */
1385 for (cp2 = cp1; *cp2; cp2++) ;
1388 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1390 /* We've now got a VMS 'path'; fall through */
1392 dirfab.fab$b_fns = strlen(dir);
1393 dirfab.fab$l_fna = dir;
1394 if (dir[dirfab.fab$b_fns-1] == ']' ||
1395 dir[dirfab.fab$b_fns-1] == '>' ||
1396 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1397 if (buf) retpath = buf;
1398 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1399 else retpath = __pathify_retbuf;
1400 strcpy(retpath,dir);
1403 dirfab.fab$l_dna = ".DIR;1";
1404 dirfab.fab$b_dns = 6;
1405 dirfab.fab$l_nam = &dirnam;
1406 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1407 dirnam.nam$l_esa = esa;
1409 for (cp = dir; *cp; cp++)
1410 if (islower(*cp)) { haslower = 1; break; }
1412 if (!(sts = (sys$parse(&dirfab)&1))) {
1413 if (dirfab.fab$l_sts == RMS$_DIR) {
1414 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1415 sts = sys$parse(&dirfab) & 1;
1419 set_vaxc_errno(dirfab.fab$l_sts);
1425 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1426 if (dirfab.fab$l_sts != RMS$_FNF) {
1428 set_vaxc_errno(dirfab.fab$l_sts);
1431 dirnam = savnam; /* No; just work with potential name */
1434 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1435 /* Yep; check version while we're at it, if it's there. */
1436 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1437 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1438 /* Something other than .DIR[;1]. Bzzt. */
1440 set_vaxc_errno(RMS$_DIR);
1444 /* OK, the type was fine. Now pull any file name into the
1446 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1448 cp1 = strrchr(esa,'>');
1449 *dirnam.nam$l_type = '>';
1452 *(dirnam.nam$l_type + 1) = '\0';
1453 retlen = dirnam.nam$l_type - esa + 2;
1454 if (buf) retpath = buf;
1455 else if (ts) New(7014,retpath,retlen,char);
1456 else retpath = __pathify_retbuf;
1457 strcpy(retpath,esa);
1458 /* $PARSE may have upcased filespec, so convert output to lower
1459 * case if input contained any lowercase characters. */
1460 if (haslower) __mystrtolower(retpath);
1464 } /* end of do_pathify_dirspec() */
1466 /* External entry points */
1467 char *pathify_dirspec(char *dir, char *buf)
1468 { return do_pathify_dirspec(dir,buf,0); }
1469 char *pathify_dirspec_ts(char *dir, char *buf)
1470 { return do_pathify_dirspec(dir,buf,1); }
1472 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1473 static char *do_tounixspec(char *spec, char *buf, int ts)
1475 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1476 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1477 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1479 if (spec == NULL) return NULL;
1480 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1481 if (buf) rslt = buf;
1483 retlen = strlen(spec);
1484 cp1 = strchr(spec,'[');
1485 if (!cp1) cp1 = strchr(spec,'<');
1487 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1489 New(7015,rslt,retlen+2+2*dashes,char);
1491 else rslt = __tounixspec_retbuf;
1492 if (strchr(spec,'/') != NULL) {
1499 dirend = strrchr(spec,']');
1500 if (dirend == NULL) dirend = strrchr(spec,'>');
1501 if (dirend == NULL) dirend = strchr(spec,':');
1502 if (dirend == NULL) {
1506 if (*cp2 != '[' && *cp2 != '<') {
1509 else { /* the VMS spec begins with directories */
1511 if (*cp2 == ']' || *cp2 == '>') {
1515 else if ( *cp2 != '.' && *cp2 != '-') {
1516 *(cp1++) = '/'; /* add the implied device into the Unix spec */
1517 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1518 if (ts) Safefree(rslt);
1523 while (*cp3 != ':' && *cp3) cp3++;
1525 if (strchr(cp3,']') != NULL) break;
1526 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1528 while (*cp3) *(cp1++) = *(cp3++);
1531 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1532 int offset = cp1 - rslt;
1534 retlen = devlen + dirlen;
1535 Renew(rslt,retlen+1+2*dashes,char);
1536 cp1 = rslt + offset;
1539 else if (*cp2 == '.') cp2++;
1541 for (; cp2 <= dirend; cp2++) {
1544 if (*(cp2+1) == '[') cp2++;
1546 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1547 else if (*cp2 == '.') {
1549 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1550 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1551 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1552 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1553 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1556 else if (*cp2 == '-') {
1557 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1558 while (*cp2 == '-') {
1560 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1562 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1563 if (ts) Safefree(rslt); /* filespecs like */
1564 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1568 else *(cp1++) = *cp2;
1570 else *(cp1++) = *cp2;
1572 while (*cp2) *(cp1++) = *(cp2++);
1577 } /* end of do_tounixspec() */
1579 /* External entry points */
1580 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1581 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1583 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1584 static char *do_tovmsspec(char *path, char *buf, int ts) {
1585 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1586 char *rslt, *dirend;
1587 register char *cp1, *cp2;
1588 unsigned long int infront = 0, hasdir = 1;
1590 if (path == NULL) return NULL;
1591 if (buf) rslt = buf;
1592 else if (ts) New(7016,rslt,strlen(path)+9,char);
1593 else rslt = __tovmsspec_retbuf;
1594 if (strpbrk(path,"]:>") ||
1595 (dirend = strrchr(path,'/')) == NULL) {
1596 if (path[0] == '.') {
1597 if (path[1] == '\0') strcpy(rslt,"[]");
1598 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1599 else strcpy(rslt,path); /* probably garbage */
1601 else strcpy(rslt,path);
1604 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1605 if (!*(dirend+2)) dirend +=2;
1606 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1611 char trndev[NAM$C_MAXRSS+1];
1615 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1616 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1618 islnm = my_trnlnm(rslt,trndev,0);
1619 trnend = islnm ? strlen(trndev) - 1 : 0;
1620 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1621 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1622 /* If the first element of the path is a logical name, determine
1623 * whether it has to be translated so we can add more directories. */
1624 if (!islnm || rooted) {
1627 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1631 if (cp2 != dirend) {
1632 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1633 strcpy(rslt,trndev);
1634 cp1 = rslt + trnend;
1647 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1648 cp2 += 2; /* skip over "./" - it's redundant */
1649 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1651 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1652 *(cp1++) = '-'; /* "../" --> "-" */
1655 if (cp2 > dirend) cp2 = dirend;
1657 else *(cp1++) = '.';
1659 for (; cp2 < dirend; cp2++) {
1661 if (*(cp2-1) == '/') continue;
1662 if (*(cp1-1) != '.') *(cp1++) = '.';
1665 else if (!infront && *cp2 == '.') {
1666 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1667 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1668 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1669 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1670 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1671 else { /* back up over previous directory name */
1673 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1674 if (*(cp1-1) == '[') {
1675 memcpy(cp1,"000000.",7);
1680 if (cp2 == dirend) break;
1682 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1685 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1686 if (*cp2 == '.') *(cp1++) = '_';
1687 else *(cp1++) = *cp2;
1691 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1692 if (hasdir) *(cp1++) = ']';
1693 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1694 while (*cp2) *(cp1++) = *(cp2++);
1699 } /* end of do_tovmsspec() */
1701 /* External entry points */
1702 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1703 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1705 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1706 static char *do_tovmspath(char *path, char *buf, int ts) {
1707 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1709 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1711 if (path == NULL) return NULL;
1712 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1713 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1714 if (buf) return buf;
1716 vmslen = strlen(vmsified);
1717 New(7017,cp,vmslen+1,char);
1718 memcpy(cp,vmsified,vmslen);
1723 strcpy(__tovmspath_retbuf,vmsified);
1724 return __tovmspath_retbuf;
1727 } /* end of do_tovmspath() */
1729 /* External entry points */
1730 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1731 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1734 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1735 static char *do_tounixpath(char *path, char *buf, int ts) {
1736 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1738 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1740 if (path == NULL) return NULL;
1741 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1742 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1743 if (buf) return buf;
1745 unixlen = strlen(unixified);
1746 New(7017,cp,unixlen+1,char);
1747 memcpy(cp,unixified,unixlen);
1752 strcpy(__tounixpath_retbuf,unixified);
1753 return __tounixpath_retbuf;
1756 } /* end of do_tounixpath() */
1758 /* External entry points */
1759 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1760 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1763 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1765 *****************************************************************************
1767 * Copyright (C) 1989-1994 by *
1768 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1770 * Permission is hereby granted for the reproduction of this software, *
1771 * on condition that this copyright notice is included in the reproduction, *
1772 * and that such reproduction is not for purposes of profit or material *
1775 * 27-Aug-1994 Modified for inclusion in perl5 *
1776 * by Charles Bailey bailey@genetics.upenn.edu *
1777 *****************************************************************************
1781 * getredirection() is intended to aid in porting C programs
1782 * to VMS (Vax-11 C). The native VMS environment does not support
1783 * '>' and '<' I/O redirection, or command line wild card expansion,
1784 * or a command line pipe mechanism using the '|' AND background
1785 * command execution '&'. All of these capabilities are provided to any
1786 * C program which calls this procedure as the first thing in the
1788 * The piping mechanism will probably work with almost any 'filter' type
1789 * of program. With suitable modification, it may useful for other
1790 * portability problems as well.
1792 * Author: Mark Pizzolato mark@infocomm.com
1796 struct list_item *next;
1800 static void add_item(struct list_item **head,
1801 struct list_item **tail,
1805 static void expand_wild_cards(char *item,
1806 struct list_item **head,
1807 struct list_item **tail,
1810 static int background_process(int argc, char **argv);
1812 static void pipe_and_fork(char **cmargv);
1814 /*{{{ void getredirection(int *ac, char ***av)*/
1816 getredirection(int *ac, char ***av)
1818 * Process vms redirection arg's. Exit if any error is seen.
1819 * If getredirection() processes an argument, it is erased
1820 * from the vector. getredirection() returns a new argc and argv value.
1821 * In the event that a background command is requested (by a trailing "&"),
1822 * this routine creates a background subprocess, and simply exits the program.
1824 * Warning: do not try to simplify the code for vms. The code
1825 * presupposes that getredirection() is called before any data is
1826 * read from stdin or written to stdout.
1828 * Normal usage is as follows:
1834 * getredirection(&argc, &argv);
1838 int argc = *ac; /* Argument Count */
1839 char **argv = *av; /* Argument Vector */
1840 char *ap; /* Argument pointer */
1841 int j; /* argv[] index */
1842 int item_count = 0; /* Count of Items in List */
1843 struct list_item *list_head = 0; /* First Item in List */
1844 struct list_item *list_tail; /* Last Item in List */
1845 char *in = NULL; /* Input File Name */
1846 char *out = NULL; /* Output File Name */
1847 char *outmode = "w"; /* Mode to Open Output File */
1848 char *err = NULL; /* Error File Name */
1849 char *errmode = "w"; /* Mode to Open Error File */
1850 int cmargc = 0; /* Piped Command Arg Count */
1851 char **cmargv = NULL;/* Piped Command Arg Vector */
1854 * First handle the case where the last thing on the line ends with
1855 * a '&'. This indicates the desire for the command to be run in a
1856 * subprocess, so we satisfy that desire.
1859 if (0 == strcmp("&", ap))
1860 exit(background_process(--argc, argv));
1861 if (*ap && '&' == ap[strlen(ap)-1])
1863 ap[strlen(ap)-1] = '\0';
1864 exit(background_process(argc, argv));
1867 * Now we handle the general redirection cases that involve '>', '>>',
1868 * '<', and pipes '|'.
1870 for (j = 0; j < argc; ++j)
1872 if (0 == strcmp("<", argv[j]))
1876 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1877 exit(LIB$_WRONUMARG);
1882 if ('<' == *(ap = argv[j]))
1887 if (0 == strcmp(">", ap))
1891 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1892 exit(LIB$_WRONUMARG);
1911 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1912 exit(LIB$_WRONUMARG);
1916 if (('2' == *ap) && ('>' == ap[1]))
1933 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1934 exit(LIB$_WRONUMARG);
1938 if (0 == strcmp("|", argv[j]))
1942 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1943 exit(LIB$_WRONUMARG);
1945 cmargc = argc-(j+1);
1946 cmargv = &argv[j+1];
1950 if ('|' == *(ap = argv[j]))
1958 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1961 * Allocate and fill in the new argument vector, Some Unix's terminate
1962 * the list with an extra null pointer.
1964 New(7002, argv, item_count+1, char *);
1966 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1967 argv[j] = list_head->value;
1973 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1974 exit(LIB$_INVARGORD);
1976 pipe_and_fork(cmargv);
1979 /* Check for input from a pipe (mailbox) */
1981 if (in == NULL && 1 == isapipe(0))
1983 char mbxname[L_tmpnam];
1985 long int dvi_item = DVI$_DEVBUFSIZ;
1986 $DESCRIPTOR(mbxnam, "");
1987 $DESCRIPTOR(mbxdevnam, "");
1989 /* Input from a pipe, reopen it in binary mode to disable */
1990 /* carriage control processing. */
1992 PerlIO_getname(stdin, mbxname);
1993 mbxnam.dsc$a_pointer = mbxname;
1994 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1995 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1996 mbxdevnam.dsc$a_pointer = mbxname;
1997 mbxdevnam.dsc$w_length = sizeof(mbxname);
1998 dvi_item = DVI$_DEVNAM;
1999 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2000 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2003 freopen(mbxname, "rb", stdin);
2006 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2010 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2012 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2015 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2017 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2022 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2024 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2028 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2033 #ifdef ARGPROC_DEBUG
2034 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2035 for (j = 0; j < *ac; ++j)
2036 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2038 /* Clear errors we may have hit expanding wildcards, so they don't
2039 show up in Perl's $! later */
2040 set_errno(0); set_vaxc_errno(1);
2041 } /* end of getredirection() */
2044 static void add_item(struct list_item **head,
2045 struct list_item **tail,
2051 New(7003,*head,1,struct list_item);
2055 New(7004,(*tail)->next,1,struct list_item);
2056 *tail = (*tail)->next;
2058 (*tail)->value = value;
2062 static void expand_wild_cards(char *item,
2063 struct list_item **head,
2064 struct list_item **tail,
2068 unsigned long int context = 0;
2074 char vmsspec[NAM$C_MAXRSS+1];
2075 $DESCRIPTOR(filespec, "");
2076 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2077 $DESCRIPTOR(resultspec, "");
2078 unsigned long int zero = 0, sts;
2080 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2082 add_item(head, tail, item, count);
2085 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2086 resultspec.dsc$b_class = DSC$K_CLASS_D;
2087 resultspec.dsc$a_pointer = NULL;
2088 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2089 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2090 if (!isunix || !filespec.dsc$a_pointer)
2091 filespec.dsc$a_pointer = item;
2092 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2094 * Only return version specs, if the caller specified a version
2096 had_version = strchr(item, ';');
2098 * Only return device and directory specs, if the caller specifed either.
2100 had_device = strchr(item, ':');
2101 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2103 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2104 &defaultspec, 0, 0, &zero))))
2109 New(7005,string,resultspec.dsc$w_length+1,char);
2110 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2111 string[resultspec.dsc$w_length] = '\0';
2112 if (NULL == had_version)
2113 *((char *)strrchr(string, ';')) = '\0';
2114 if ((!had_directory) && (had_device == NULL))
2116 if (NULL == (devdir = strrchr(string, ']')))
2117 devdir = strrchr(string, '>');
2118 strcpy(string, devdir + 1);
2121 * Be consistent with what the C RTL has already done to the rest of
2122 * the argv items and lowercase all of these names.
2124 for (c = string; *c; ++c)
2127 if (isunix) trim_unixpath(string,item);
2128 add_item(head, tail, string, count);
2131 if (sts != RMS$_NMF)
2133 set_vaxc_errno(sts);
2139 set_errno(ENOENT); break;
2141 set_errno(ENODEV); break;
2143 set_errno(EINVAL); break;
2145 set_errno(EACCES); break;
2147 _ckvmssts_noperl(sts);
2151 add_item(head, tail, item, count);
2152 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2153 _ckvmssts_noperl(lib$find_file_end(&context));
2156 static int child_st[2];/* Event Flag set when child process completes */
2158 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2160 static unsigned long int exit_handler(int *status)
2164 if (0 == child_st[0])
2166 #ifdef ARGPROC_DEBUG
2167 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2169 fflush(stdout); /* Have to flush pipe for binary data to */
2170 /* terminate properly -- <tp@mccall.com> */
2171 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2172 sys$dassgn(child_chan);
2174 sys$synch(0, child_st);
2179 static void sig_child(int chan)
2181 #ifdef ARGPROC_DEBUG
2182 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2184 if (child_st[0] == 0)
2188 static struct exit_control_block exit_block =
2193 &exit_block.exit_status,
2197 static void pipe_and_fork(char **cmargv)
2200 $DESCRIPTOR(cmddsc, "");
2201 static char mbxname[64];
2202 $DESCRIPTOR(mbxdsc, mbxname);
2204 unsigned long int zero = 0, one = 1;
2206 strcpy(subcmd, cmargv[0]);
2207 for (j = 1; NULL != cmargv[j]; ++j)
2209 strcat(subcmd, " \"");
2210 strcat(subcmd, cmargv[j]);
2211 strcat(subcmd, "\"");
2213 cmddsc.dsc$a_pointer = subcmd;
2214 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2216 create_mbx(&child_chan,&mbxdsc);
2217 #ifdef ARGPROC_DEBUG
2218 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2219 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2221 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2222 0, &pid, child_st, &zero, sig_child,
2224 #ifdef ARGPROC_DEBUG
2225 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2227 sys$dclexh(&exit_block);
2228 if (NULL == freopen(mbxname, "wb", stdout))
2230 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2234 static int background_process(int argc, char **argv)
2236 char command[2048] = "$";
2237 $DESCRIPTOR(value, "");
2238 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2239 static $DESCRIPTOR(null, "NLA0:");
2240 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2242 $DESCRIPTOR(pidstr, "");
2244 unsigned long int flags = 17, one = 1, retsts;
2246 strcat(command, argv[0]);
2249 strcat(command, " \"");
2250 strcat(command, *(++argv));
2251 strcat(command, "\"");
2253 value.dsc$a_pointer = command;
2254 value.dsc$w_length = strlen(value.dsc$a_pointer);
2255 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2256 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2257 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2258 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2261 _ckvmssts_noperl(retsts);
2263 #ifdef ARGPROC_DEBUG
2264 PerlIO_printf(Perl_debug_log, "%s\n", command);
2266 sprintf(pidstring, "%08X", pid);
2267 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2268 pidstr.dsc$a_pointer = pidstring;
2269 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2270 lib$set_symbol(&pidsymbol, &pidstr);
2274 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2277 * Trim Unix-style prefix off filespec, so it looks like what a shell
2278 * glob expansion would return (i.e. from specified prefix on, not
2279 * full path). Note that returned filespec is Unix-style, regardless
2280 * of whether input filespec was VMS-style or Unix-style.
2282 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2283 * determine prefix (both may be in VMS or Unix syntax).
2285 * Returns !=0 on success, with trimmed filespec replacing contents of
2286 * fspec, and 0 on failure, with contents of fpsec unchanged.
2288 /*{{{int trim_unixpath(char *fspec, char *wildspec)*/
2290 trim_unixpath(char *fspec, char *wildspec)
2292 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2293 *template, *base, *cp1, *cp2;
2294 register int tmplen, reslen = 0;
2296 if (!wildspec || !fspec) return 0;
2297 if (strpbrk(wildspec,"]>:") != NULL) {
2298 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2299 else template = unixified;
2301 else template = wildspec;
2302 if (strpbrk(fspec,"]>:") != NULL) {
2303 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2304 else base = unixified;
2305 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2306 * check to see that final result fits into (isn't longer than) fspec */
2307 reslen = strlen(fspec);
2311 /* No prefix or absolute path on wildcard, so nothing to remove */
2312 if (!*template || *template == '/') {
2313 if (base == fspec) return 1;
2314 tmplen = strlen(unixified);
2315 if (tmplen > reslen) return 0; /* not enough space */
2316 /* Copy unixified resultant, including trailing NUL */
2317 memmove(fspec,unixified,tmplen+1);
2321 /* Find prefix to template consisting of path elements without wildcards */
2322 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2323 for (cp1 = template; *cp1; cp1++) ;
2324 else while (cp1 > template && *cp1 != '/') cp1--;
2325 for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
2327 /* Wildcard was in first element, so we don't have a reliable string to
2328 * match against. Guess where to trim resultant filespec by counting
2329 * directory levels in the Unix template. (We could do this instead of
2330 * string matching in all cases, since Unix doesn't have a ... wildcard
2331 * that can expand into multiple levels of subdirectory, but we try for
2332 * the string match so our caller can interpret foo/.../bar.* as
2333 * [.foo...]bar.* if it wants, and only get burned if there was a
2334 * wildcard in the first word (in which case, caveat caller). */
2335 if (cp1 == template) {
2337 for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
2338 /* need to back one more '/' than in template, to pick up leading dirname */
2340 while (cp2 > base) {
2341 if (*cp2 == '/') subdirs--;
2342 if (!subdirs) break; /* quit without decrement when we hit last '/' */
2345 /* ran out of directories on resultant; allow for already trimmed
2346 * resultant, which hits start of string looking for leading '/' */
2347 if (subdirs && (cp2 != base || subdirs != 1)) return 0;
2348 /* Move past leading '/', if there is one */
2349 base = cp2 + (*cp2 == '/' ? 1 : 0);
2350 tmplen = strlen(base);
2351 if (reslen && tmplen > reslen) return 0; /* not enough space */
2352 memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
2355 /* We have a prefix string of complete directory names, so we
2356 * try to find it on the resultant filespec */
2358 tmplen = cp1 - template;
2359 if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
2360 if (reslen) { /* we converted to Unix syntax; copy result over */
2361 tmplen = cp2 - base;
2362 if (tmplen > reslen) return 0; /* not enough space */
2363 memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
2367 for ( ; cp2 - base > tmplen; base++) {
2368 if (*base != '/') continue;
2369 if (!memcmp(base + 1,template,tmplen)) break;
2372 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2373 base++; /* Move past leading '/' */
2374 if (reslen && cp2 - base > reslen) return 0; /* not enough space */
2375 /* Copy down remaining portion of filespec, including trailing NUL */
2376 memmove(fspec,base,cp2 - base + 1);
2380 } /* end of trim_unixpath() */
2385 * VMS readdir() routines.
2386 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2387 * This code has no copyright.
2389 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2390 * Minor modifications to original routines.
2393 /* Number of elements in vms_versions array */
2394 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2397 * Open a directory, return a handle for later use.
2399 /*{{{ DIR *opendir(char*name) */
2404 char dir[NAM$C_MAXRSS+1];
2406 /* Get memory for the handle, and the pattern. */
2408 if (do_tovmspath(name,dir,0) == NULL) {
2409 Safefree((char *)dd);
2412 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2414 /* Fill in the fields; mainly playing with the descriptor. */
2415 (void)sprintf(dd->pattern, "%s*.*",dir);
2418 dd->vms_wantversions = 0;
2419 dd->pat.dsc$a_pointer = dd->pattern;
2420 dd->pat.dsc$w_length = strlen(dd->pattern);
2421 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2422 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2425 } /* end of opendir() */
2429 * Set the flag to indicate we want versions or not.
2431 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2433 vmsreaddirversions(DIR *dd, int flag)
2435 dd->vms_wantversions = flag;
2440 * Free up an opened directory.
2442 /*{{{ void closedir(DIR *dd)*/
2446 (void)lib$find_file_end(&dd->context);
2447 Safefree(dd->pattern);
2448 Safefree((char *)dd);
2453 * Collect all the version numbers for the current file.
2459 struct dsc$descriptor_s pat;
2460 struct dsc$descriptor_s res;
2462 char *p, *text, buff[sizeof dd->entry.d_name];
2464 unsigned long context, tmpsts;
2466 /* Convenient shorthand. */
2469 /* Add the version wildcard, ignoring the "*.*" put on before */
2470 i = strlen(dd->pattern);
2471 New(7008,text,i + e->d_namlen + 3,char);
2472 (void)strcpy(text, dd->pattern);
2473 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2475 /* Set up the pattern descriptor. */
2476 pat.dsc$a_pointer = text;
2477 pat.dsc$w_length = i + e->d_namlen - 1;
2478 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2479 pat.dsc$b_class = DSC$K_CLASS_S;
2481 /* Set up result descriptor. */
2482 res.dsc$a_pointer = buff;
2483 res.dsc$w_length = sizeof buff - 2;
2484 res.dsc$b_dtype = DSC$K_DTYPE_T;
2485 res.dsc$b_class = DSC$K_CLASS_S;
2487 /* Read files, collecting versions. */
2488 for (context = 0, e->vms_verscount = 0;
2489 e->vms_verscount < VERSIZE(e);
2490 e->vms_verscount++) {
2491 tmpsts = lib$find_file(&pat, &res, &context);
2492 if (tmpsts == RMS$_NMF || context == 0) break;
2494 buff[sizeof buff - 1] = '\0';
2495 if ((p = strchr(buff, ';')))
2496 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2498 e->vms_versions[e->vms_verscount] = -1;
2501 _ckvmssts(lib$find_file_end(&context));
2504 } /* end of collectversions() */
2507 * Read the next entry from the directory.
2509 /*{{{ struct dirent *readdir(DIR *dd)*/
2513 struct dsc$descriptor_s res;
2514 char *p, buff[sizeof dd->entry.d_name];
2515 unsigned long int tmpsts;
2517 /* Set up result descriptor, and get next file. */
2518 res.dsc$a_pointer = buff;
2519 res.dsc$w_length = sizeof buff - 2;
2520 res.dsc$b_dtype = DSC$K_DTYPE_T;
2521 res.dsc$b_class = DSC$K_CLASS_S;
2522 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2523 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2524 if (!(tmpsts & 1)) {
2525 set_vaxc_errno(tmpsts);
2528 set_errno(EACCES); break;
2530 set_errno(ENODEV); break;
2533 set_errno(ENOENT); break;
2540 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2541 buff[sizeof buff - 1] = '\0';
2542 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2545 /* Skip any directory component and just copy the name. */
2546 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2547 else (void)strcpy(dd->entry.d_name, buff);
2549 /* Clobber the version. */
2550 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2552 dd->entry.d_namlen = strlen(dd->entry.d_name);
2553 dd->entry.vms_verscount = 0;
2554 if (dd->vms_wantversions) collectversions(dd);
2557 } /* end of readdir() */
2561 * Return something that can be used in a seekdir later.
2563 /*{{{ long telldir(DIR *dd)*/
2572 * Return to a spot where we used to be. Brute force.
2574 /*{{{ void seekdir(DIR *dd,long count)*/
2576 seekdir(DIR *dd, long count)
2578 int vms_wantversions;
2580 /* If we haven't done anything yet... */
2584 /* Remember some state, and clear it. */
2585 vms_wantversions = dd->vms_wantversions;
2586 dd->vms_wantversions = 0;
2587 _ckvmssts(lib$find_file_end(&dd->context));
2590 /* The increment is in readdir(). */
2591 for (dd->count = 0; dd->count < count; )
2594 dd->vms_wantversions = vms_wantversions;
2596 } /* end of seekdir() */
2599 /* VMS subprocess management
2601 * my_vfork() - just a vfork(), after setting a flag to record that
2602 * the current script is trying a Unix-style fork/exec.
2604 * vms_do_aexec() and vms_do_exec() are called in response to the
2605 * perl 'exec' function. If this follows a vfork call, then they
2606 * call out the the regular perl routines in doio.c which do an
2607 * execvp (for those who really want to try this under VMS).
2608 * Otherwise, they do exactly what the perl docs say exec should
2609 * do - terminate the current script and invoke a new command
2610 * (See below for notes on command syntax.)
2612 * do_aspawn() and do_spawn() implement the VMS side of the perl
2613 * 'system' function.
2615 * Note on command arguments to perl 'exec' and 'system': When handled
2616 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2617 * are concatenated to form a DCL command string. If the first arg
2618 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2619 * the the command string is hrnded off to DCL directly. Otherwise,
2620 * the first token of the command is taken as the filespec of an image
2621 * to run. The filespec is expanded using a default type of '.EXE' and
2622 * the process defaults for device, directory, etc., and the resultant
2623 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2624 * the command string as parameters. This is perhaps a bit compicated,
2625 * but I hope it will form a happy medium between what VMS folks expect
2626 * from lib$spawn and what Unix folks expect from exec.
2629 static int vfork_called;
2631 /*{{{int my_vfork()*/
2641 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2649 if (VMScmd.dsc$a_pointer) {
2650 Safefree(VMScmd.dsc$a_pointer);
2651 VMScmd.dsc$w_length = 0;
2652 VMScmd.dsc$a_pointer = Nullch;
2657 setup_argstr(SV *really, SV **mark, SV **sp)
2659 char *junk, *tmps = Nullch;
2660 register size_t cmdlen = 0;
2666 tmps = SvPV(really,rlen);
2673 for (idx++; idx <= sp; idx++) {
2675 junk = SvPVx(*idx,rlen);
2676 cmdlen += rlen ? rlen + 1 : 0;
2679 New(401,Cmd,cmdlen+1,char);
2681 if (tmps && *tmps) {
2686 while (++mark <= sp) {
2689 strcat(Cmd,SvPVx(*mark,na));
2694 } /* end of setup_argstr() */
2697 static unsigned long int
2698 setup_cmddsc(char *cmd, int check_img)
2700 char resspec[NAM$C_MAXRSS+1];
2701 $DESCRIPTOR(defdsc,".EXE");
2702 $DESCRIPTOR(resdsc,resspec);
2703 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2704 unsigned long int cxt = 0, flags = 1, retsts;
2705 register char *s, *rest, *cp;
2706 register int isdcl = 0;
2709 while (*s && isspace(*s)) s++;
2711 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2712 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2713 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2714 if (*cp == ':' || *cp == '[' || *cp == '<') {
2722 if (isdcl) { /* It's a DCL command, just do it. */
2723 VMScmd.dsc$w_length = strlen(cmd);
2725 VMScmd.dsc$a_pointer = Cmd;
2726 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2728 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2730 else { /* assume first token is an image spec */
2732 while (*s && !isspace(*s)) s++;
2734 imgdsc.dsc$a_pointer = cmd;
2735 imgdsc.dsc$w_length = s - cmd;
2736 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2737 if (!(retsts & 1)) {
2738 /* just hand off status values likely to be due to user error */
2739 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2740 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2741 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2742 else { _ckvmssts(retsts); }
2745 _ckvmssts(lib$find_file_end(&cxt));
2747 while (*s && !isspace(*s)) s++;
2749 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2750 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2751 strcat(VMScmd.dsc$a_pointer,resspec);
2752 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2753 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2757 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2759 } /* end of setup_cmddsc() */
2762 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2764 vms_do_aexec(SV *really,SV **mark,SV **sp)
2767 if (vfork_called) { /* this follows a vfork - act Unixish */
2769 if (vfork_called < 0) {
2770 warn("Internal inconsistency in tracking vforks");
2773 else return do_aexec(really,mark,sp);
2775 /* no vfork - act VMSish */
2776 return vms_do_exec(setup_argstr(really,mark,sp));
2781 } /* end of vms_do_aexec() */
2784 /* {{{bool vms_do_exec(char *cmd) */
2786 vms_do_exec(char *cmd)
2789 if (vfork_called) { /* this follows a vfork - act Unixish */
2791 if (vfork_called < 0) {
2792 warn("Internal inconsistency in tracking vforks");
2795 else return do_exec(cmd);
2798 { /* no vfork - act VMSish */
2799 unsigned long int retsts;
2801 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2802 retsts = lib$do_command(&VMScmd);
2805 set_vaxc_errno(retsts);
2807 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2813 } /* end of vms_do_exec() */
2816 unsigned long int do_spawn(char *);
2818 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2820 do_aspawn(SV *really,SV **mark,SV **sp)
2822 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2825 } /* end of do_aspawn() */
2828 /* {{{unsigned long int do_spawn(char *cmd) */
2832 unsigned long int substs, hadcmd = 1;
2834 if (!cmd || !*cmd) {
2836 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2838 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2839 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2844 set_vaxc_errno(substs);
2846 warn("Can't spawn \"%s\": %s",
2847 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2852 } /* end of do_spawn() */
2856 * A simple fwrite replacement which outputs itmsz*nitm chars without
2857 * introducing record boundaries every itmsz chars.
2859 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2861 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2863 register char *cp, *end;
2865 end = (char *)src + itmsz * nitm;
2867 while ((char *)src <= end) {
2868 for (cp = src; cp <= end; cp++) if (!*cp) break;
2869 if (fputs(src,dest) == EOF) return EOF;
2871 if (fputc('\0',dest) == EOF) return EOF;
2877 } /* end of my_fwrite() */
2881 * Here are replacements for the following Unix routines in the VMS environment:
2882 * getpwuid Get information for a particular UIC or UID
2883 * getpwnam Get information for a named user
2884 * getpwent Get information for each user in the rights database
2885 * setpwent Reset search to the start of the rights database
2886 * endpwent Finish searching for users in the rights database
2888 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2889 * (defined in pwd.h), which contains the following fields:-
2891 * char *pw_name; Username (in lower case)
2892 * char *pw_passwd; Hashed password
2893 * unsigned int pw_uid; UIC
2894 * unsigned int pw_gid; UIC group number
2895 * char *pw_unixdir; Default device/directory (VMS-style)
2896 * char *pw_gecos; Owner name
2897 * char *pw_dir; Default device/directory (Unix-style)
2898 * char *pw_shell; Default CLI name (eg. DCL)
2900 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2902 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2903 * not the UIC member number (eg. what's returned by getuid()),
2904 * getpwuid() can accept either as input (if uid is specified, the caller's
2905 * UIC group is used), though it won't recognise gid=0.
2907 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2908 * information about other users in your group or in other groups, respectively.
2909 * If the required privilege is not available, then these routines fill only
2910 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2913 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2916 /* sizes of various UAF record fields */
2917 #define UAI$S_USERNAME 12
2918 #define UAI$S_IDENT 31
2919 #define UAI$S_OWNER 31
2920 #define UAI$S_DEFDEV 31
2921 #define UAI$S_DEFDIR 63
2922 #define UAI$S_DEFCLI 31
2925 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2926 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2927 (uic).uic$v_group != UIC$K_WILD_GROUP)
2929 static char __empty[]= "";
2930 static struct passwd __passwd_empty=
2931 {(char *) __empty, (char *) __empty, 0, 0,
2932 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2933 static int contxt= 0;
2934 static struct passwd __pwdcache;
2935 static char __pw_namecache[UAI$S_IDENT+1];
2938 * This routine does most of the work extracting the user information.
2940 static int fillpasswd (const char *name, struct passwd *pwd)
2943 unsigned char length;
2944 char pw_gecos[UAI$S_OWNER+1];
2946 static union uicdef uic;
2948 unsigned char length;
2949 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2952 unsigned char length;
2953 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2956 unsigned char length;
2957 char pw_shell[UAI$S_DEFCLI+1];
2959 static char pw_passwd[UAI$S_PWD+1];
2961 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2962 struct dsc$descriptor_s name_desc;
2963 unsigned long int sts;
2965 static struct itmlst_3 itmlst[]= {
2966 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2967 {sizeof(uic), UAI$_UIC, &uic, &luic},
2968 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2969 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2970 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2971 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2972 {0, 0, NULL, NULL}};
2974 name_desc.dsc$w_length= strlen(name);
2975 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2976 name_desc.dsc$b_class= DSC$K_CLASS_S;
2977 name_desc.dsc$a_pointer= (char *) name;
2979 /* Note that sys$getuai returns many fields as counted strings. */
2980 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2981 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2982 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2984 else { _ckvmssts(sts); }
2985 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2987 if ((int) owner.length < lowner) lowner= (int) owner.length;
2988 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2989 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2990 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2991 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2992 owner.pw_gecos[lowner]= '\0';
2993 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2994 defcli.pw_shell[ldefcli]= '\0';
2995 if (valid_uic(uic)) {
2996 pwd->pw_uid= uic.uic$l_uic;
2997 pwd->pw_gid= uic.uic$v_group;
3000 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3001 pwd->pw_passwd= pw_passwd;
3002 pwd->pw_gecos= owner.pw_gecos;
3003 pwd->pw_dir= defdev.pw_dir;
3004 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3005 pwd->pw_shell= defcli.pw_shell;
3006 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3008 ldir= strlen(pwd->pw_unixdir) - 1;
3009 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3012 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3013 __mystrtolower(pwd->pw_unixdir);
3018 * Get information for a named user.
3020 /*{{{struct passwd *getpwnam(char *name)*/
3021 struct passwd *my_getpwnam(char *name)
3023 struct dsc$descriptor_s name_desc;
3025 unsigned long int status, stat;
3027 __pwdcache = __passwd_empty;
3028 if (!fillpasswd(name, &__pwdcache)) {
3029 /* We still may be able to determine pw_uid and pw_gid */
3030 name_desc.dsc$w_length= strlen(name);
3031 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3032 name_desc.dsc$b_class= DSC$K_CLASS_S;
3033 name_desc.dsc$a_pointer= (char *) name;
3034 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3035 __pwdcache.pw_uid= uic.uic$l_uic;
3036 __pwdcache.pw_gid= uic.uic$v_group;
3039 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
3040 set_vaxc_errno(stat);
3041 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
3044 else { _ckvmssts(stat); }
3047 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3048 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3049 __pwdcache.pw_name= __pw_namecache;
3051 } /* end of my_getpwnam() */
3055 * Get information for a particular UIC or UID.
3056 * Called by my_getpwent with uid=-1 to list all users.
3058 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3059 struct passwd *my_getpwuid(Uid_t uid)
3061 const $DESCRIPTOR(name_desc,__pw_namecache);
3062 unsigned short lname;
3064 unsigned long int status;
3066 if (uid == (unsigned int) -1) {
3068 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3069 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3070 set_vaxc_errno(status);
3071 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3075 else { _ckvmssts(status); }
3076 } while (!valid_uic (uic));
3080 if (!uic.uic$v_group)
3081 uic.uic$v_group= getgid();
3083 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3084 else status = SS$_IVIDENT;
3085 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3086 status == RMS$_PRV) {
3087 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3090 else { _ckvmssts(status); }
3092 __pw_namecache[lname]= '\0';
3093 __mystrtolower(__pw_namecache);
3095 __pwdcache = __passwd_empty;
3096 __pwdcache.pw_name = __pw_namecache;
3098 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3099 The identifier's value is usually the UIC, but it doesn't have to be,
3100 so if we can, we let fillpasswd update this. */
3101 __pwdcache.pw_uid = uic.uic$l_uic;
3102 __pwdcache.pw_gid = uic.uic$v_group;
3104 fillpasswd(__pw_namecache, &__pwdcache);
3107 } /* end of my_getpwuid() */
3111 * Get information for next user.
3113 /*{{{struct passwd *my_getpwent()*/
3114 struct passwd *my_getpwent()
3116 return (my_getpwuid((unsigned int) -1));
3121 * Finish searching rights database for users.
3123 /*{{{void my_endpwent()*/
3127 _ckvmssts(sys$finish_rdb(&contxt));
3135 * If the CRTL has a real gmtime(), use it, else look for the logical
3136 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
3137 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
3138 * to translate to the number of seconds which must be added to UTC
3139 * to get to the local time of the system.
3140 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3143 /*{{{struct tm *my_gmtime(const time_t *time)*/
3144 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
3145 * so we can call the CRTL's routine to see if it works.
3149 my_gmtime(const time_t *time)
3151 static int gmtime_emulation_type;
3152 static long int utc_offset_secs;
3156 if (gmtime_emulation_type == 0) {
3157 gmtime_emulation_type++;
3159 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
3160 gmtime_emulation_type++;
3161 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
3162 gmtime_emulation_type++;
3164 utc_offset_secs = atol(p);
3168 switch (gmtime_emulation_type) {
3170 return gmtime(time);
3172 when = *time - utc_offset_secs;
3173 return localtime(&when);
3175 warn("gmtime not supported on this system");
3178 } /* end of my_gmtime() */
3179 /* Reset definition for later calls */
3180 #define gmtime(t) my_gmtime(t)
3185 * flex_stat, flex_fstat
3186 * basic stat, but gets it right when asked to stat
3187 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3190 /* encode_dev packs a VMS device name string into an integer to allow
3191 * simple comparisons. This can be used, for example, to check whether two
3192 * files are located on the same device, by comparing their encoded device
3193 * names. Even a string comparison would not do, because stat() reuses the
3194 * device name buffer for each call; so without encode_dev, it would be
3195 * necessary to save the buffer and use strcmp (this would mean a number of
3196 * changes to the standard Perl code, to say nothing of what a Perl script
3199 * The device lock id, if it exists, should be unique (unless perhaps compared
3200 * with lock ids transferred from other nodes). We have a lock id if the disk is
3201 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3202 * device names. Thus we use the lock id in preference, and only if that isn't
3203 * available, do we try to pack the device name into an integer (flagged by
3204 * the sign bit (LOCKID_MASK) being set).
3206 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3207 * name and its encoded form, but it seems very unlikely that we will find
3208 * two files on different disks that share the same encoded device names,
3209 * and even more remote that they will share the same file id (if the test
3210 * is to check for the same file).
3212 * A better method might be to use sys$device_scan on the first call, and to
3213 * search for the device, returning an index into the cached array.
3214 * The number returned would be more intelligable.
3215 * This is probably not worth it, and anyway would take quite a bit longer
3216 * on the first call.
3218 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3219 static dev_t encode_dev (const char *dev)
3222 unsigned long int f;
3227 if (!dev || !dev[0]) return 0;
3231 struct dsc$descriptor_s dev_desc;
3232 unsigned long int status, lockid, item = DVI$_LOCKID;
3234 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3235 can try that first. */
3236 dev_desc.dsc$w_length = strlen (dev);
3237 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3238 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3239 dev_desc.dsc$a_pointer = (char *) dev;
3240 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3241 if (lockid) return (lockid & ~LOCKID_MASK);
3245 /* Otherwise we try to encode the device name */
3249 for (q = dev + strlen(dev); q--; q >= dev) {
3252 else if (isalpha (toupper (*q)))
3253 c= toupper (*q) - 'A' + (char)10;
3255 continue; /* Skip '$'s */
3257 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3259 enc += f * (unsigned long int) c;
3261 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3263 } /* end of encode_dev() */
3265 static char namecache[NAM$C_MAXRSS+1];
3268 is_null_device(name)
3271 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3272 The underscore prefix, controller letter, and unit number are
3273 independently optional; for our purposes, the colon punctuation
3274 is not. The colon can be trailed by optional directory and/or
3275 filename, but two consecutive colons indicates a nodename rather
3276 than a device. [pr] */
3277 if (*name == '_') ++name;
3278 if (tolower(*name++) != 'n') return 0;
3279 if (tolower(*name++) != 'l') return 0;
3280 if (tolower(*name) == 'a') ++name;
3281 if (*name == '0') ++name;
3282 return (*name++ == ':') && (*name != ':');
3285 /* Do the permissions allow some operation? Assumes statcache already set. */
3286 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3287 * subset of the applicable information.
3289 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3291 cando(I32 bit, I32 effective, struct stat *statbufp)
3293 if (statbufp == &statcache)
3294 return cando_by_name(bit,effective,namecache);
3296 char fname[NAM$C_MAXRSS+1];
3297 unsigned long int retsts;
3298 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3299 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3301 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3302 device name on successive calls */
3303 devdsc.dsc$a_pointer = statbufp->st_devnam;
3304 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3305 namdsc.dsc$a_pointer = fname;
3306 namdsc.dsc$w_length = sizeof fname - 1;
3308 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3309 &namdsc.dsc$w_length,0,0);
3311 fname[namdsc.dsc$w_length] = '\0';
3312 return cando_by_name(bit,effective,fname);
3314 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3315 warn("Can't get filespec - stale stat buffer?\n");
3319 return FALSE; /* Should never get to here */
3321 } /* end of cando() */
3325 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3327 cando_by_name(I32 bit, I32 effective, char *fname)
3329 static char usrname[L_cuserid];
3330 static struct dsc$descriptor_s usrdsc =
3331 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3332 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3333 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3334 unsigned short int retlen;
3335 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3336 union prvdef curprv;
3337 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3338 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3339 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3342 if (!fname || !*fname) return FALSE;
3343 /* Make sure we expand logical names, since sys$check_access doesn't */
3344 if (!strpbrk(fname,"/]>:")) {
3345 strcpy(fileified,fname);
3346 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3349 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3350 retlen = namdsc.dsc$w_length = strlen(vmsname);
3351 namdsc.dsc$a_pointer = vmsname;
3352 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3353 vmsname[retlen-1] == ':') {
3354 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3355 namdsc.dsc$w_length = strlen(fileified);
3356 namdsc.dsc$a_pointer = fileified;
3359 if (!usrdsc.dsc$w_length) {
3361 usrdsc.dsc$w_length = strlen(usrname);
3368 access = ARM$M_EXECUTE;
3373 access = ARM$M_READ;
3378 access = ARM$M_WRITE;
3383 access = ARM$M_DELETE;
3389 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3390 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3391 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3392 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3393 set_vaxc_errno(retsts);
3394 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3395 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3396 else set_errno(ENOENT);
3399 if (retsts == SS$_NORMAL) {
3400 if (!privused) return TRUE;
3401 /* We can get access, but only by using privs. Do we have the
3402 necessary privs currently enabled? */
3403 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3404 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3405 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3406 !curprv.prv$v_bypass) return FALSE;
3407 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3408 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3409 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3414 return FALSE; /* Should never get here */
3416 } /* end of cando_by_name() */
3420 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3423 flex_fstat(int fd, struct mystat *statbufp)
3425 if (!fstat(fd,(stat_t *) statbufp)) {
3426 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3431 } /* end of flex_fstat() */
3434 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3435 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3436 * 'struct stat' elsewhere in Perl would use our struct. We go back
3437 * to the system version here, since we're actually calling their
3441 flex_stat(char *fspec, struct mystat *statbufp)
3443 char fileified[NAM$C_MAXRSS+1];
3446 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3447 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3448 memset(statbufp,0,sizeof *statbufp);
3449 statbufp->st_dev = encode_dev("_NLA0:");
3450 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3451 statbufp->st_uid = 0x00010001;
3452 statbufp->st_gid = 0x0001;
3453 time((time_t *)&statbufp->st_mtime);
3454 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3458 /* Try for a directory name first. If fspec contains a filename without
3459 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3460 * and sea:[wine.dark]water. exist, we prefer the directory here.
3461 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3462 * not sea:[wine.dark]., if the latter exists. If the intended target is
3463 * the file with null type, specify this by calling flex_stat() with
3464 * a '.' at the end of fspec.
3466 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3467 retval = stat(fileified,(stat_t *) statbufp);
3468 if (!retval && statbufp == &statcache) strcpy(namecache,fileified);
3470 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3471 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3474 } /* end of flex_stat() */
3475 /* Reset definition for later calls */
3479 /* Insures that no carriage-control translation will be done on a file. */
3480 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3482 my_binmode(FILE *fp, char iotype)
3484 char filespec[NAM$C_MAXRSS], *acmode;
3487 if (!fgetname(fp,filespec)) return NULL;
3488 if (fgetpos(fp,&pos) == -1) return NULL;
3490 case '<': case 'r': acmode = "rb"; break;
3491 case '>': case 'w': acmode = "wb"; break;
3492 case '+': case '|': case 's': acmode = "rb+"; break;
3493 case 'a': acmode = "ab"; break;
3494 case '-': acmode = fileno(fp) ? "wb" : "rb"; break;
3496 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3497 if (fsetpos(fp,&pos) == -1) return NULL;
3498 } /* end of my_binmode() */
3502 /*{{{char *my_getlogin()*/
3503 /* VMS cuserid == Unix getlogin, except calling sequence */
3507 static char user[L_cuserid];
3508 return cuserid(user);
3513 /* rmscopy - copy a file using VMS RMS routines
3515 * Copies contents and attributes of spec_in to spec_out, except owner
3516 * and protection information. Name and type of spec_in are used as
3517 * defaults for spec_out. The third parameter specifies whether rmscopy()
3518 * should try to propagate timestamps from the input file to the output file.
3519 * If it is less than 0, no timestamps are preserved. If it is 0, then
3520 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3521 * propagated to the output file at creation iff the output file specification
3522 * did not contain an explicit name or type, and the revision date is always
3523 * updated at the end of the copy operation. If it is greater than 0, then
3524 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3525 * other than the revision date should be propagated, and bit 1 indicates
3526 * that the revision date should be propagated.
3528 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3530 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3531 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3532 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3533 * as part of the Perl standard distribution under the terms of the
3534 * GNU General Public License or the Perl Artistic License. Copies
3535 * of each may be found in the Perl standard distribution.
3537 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3539 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3541 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3542 rsa[NAM$C_MAXRSS], ubf[32256];
3543 unsigned long int i, sts, sts2;
3544 struct FAB fab_in, fab_out;
3545 struct RAB rab_in, rab_out;
3547 struct XABDAT xabdat;
3548 struct XABFHC xabfhc;
3549 struct XABRDT xabrdt;
3550 struct XABSUM xabsum;
3552 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3553 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3554 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3558 fab_in = cc$rms_fab;
3559 fab_in.fab$l_fna = vmsin;
3560 fab_in.fab$b_fns = strlen(vmsin);
3561 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3562 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3563 fab_in.fab$l_fop = FAB$M_SQO;
3564 fab_in.fab$l_nam = &nam;
3565 fab_in.fab$l_xab = (void *) &xabdat;
3568 nam.nam$l_rsa = rsa;
3569 nam.nam$b_rss = sizeof(rsa);
3570 nam.nam$l_esa = esa;
3571 nam.nam$b_ess = sizeof (esa);
3572 nam.nam$b_esl = nam.nam$b_rsl = 0;
3574 xabdat = cc$rms_xabdat; /* To get creation date */
3575 xabdat.xab$l_nxt = (void *) &xabfhc;
3577 xabfhc = cc$rms_xabfhc; /* To get record length */
3578 xabfhc.xab$l_nxt = (void *) &xabsum;
3580 xabsum = cc$rms_xabsum; /* To get key and area information */
3582 if (!((sts = sys$open(&fab_in)) & 1)) {
3583 set_vaxc_errno(sts);
3587 set_errno(ENOENT); break;
3589 set_errno(ENODEV); break;
3591 set_errno(EINVAL); break;
3593 set_errno(EACCES); break;
3601 fab_out.fab$w_ifi = 0;
3602 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3603 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3604 fab_out.fab$l_fop = FAB$M_SQO;
3605 fab_out.fab$l_fna = vmsout;
3606 fab_out.fab$b_fns = strlen(vmsout);
3607 fab_out.fab$l_dna = nam.nam$l_name;
3608 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3610 if (preserve_dates == 0) { /* Act like DCL COPY */
3611 nam.nam$b_nop = NAM$M_SYNCHK;
3612 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3613 if (!((sts = sys$parse(&fab_out)) & 1)) {
3614 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3615 set_vaxc_errno(sts);
3618 fab_out.fab$l_xab = (void *) &xabdat;
3619 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3621 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3622 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3623 preserve_dates =0; /* bitmask from this point forward */
3625 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3626 if (!((sts = sys$create(&fab_out)) & 1)) {
3627 set_vaxc_errno(sts);
3630 set_errno(ENOENT); break;
3632 set_errno(ENODEV); break;
3634 set_errno(EINVAL); break;
3636 set_errno(EACCES); break;
3642 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3643 if (preserve_dates & 2) {
3644 /* sys$close() will process xabrdt, not xabdat */
3645 xabrdt = cc$rms_xabrdt;
3647 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3649 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3650 * is unsigned long[2], while DECC & VAXC use a struct */
3651 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3653 fab_out.fab$l_xab = (void *) &xabrdt;
3656 rab_in = cc$rms_rab;
3657 rab_in.rab$l_fab = &fab_in;
3658 rab_in.rab$l_rop = RAB$M_BIO;
3659 rab_in.rab$l_ubf = ubf;
3660 rab_in.rab$w_usz = sizeof ubf;
3661 if (!((sts = sys$connect(&rab_in)) & 1)) {
3662 sys$close(&fab_in); sys$close(&fab_out);
3663 set_errno(EVMSERR); set_vaxc_errno(sts);
3667 rab_out = cc$rms_rab;
3668 rab_out.rab$l_fab = &fab_out;
3669 rab_out.rab$l_rbf = ubf;
3670 if (!((sts = sys$connect(&rab_out)) & 1)) {
3671 sys$close(&fab_in); sys$close(&fab_out);
3672 set_errno(EVMSERR); set_vaxc_errno(sts);
3676 while ((sts = sys$read(&rab_in))) { /* always true */
3677 if (sts == RMS$_EOF) break;
3678 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3679 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3680 sys$close(&fab_in); sys$close(&fab_out);
3681 set_errno(EVMSERR); set_vaxc_errno(sts);
3686 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3687 sys$close(&fab_in); sys$close(&fab_out);
3688 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3690 set_errno(EVMSERR); set_vaxc_errno(sts);
3696 } /* end of rmscopy() */
3700 /*** The following glue provides 'hooks' to make some of the routines
3701 * from this file available from Perl. These routines are sufficiently
3702 * basic, and are required sufficiently early in the build process,
3703 * that's it's nice to have them available to miniperl as well as the
3704 * full Perl, so they're set up here instead of in an extension. The
3705 * Perl code which handles importation of these names into a given
3706 * package lives in [.VMS]Filespec.pm in @INC.
3710 rmsexpand_fromperl(CV *cv)
3713 char *fspec, *defspec = NULL, *rslt;
3715 if (!items || items > 2)
3716 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3717 fspec = SvPV(ST(0),na);
3718 if (!fspec || !*fspec) XSRETURN_UNDEF;
3719 if (items == 2) defspec = SvPV(ST(1),na);
3721 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3722 ST(0) = sv_newmortal();
3723 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3728 vmsify_fromperl(CV *cv)
3733 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3734 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3735 ST(0) = sv_newmortal();
3736 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3741 unixify_fromperl(CV *cv)
3746 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3747 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3748 ST(0) = sv_newmortal();
3749 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3754 fileify_fromperl(CV *cv)
3759 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3760 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3761 ST(0) = sv_newmortal();
3762 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3767 pathify_fromperl(CV *cv)
3772 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3773 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3774 ST(0) = sv_newmortal();
3775 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3780 vmspath_fromperl(CV *cv)
3785 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3786 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3787 ST(0) = sv_newmortal();
3788 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3793 unixpath_fromperl(CV *cv)
3798 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3799 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3800 ST(0) = sv_newmortal();
3801 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3806 candelete_fromperl(CV *cv)
3809 char fspec[NAM$C_MAXRSS+1], *fsp;
3813 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3815 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3816 if (SvTYPE(mysv) == SVt_PVGV) {
3817 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3818 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3825 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3826 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3832 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3837 rmscopy_fromperl(CV *cv)
3840 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3842 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3843 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3844 unsigned long int sts;
3848 if (items < 2 || items > 3)
3849 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3851 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3852 if (SvTYPE(mysv) == SVt_PVGV) {
3853 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3854 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3861 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3862 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3867 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3868 if (SvTYPE(mysv) == SVt_PVGV) {
3869 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3870 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3877 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3878 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3883 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3885 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3892 char* file = __FILE__;
3894 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
3895 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3896 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3897 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3898 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3899 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3900 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3901 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3902 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);