3 * VMS-specific routines for perl5
5 * Last revised: 29-Jan-1997 by Charles Bailey bailey@genetics.upenn.edu
14 #include <climsgdef.h>
23 #include <lib$routines.h>
32 #include <str$routines.h>
37 /* Older versions of ssdef.h don't have these */
38 #ifndef SS$_INVFILFOROP
39 # define SS$_INVFILFOROP 3930
41 #ifndef SS$_NOSUCHOBJECT
42 # define SS$_NOSUCHOBJECT 2696
45 /* Don't intercept calls to vfork, since my_vfork below needs to
46 * get to the underlying CRTL routine. */
47 #define __DONT_MASK_VFORK
52 /* gcc's header files don't #define direct access macros
53 * corresponding to VAXC's variant structs */
55 # define uic$v_format uic$r_uic_form.uic$v_format
56 # define uic$v_group uic$r_uic_form.uic$v_group
57 # define uic$v_member uic$r_uic_form.uic$v_member
58 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
59 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
60 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
61 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
66 unsigned short int buflen;
67 unsigned short int itmcode;
69 unsigned short int *retlen;
72 static char *__mystrtolower(char *str)
74 if (str) for (; *str; ++str) *str= tolower(*str);
79 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
81 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
82 unsigned short int eqvlen;
83 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
84 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
85 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
86 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
87 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
90 if (!lnm || idx > LNM$_MAX_INDEX) {
91 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
93 if (!eqv) eqv = __my_trnlnm_eqv;
94 lnmlst[1].bufadr = (void *)eqv;
95 lnmdsc.dsc$a_pointer = lnm;
96 lnmdsc.dsc$w_length = strlen(lnm);
97 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
98 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
99 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
101 else if (retsts & 1) {
105 _ckvmssts(retsts); /* Must be an error */
106 return 0; /* Not reached, assuming _ckvmssts() bails out */
108 } /* end of my_trnlnm */
111 * Translate a logical name. Substitute for CRTL getenv() to avoid
112 * memory leak, and to keep my_getenv() and my_setenv() in the same
113 * domain (mostly - my_getenv() need not return a translation from
114 * the process logical name table)
116 * Note: Uses static buffer -- not thread-safe!
118 /*{{{ char *my_getenv(char *lnm)*/
122 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
123 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
124 unsigned long int idx = 0;
127 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
129 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
130 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
131 return __my_getenv_eqv;
134 if ((cp2 = strchr(uplnm,';')) != NULL) {
136 idx = strtoul(cp2+1,NULL,0);
138 trnsuccess = my_trnlnm(uplnm,__my_getenv_eqv,idx);
139 /* If we had a translation index, we're only interested in lnms */
140 if (!trnsuccess && cp2 != NULL) return Nullch;
141 if (trnsuccess) return __my_getenv_eqv;
143 unsigned long int retsts;
144 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
145 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
146 DSC$K_CLASS_S, __my_getenv_eqv};
147 symdsc.dsc$w_length = cp1 - lnm;
148 symdsc.dsc$a_pointer = uplnm;
149 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
150 if (retsts == LIB$_INVSYMNAM) return Nullch;
151 if (retsts != LIB$_NOSUCHSYM) {
152 /* We want to return only logical names or CRTL Unix emulations */
153 if (retsts & 1) return Nullch;
156 /* Try for CRTL emulation of a Unix/POSIX name */
157 else return getenv(uplnm);
162 } /* end of my_getenv() */
165 /*{{{ void prime_env_iter() */
168 /* Fill the %ENV associative array with all logical names we can
169 * find, in preparation for iterating over it.
172 static int primed = 0; /* XXX Not thread-safe!!! */
173 HV *envhv = GvHVn(envgv);
175 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
177 SV *oldrs, *linesv, *eqvsv;
180 /* Perform a dummy fetch as an lval to insure that the hash table is
181 * set up. Otherwise, the hv_store() will turn into a nullop */
182 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
183 /* Also, set up the four "special" keys that the CRTL defines,
184 * whether or not underlying logical names exist. */
185 (void) hv_fetch(envhv,"HOME",4,TRUE);
186 (void) hv_fetch(envhv,"TERM",4,TRUE);
187 (void) hv_fetch(envhv,"PATH",4,TRUE);
188 (void) hv_fetch(envhv,"USER",4,TRUE);
190 /* Now, go get the logical names */
191 if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
192 _ckvmssts(vaxc$errno);
193 /* We use Perl's sv_gets to read from the pipe, since my_popen is
194 * tied to Perl's I/O layer, so it may not return a simple FILE * */
196 rs = newSVpv("\n",1);
197 linesv = newSVpv("",0);
199 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
201 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
205 while (*start != '"' && *start != '=' && *start) start++;
206 if (*start != '"') continue;
207 for (end = ++start; *end && *end != '"'; end++) ;
208 if (*end) *end = '\0';
210 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
211 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
213 warn("Ill-formed logical name |%s| in prime_env_iter",start);
216 else _ckvmssts(vaxc$errno);
219 eqvsv = newSVpv(eqv,eqvlen);
220 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
223 } /* end of prime_env_iter */
227 /*{{{ void my_setenv(char *lnm, char *eqv)*/
229 my_setenv(char *lnm,char *eqv)
230 /* Define a supervisor-mode logical name in the process table.
231 * In the future we'll add tables, attribs, and acmodes,
232 * probably through a different call.
235 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
236 unsigned long int retsts, usermode = PSL$C_USER;
237 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
238 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
239 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
241 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
242 lnmdsc.dsc$w_length = cp1 - lnm;
244 if (!eqv || !*eqv) { /* we're deleting a logical name */
245 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
246 if (retsts == SS$_IVLOGNAM) return;
247 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
249 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
250 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
254 eqvdsc.dsc$w_length = strlen(eqv);
255 eqvdsc.dsc$a_pointer = eqv;
257 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
260 } /* end of my_setenv() */
264 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
265 /* my_crypt - VMS password hashing
266 * my_crypt() provides an interface compatible with the Unix crypt()
267 * C library function, and uses sys$hash_password() to perform VMS
268 * password hashing. The quadword hashed password value is returned
269 * as a NUL-terminated 8 character string. my_crypt() does not change
270 * the case of its string arguments; in order to match the behavior
271 * of LOGINOUT et al., alphabetic characters in both arguments must
272 * be upcased by the caller.
275 my_crypt(const char *textpasswd, const char *usrname)
277 # ifndef UAI$C_PREFERRED_ALGORITHM
278 # define UAI$C_PREFERRED_ALGORITHM 127
280 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
281 unsigned short int salt = 0;
282 unsigned long int sts;
284 unsigned short int dsc$w_length;
285 unsigned char dsc$b_type;
286 unsigned char dsc$b_class;
287 const char * dsc$a_pointer;
288 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
289 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
290 struct itmlst_3 uailst[3] = {
291 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
292 { sizeof salt, UAI$_SALT, &salt, 0},
293 { 0, 0, NULL, NULL}};
296 usrdsc.dsc$w_length = strlen(usrname);
297 usrdsc.dsc$a_pointer = usrname;
298 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
305 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
311 if (sts != RMS$_RNF) return NULL;
314 txtdsc.dsc$w_length = strlen(textpasswd);
315 txtdsc.dsc$a_pointer = textpasswd;
316 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
317 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
320 return (char *) hash;
322 } /* end of my_crypt() */
326 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
327 static char *do_fileify_dirspec(char *, char *, int);
328 static char *do_tovmsspec(char *, char *, int);
330 /*{{{int do_rmdir(char *name)*/
334 char dirfile[NAM$C_MAXRSS+1];
338 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
339 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
340 else retval = kill_file(dirfile);
343 } /* end of do_rmdir */
347 * Delete any file to which user has control access, regardless of whether
348 * delete access is explicitly allowed.
349 * Limitations: User must have write access to parent directory.
350 * Does not block signals or ASTs; if interrupted in midstream
351 * may leave file with an altered ACL.
354 /*{{{int kill_file(char *name)*/
356 kill_file(char *name)
358 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
359 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
360 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
361 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
363 unsigned char myace$b_length;
364 unsigned char myace$b_type;
365 unsigned short int myace$w_flags;
366 unsigned long int myace$l_access;
367 unsigned long int myace$l_ident;
368 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
369 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
370 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
372 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
373 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
374 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
375 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
376 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
377 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
379 /* Expand the input spec using RMS, since the CRTL remove() and
380 * system services won't do this by themselves, so we may miss
381 * a file "hiding" behind a logical name or search list. */
382 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
383 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
384 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
385 /* If not, can changing protections help? */
386 if (vaxc$errno != RMS$_PRV) return -1;
388 /* No, so we get our own UIC to use as a rights identifier,
389 * and the insert an ACE at the head of the ACL which allows us
390 * to delete the file.
392 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
393 fildsc.dsc$w_length = strlen(rspec);
394 fildsc.dsc$a_pointer = rspec;
396 newace.myace$l_ident = oldace.myace$l_ident;
397 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
402 case SS$_NOSUCHOBJECT:
403 set_errno(ENOENT); break;
405 set_errno(ENODEV); break;
407 case SS$_INVFILFOROP:
408 set_errno(EINVAL); break;
410 set_errno(EACCES); break;
414 set_vaxc_errno(aclsts);
417 /* Grab any existing ACEs with this identifier in case we fail */
418 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
419 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
420 || fndsts == SS$_NOMOREACE ) {
421 /* Add the new ACE . . . */
422 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
424 if ((rmsts = remove(name))) {
425 /* We blew it - dir with files in it, no write priv for
426 * parent directory, etc. Put things back the way they were. */
427 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
430 addlst[0].bufadr = &oldace;
431 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
438 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
439 /* We just deleted it, so of course it's not there. Some versions of
440 * VMS seem to return success on the unlock operation anyhow (after all
441 * the unlock is successful), but others don't.
443 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
444 if (aclsts & 1) aclsts = fndsts;
447 set_vaxc_errno(aclsts);
453 } /* end of kill_file() */
456 /* my_utime - update modification time of a file
457 * calling sequence is identical to POSIX utime(), but under
458 * VMS only the modification time is changed; ODS-2 does not
459 * maintain access times. Restrictions differ from the POSIX
460 * definition in that the time can be changed as long as the
461 * caller has permission to execute the necessary IO$_MODIFY $QIO;
462 * no separate checks are made to insure that the caller is the
463 * owner of the file or has special privs enabled.
464 * Code here is based on Joe Meadows' FILE utility.
467 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
468 * to VMS epoch (01-JAN-1858 00:00:00.00)
469 * in 100 ns intervals.
471 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
473 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
474 int my_utime(char *file, struct utimbuf *utimes)
477 long int bintime[2], len = 2, lowbit, unixtime,
478 secscale = 10000000; /* seconds --> 100 ns intervals */
479 unsigned long int chan, iosb[2], retsts;
480 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
481 struct FAB myfab = cc$rms_fab;
482 struct NAM mynam = cc$rms_nam;
483 #if defined (__DECC) && defined (__VAX)
484 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
485 * at least through VMS V6.1, which causes a type-conversion warning.
487 # pragma message save
488 # pragma message disable cvtdiftypes
490 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
492 #if defined (__DECC) && defined (__VAX)
493 /* This should be right after the declaration of myatr, but due
494 * to a bug in VAX DEC C, this takes effect a statement early.
496 # pragma message restore
498 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
499 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
500 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
502 if (file == NULL || *file == '\0') {
504 set_vaxc_errno(LIB$_INVARG);
507 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
509 if (utimes != NULL) {
510 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
511 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
512 * Since time_t is unsigned long int, and lib$emul takes a signed long int
513 * as input, we force the sign bit to be clear by shifting unixtime right
514 * one bit, then multiplying by an extra factor of 2 in lib$emul().
516 lowbit = (utimes->modtime & 1) ? secscale : 0;
517 unixtime = (long int) utimes->modtime;
518 unixtime >> 1; secscale << 1;
519 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
522 set_vaxc_errno(retsts);
525 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
528 set_vaxc_errno(retsts);
533 /* Just get the current time in VMS format directly */
534 retsts = sys$gettim(bintime);
537 set_vaxc_errno(retsts);
542 myfab.fab$l_fna = vmsspec;
543 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
544 myfab.fab$l_nam = &mynam;
545 mynam.nam$l_esa = esa;
546 mynam.nam$b_ess = (unsigned char) sizeof esa;
547 mynam.nam$l_rsa = rsa;
548 mynam.nam$b_rss = (unsigned char) sizeof rsa;
550 /* Look for the file to be affected, letting RMS parse the file
551 * specification for us as well. I have set errno using only
552 * values documented in the utime() man page for VMS POSIX.
554 retsts = sys$parse(&myfab,0,0);
556 set_vaxc_errno(retsts);
557 if (retsts == RMS$_PRV) set_errno(EACCES);
558 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
559 else set_errno(EVMSERR);
562 retsts = sys$search(&myfab,0,0);
564 set_vaxc_errno(retsts);
565 if (retsts == RMS$_PRV) set_errno(EACCES);
566 else if (retsts == RMS$_FNF) set_errno(ENOENT);
567 else set_errno(EVMSERR);
571 devdsc.dsc$w_length = mynam.nam$b_dev;
572 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
574 retsts = sys$assign(&devdsc,&chan,0,0);
576 set_vaxc_errno(retsts);
577 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
578 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
579 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
580 else set_errno(EVMSERR);
584 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
585 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
587 memset((void *) &myfib, 0, sizeof myfib);
589 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
590 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
591 /* This prevents the revision time of the file being reset to the current
592 * time as a result of our IO$_MODIFY $QIO. */
593 myfib.fib$l_acctl = FIB$M_NORECORD;
595 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
596 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
597 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
599 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
600 _ckvmssts(sys$dassgn(chan));
601 if (retsts & 1) retsts = iosb[0];
603 set_vaxc_errno(retsts);
604 if (retsts == SS$_NOPRIV) set_errno(EACCES);
605 else set_errno(EVMSERR);
610 } /* end of my_utime() */
614 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
616 static unsigned long int mbxbufsiz;
617 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
621 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
622 * preprocessor consant BUFSIZ from stdio.h as the size of the
625 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
626 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
628 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
630 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
631 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
633 } /* end of create_mbx() */
635 /*{{{ my_popen and my_pclose*/
638 struct pipe_details *next;
639 PerlIO *fp; /* stdio file pointer to pipe mailbox */
640 int pid; /* PID of subprocess */
641 int mode; /* == 'r' if pipe open for reading */
642 int done; /* subprocess has completed */
643 unsigned long int completion; /* termination status of subprocess */
646 struct exit_control_block
648 struct exit_control_block *flink;
649 unsigned long int (*exit_routine)();
650 unsigned long int arg_count;
651 unsigned long int *status_address;
652 unsigned long int exit_status;
655 static struct pipe_details *open_pipes = NULL;
656 static $DESCRIPTOR(nl_desc, "NL:");
657 static int waitpid_asleep = 0;
659 static unsigned long int
662 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
664 while (open_pipes != NULL) {
665 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
666 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
669 if (!open_pipes->done) /* We tried to be nice . . . */
670 _ckvmssts(sys$delprc(&open_pipes->pid,0));
671 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
676 static struct exit_control_block pipe_exitblock =
677 {(struct exit_control_block *) 0,
678 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
682 popen_completion_ast(struct pipe_details *thispipe)
684 thispipe->done = TRUE;
685 if (waitpid_asleep) {
691 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
693 my_popen(char *cmd, char *mode)
695 static int handler_set_up = FALSE;
697 unsigned short int chan;
698 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
699 struct pipe_details *info;
700 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
701 DSC$K_CLASS_S, mbxname},
702 cmddsc = {0, DSC$K_DTYPE_T,
706 cmddsc.dsc$w_length=strlen(cmd);
707 cmddsc.dsc$a_pointer=cmd;
708 if (cmddsc.dsc$w_length > 255) {
709 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
713 New(7001,info,1,struct pipe_details);
716 create_mbx(&chan,&namdsc);
718 /* open a FILE* onto it */
719 info->fp = PerlIO_open(mbxname, mode);
721 /* give up other channel onto it */
722 _ckvmssts(sys$dassgn(chan));
732 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
733 0 /* name */, &info->pid, &info->completion,
734 0, popen_completion_ast,info,0,0,0));
737 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
738 0 /* name */, &info->pid, &info->completion,
739 0, popen_completion_ast,info,0,0,0));
742 if (!handler_set_up) {
743 _ckvmssts(sys$dclexh(&pipe_exitblock));
744 handler_set_up = TRUE;
746 info->next=open_pipes; /* prepend to list */
749 forkprocess = info->pid;
754 /*{{{ I32 my_pclose(FILE *fp)*/
755 I32 my_pclose(FILE *fp)
757 struct pipe_details *info, *last = NULL;
758 unsigned long int retsts;
760 for (info = open_pipes; info != NULL; last = info, info = info->next)
761 if (info->fp == fp) break;
764 /* get here => no such pipe open */
765 croak("No such pipe open");
767 /* If we were writing to a subprocess, insure that someone reading from
768 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
769 * produce an EOF record in the mailbox. */
770 if (info->mode != 'r') {
771 char devnam[NAM$C_MAXRSS+1], *cp;
772 unsigned long int chan, iosb[2], retsts, retsts2;
773 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
775 if (fgetname(info->fp,devnam)) {
776 /* It oughta be a mailbox, so fgetname should give just the device
777 * name, but just in case . . . */
778 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
779 devdsc.dsc$w_length = strlen(devnam);
780 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
781 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
782 if (retsts & 1) retsts = iosb[0];
783 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
784 if (retsts & 1) retsts = retsts2;
787 else _ckvmssts(vaxc$errno); /* Should never happen */
789 PerlIO_close(info->fp);
791 if (info->done) retsts = info->completion;
792 else waitpid(info->pid,(int *) &retsts,0);
794 /* remove from list of open pipes */
795 if (last) last->next = info->next;
796 else open_pipes = info->next;
801 } /* end of my_pclose() */
803 /* sort-of waitpid; use only with popen() */
804 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
806 my_waitpid(Pid_t pid, int *statusp, int flags)
808 struct pipe_details *info;
810 for (info = open_pipes; info != NULL; info = info->next)
811 if (info->pid == pid) break;
813 if (info != NULL) { /* we know about this child */
814 while (!info->done) {
819 *statusp = info->completion;
822 else { /* we haven't heard of this child */
823 $DESCRIPTOR(intdsc,"0 00:00:01");
824 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
825 unsigned long int interval[2],sts;
828 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
829 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
830 if (ownerpid != mypid)
831 warn("pid %d not a child",pid);
834 _ckvmssts(sys$bintim(&intdsc,interval));
835 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
836 _ckvmssts(sys$schdwk(0,0,interval,0));
837 _ckvmssts(sys$hiber());
841 /* There's no easy way to find the termination status a child we're
842 * not aware of beforehand. If we're really interested in the future,
843 * we can go looking for a termination mailbox, or chase after the
844 * accounting record for the process.
850 } /* end of waitpid() */
855 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
857 my_gconvert(double val, int ndig, int trail, char *buf)
859 static char __gcvtbuf[DBL_DIG+1];
862 loc = buf ? buf : __gcvtbuf;
864 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
866 sprintf(loc,"%.*g",ndig,val);
872 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
873 return gcvt(val,ndig,loc);
876 loc[0] = '0'; loc[1] = '\0';
884 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
885 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
886 * to expand file specification. Allows for a single default file
887 * specification and a simple mask of options. If outbuf is non-NULL,
888 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
889 * the resultant file specification is placed. If outbuf is NULL, the
890 * resultant file specification is placed into a static buffer.
891 * The third argument, if non-NULL, is taken to be a default file
892 * specification string. The fourth argument is unused at present.
893 * rmesexpand() returns the address of the resultant string if
894 * successful, and NULL on error.
897 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
899 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
900 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
901 struct FAB myfab = cc$rms_fab;
902 struct NAM mynam = cc$rms_nam;
904 unsigned long int retsts, haslower = 0;
906 if (!filespec || !*filespec) {
907 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
911 if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
912 else outbuf = __rmsexpand_retbuf;
915 myfab.fab$l_fna = filespec;
916 myfab.fab$b_fns = strlen(filespec);
917 myfab.fab$l_nam = &mynam;
919 if (defspec && *defspec) {
920 myfab.fab$l_dna = defspec;
921 myfab.fab$b_dns = strlen(defspec);
924 mynam.nam$l_esa = esa;
925 mynam.nam$b_ess = sizeof esa;
926 mynam.nam$l_rsa = outbuf;
927 mynam.nam$b_rss = NAM$C_MAXRSS;
929 retsts = sys$parse(&myfab,0,0);
931 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
932 retsts == RMS$_DEV || retsts == RMS$_DEV) {
933 mynam.nam$b_nop |= NAM$M_SYNCHK;
934 retsts = sys$parse(&myfab,0,0);
935 if (retsts & 1) goto expanded;
937 if (out) Safefree(out);
938 set_vaxc_errno(retsts);
939 if (retsts == RMS$_PRV) set_errno(EACCES);
940 else if (retsts == RMS$_DEV) set_errno(ENODEV);
941 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
942 else set_errno(EVMSERR);
945 retsts = sys$search(&myfab,0,0);
946 if (!(retsts & 1) && retsts != RMS$_FNF) {
947 if (out) Safefree(out);
948 set_vaxc_errno(retsts);
949 if (retsts == RMS$_PRV) set_errno(EACCES);
950 else set_errno(EVMSERR);
954 /* If the input filespec contained any lowercase characters,
955 * downcase the result for compatibility with Unix-minded code. */
957 for (out = myfab.fab$l_fna; *out; out++)
958 if (islower(*out)) { haslower = 1; break; }
959 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
960 else { out = esa; speclen = mynam.nam$b_esl; }
961 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
962 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
963 speclen = mynam.nam$l_ver - out;
964 /* If we just had a directory spec on input, $PARSE "helpfully"
965 * adds an empty name and type for us */
966 if (mynam.nam$l_name == mynam.nam$l_type &&
967 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
968 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
969 speclen = mynam.nam$l_name - out;
971 if (haslower) __mystrtolower(out);
973 /* Have we been working with an expanded, but not resultant, spec? */
974 if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
978 /* External entry points */
979 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
980 { return do_rmsexpand(spec,buf,0,def,opt); }
981 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
982 { return do_rmsexpand(spec,buf,1,def,opt); }
986 ** The following routines are provided to make life easier when
987 ** converting among VMS-style and Unix-style directory specifications.
988 ** All will take input specifications in either VMS or Unix syntax. On
989 ** failure, all return NULL. If successful, the routines listed below
990 ** return a pointer to a buffer containing the appropriately
991 ** reformatted spec (and, therefore, subsequent calls to that routine
992 ** will clobber the result), while the routines of the same names with
993 ** a _ts suffix appended will return a pointer to a mallocd string
994 ** containing the appropriately reformatted spec.
995 ** In all cases, only explicit syntax is altered; no check is made that
996 ** the resulting string is valid or that the directory in question
999 ** fileify_dirspec() - convert a directory spec into the name of the
1000 ** directory file (i.e. what you can stat() to see if it's a dir).
1001 ** The style (VMS or Unix) of the result is the same as the style
1002 ** of the parameter passed in.
1003 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1004 ** what you prepend to a filename to indicate what directory it's in).
1005 ** The style (VMS or Unix) of the result is the same as the style
1006 ** of the parameter passed in.
1007 ** tounixpath() - convert a directory spec into a Unix-style path.
1008 ** tovmspath() - convert a directory spec into a VMS-style path.
1009 ** tounixspec() - convert any file spec into a Unix-style file spec.
1010 ** tovmsspec() - convert any file spec into a VMS-style spec.
1012 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
1013 ** Permission is given to distribute this code as part of the Perl
1014 ** standard distribution under the terms of the GNU General Public
1015 ** License or the Perl Artistic License. Copies of each may be
1016 ** found in the Perl standard distribution.
1019 static char *do_tounixspec(char *, char *, int);
1021 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1022 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1024 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1025 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1026 char *retspec, *cp1, *cp2, *lastdir;
1027 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
1029 if (!dir || !*dir) {
1030 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1032 dirlen = strlen(dir);
1033 if (dir[dirlen-1] == '/') --dirlen;
1036 set_vaxc_errno(RMS$_DIR);
1039 if (!strpbrk(dir+1,"/]>:")) {
1040 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1041 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1043 dirlen = strlen(dir);
1046 strncpy(trndir,dir,dirlen);
1047 trndir[dirlen] = '\0';
1050 /* If we were handed a rooted logical name or spec, treat it like a
1051 * simple directory, so that
1052 * $ Define myroot dev:[dir.]
1053 * ... do_fileify_dirspec("myroot",buf,1) ...
1054 * does something useful.
1056 if (!strcmp(dir+dirlen-2,".]")) {
1057 dir[--dirlen] = '\0';
1058 dir[dirlen-1] = ']';
1061 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1062 /* If we've got an explicit filename, we can just shuffle the string. */
1063 if (*(cp1+1)) hasfilename = 1;
1064 /* Similarly, we can just back up a level if we've got multiple levels
1065 of explicit directories in a VMS spec which ends with directories. */
1067 for (cp2 = cp1; cp2 > dir; cp2--) {
1069 *cp2 = *cp1; *cp1 = '\0';
1073 if (*cp2 == '[' || *cp2 == '<') break;
1078 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1079 if (dir[0] == '.') {
1080 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1081 return do_fileify_dirspec("[]",buf,ts);
1082 else if (dir[1] == '.' &&
1083 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1084 return do_fileify_dirspec("[-]",buf,ts);
1086 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1087 dirlen -= 1; /* to last element */
1088 lastdir = strrchr(dir,'/');
1090 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1091 /* If we have "/." or "/..", VMSify it and let the VMS code
1092 * below expand it, rather than repeating the code to handle
1093 * relative components of a filespec here */
1095 if (*(cp1+2) == '.') cp1++;
1096 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1097 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1098 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1099 return do_tounixspec(trndir,buf,ts);
1102 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1105 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1106 !(lastdir = cp1 = strrchr(dir,']')) &&
1107 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1108 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1110 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1111 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1112 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1113 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1114 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1115 (ver || *cp3)))))) {
1117 set_vaxc_errno(RMS$_DIR);
1123 /* If we lead off with a device or rooted logical, add the MFD
1124 if we're specifying a top-level directory. */
1125 if (lastdir && *dir == '/') {
1127 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1134 retlen = dirlen + (addmfd ? 13 : 6);
1135 if (buf) retspec = buf;
1136 else if (ts) New(7009,retspec,retlen+1,char);
1137 else retspec = __fileify_retbuf;
1139 dirlen = lastdir - dir;
1140 memcpy(retspec,dir,dirlen);
1141 strcpy(&retspec[dirlen],"/000000");
1142 strcpy(&retspec[dirlen+7],lastdir);
1145 memcpy(retspec,dir,dirlen);
1146 retspec[dirlen] = '\0';
1148 /* We've picked up everything up to the directory file name.
1149 Now just add the type and version, and we're set. */
1150 strcat(retspec,".dir;1");
1153 else { /* VMS-style directory spec */
1154 char esa[NAM$C_MAXRSS+1], term, *cp;
1155 unsigned long int sts, cmplen, haslower = 0;
1156 struct FAB dirfab = cc$rms_fab;
1157 struct NAM savnam, dirnam = cc$rms_nam;
1159 dirfab.fab$b_fns = strlen(dir);
1160 dirfab.fab$l_fna = dir;
1161 dirfab.fab$l_nam = &dirnam;
1162 dirfab.fab$l_dna = ".DIR;1";
1163 dirfab.fab$b_dns = 6;
1164 dirnam.nam$b_ess = NAM$C_MAXRSS;
1165 dirnam.nam$l_esa = esa;
1167 for (cp = dir; *cp; cp++)
1168 if (islower(*cp)) { haslower = 1; break; }
1169 if (!((sts = sys$parse(&dirfab))&1)) {
1170 if (dirfab.fab$l_sts == RMS$_DIR) {
1171 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1172 sts = sys$parse(&dirfab) & 1;
1176 set_vaxc_errno(dirfab.fab$l_sts);
1182 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1183 /* Yes; fake the fnb bits so we'll check type below */
1184 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1187 if (dirfab.fab$l_sts != RMS$_FNF) {
1189 set_vaxc_errno(dirfab.fab$l_sts);
1192 dirnam = savnam; /* No; just work with potential name */
1195 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1196 cp1 = strchr(esa,']');
1197 if (!cp1) cp1 = strchr(esa,'>');
1198 if (cp1) { /* Should always be true */
1199 dirnam.nam$b_esl -= cp1 - esa - 1;
1200 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1203 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1204 /* Yep; check version while we're at it, if it's there. */
1205 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1206 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1207 /* Something other than .DIR[;1]. Bzzt. */
1209 set_vaxc_errno(RMS$_DIR);
1213 esa[dirnam.nam$b_esl] = '\0';
1214 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1215 /* They provided at least the name; we added the type, if necessary, */
1216 if (buf) retspec = buf; /* in sys$parse() */
1217 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
1218 else retspec = __fileify_retbuf;
1219 strcpy(retspec,esa);
1222 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1223 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1225 dirnam.nam$b_esl -= 9;
1227 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1228 if (cp1 == NULL) return NULL; /* should never happen */
1231 retlen = strlen(esa);
1232 if ((cp1 = strrchr(esa,'.')) != NULL) {
1233 /* There's more than one directory in the path. Just roll back. */
1235 if (buf) retspec = buf;
1236 else if (ts) New(7011,retspec,retlen+7,char);
1237 else retspec = __fileify_retbuf;
1238 strcpy(retspec,esa);
1241 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1242 /* Go back and expand rooted logical name */
1243 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1244 if (!(sys$parse(&dirfab) & 1)) {
1246 set_vaxc_errno(dirfab.fab$l_sts);
1249 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1250 if (buf) retspec = buf;
1251 else if (ts) New(7012,retspec,retlen+16,char);
1252 else retspec = __fileify_retbuf;
1253 cp1 = strstr(esa,"][");
1255 memcpy(retspec,esa,dirlen);
1256 if (!strncmp(cp1+2,"000000]",7)) {
1257 retspec[dirlen-1] = '\0';
1258 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1259 if (*cp1 == '.') *cp1 = ']';
1261 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1262 memcpy(cp1+1,"000000]",7);
1266 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1267 retspec[retlen] = '\0';
1268 /* Convert last '.' to ']' */
1269 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1270 if (*cp1 == '.') *cp1 = ']';
1272 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1273 memcpy(cp1+1,"000000]",7);
1277 else { /* This is a top-level dir. Add the MFD to the path. */
1278 if (buf) retspec = buf;
1279 else if (ts) New(7012,retspec,retlen+16,char);
1280 else retspec = __fileify_retbuf;
1283 while (*cp1 != ':') *(cp2++) = *(cp1++);
1284 strcpy(cp2,":[000000]");
1289 /* We've set up the string up through the filename. Add the
1290 type and version, and we're done. */
1291 strcat(retspec,".DIR;1");
1293 /* $PARSE may have upcased filespec, so convert output to lower
1294 * case if input contained any lowercase characters. */
1295 if (haslower) __mystrtolower(retspec);
1298 } /* end of do_fileify_dirspec() */
1300 /* External entry points */
1301 char *fileify_dirspec(char *dir, char *buf)
1302 { return do_fileify_dirspec(dir,buf,0); }
1303 char *fileify_dirspec_ts(char *dir, char *buf)
1304 { return do_fileify_dirspec(dir,buf,1); }
1306 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1307 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1309 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1310 unsigned long int retlen;
1311 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1313 if (!dir || !*dir) {
1314 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1317 if (*dir) strcpy(trndir,dir);
1318 else getcwd(trndir,sizeof trndir - 1);
1320 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1321 STRLEN trnlen = strlen(trndir);
1323 /* Trap simple rooted lnms, and return lnm:[000000] */
1324 if (!strcmp(trndir+trnlen-2,".]")) {
1325 if (buf) retpath = buf;
1326 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1327 else retpath = __pathify_retbuf;
1328 strcpy(retpath,dir);
1329 strcat(retpath,":[000000]");
1335 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1336 if (*dir == '.' && (*(dir+1) == '\0' ||
1337 (*(dir+1) == '.' && *(dir+2) == '\0')))
1338 retlen = 2 + (*(dir+1) != '\0');
1340 if ( !(cp1 = strrchr(dir,'/')) &&
1341 !(cp1 = strrchr(dir,']')) &&
1342 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1343 if ((cp2 = strchr(cp1,'.')) != NULL &&
1344 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1345 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1346 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1347 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1349 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1350 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1351 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1352 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1353 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1354 (ver || *cp3)))))) {
1356 set_vaxc_errno(RMS$_DIR);
1359 retlen = cp2 - dir + 1;
1361 else { /* No file type present. Treat the filename as a directory. */
1362 retlen = strlen(dir) + 1;
1365 if (buf) retpath = buf;
1366 else if (ts) New(7013,retpath,retlen+1,char);
1367 else retpath = __pathify_retbuf;
1368 strncpy(retpath,dir,retlen-1);
1369 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1370 retpath[retlen-1] = '/'; /* with '/', add it. */
1371 retpath[retlen] = '\0';
1373 else retpath[retlen-1] = '\0';
1375 else { /* VMS-style directory spec */
1376 char esa[NAM$C_MAXRSS+1], *cp;
1377 unsigned long int sts, cmplen, haslower;
1378 struct FAB dirfab = cc$rms_fab;
1379 struct NAM savnam, dirnam = cc$rms_nam;
1381 /* If we've got an explicit filename, we can just shuffle the string. */
1382 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1383 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1384 if ((cp2 = strchr(cp1,'.')) != NULL) {
1386 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1387 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1388 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1389 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1390 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1391 (ver || *cp3)))))) {
1393 set_vaxc_errno(RMS$_DIR);
1397 else { /* No file type, so just draw name into directory part */
1398 for (cp2 = cp1; *cp2; cp2++) ;
1401 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1403 /* We've now got a VMS 'path'; fall through */
1405 dirfab.fab$b_fns = strlen(dir);
1406 dirfab.fab$l_fna = dir;
1407 if (dir[dirfab.fab$b_fns-1] == ']' ||
1408 dir[dirfab.fab$b_fns-1] == '>' ||
1409 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1410 if (buf) retpath = buf;
1411 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1412 else retpath = __pathify_retbuf;
1413 strcpy(retpath,dir);
1416 dirfab.fab$l_dna = ".DIR;1";
1417 dirfab.fab$b_dns = 6;
1418 dirfab.fab$l_nam = &dirnam;
1419 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1420 dirnam.nam$l_esa = esa;
1422 for (cp = dir; *cp; cp++)
1423 if (islower(*cp)) { haslower = 1; break; }
1425 if (!(sts = (sys$parse(&dirfab)&1))) {
1426 if (dirfab.fab$l_sts == RMS$_DIR) {
1427 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1428 sts = sys$parse(&dirfab) & 1;
1432 set_vaxc_errno(dirfab.fab$l_sts);
1438 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1439 if (dirfab.fab$l_sts != RMS$_FNF) {
1441 set_vaxc_errno(dirfab.fab$l_sts);
1444 dirnam = savnam; /* No; just work with potential name */
1447 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1448 /* Yep; check version while we're at it, if it's there. */
1449 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1450 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1451 /* Something other than .DIR[;1]. Bzzt. */
1453 set_vaxc_errno(RMS$_DIR);
1457 /* OK, the type was fine. Now pull any file name into the
1459 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1461 cp1 = strrchr(esa,'>');
1462 *dirnam.nam$l_type = '>';
1465 *(dirnam.nam$l_type + 1) = '\0';
1466 retlen = dirnam.nam$l_type - esa + 2;
1467 if (buf) retpath = buf;
1468 else if (ts) New(7014,retpath,retlen,char);
1469 else retpath = __pathify_retbuf;
1470 strcpy(retpath,esa);
1471 /* $PARSE may have upcased filespec, so convert output to lower
1472 * case if input contained any lowercase characters. */
1473 if (haslower) __mystrtolower(retpath);
1477 } /* end of do_pathify_dirspec() */
1479 /* External entry points */
1480 char *pathify_dirspec(char *dir, char *buf)
1481 { return do_pathify_dirspec(dir,buf,0); }
1482 char *pathify_dirspec_ts(char *dir, char *buf)
1483 { return do_pathify_dirspec(dir,buf,1); }
1485 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1486 static char *do_tounixspec(char *spec, char *buf, int ts)
1488 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1489 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1490 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1492 if (spec == NULL) return NULL;
1493 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1494 if (buf) rslt = buf;
1496 retlen = strlen(spec);
1497 cp1 = strchr(spec,'[');
1498 if (!cp1) cp1 = strchr(spec,'<');
1500 for (cp1++; *cp1; cp1++) {
1501 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1502 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1503 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1506 New(7015,rslt,retlen+2+2*expand,char);
1508 else rslt = __tounixspec_retbuf;
1509 if (strchr(spec,'/') != NULL) {
1516 dirend = strrchr(spec,']');
1517 if (dirend == NULL) dirend = strrchr(spec,'>');
1518 if (dirend == NULL) dirend = strchr(spec,':');
1519 if (dirend == NULL) {
1523 if (*cp2 != '[' && *cp2 != '<') {
1526 else { /* the VMS spec begins with directories */
1528 if (*cp2 == ']' || *cp2 == '>') {
1529 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1532 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1533 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1534 if (ts) Safefree(rslt);
1539 while (*cp3 != ':' && *cp3) cp3++;
1541 if (strchr(cp3,']') != NULL) break;
1542 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1544 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1545 retlen = devlen + dirlen;
1546 Renew(rslt,retlen+1+2*expand,char);
1552 *(cp1++) = *(cp3++);
1553 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1557 else if ( *cp2 == '.') {
1558 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1559 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1565 for (; cp2 <= dirend; cp2++) {
1568 if (*(cp2+1) == '[') cp2++;
1570 else if (*cp2 == ']' || *cp2 == '>') {
1571 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1573 else if (*cp2 == '.') {
1575 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1576 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1577 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1578 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1579 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1581 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1582 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1586 else if (*cp2 == '-') {
1587 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1588 while (*cp2 == '-') {
1590 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1592 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1593 if (ts) Safefree(rslt); /* filespecs like */
1594 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1598 else *(cp1++) = *cp2;
1600 else *(cp1++) = *cp2;
1602 while (*cp2) *(cp1++) = *(cp2++);
1607 } /* end of do_tounixspec() */
1609 /* External entry points */
1610 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1611 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1613 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1614 static char *do_tovmsspec(char *path, char *buf, int ts) {
1615 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1616 char *rslt, *dirend;
1617 register char *cp1, *cp2;
1618 unsigned long int infront = 0, hasdir = 1;
1620 if (path == NULL) return NULL;
1621 if (buf) rslt = buf;
1622 else if (ts) New(7016,rslt,strlen(path)+9,char);
1623 else rslt = __tovmsspec_retbuf;
1624 if (strpbrk(path,"]:>") ||
1625 (dirend = strrchr(path,'/')) == NULL) {
1626 if (path[0] == '.') {
1627 if (path[1] == '\0') strcpy(rslt,"[]");
1628 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1629 else strcpy(rslt,path); /* probably garbage */
1631 else strcpy(rslt,path);
1634 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1635 if (!*(dirend+2)) dirend +=2;
1636 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1637 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1642 char trndev[NAM$C_MAXRSS+1];
1646 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1647 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1649 islnm = my_trnlnm(rslt,trndev,0);
1650 trnend = islnm ? strlen(trndev) - 1 : 0;
1651 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1652 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1653 /* If the first element of the path is a logical name, determine
1654 * whether it has to be translated so we can add more directories. */
1655 if (!islnm || rooted) {
1658 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1662 if (cp2 != dirend) {
1663 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1664 strcpy(rslt,trndev);
1665 cp1 = rslt + trnend;
1678 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1679 cp2 += 2; /* skip over "./" - it's redundant */
1680 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1682 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1683 *(cp1++) = '-'; /* "../" --> "-" */
1686 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1687 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1688 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1689 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1692 if (cp2 > dirend) cp2 = dirend;
1694 else *(cp1++) = '.';
1696 for (; cp2 < dirend; cp2++) {
1698 if (*(cp2-1) == '/') continue;
1699 if (*(cp1-1) != '.') *(cp1++) = '.';
1702 else if (!infront && *cp2 == '.') {
1703 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1704 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1705 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1706 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1707 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1708 else { /* back up over previous directory name */
1710 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1711 if (*(cp1-1) == '[') {
1712 memcpy(cp1,"000000.",7);
1717 if (cp2 == dirend) break;
1719 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1720 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1721 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1722 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1724 *(cp1++) = '.'; /* Simulate trailing '/' */
1725 cp2 += 2; /* for loop will incr this to == dirend */
1727 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1729 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1732 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1733 if (*cp2 == '.') *(cp1++) = '_';
1734 else *(cp1++) = *cp2;
1738 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1739 if (hasdir) *(cp1++) = ']';
1740 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1741 while (*cp2) *(cp1++) = *(cp2++);
1746 } /* end of do_tovmsspec() */
1748 /* External entry points */
1749 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1750 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1752 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1753 static char *do_tovmspath(char *path, char *buf, int ts) {
1754 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1756 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1758 if (path == NULL) return NULL;
1759 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1760 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1761 if (buf) return buf;
1763 vmslen = strlen(vmsified);
1764 New(7017,cp,vmslen+1,char);
1765 memcpy(cp,vmsified,vmslen);
1770 strcpy(__tovmspath_retbuf,vmsified);
1771 return __tovmspath_retbuf;
1774 } /* end of do_tovmspath() */
1776 /* External entry points */
1777 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1778 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1781 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1782 static char *do_tounixpath(char *path, char *buf, int ts) {
1783 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1785 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1787 if (path == NULL) return NULL;
1788 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1789 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1790 if (buf) return buf;
1792 unixlen = strlen(unixified);
1793 New(7017,cp,unixlen+1,char);
1794 memcpy(cp,unixified,unixlen);
1799 strcpy(__tounixpath_retbuf,unixified);
1800 return __tounixpath_retbuf;
1803 } /* end of do_tounixpath() */
1805 /* External entry points */
1806 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1807 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1810 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1812 *****************************************************************************
1814 * Copyright (C) 1989-1994 by *
1815 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1817 * Permission is hereby granted for the reproduction of this software, *
1818 * on condition that this copyright notice is included in the reproduction, *
1819 * and that such reproduction is not for purposes of profit or material *
1822 * 27-Aug-1994 Modified for inclusion in perl5 *
1823 * by Charles Bailey bailey@genetics.upenn.edu *
1824 *****************************************************************************
1828 * getredirection() is intended to aid in porting C programs
1829 * to VMS (Vax-11 C). The native VMS environment does not support
1830 * '>' and '<' I/O redirection, or command line wild card expansion,
1831 * or a command line pipe mechanism using the '|' AND background
1832 * command execution '&'. All of these capabilities are provided to any
1833 * C program which calls this procedure as the first thing in the
1835 * The piping mechanism will probably work with almost any 'filter' type
1836 * of program. With suitable modification, it may useful for other
1837 * portability problems as well.
1839 * Author: Mark Pizzolato mark@infocomm.com
1843 struct list_item *next;
1847 static void add_item(struct list_item **head,
1848 struct list_item **tail,
1852 static void expand_wild_cards(char *item,
1853 struct list_item **head,
1854 struct list_item **tail,
1857 static int background_process(int argc, char **argv);
1859 static void pipe_and_fork(char **cmargv);
1861 /*{{{ void getredirection(int *ac, char ***av)*/
1863 getredirection(int *ac, char ***av)
1865 * Process vms redirection arg's. Exit if any error is seen.
1866 * If getredirection() processes an argument, it is erased
1867 * from the vector. getredirection() returns a new argc and argv value.
1868 * In the event that a background command is requested (by a trailing "&"),
1869 * this routine creates a background subprocess, and simply exits the program.
1871 * Warning: do not try to simplify the code for vms. The code
1872 * presupposes that getredirection() is called before any data is
1873 * read from stdin or written to stdout.
1875 * Normal usage is as follows:
1881 * getredirection(&argc, &argv);
1885 int argc = *ac; /* Argument Count */
1886 char **argv = *av; /* Argument Vector */
1887 char *ap; /* Argument pointer */
1888 int j; /* argv[] index */
1889 int item_count = 0; /* Count of Items in List */
1890 struct list_item *list_head = 0; /* First Item in List */
1891 struct list_item *list_tail; /* Last Item in List */
1892 char *in = NULL; /* Input File Name */
1893 char *out = NULL; /* Output File Name */
1894 char *outmode = "w"; /* Mode to Open Output File */
1895 char *err = NULL; /* Error File Name */
1896 char *errmode = "w"; /* Mode to Open Error File */
1897 int cmargc = 0; /* Piped Command Arg Count */
1898 char **cmargv = NULL;/* Piped Command Arg Vector */
1901 * First handle the case where the last thing on the line ends with
1902 * a '&'. This indicates the desire for the command to be run in a
1903 * subprocess, so we satisfy that desire.
1906 if (0 == strcmp("&", ap))
1907 exit(background_process(--argc, argv));
1908 if (*ap && '&' == ap[strlen(ap)-1])
1910 ap[strlen(ap)-1] = '\0';
1911 exit(background_process(argc, argv));
1914 * Now we handle the general redirection cases that involve '>', '>>',
1915 * '<', and pipes '|'.
1917 for (j = 0; j < argc; ++j)
1919 if (0 == strcmp("<", argv[j]))
1923 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1924 exit(LIB$_WRONUMARG);
1929 if ('<' == *(ap = argv[j]))
1934 if (0 == strcmp(">", ap))
1938 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1939 exit(LIB$_WRONUMARG);
1958 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1959 exit(LIB$_WRONUMARG);
1963 if (('2' == *ap) && ('>' == ap[1]))
1980 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1981 exit(LIB$_WRONUMARG);
1985 if (0 == strcmp("|", argv[j]))
1989 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1990 exit(LIB$_WRONUMARG);
1992 cmargc = argc-(j+1);
1993 cmargv = &argv[j+1];
1997 if ('|' == *(ap = argv[j]))
2005 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2008 * Allocate and fill in the new argument vector, Some Unix's terminate
2009 * the list with an extra null pointer.
2011 New(7002, argv, item_count+1, char *);
2013 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2014 argv[j] = list_head->value;
2020 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2021 exit(LIB$_INVARGORD);
2023 pipe_and_fork(cmargv);
2026 /* Check for input from a pipe (mailbox) */
2028 if (in == NULL && 1 == isapipe(0))
2030 char mbxname[L_tmpnam];
2032 long int dvi_item = DVI$_DEVBUFSIZ;
2033 $DESCRIPTOR(mbxnam, "");
2034 $DESCRIPTOR(mbxdevnam, "");
2036 /* Input from a pipe, reopen it in binary mode to disable */
2037 /* carriage control processing. */
2039 PerlIO_getname(stdin, mbxname);
2040 mbxnam.dsc$a_pointer = mbxname;
2041 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2042 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2043 mbxdevnam.dsc$a_pointer = mbxname;
2044 mbxdevnam.dsc$w_length = sizeof(mbxname);
2045 dvi_item = DVI$_DEVNAM;
2046 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2047 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2050 freopen(mbxname, "rb", stdin);
2053 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2057 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2059 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2062 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2064 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2069 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2071 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2075 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2080 #ifdef ARGPROC_DEBUG
2081 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2082 for (j = 0; j < *ac; ++j)
2083 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2085 /* Clear errors we may have hit expanding wildcards, so they don't
2086 show up in Perl's $! later */
2087 set_errno(0); set_vaxc_errno(1);
2088 } /* end of getredirection() */
2091 static void add_item(struct list_item **head,
2092 struct list_item **tail,
2098 New(7003,*head,1,struct list_item);
2102 New(7004,(*tail)->next,1,struct list_item);
2103 *tail = (*tail)->next;
2105 (*tail)->value = value;
2109 static void expand_wild_cards(char *item,
2110 struct list_item **head,
2111 struct list_item **tail,
2115 unsigned long int context = 0;
2121 char vmsspec[NAM$C_MAXRSS+1];
2122 $DESCRIPTOR(filespec, "");
2123 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2124 $DESCRIPTOR(resultspec, "");
2125 unsigned long int zero = 0, sts;
2127 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2129 add_item(head, tail, item, count);
2132 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2133 resultspec.dsc$b_class = DSC$K_CLASS_D;
2134 resultspec.dsc$a_pointer = NULL;
2135 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2136 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2137 if (!isunix || !filespec.dsc$a_pointer)
2138 filespec.dsc$a_pointer = item;
2139 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2141 * Only return version specs, if the caller specified a version
2143 had_version = strchr(item, ';');
2145 * Only return device and directory specs, if the caller specifed either.
2147 had_device = strchr(item, ':');
2148 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2150 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2151 &defaultspec, 0, 0, &zero))))
2156 New(7005,string,resultspec.dsc$w_length+1,char);
2157 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2158 string[resultspec.dsc$w_length] = '\0';
2159 if (NULL == had_version)
2160 *((char *)strrchr(string, ';')) = '\0';
2161 if ((!had_directory) && (had_device == NULL))
2163 if (NULL == (devdir = strrchr(string, ']')))
2164 devdir = strrchr(string, '>');
2165 strcpy(string, devdir + 1);
2168 * Be consistent with what the C RTL has already done to the rest of
2169 * the argv items and lowercase all of these names.
2171 for (c = string; *c; ++c)
2174 if (isunix) trim_unixpath(string,item,1);
2175 add_item(head, tail, string, count);
2178 if (sts != RMS$_NMF)
2180 set_vaxc_errno(sts);
2186 set_errno(ENOENT); break;
2188 set_errno(ENODEV); break;
2191 set_errno(EINVAL); break;
2193 set_errno(EACCES); break;
2195 _ckvmssts_noperl(sts);
2199 add_item(head, tail, item, count);
2200 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2201 _ckvmssts_noperl(lib$find_file_end(&context));
2204 static int child_st[2];/* Event Flag set when child process completes */
2206 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2208 static unsigned long int exit_handler(int *status)
2212 if (0 == child_st[0])
2214 #ifdef ARGPROC_DEBUG
2215 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2217 fflush(stdout); /* Have to flush pipe for binary data to */
2218 /* terminate properly -- <tp@mccall.com> */
2219 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2220 sys$dassgn(child_chan);
2222 sys$synch(0, child_st);
2227 static void sig_child(int chan)
2229 #ifdef ARGPROC_DEBUG
2230 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2232 if (child_st[0] == 0)
2236 static struct exit_control_block exit_block =
2241 &exit_block.exit_status,
2245 static void pipe_and_fork(char **cmargv)
2248 $DESCRIPTOR(cmddsc, "");
2249 static char mbxname[64];
2250 $DESCRIPTOR(mbxdsc, mbxname);
2252 unsigned long int zero = 0, one = 1;
2254 strcpy(subcmd, cmargv[0]);
2255 for (j = 1; NULL != cmargv[j]; ++j)
2257 strcat(subcmd, " \"");
2258 strcat(subcmd, cmargv[j]);
2259 strcat(subcmd, "\"");
2261 cmddsc.dsc$a_pointer = subcmd;
2262 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2264 create_mbx(&child_chan,&mbxdsc);
2265 #ifdef ARGPROC_DEBUG
2266 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2267 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2269 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2270 0, &pid, child_st, &zero, sig_child,
2272 #ifdef ARGPROC_DEBUG
2273 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2275 sys$dclexh(&exit_block);
2276 if (NULL == freopen(mbxname, "wb", stdout))
2278 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2282 static int background_process(int argc, char **argv)
2284 char command[2048] = "$";
2285 $DESCRIPTOR(value, "");
2286 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2287 static $DESCRIPTOR(null, "NLA0:");
2288 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2290 $DESCRIPTOR(pidstr, "");
2292 unsigned long int flags = 17, one = 1, retsts;
2294 strcat(command, argv[0]);
2297 strcat(command, " \"");
2298 strcat(command, *(++argv));
2299 strcat(command, "\"");
2301 value.dsc$a_pointer = command;
2302 value.dsc$w_length = strlen(value.dsc$a_pointer);
2303 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2304 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2305 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2306 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2309 _ckvmssts_noperl(retsts);
2311 #ifdef ARGPROC_DEBUG
2312 PerlIO_printf(Perl_debug_log, "%s\n", command);
2314 sprintf(pidstring, "%08X", pid);
2315 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2316 pidstr.dsc$a_pointer = pidstring;
2317 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2318 lib$set_symbol(&pidsymbol, &pidstr);
2322 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2325 * Trim Unix-style prefix off filespec, so it looks like what a shell
2326 * glob expansion would return (i.e. from specified prefix on, not
2327 * full path). Note that returned filespec is Unix-style, regardless
2328 * of whether input filespec was VMS-style or Unix-style.
2330 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2331 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2332 * vector of options; at present, only bit 0 is used, and if set tells
2333 * trim unixpath to try the current default directory as a prefix when
2334 * presented with a possibly ambiguous ... wildcard.
2336 * Returns !=0 on success, with trimmed filespec replacing contents of
2337 * fspec, and 0 on failure, with contents of fpsec unchanged.
2339 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2341 trim_unixpath(char *fspec, char *wildspec, int opts)
2343 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2344 *template, *base, *end, *cp1, *cp2;
2345 register int tmplen, reslen = 0, dirs = 0;
2347 if (!wildspec || !fspec) return 0;
2348 if (strpbrk(wildspec,"]>:") != NULL) {
2349 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2350 else template = unixwild;
2352 else template = wildspec;
2353 if (strpbrk(fspec,"]>:") != NULL) {
2354 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2355 else base = unixified;
2356 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2357 * check to see that final result fits into (isn't longer than) fspec */
2358 reslen = strlen(fspec);
2362 /* No prefix or absolute path on wildcard, so nothing to remove */
2363 if (!*template || *template == '/') {
2364 if (base == fspec) return 1;
2365 tmplen = strlen(unixified);
2366 if (tmplen > reslen) return 0; /* not enough space */
2367 /* Copy unixified resultant, including trailing NUL */
2368 memmove(fspec,unixified,tmplen+1);
2372 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2373 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2374 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2375 for (cp1 = end ;cp1 >= base; cp1--)
2376 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2378 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2382 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2383 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2384 int ells = 1, totells, segdirs, match;
2385 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2386 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2388 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2390 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2391 if (ellipsis == template && opts & 1) {
2392 /* Template begins with an ellipsis. Since we can't tell how many
2393 * directory names at the front of the resultant to keep for an
2394 * arbitrary starting point, we arbitrarily choose the current
2395 * default directory as a starting point. If it's there as a prefix,
2396 * clip it off. If not, fall through and act as if the leading
2397 * ellipsis weren't there (i.e. return shortest possible path that
2398 * could match template).
2400 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2401 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2402 if (_tolower(*cp1) != _tolower(*cp2)) break;
2403 segdirs = dirs - totells; /* Min # of dirs we must have left */
2404 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2405 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2406 memcpy(fspec,cp2+1,end - cp2);
2410 /* First off, back up over constant elements at end of path */
2412 for (front = end ; front >= base; front--)
2413 if (*front == '/' && !dirs--) { front++; break; }
2415 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2416 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2417 if (cp1 != '\0') return 0; /* Path too long. */
2419 *cp2 = '\0'; /* Pick up with memcpy later */
2420 lcfront = lcres + (front - base);
2421 /* Now skip over each ellipsis and try to match the path in front of it. */
2423 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2424 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2425 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2426 if (cp1 < template) break; /* template started with an ellipsis */
2427 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2428 ellipsis = cp1; continue;
2430 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2432 for (segdirs = 0, cp2 = tpl;
2433 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2435 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2436 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2437 if (*cp2 == '/') segdirs++;
2439 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2440 /* Back up at least as many dirs as in template before matching */
2441 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2442 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2443 for (match = 0; cp1 > lcres;) {
2444 resdsc.dsc$a_pointer = cp1;
2445 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2447 if (match == 1) lcfront = cp1;
2449 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2451 if (!match) return 0; /* Can't find prefix ??? */
2452 if (match > 1 && opts & 1) {
2453 /* This ... wildcard could cover more than one set of dirs (i.e.
2454 * a set of similar dir names is repeated). If the template
2455 * contains more than 1 ..., upstream elements could resolve the
2456 * ambiguity, but it's not worth a full backtracking setup here.
2457 * As a quick heuristic, clip off the current default directory
2458 * if it's present to find the trimmed spec, else use the
2459 * shortest string that this ... could cover.
2461 char def[NAM$C_MAXRSS+1], *st;
2463 if (getcwd(def, sizeof def,0) == NULL) return 0;
2464 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2465 if (_tolower(*cp1) != _tolower(*cp2)) break;
2466 segdirs = dirs - totells; /* Min # of dirs we must have left */
2467 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2468 if (*cp1 == '\0' && *cp2 == '/') {
2469 memcpy(fspec,cp2+1,end - cp2);
2472 /* Nope -- stick with lcfront from above and keep going. */
2475 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2480 } /* end of trim_unixpath() */
2485 * VMS readdir() routines.
2486 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2487 * This code has no copyright.
2489 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2490 * Minor modifications to original routines.
2493 /* Number of elements in vms_versions array */
2494 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2497 * Open a directory, return a handle for later use.
2499 /*{{{ DIR *opendir(char*name) */
2504 char dir[NAM$C_MAXRSS+1];
2506 /* Get memory for the handle, and the pattern. */
2508 if (do_tovmspath(name,dir,0) == NULL) {
2509 Safefree((char *)dd);
2512 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2514 /* Fill in the fields; mainly playing with the descriptor. */
2515 (void)sprintf(dd->pattern, "%s*.*",dir);
2518 dd->vms_wantversions = 0;
2519 dd->pat.dsc$a_pointer = dd->pattern;
2520 dd->pat.dsc$w_length = strlen(dd->pattern);
2521 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2522 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2525 } /* end of opendir() */
2529 * Set the flag to indicate we want versions or not.
2531 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2533 vmsreaddirversions(DIR *dd, int flag)
2535 dd->vms_wantversions = flag;
2540 * Free up an opened directory.
2542 /*{{{ void closedir(DIR *dd)*/
2546 (void)lib$find_file_end(&dd->context);
2547 Safefree(dd->pattern);
2548 Safefree((char *)dd);
2553 * Collect all the version numbers for the current file.
2559 struct dsc$descriptor_s pat;
2560 struct dsc$descriptor_s res;
2562 char *p, *text, buff[sizeof dd->entry.d_name];
2564 unsigned long context, tmpsts;
2566 /* Convenient shorthand. */
2569 /* Add the version wildcard, ignoring the "*.*" put on before */
2570 i = strlen(dd->pattern);
2571 New(7008,text,i + e->d_namlen + 3,char);
2572 (void)strcpy(text, dd->pattern);
2573 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2575 /* Set up the pattern descriptor. */
2576 pat.dsc$a_pointer = text;
2577 pat.dsc$w_length = i + e->d_namlen - 1;
2578 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2579 pat.dsc$b_class = DSC$K_CLASS_S;
2581 /* Set up result descriptor. */
2582 res.dsc$a_pointer = buff;
2583 res.dsc$w_length = sizeof buff - 2;
2584 res.dsc$b_dtype = DSC$K_DTYPE_T;
2585 res.dsc$b_class = DSC$K_CLASS_S;
2587 /* Read files, collecting versions. */
2588 for (context = 0, e->vms_verscount = 0;
2589 e->vms_verscount < VERSIZE(e);
2590 e->vms_verscount++) {
2591 tmpsts = lib$find_file(&pat, &res, &context);
2592 if (tmpsts == RMS$_NMF || context == 0) break;
2594 buff[sizeof buff - 1] = '\0';
2595 if ((p = strchr(buff, ';')))
2596 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2598 e->vms_versions[e->vms_verscount] = -1;
2601 _ckvmssts(lib$find_file_end(&context));
2604 } /* end of collectversions() */
2607 * Read the next entry from the directory.
2609 /*{{{ struct dirent *readdir(DIR *dd)*/
2613 struct dsc$descriptor_s res;
2614 char *p, buff[sizeof dd->entry.d_name];
2615 unsigned long int tmpsts;
2617 /* Set up result descriptor, and get next file. */
2618 res.dsc$a_pointer = buff;
2619 res.dsc$w_length = sizeof buff - 2;
2620 res.dsc$b_dtype = DSC$K_DTYPE_T;
2621 res.dsc$b_class = DSC$K_CLASS_S;
2622 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2623 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2624 if (!(tmpsts & 1)) {
2625 set_vaxc_errno(tmpsts);
2628 set_errno(EACCES); break;
2630 set_errno(ENODEV); break;
2633 set_errno(ENOENT); break;
2640 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2641 buff[sizeof buff - 1] = '\0';
2642 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2645 /* Skip any directory component and just copy the name. */
2646 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2647 else (void)strcpy(dd->entry.d_name, buff);
2649 /* Clobber the version. */
2650 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2652 dd->entry.d_namlen = strlen(dd->entry.d_name);
2653 dd->entry.vms_verscount = 0;
2654 if (dd->vms_wantversions) collectversions(dd);
2657 } /* end of readdir() */
2661 * Return something that can be used in a seekdir later.
2663 /*{{{ long telldir(DIR *dd)*/
2672 * Return to a spot where we used to be. Brute force.
2674 /*{{{ void seekdir(DIR *dd,long count)*/
2676 seekdir(DIR *dd, long count)
2678 int vms_wantversions;
2680 /* If we haven't done anything yet... */
2684 /* Remember some state, and clear it. */
2685 vms_wantversions = dd->vms_wantversions;
2686 dd->vms_wantversions = 0;
2687 _ckvmssts(lib$find_file_end(&dd->context));
2690 /* The increment is in readdir(). */
2691 for (dd->count = 0; dd->count < count; )
2694 dd->vms_wantversions = vms_wantversions;
2696 } /* end of seekdir() */
2699 /* VMS subprocess management
2701 * my_vfork() - just a vfork(), after setting a flag to record that
2702 * the current script is trying a Unix-style fork/exec.
2704 * vms_do_aexec() and vms_do_exec() are called in response to the
2705 * perl 'exec' function. If this follows a vfork call, then they
2706 * call out the the regular perl routines in doio.c which do an
2707 * execvp (for those who really want to try this under VMS).
2708 * Otherwise, they do exactly what the perl docs say exec should
2709 * do - terminate the current script and invoke a new command
2710 * (See below for notes on command syntax.)
2712 * do_aspawn() and do_spawn() implement the VMS side of the perl
2713 * 'system' function.
2715 * Note on command arguments to perl 'exec' and 'system': When handled
2716 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2717 * are concatenated to form a DCL command string. If the first arg
2718 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2719 * the the command string is hrnded off to DCL directly. Otherwise,
2720 * the first token of the command is taken as the filespec of an image
2721 * to run. The filespec is expanded using a default type of '.EXE' and
2722 * the process defaults for device, directory, etc., and the resultant
2723 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2724 * the command string as parameters. This is perhaps a bit compicated,
2725 * but I hope it will form a happy medium between what VMS folks expect
2726 * from lib$spawn and what Unix folks expect from exec.
2729 static int vfork_called;
2731 /*{{{int my_vfork()*/
2741 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2749 if (VMScmd.dsc$a_pointer) {
2750 Safefree(VMScmd.dsc$a_pointer);
2751 VMScmd.dsc$w_length = 0;
2752 VMScmd.dsc$a_pointer = Nullch;
2757 setup_argstr(SV *really, SV **mark, SV **sp)
2759 char *junk, *tmps = Nullch;
2760 register size_t cmdlen = 0;
2766 tmps = SvPV(really,rlen);
2773 for (idx++; idx <= sp; idx++) {
2775 junk = SvPVx(*idx,rlen);
2776 cmdlen += rlen ? rlen + 1 : 0;
2779 New(401,Cmd,cmdlen+1,char);
2781 if (tmps && *tmps) {
2786 while (++mark <= sp) {
2789 strcat(Cmd,SvPVx(*mark,na));
2794 } /* end of setup_argstr() */
2797 static unsigned long int
2798 setup_cmddsc(char *cmd, int check_img)
2800 char resspec[NAM$C_MAXRSS+1];
2801 $DESCRIPTOR(defdsc,".EXE");
2802 $DESCRIPTOR(resdsc,resspec);
2803 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2804 unsigned long int cxt = 0, flags = 1, retsts;
2805 register char *s, *rest, *cp;
2806 register int isdcl = 0;
2809 while (*s && isspace(*s)) s++;
2811 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2812 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2813 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2814 if (*cp == ':' || *cp == '[' || *cp == '<') {
2822 if (isdcl) { /* It's a DCL command, just do it. */
2823 VMScmd.dsc$w_length = strlen(cmd);
2825 VMScmd.dsc$a_pointer = Cmd;
2826 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2828 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2830 else { /* assume first token is an image spec */
2832 while (*s && !isspace(*s)) s++;
2834 imgdsc.dsc$a_pointer = cmd;
2835 imgdsc.dsc$w_length = s - cmd;
2836 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2837 if (!(retsts & 1)) {
2838 /* just hand off status values likely to be due to user error */
2839 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2840 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2841 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2842 else { _ckvmssts(retsts); }
2845 _ckvmssts(lib$find_file_end(&cxt));
2847 while (*s && !isspace(*s)) s++;
2849 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2850 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2851 strcat(VMScmd.dsc$a_pointer,resspec);
2852 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2853 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2857 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2859 } /* end of setup_cmddsc() */
2862 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2864 vms_do_aexec(SV *really,SV **mark,SV **sp)
2867 if (vfork_called) { /* this follows a vfork - act Unixish */
2869 if (vfork_called < 0) {
2870 warn("Internal inconsistency in tracking vforks");
2873 else return do_aexec(really,mark,sp);
2875 /* no vfork - act VMSish */
2876 return vms_do_exec(setup_argstr(really,mark,sp));
2881 } /* end of vms_do_aexec() */
2884 /* {{{bool vms_do_exec(char *cmd) */
2886 vms_do_exec(char *cmd)
2889 if (vfork_called) { /* this follows a vfork - act Unixish */
2891 if (vfork_called < 0) {
2892 warn("Internal inconsistency in tracking vforks");
2895 else return do_exec(cmd);
2898 { /* no vfork - act VMSish */
2899 unsigned long int retsts;
2901 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2902 retsts = lib$do_command(&VMScmd);
2905 set_vaxc_errno(retsts);
2907 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2913 } /* end of vms_do_exec() */
2916 unsigned long int do_spawn(char *);
2918 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2920 do_aspawn(SV *really,SV **mark,SV **sp)
2922 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2925 } /* end of do_aspawn() */
2928 /* {{{unsigned long int do_spawn(char *cmd) */
2932 unsigned long int substs, hadcmd = 1;
2934 if (!cmd || !*cmd) {
2936 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2938 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2939 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2944 set_vaxc_errno(substs);
2946 warn("Can't spawn \"%s\": %s",
2947 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2952 } /* end of do_spawn() */
2956 * A simple fwrite replacement which outputs itmsz*nitm chars without
2957 * introducing record boundaries every itmsz chars.
2959 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2961 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2963 register char *cp, *end;
2965 end = (char *)src + itmsz * nitm;
2967 while ((char *)src <= end) {
2968 for (cp = src; cp <= end; cp++) if (!*cp) break;
2969 if (fputs(src,dest) == EOF) return EOF;
2971 if (fputc('\0',dest) == EOF) return EOF;
2977 } /* end of my_fwrite() */
2981 * Here are replacements for the following Unix routines in the VMS environment:
2982 * getpwuid Get information for a particular UIC or UID
2983 * getpwnam Get information for a named user
2984 * getpwent Get information for each user in the rights database
2985 * setpwent Reset search to the start of the rights database
2986 * endpwent Finish searching for users in the rights database
2988 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2989 * (defined in pwd.h), which contains the following fields:-
2991 * char *pw_name; Username (in lower case)
2992 * char *pw_passwd; Hashed password
2993 * unsigned int pw_uid; UIC
2994 * unsigned int pw_gid; UIC group number
2995 * char *pw_unixdir; Default device/directory (VMS-style)
2996 * char *pw_gecos; Owner name
2997 * char *pw_dir; Default device/directory (Unix-style)
2998 * char *pw_shell; Default CLI name (eg. DCL)
3000 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3002 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3003 * not the UIC member number (eg. what's returned by getuid()),
3004 * getpwuid() can accept either as input (if uid is specified, the caller's
3005 * UIC group is used), though it won't recognise gid=0.
3007 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3008 * information about other users in your group or in other groups, respectively.
3009 * If the required privilege is not available, then these routines fill only
3010 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3013 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3016 /* sizes of various UAF record fields */
3017 #define UAI$S_USERNAME 12
3018 #define UAI$S_IDENT 31
3019 #define UAI$S_OWNER 31
3020 #define UAI$S_DEFDEV 31
3021 #define UAI$S_DEFDIR 63
3022 #define UAI$S_DEFCLI 31
3025 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3026 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3027 (uic).uic$v_group != UIC$K_WILD_GROUP)
3029 static char __empty[]= "";
3030 static struct passwd __passwd_empty=
3031 {(char *) __empty, (char *) __empty, 0, 0,
3032 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3033 static int contxt= 0;
3034 static struct passwd __pwdcache;
3035 static char __pw_namecache[UAI$S_IDENT+1];
3038 * This routine does most of the work extracting the user information.
3040 static int fillpasswd (const char *name, struct passwd *pwd)
3043 unsigned char length;
3044 char pw_gecos[UAI$S_OWNER+1];
3046 static union uicdef uic;
3048 unsigned char length;
3049 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3052 unsigned char length;
3053 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3056 unsigned char length;
3057 char pw_shell[UAI$S_DEFCLI+1];
3059 static char pw_passwd[UAI$S_PWD+1];
3061 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3062 struct dsc$descriptor_s name_desc;
3063 unsigned long int sts;
3065 static struct itmlst_3 itmlst[]= {
3066 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3067 {sizeof(uic), UAI$_UIC, &uic, &luic},
3068 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3069 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3070 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3071 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3072 {0, 0, NULL, NULL}};
3074 name_desc.dsc$w_length= strlen(name);
3075 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3076 name_desc.dsc$b_class= DSC$K_CLASS_S;
3077 name_desc.dsc$a_pointer= (char *) name;
3079 /* Note that sys$getuai returns many fields as counted strings. */
3080 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3081 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3082 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3084 else { _ckvmssts(sts); }
3085 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3087 if ((int) owner.length < lowner) lowner= (int) owner.length;
3088 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3089 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3090 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3091 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3092 owner.pw_gecos[lowner]= '\0';
3093 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3094 defcli.pw_shell[ldefcli]= '\0';
3095 if (valid_uic(uic)) {
3096 pwd->pw_uid= uic.uic$l_uic;
3097 pwd->pw_gid= uic.uic$v_group;
3100 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3101 pwd->pw_passwd= pw_passwd;
3102 pwd->pw_gecos= owner.pw_gecos;
3103 pwd->pw_dir= defdev.pw_dir;
3104 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3105 pwd->pw_shell= defcli.pw_shell;
3106 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3108 ldir= strlen(pwd->pw_unixdir) - 1;
3109 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3112 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3113 __mystrtolower(pwd->pw_unixdir);
3118 * Get information for a named user.
3120 /*{{{struct passwd *getpwnam(char *name)*/
3121 struct passwd *my_getpwnam(char *name)
3123 struct dsc$descriptor_s name_desc;
3125 unsigned long int status, stat;
3127 __pwdcache = __passwd_empty;
3128 if (!fillpasswd(name, &__pwdcache)) {
3129 /* We still may be able to determine pw_uid and pw_gid */
3130 name_desc.dsc$w_length= strlen(name);
3131 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3132 name_desc.dsc$b_class= DSC$K_CLASS_S;
3133 name_desc.dsc$a_pointer= (char *) name;
3134 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3135 __pwdcache.pw_uid= uic.uic$l_uic;
3136 __pwdcache.pw_gid= uic.uic$v_group;
3139 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
3140 set_vaxc_errno(stat);
3141 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
3144 else { _ckvmssts(stat); }
3147 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3148 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3149 __pwdcache.pw_name= __pw_namecache;
3151 } /* end of my_getpwnam() */
3155 * Get information for a particular UIC or UID.
3156 * Called by my_getpwent with uid=-1 to list all users.
3158 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3159 struct passwd *my_getpwuid(Uid_t uid)
3161 const $DESCRIPTOR(name_desc,__pw_namecache);
3162 unsigned short lname;
3164 unsigned long int status;
3166 if (uid == (unsigned int) -1) {
3168 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3169 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3170 set_vaxc_errno(status);
3171 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3175 else { _ckvmssts(status); }
3176 } while (!valid_uic (uic));
3180 if (!uic.uic$v_group)
3181 uic.uic$v_group= getgid();
3183 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3184 else status = SS$_IVIDENT;
3185 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3186 status == RMS$_PRV) {
3187 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3190 else { _ckvmssts(status); }
3192 __pw_namecache[lname]= '\0';
3193 __mystrtolower(__pw_namecache);
3195 __pwdcache = __passwd_empty;
3196 __pwdcache.pw_name = __pw_namecache;
3198 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3199 The identifier's value is usually the UIC, but it doesn't have to be,
3200 so if we can, we let fillpasswd update this. */
3201 __pwdcache.pw_uid = uic.uic$l_uic;
3202 __pwdcache.pw_gid = uic.uic$v_group;
3204 fillpasswd(__pw_namecache, &__pwdcache);
3207 } /* end of my_getpwuid() */
3211 * Get information for next user.
3213 /*{{{struct passwd *my_getpwent()*/
3214 struct passwd *my_getpwent()
3216 return (my_getpwuid((unsigned int) -1));
3221 * Finish searching rights database for users.
3223 /*{{{void my_endpwent()*/
3227 _ckvmssts(sys$finish_rdb(&contxt));
3235 * If the CRTL has a real gmtime(), use it, else look for the logical
3236 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
3237 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
3238 * to translate to the number of seconds which must be added to UTC
3239 * to get to the local time of the system.
3240 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3243 /*{{{struct tm *my_gmtime(const time_t *time)*/
3244 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
3245 * so we can call the CRTL's routine to see if it works.
3249 my_gmtime(const time_t *time)
3251 static int gmtime_emulation_type;
3252 static long int utc_offset_secs;
3256 if (gmtime_emulation_type == 0) {
3257 gmtime_emulation_type++;
3259 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
3260 gmtime_emulation_type++;
3261 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
3262 gmtime_emulation_type++;
3264 utc_offset_secs = atol(p);
3268 switch (gmtime_emulation_type) {
3270 return gmtime(time);
3272 when = *time - utc_offset_secs;
3273 return localtime(&when);
3275 warn("gmtime not supported on this system");
3278 } /* end of my_gmtime() */
3279 /* Reset definition for later calls */
3280 #define gmtime(t) my_gmtime(t)
3285 * flex_stat, flex_fstat
3286 * basic stat, but gets it right when asked to stat
3287 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3290 /* encode_dev packs a VMS device name string into an integer to allow
3291 * simple comparisons. This can be used, for example, to check whether two
3292 * files are located on the same device, by comparing their encoded device
3293 * names. Even a string comparison would not do, because stat() reuses the
3294 * device name buffer for each call; so without encode_dev, it would be
3295 * necessary to save the buffer and use strcmp (this would mean a number of
3296 * changes to the standard Perl code, to say nothing of what a Perl script
3299 * The device lock id, if it exists, should be unique (unless perhaps compared
3300 * with lock ids transferred from other nodes). We have a lock id if the disk is
3301 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3302 * device names. Thus we use the lock id in preference, and only if that isn't
3303 * available, do we try to pack the device name into an integer (flagged by
3304 * the sign bit (LOCKID_MASK) being set).
3306 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3307 * name and its encoded form, but it seems very unlikely that we will find
3308 * two files on different disks that share the same encoded device names,
3309 * and even more remote that they will share the same file id (if the test
3310 * is to check for the same file).
3312 * A better method might be to use sys$device_scan on the first call, and to
3313 * search for the device, returning an index into the cached array.
3314 * The number returned would be more intelligable.
3315 * This is probably not worth it, and anyway would take quite a bit longer
3316 * on the first call.
3318 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3319 static dev_t encode_dev (const char *dev)
3322 unsigned long int f;
3327 if (!dev || !dev[0]) return 0;
3331 struct dsc$descriptor_s dev_desc;
3332 unsigned long int status, lockid, item = DVI$_LOCKID;
3334 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3335 can try that first. */
3336 dev_desc.dsc$w_length = strlen (dev);
3337 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3338 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3339 dev_desc.dsc$a_pointer = (char *) dev;
3340 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3341 if (lockid) return (lockid & ~LOCKID_MASK);
3345 /* Otherwise we try to encode the device name */
3349 for (q = dev + strlen(dev); q--; q >= dev) {
3352 else if (isalpha (toupper (*q)))
3353 c= toupper (*q) - 'A' + (char)10;
3355 continue; /* Skip '$'s */
3357 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3359 enc += f * (unsigned long int) c;
3361 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3363 } /* end of encode_dev() */
3365 static char namecache[NAM$C_MAXRSS+1];
3368 is_null_device(name)
3371 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3372 The underscore prefix, controller letter, and unit number are
3373 independently optional; for our purposes, the colon punctuation
3374 is not. The colon can be trailed by optional directory and/or
3375 filename, but two consecutive colons indicates a nodename rather
3376 than a device. [pr] */
3377 if (*name == '_') ++name;
3378 if (tolower(*name++) != 'n') return 0;
3379 if (tolower(*name++) != 'l') return 0;
3380 if (tolower(*name) == 'a') ++name;
3381 if (*name == '0') ++name;
3382 return (*name++ == ':') && (*name != ':');
3385 /* Do the permissions allow some operation? Assumes statcache already set. */
3386 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3387 * subset of the applicable information.
3389 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3391 cando(I32 bit, I32 effective, struct stat *statbufp)
3393 if (statbufp == &statcache)
3394 return cando_by_name(bit,effective,namecache);
3396 char fname[NAM$C_MAXRSS+1];
3397 unsigned long int retsts;
3398 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3399 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3401 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3402 device name on successive calls */
3403 devdsc.dsc$a_pointer = statbufp->st_devnam;
3404 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3405 namdsc.dsc$a_pointer = fname;
3406 namdsc.dsc$w_length = sizeof fname - 1;
3408 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3409 &namdsc.dsc$w_length,0,0);
3411 fname[namdsc.dsc$w_length] = '\0';
3412 return cando_by_name(bit,effective,fname);
3414 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3415 warn("Can't get filespec - stale stat buffer?\n");
3419 return FALSE; /* Should never get to here */
3421 } /* end of cando() */
3425 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3427 cando_by_name(I32 bit, I32 effective, char *fname)
3429 static char usrname[L_cuserid];
3430 static struct dsc$descriptor_s usrdsc =
3431 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3432 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3433 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3434 unsigned short int retlen;
3435 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3436 union prvdef curprv;
3437 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3438 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3439 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3442 if (!fname || !*fname) return FALSE;
3443 /* Make sure we expand logical names, since sys$check_access doesn't */
3444 if (!strpbrk(fname,"/]>:")) {
3445 strcpy(fileified,fname);
3446 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3449 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3450 retlen = namdsc.dsc$w_length = strlen(vmsname);
3451 namdsc.dsc$a_pointer = vmsname;
3452 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3453 vmsname[retlen-1] == ':') {
3454 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3455 namdsc.dsc$w_length = strlen(fileified);
3456 namdsc.dsc$a_pointer = fileified;
3459 if (!usrdsc.dsc$w_length) {
3461 usrdsc.dsc$w_length = strlen(usrname);
3468 access = ARM$M_EXECUTE;
3473 access = ARM$M_READ;
3478 access = ARM$M_WRITE;
3483 access = ARM$M_DELETE;
3489 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3490 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3491 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
3492 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3493 set_vaxc_errno(retsts);
3494 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3495 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3496 else set_errno(ENOENT);
3499 if (retsts == SS$_NORMAL) {
3500 if (!privused) return TRUE;
3501 /* We can get access, but only by using privs. Do we have the
3502 necessary privs currently enabled? */
3503 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3504 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3505 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3506 !curprv.prv$v_bypass) return FALSE;
3507 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3508 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3509 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3514 return FALSE; /* Should never get here */
3516 } /* end of cando_by_name() */
3520 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3523 flex_fstat(int fd, struct mystat *statbufp)
3525 if (!fstat(fd,(stat_t *) statbufp)) {
3526 if (statbufp == &statcache) *namecache == '\0';
3527 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3532 } /* end of flex_fstat() */
3535 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3536 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3537 * 'struct stat' elsewhere in Perl would use our struct. We go back
3538 * to the system version here, since we're actually calling their
3542 flex_stat(char *fspec, struct mystat *statbufp)
3544 char fileified[NAM$C_MAXRSS+1];
3547 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3548 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3549 memset(statbufp,0,sizeof *statbufp);
3550 statbufp->st_dev = encode_dev("_NLA0:");
3551 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3552 statbufp->st_uid = 0x00010001;
3553 statbufp->st_gid = 0x0001;
3554 time((time_t *)&statbufp->st_mtime);
3555 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3559 /* Try for a directory name first. If fspec contains a filename without
3560 * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
3561 * and sea:[wine.dark]water. exist, we prefer the directory here.
3562 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
3563 * not sea:[wine.dark]., if the latter exists. If the intended target is
3564 * the file with null type, specify this by calling flex_stat() with
3565 * a '.' at the end of fspec.
3567 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
3568 retval = stat(fileified,(stat_t *) statbufp);
3569 if (!retval && statbufp == &statcache) strcpy(namecache,fileified);
3571 if (retval) retval = stat(fspec,(stat_t *) statbufp);
3572 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3575 } /* end of flex_stat() */
3576 /* Reset definition for later calls */
3580 /* Insures that no carriage-control translation will be done on a file. */
3581 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
3583 my_binmode(FILE *fp, char iotype)
3585 char filespec[NAM$C_MAXRSS], *acmode;
3588 if (!fgetname(fp,filespec)) return NULL;
3589 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
3591 case '<': case 'r': acmode = "rb"; break;
3593 /* use 'a' instead of 'w' to avoid creating new file;
3594 fsetpos below will take care of restoring file position */
3595 case 'a': acmode = "ab"; break;
3596 case '+': case '|': case 's': acmode = "rb+"; break;
3597 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
3599 warn("Unrecognized iotype %c in my_binmode",iotype);
3602 if (freopen(filespec,acmode,fp) == NULL) return NULL;
3603 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
3605 } /* end of my_binmode() */
3609 /*{{{char *my_getlogin()*/
3610 /* VMS cuserid == Unix getlogin, except calling sequence */
3614 static char user[L_cuserid];
3615 return cuserid(user);
3620 /* rmscopy - copy a file using VMS RMS routines
3622 * Copies contents and attributes of spec_in to spec_out, except owner
3623 * and protection information. Name and type of spec_in are used as
3624 * defaults for spec_out. The third parameter specifies whether rmscopy()
3625 * should try to propagate timestamps from the input file to the output file.
3626 * If it is less than 0, no timestamps are preserved. If it is 0, then
3627 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3628 * propagated to the output file at creation iff the output file specification
3629 * did not contain an explicit name or type, and the revision date is always
3630 * updated at the end of the copy operation. If it is greater than 0, then
3631 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3632 * other than the revision date should be propagated, and bit 1 indicates
3633 * that the revision date should be propagated.
3635 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3637 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3638 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3639 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3640 * as part of the Perl standard distribution under the terms of the
3641 * GNU General Public License or the Perl Artistic License. Copies
3642 * of each may be found in the Perl standard distribution.
3644 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3646 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3648 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3649 rsa[NAM$C_MAXRSS], ubf[32256];
3650 unsigned long int i, sts, sts2;
3651 struct FAB fab_in, fab_out;
3652 struct RAB rab_in, rab_out;
3654 struct XABDAT xabdat;
3655 struct XABFHC xabfhc;
3656 struct XABRDT xabrdt;
3657 struct XABSUM xabsum;
3659 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3660 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3661 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3665 fab_in = cc$rms_fab;
3666 fab_in.fab$l_fna = vmsin;
3667 fab_in.fab$b_fns = strlen(vmsin);
3668 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3669 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3670 fab_in.fab$l_fop = FAB$M_SQO;
3671 fab_in.fab$l_nam = &nam;
3672 fab_in.fab$l_xab = (void *) &xabdat;
3675 nam.nam$l_rsa = rsa;
3676 nam.nam$b_rss = sizeof(rsa);
3677 nam.nam$l_esa = esa;
3678 nam.nam$b_ess = sizeof (esa);
3679 nam.nam$b_esl = nam.nam$b_rsl = 0;
3681 xabdat = cc$rms_xabdat; /* To get creation date */
3682 xabdat.xab$l_nxt = (void *) &xabfhc;
3684 xabfhc = cc$rms_xabfhc; /* To get record length */
3685 xabfhc.xab$l_nxt = (void *) &xabsum;
3687 xabsum = cc$rms_xabsum; /* To get key and area information */
3689 if (!((sts = sys$open(&fab_in)) & 1)) {
3690 set_vaxc_errno(sts);
3694 set_errno(ENOENT); break;
3696 set_errno(ENODEV); break;
3698 set_errno(EINVAL); break;
3700 set_errno(EACCES); break;
3708 fab_out.fab$w_ifi = 0;
3709 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3710 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3711 fab_out.fab$l_fop = FAB$M_SQO;
3712 fab_out.fab$l_fna = vmsout;
3713 fab_out.fab$b_fns = strlen(vmsout);
3714 fab_out.fab$l_dna = nam.nam$l_name;
3715 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3717 if (preserve_dates == 0) { /* Act like DCL COPY */
3718 nam.nam$b_nop = NAM$M_SYNCHK;
3719 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3720 if (!((sts = sys$parse(&fab_out)) & 1)) {
3721 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3722 set_vaxc_errno(sts);
3725 fab_out.fab$l_xab = (void *) &xabdat;
3726 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3728 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3729 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3730 preserve_dates =0; /* bitmask from this point forward */
3732 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3733 if (!((sts = sys$create(&fab_out)) & 1)) {
3734 set_vaxc_errno(sts);
3737 set_errno(ENOENT); break;
3739 set_errno(ENODEV); break;
3741 set_errno(EINVAL); break;
3743 set_errno(EACCES); break;
3749 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3750 if (preserve_dates & 2) {
3751 /* sys$close() will process xabrdt, not xabdat */
3752 xabrdt = cc$rms_xabrdt;
3754 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3756 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
3757 * is unsigned long[2], while DECC & VAXC use a struct */
3758 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
3760 fab_out.fab$l_xab = (void *) &xabrdt;
3763 rab_in = cc$rms_rab;
3764 rab_in.rab$l_fab = &fab_in;
3765 rab_in.rab$l_rop = RAB$M_BIO;
3766 rab_in.rab$l_ubf = ubf;
3767 rab_in.rab$w_usz = sizeof ubf;
3768 if (!((sts = sys$connect(&rab_in)) & 1)) {
3769 sys$close(&fab_in); sys$close(&fab_out);
3770 set_errno(EVMSERR); set_vaxc_errno(sts);
3774 rab_out = cc$rms_rab;
3775 rab_out.rab$l_fab = &fab_out;
3776 rab_out.rab$l_rbf = ubf;
3777 if (!((sts = sys$connect(&rab_out)) & 1)) {
3778 sys$close(&fab_in); sys$close(&fab_out);
3779 set_errno(EVMSERR); set_vaxc_errno(sts);
3783 while ((sts = sys$read(&rab_in))) { /* always true */
3784 if (sts == RMS$_EOF) break;
3785 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3786 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3787 sys$close(&fab_in); sys$close(&fab_out);
3788 set_errno(EVMSERR); set_vaxc_errno(sts);
3793 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3794 sys$close(&fab_in); sys$close(&fab_out);
3795 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3797 set_errno(EVMSERR); set_vaxc_errno(sts);
3803 } /* end of rmscopy() */
3807 /*** The following glue provides 'hooks' to make some of the routines
3808 * from this file available from Perl. These routines are sufficiently
3809 * basic, and are required sufficiently early in the build process,
3810 * that's it's nice to have them available to miniperl as well as the
3811 * full Perl, so they're set up here instead of in an extension. The
3812 * Perl code which handles importation of these names into a given
3813 * package lives in [.VMS]Filespec.pm in @INC.
3817 rmsexpand_fromperl(CV *cv)
3820 char *fspec, *defspec = NULL, *rslt;
3822 if (!items || items > 2)
3823 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
3824 fspec = SvPV(ST(0),na);
3825 if (!fspec || !*fspec) XSRETURN_UNDEF;
3826 if (items == 2) defspec = SvPV(ST(1),na);
3828 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
3829 ST(0) = sv_newmortal();
3830 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
3835 vmsify_fromperl(CV *cv)
3840 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3841 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3842 ST(0) = sv_newmortal();
3843 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3848 unixify_fromperl(CV *cv)
3853 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3854 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3855 ST(0) = sv_newmortal();
3856 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3861 fileify_fromperl(CV *cv)
3866 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3867 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3868 ST(0) = sv_newmortal();
3869 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3874 pathify_fromperl(CV *cv)
3879 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3880 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3881 ST(0) = sv_newmortal();
3882 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3887 vmspath_fromperl(CV *cv)
3892 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3893 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3894 ST(0) = sv_newmortal();
3895 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3900 unixpath_fromperl(CV *cv)
3905 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3906 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3907 ST(0) = sv_newmortal();
3908 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3913 candelete_fromperl(CV *cv)
3916 char fspec[NAM$C_MAXRSS+1], *fsp;
3920 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3922 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3923 if (SvTYPE(mysv) == SVt_PVGV) {
3924 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3925 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3932 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3933 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3939 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3944 rmscopy_fromperl(CV *cv)
3947 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3949 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3950 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3951 unsigned long int sts;
3955 if (items < 2 || items > 3)
3956 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3958 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3959 if (SvTYPE(mysv) == SVt_PVGV) {
3960 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3961 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3968 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3969 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3974 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3975 if (SvTYPE(mysv) == SVt_PVGV) {
3976 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3977 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3984 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3985 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3990 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3992 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3999 char* file = __FILE__;
4001 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4002 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4003 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4004 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4005 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4006 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4007 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4008 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4009 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);