3 * VMS-specific routines for perl5
5 * Last revised: 27-Feb-1998 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
25 #include <lib$routines.h>
34 #include <str$routines.h>
39 /* Older versions of ssdef.h don't have these */
40 #ifndef SS$_INVFILFOROP
41 # define SS$_INVFILFOROP 3930
43 #ifndef SS$_NOSUCHOBJECT
44 # define SS$_NOSUCHOBJECT 2696
47 /* Don't replace system definitions of vfork, getenv, and stat,
48 * code below needs to get to the underlying CRTL routines. */
49 #define DONT_MASK_RTL_CALLS
54 /* gcc's header files don't #define direct access macros
55 * corresponding to VAXC's variant structs */
57 # define uic$v_format uic$r_uic_form.uic$v_format
58 # define uic$v_group uic$r_uic_form.uic$v_group
59 # define uic$v_member uic$r_uic_form.uic$v_member
60 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
61 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
62 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
63 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
68 unsigned short int buflen;
69 unsigned short int itmcode;
71 unsigned short int *retlen;
74 static char *__mystrtolower(char *str)
76 if (str) for (; *str; ++str) *str= tolower(*str);
81 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
83 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
84 unsigned short int eqvlen;
85 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
86 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
87 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
88 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
89 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
92 if (!lnm || idx > LNM$_MAX_INDEX) {
93 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
95 if (!eqv) eqv = __my_trnlnm_eqv;
96 lnmlst[1].bufadr = (void *)eqv;
97 lnmdsc.dsc$a_pointer = lnm;
98 lnmdsc.dsc$w_length = strlen(lnm);
99 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
100 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
101 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
103 else if (retsts & 1) {
107 _ckvmssts(retsts); /* Must be an error */
108 return 0; /* Not reached, assuming _ckvmssts() bails out */
110 } /* end of my_trnlnm */
113 * Translate a logical name. Substitute for CRTL getenv() to avoid
114 * memory leak, and to keep my_getenv() and my_setenv() in the same
115 * domain (mostly - my_getenv() need not return a translation from
116 * the process logical name table)
118 * Note: Uses Perl temp to store result so char * can be returned to
119 * caller; this pointer will be invalidated at next Perl statement
122 /*{{{ char *my_getenv(char *lnm)*/
126 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
127 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
128 unsigned long int idx = 0;
132 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
133 /* Set up a temporary buffer for the return value; Perl will
134 * clean it up at the next statement transition */
135 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
136 if (!tmpsv) return NULL;
139 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
140 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
142 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
143 getcwd(eqv,LNM$C_NAMLENGTH);
147 if ((cp2 = strchr(uplnm,';')) != NULL) {
149 idx = strtoul(cp2+1,NULL,0);
151 trnsuccess = my_trnlnm(uplnm,eqv,idx);
152 /* If we had a translation index, we're only interested in lnms */
153 if (!trnsuccess && cp2 != NULL) return Nullch;
154 if (trnsuccess) return eqv;
156 unsigned long int retsts;
157 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
158 valdsc = {LNM$C_NAMLENGTH,DSC$K_DTYPE_T,
160 symdsc.dsc$w_length = cp1 - lnm;
161 symdsc.dsc$a_pointer = uplnm;
162 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
163 if (retsts == LIB$_INVSYMNAM) return Nullch;
164 if (retsts != LIB$_NOSUCHSYM) {
165 /* We want to return only logical names or CRTL Unix emulations */
166 if (retsts & 1) return Nullch;
169 /* Try for CRTL emulation of a Unix/POSIX name */
170 else return getenv(uplnm);
175 } /* end of my_getenv() */
178 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
180 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
182 /*{{{ void prime_env_iter() */
185 /* Fill the %ENV associative array with all logical names we can
186 * find, in preparation for iterating over it.
190 static int primed = 0;
191 HV *envhv = GvHVn(PL_envgv);
193 char eqv[LNM$C_NAMLENGTH+1],mbxnam[LNM$C_NAMLENGTH+1],*start,*end;
194 unsigned short int chan;
195 #ifndef CLI$M_TRUSTED
196 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
198 unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
199 unsigned long int i, retsts, substs = 0, wakect = 0;
201 SV *oldrs, *linesv, *eqvsv;
202 $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:");
203 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(tabdsc,"DCLTABLES");
204 $DESCRIPTOR(mbxdsc,mbxnam);
206 static perl_mutex primenv_mutex;
207 MUTEX_INIT(&primenv_mutex);
211 MUTEX_LOCK(&primenv_mutex);
212 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
213 /* Perform a dummy fetch as an lval to insure that the hash table is
214 * set up. Otherwise, the hv_store() will turn into a nullop. */
215 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
216 /* Also, set up any "special" keys that the CRTL defines,
217 * either by itself or becasue we were called from a C program
218 * using exec[lv]e() */
219 for (i = 0; environ[i]; i++) {
220 if (!(start = strchr(environ[i],'='))) {
221 warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]);
225 (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0);
229 /* Now, go get the logical names */
230 create_mbx(&chan,&mbxdsc);
231 if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
232 if ((retsts = sys$dassgn(chan)) & 1) {
233 /* Be certain that subprocess is using the CLI and command tables we
234 * expect, and don't pass symbols through so that we insure that
235 * "Show Logical" can't be subverted.
238 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
239 0,&riseandshine,0,0,&clidsc,&tabdsc);
240 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
241 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
244 if (sholog == Nullfp || !(retsts & 1)) {
245 if (sholog != Nullfp) PerlIO_close(sholog);
246 MUTEX_UNLOCK(&primenv_mutex);
247 _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
249 /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
250 * tied to Perl's I/O layer, so it may not return a simple FILE * */
252 PL_rs = newSVpv("\n",1);
253 linesv = newSVpv("",0);
255 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
256 PerlIO_close(sholog);
257 SvREFCNT_dec(linesv); SvREFCNT_dec(PL_rs); PL_rs = oldrs;
259 /* Wait for subprocess to clean up (we know subproc won't return 0) */
260 while (substs == 0) { sys$hiber(); wakect++;}
261 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
263 MUTEX_UNLOCK(&primenv_mutex);
266 while (*start != '"' && *start != '=' && *start) start++;
267 if (*start != '"') continue;
268 for (end = ++start; *end && *end != '"'; end++) ;
269 if (*end) *end = '\0';
271 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
272 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
274 warn("Ill-formed logical name |%s| in prime_env_iter",start);
277 else { MUTEX_UNLOCK(&primenv_mutex); _ckvmssts(vaxc$errno); }
280 eqvsv = newSVpv(eqv,eqvlen);
281 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
284 } /* end of prime_env_iter */
288 /*{{{ void my_setenv(char *lnm, char *eqv)*/
290 my_setenv(char *lnm,char *eqv)
291 /* Define a supervisor-mode logical name in the process table.
292 * In the future we'll add tables, attribs, and acmodes,
293 * probably through a different call.
296 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
297 unsigned long int retsts, usermode = PSL$C_USER;
298 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
299 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
300 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
302 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
303 lnmdsc.dsc$w_length = cp1 - lnm;
305 if (!eqv || !*eqv) { /* we're deleting a logical name */
306 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
307 if (retsts == SS$_IVLOGNAM) return;
308 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
310 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
311 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
315 eqvdsc.dsc$w_length = strlen(eqv);
316 eqvdsc.dsc$a_pointer = eqv;
318 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
321 } /* end of my_setenv() */
325 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
326 /* my_crypt - VMS password hashing
327 * my_crypt() provides an interface compatible with the Unix crypt()
328 * C library function, and uses sys$hash_password() to perform VMS
329 * password hashing. The quadword hashed password value is returned
330 * as a NUL-terminated 8 character string. my_crypt() does not change
331 * the case of its string arguments; in order to match the behavior
332 * of LOGINOUT et al., alphabetic characters in both arguments must
333 * be upcased by the caller.
336 my_crypt(const char *textpasswd, const char *usrname)
338 # ifndef UAI$C_PREFERRED_ALGORITHM
339 # define UAI$C_PREFERRED_ALGORITHM 127
341 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
342 unsigned short int salt = 0;
343 unsigned long int sts;
345 unsigned short int dsc$w_length;
346 unsigned char dsc$b_type;
347 unsigned char dsc$b_class;
348 const char * dsc$a_pointer;
349 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
350 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
351 struct itmlst_3 uailst[3] = {
352 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
353 { sizeof salt, UAI$_SALT, &salt, 0},
354 { 0, 0, NULL, NULL}};
357 usrdsc.dsc$w_length = strlen(usrname);
358 usrdsc.dsc$a_pointer = usrname;
359 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
366 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
372 if (sts != RMS$_RNF) return NULL;
375 txtdsc.dsc$w_length = strlen(textpasswd);
376 txtdsc.dsc$a_pointer = textpasswd;
377 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
378 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
381 return (char *) hash;
383 } /* end of my_crypt() */
387 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
388 static char *do_fileify_dirspec(char *, char *, int);
389 static char *do_tovmsspec(char *, char *, int);
391 /*{{{int do_rmdir(char *name)*/
395 char dirfile[NAM$C_MAXRSS+1];
399 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
400 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
401 else retval = kill_file(dirfile);
404 } /* end of do_rmdir */
408 * Delete any file to which user has control access, regardless of whether
409 * delete access is explicitly allowed.
410 * Limitations: User must have write access to parent directory.
411 * Does not block signals or ASTs; if interrupted in midstream
412 * may leave file with an altered ACL.
415 /*{{{int kill_file(char *name)*/
417 kill_file(char *name)
419 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
420 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
421 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
422 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
424 unsigned char myace$b_length;
425 unsigned char myace$b_type;
426 unsigned short int myace$w_flags;
427 unsigned long int myace$l_access;
428 unsigned long int myace$l_ident;
429 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
430 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
431 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
433 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
434 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
435 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
436 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
437 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
438 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
440 /* Expand the input spec using RMS, since the CRTL remove() and
441 * system services won't do this by themselves, so we may miss
442 * a file "hiding" behind a logical name or search list. */
443 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
444 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
445 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
446 /* If not, can changing protections help? */
447 if (vaxc$errno != RMS$_PRV) return -1;
449 /* No, so we get our own UIC to use as a rights identifier,
450 * and the insert an ACE at the head of the ACL which allows us
451 * to delete the file.
453 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
454 fildsc.dsc$w_length = strlen(rspec);
455 fildsc.dsc$a_pointer = rspec;
457 newace.myace$l_ident = oldace.myace$l_ident;
458 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
463 case SS$_NOSUCHOBJECT:
464 set_errno(ENOENT); break;
466 set_errno(ENODEV); break;
468 case SS$_INVFILFOROP:
469 set_errno(EINVAL); break;
471 set_errno(EACCES); break;
475 set_vaxc_errno(aclsts);
478 /* Grab any existing ACEs with this identifier in case we fail */
479 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
480 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
481 || fndsts == SS$_NOMOREACE ) {
482 /* Add the new ACE . . . */
483 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
485 if ((rmsts = remove(name))) {
486 /* We blew it - dir with files in it, no write priv for
487 * parent directory, etc. Put things back the way they were. */
488 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
491 addlst[0].bufadr = &oldace;
492 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
499 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
500 /* We just deleted it, so of course it's not there. Some versions of
501 * VMS seem to return success on the unlock operation anyhow (after all
502 * the unlock is successful), but others don't.
504 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
505 if (aclsts & 1) aclsts = fndsts;
508 set_vaxc_errno(aclsts);
514 } /* end of kill_file() */
518 /*{{{int my_mkdir(char *,Mode_t)*/
520 my_mkdir(char *dir, Mode_t mode)
522 STRLEN dirlen = strlen(dir);
524 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
525 * null file name/type. However, it's commonplace under Unix,
526 * so we'll allow it for a gain in portability.
528 if (dir[dirlen-1] == '/') {
529 char *newdir = savepvn(dir,dirlen-1);
530 int ret = mkdir(newdir,mode);
534 else return mkdir(dir,mode);
535 } /* end of my_mkdir */
540 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
542 static unsigned long int mbxbufsiz;
543 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
547 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
548 * preprocessor consant BUFSIZ from stdio.h as the size of the
551 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
552 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
554 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
556 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
557 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
559 } /* end of create_mbx() */
561 /*{{{ my_popen and my_pclose*/
564 struct pipe_details *next;
565 PerlIO *fp; /* stdio file pointer to pipe mailbox */
566 int pid; /* PID of subprocess */
567 int mode; /* == 'r' if pipe open for reading */
568 int done; /* subprocess has completed */
569 unsigned long int completion; /* termination status of subprocess */
572 struct exit_control_block
574 struct exit_control_block *flink;
575 unsigned long int (*exit_routine)();
576 unsigned long int arg_count;
577 unsigned long int *status_address;
578 unsigned long int exit_status;
581 static struct pipe_details *open_pipes = NULL;
582 static $DESCRIPTOR(nl_desc, "NL:");
583 static int waitpid_asleep = 0;
585 static unsigned long int
588 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
591 while (open_pipes != NULL) {
592 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
593 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
596 if (!open_pipes->done) /* We tried to be nice . . . */
597 _ckvmssts(sys$delprc(&open_pipes->pid,0));
598 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
599 else if (!(sts & 1)) retsts = sts;
604 static struct exit_control_block pipe_exitblock =
605 {(struct exit_control_block *) 0,
606 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
610 popen_completion_ast(struct pipe_details *thispipe)
612 thispipe->done = TRUE;
613 if (waitpid_asleep) {
620 safe_popen(char *cmd, char *mode)
622 static int handler_set_up = FALSE;
624 unsigned short int chan;
625 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
626 struct pipe_details *info;
627 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
628 DSC$K_CLASS_S, mbxname},
629 cmddsc = {0, DSC$K_DTYPE_T,
633 cmddsc.dsc$w_length=strlen(cmd);
634 cmddsc.dsc$a_pointer=cmd;
635 if (cmddsc.dsc$w_length > 255) {
636 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
640 New(1301,info,1,struct pipe_details);
643 create_mbx(&chan,&namdsc);
645 /* open a FILE* onto it */
646 info->fp = PerlIO_open(mbxname, mode);
648 /* give up other channel onto it */
649 _ckvmssts(sys$dassgn(chan));
659 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
660 0 /* name */, &info->pid, &info->completion,
661 0, popen_completion_ast,info,0,0,0));
664 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
665 0 /* name */, &info->pid, &info->completion,
666 0, popen_completion_ast,info,0,0,0));
669 if (!handler_set_up) {
670 _ckvmssts(sys$dclexh(&pipe_exitblock));
671 handler_set_up = TRUE;
673 info->next=open_pipes; /* prepend to list */
676 PL_forkprocess = info->pid;
678 } /* end of safe_popen */
681 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
683 my_popen(char *cmd, char *mode)
686 TAINT_PROPER("popen");
687 return safe_popen(cmd,mode);
692 /*{{{ I32 my_pclose(FILE *fp)*/
693 I32 my_pclose(FILE *fp)
695 struct pipe_details *info, *last = NULL;
696 unsigned long int retsts;
698 for (info = open_pipes; info != NULL; last = info, info = info->next)
699 if (info->fp == fp) break;
701 if (info == NULL) { /* no such pipe open */
702 set_errno(ECHILD); /* quoth POSIX */
703 set_vaxc_errno(SS$_NONEXPR);
707 /* If we were writing to a subprocess, insure that someone reading from
708 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
709 * produce an EOF record in the mailbox. */
710 if (info->mode != 'r') {
711 char devnam[NAM$C_MAXRSS+1], *cp;
712 unsigned long int chan, iosb[2], retsts, retsts2;
713 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
715 if (fgetname(info->fp,devnam)) {
716 /* It oughta be a mailbox, so fgetname should give just the device
717 * name, but just in case . . . */
718 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
719 devdsc.dsc$w_length = strlen(devnam);
720 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
721 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
722 if (retsts & 1) retsts = iosb[0];
723 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
724 if (retsts & 1) retsts = retsts2;
727 else _ckvmssts(vaxc$errno); /* Should never happen */
729 PerlIO_close(info->fp);
731 if (info->done) retsts = info->completion;
732 else waitpid(info->pid,(int *) &retsts,0);
734 /* remove from list of open pipes */
735 if (last) last->next = info->next;
736 else open_pipes = info->next;
741 } /* end of my_pclose() */
743 /* sort-of waitpid; use only with popen() */
744 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
746 my_waitpid(Pid_t pid, int *statusp, int flags)
748 struct pipe_details *info;
750 for (info = open_pipes; info != NULL; info = info->next)
751 if (info->pid == pid) break;
753 if (info != NULL) { /* we know about this child */
754 while (!info->done) {
759 *statusp = info->completion;
762 else { /* we haven't heard of this child */
763 $DESCRIPTOR(intdsc,"0 00:00:01");
764 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
765 unsigned long int interval[2],sts;
768 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
769 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
770 if (ownerpid != mypid)
771 warn("pid %d not a child",pid);
774 _ckvmssts(sys$bintim(&intdsc,interval));
775 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
776 _ckvmssts(sys$schdwk(0,0,interval,0));
777 _ckvmssts(sys$hiber());
781 /* There's no easy way to find the termination status a child we're
782 * not aware of beforehand. If we're really interested in the future,
783 * we can go looking for a termination mailbox, or chase after the
784 * accounting record for the process.
790 } /* end of waitpid() */
795 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
797 my_gconvert(double val, int ndig, int trail, char *buf)
799 static char __gcvtbuf[DBL_DIG+1];
802 loc = buf ? buf : __gcvtbuf;
804 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
806 sprintf(loc,"%.*g",ndig,val);
812 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
813 return gcvt(val,ndig,loc);
816 loc[0] = '0'; loc[1] = '\0';
824 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
825 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
826 * to expand file specification. Allows for a single default file
827 * specification and a simple mask of options. If outbuf is non-NULL,
828 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
829 * the resultant file specification is placed. If outbuf is NULL, the
830 * resultant file specification is placed into a static buffer.
831 * The third argument, if non-NULL, is taken to be a default file
832 * specification string. The fourth argument is unused at present.
833 * rmesexpand() returns the address of the resultant string if
834 * successful, and NULL on error.
836 static char *do_tounixspec(char *, char *, int);
839 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
841 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
842 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
843 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
844 struct FAB myfab = cc$rms_fab;
845 struct NAM mynam = cc$rms_nam;
847 unsigned long int retsts, haslower = 0, isunix = 0;
849 if (!filespec || !*filespec) {
850 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
854 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
855 else outbuf = __rmsexpand_retbuf;
857 if ((isunix = (strchr(filespec,'/') != NULL))) {
858 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
862 myfab.fab$l_fna = filespec;
863 myfab.fab$b_fns = strlen(filespec);
864 myfab.fab$l_nam = &mynam;
866 if (defspec && *defspec) {
867 if (strchr(defspec,'/') != NULL) {
868 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
871 myfab.fab$l_dna = defspec;
872 myfab.fab$b_dns = strlen(defspec);
875 mynam.nam$l_esa = esa;
876 mynam.nam$b_ess = sizeof esa;
877 mynam.nam$l_rsa = outbuf;
878 mynam.nam$b_rss = NAM$C_MAXRSS;
880 retsts = sys$parse(&myfab,0,0);
882 mynam.nam$b_nop |= NAM$M_SYNCHK;
883 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
884 retsts == RMS$_DEV || retsts == RMS$_DEV) {
885 retsts = sys$parse(&myfab,0,0);
886 if (retsts & 1) goto expanded;
888 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
889 (void) sys$parse(&myfab,0,0); /* Free search context */
890 if (out) Safefree(out);
891 set_vaxc_errno(retsts);
892 if (retsts == RMS$_PRV) set_errno(EACCES);
893 else if (retsts == RMS$_DEV) set_errno(ENODEV);
894 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
895 else set_errno(EVMSERR);
898 retsts = sys$search(&myfab,0,0);
899 if (!(retsts & 1) && retsts != RMS$_FNF) {
900 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
901 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
902 if (out) Safefree(out);
903 set_vaxc_errno(retsts);
904 if (retsts == RMS$_PRV) set_errno(EACCES);
905 else set_errno(EVMSERR);
909 /* If the input filespec contained any lowercase characters,
910 * downcase the result for compatibility with Unix-minded code. */
912 for (out = myfab.fab$l_fna; *out; out++)
913 if (islower(*out)) { haslower = 1; break; }
914 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
915 else { out = esa; speclen = mynam.nam$b_esl; }
916 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
917 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
918 speclen = mynam.nam$l_ver - out;
919 if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
920 (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' ||
921 defspec[myfab.fab$b_dns-2] == '.'))
922 speclen = mynam.nam$l_type - out;
923 /* If we just had a directory spec on input, $PARSE "helpfully"
924 * adds an empty name and type for us */
925 if (mynam.nam$l_name == mynam.nam$l_type &&
926 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
927 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
928 speclen = mynam.nam$l_name - out;
930 if (haslower) __mystrtolower(out);
932 /* Have we been working with an expanded, but not resultant, spec? */
933 /* Also, convert back to Unix syntax if necessary. */
934 if (!mynam.nam$b_rsl) {
936 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
938 else strcpy(outbuf,esa);
941 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
942 strcpy(outbuf,tmpfspec);
944 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
945 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
946 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
950 /* External entry points */
951 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
952 { return do_rmsexpand(spec,buf,0,def,opt); }
953 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
954 { return do_rmsexpand(spec,buf,1,def,opt); }
958 ** The following routines are provided to make life easier when
959 ** converting among VMS-style and Unix-style directory specifications.
960 ** All will take input specifications in either VMS or Unix syntax. On
961 ** failure, all return NULL. If successful, the routines listed below
962 ** return a pointer to a buffer containing the appropriately
963 ** reformatted spec (and, therefore, subsequent calls to that routine
964 ** will clobber the result), while the routines of the same names with
965 ** a _ts suffix appended will return a pointer to a mallocd string
966 ** containing the appropriately reformatted spec.
967 ** In all cases, only explicit syntax is altered; no check is made that
968 ** the resulting string is valid or that the directory in question
971 ** fileify_dirspec() - convert a directory spec into the name of the
972 ** directory file (i.e. what you can stat() to see if it's a dir).
973 ** The style (VMS or Unix) of the result is the same as the style
974 ** of the parameter passed in.
975 ** pathify_dirspec() - convert a directory spec into a path (i.e.
976 ** what you prepend to a filename to indicate what directory it's in).
977 ** The style (VMS or Unix) of the result is the same as the style
978 ** of the parameter passed in.
979 ** tounixpath() - convert a directory spec into a Unix-style path.
980 ** tovmspath() - convert a directory spec into a VMS-style path.
981 ** tounixspec() - convert any file spec into a Unix-style file spec.
982 ** tovmsspec() - convert any file spec into a VMS-style spec.
984 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
985 ** Permission is given to distribute this code as part of the Perl
986 ** standard distribution under the terms of the GNU General Public
987 ** License or the Perl Artistic License. Copies of each may be
988 ** found in the Perl standard distribution.
991 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
992 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
994 static char __fileify_retbuf[NAM$C_MAXRSS+1];
995 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
996 char *retspec, *cp1, *cp2, *lastdir;
997 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1000 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1002 dirlen = strlen(dir);
1003 while (dir[dirlen-1] == '/') --dirlen;
1004 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1005 strcpy(trndir,"/sys$disk/000000");
1009 if (dirlen > NAM$C_MAXRSS) {
1010 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1012 if (!strpbrk(dir+1,"/]>:")) {
1013 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1014 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1016 dirlen = strlen(dir);
1019 strncpy(trndir,dir,dirlen);
1020 trndir[dirlen] = '\0';
1023 /* If we were handed a rooted logical name or spec, treat it like a
1024 * simple directory, so that
1025 * $ Define myroot dev:[dir.]
1026 * ... do_fileify_dirspec("myroot",buf,1) ...
1027 * does something useful.
1029 if (!strcmp(dir+dirlen-2,".]")) {
1030 dir[--dirlen] = '\0';
1031 dir[dirlen-1] = ']';
1034 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1035 /* If we've got an explicit filename, we can just shuffle the string. */
1036 if (*(cp1+1)) hasfilename = 1;
1037 /* Similarly, we can just back up a level if we've got multiple levels
1038 of explicit directories in a VMS spec which ends with directories. */
1040 for (cp2 = cp1; cp2 > dir; cp2--) {
1042 *cp2 = *cp1; *cp1 = '\0';
1046 if (*cp2 == '[' || *cp2 == '<') break;
1051 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1052 if (dir[0] == '.') {
1053 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1054 return do_fileify_dirspec("[]",buf,ts);
1055 else if (dir[1] == '.' &&
1056 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1057 return do_fileify_dirspec("[-]",buf,ts);
1059 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1060 dirlen -= 1; /* to last element */
1061 lastdir = strrchr(dir,'/');
1063 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1064 /* If we have "/." or "/..", VMSify it and let the VMS code
1065 * below expand it, rather than repeating the code to handle
1066 * relative components of a filespec here */
1068 if (*(cp1+2) == '.') cp1++;
1069 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1070 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1071 if (strchr(vmsdir,'/') != NULL) {
1072 /* If do_tovmsspec() returned it, it must have VMS syntax
1073 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1074 * the time to check this here only so we avoid a recursion
1075 * loop; otherwise, gigo.
1077 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1079 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1080 return do_tounixspec(trndir,buf,ts);
1083 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1084 lastdir = strrchr(dir,'/');
1086 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1087 /* Ditto for specs that end in an MFD -- let the VMS code
1088 * figure out whether it's a real device or a rooted logical. */
1089 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1090 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1091 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1092 return do_tounixspec(trndir,buf,ts);
1095 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1096 !(lastdir = cp1 = strrchr(dir,']')) &&
1097 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1098 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1100 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1101 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1102 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1103 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1104 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1105 (ver || *cp3)))))) {
1107 set_vaxc_errno(RMS$_DIR);
1113 /* If we lead off with a device or rooted logical, add the MFD
1114 if we're specifying a top-level directory. */
1115 if (lastdir && *dir == '/') {
1117 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1124 retlen = dirlen + (addmfd ? 13 : 6);
1125 if (buf) retspec = buf;
1126 else if (ts) New(1309,retspec,retlen+1,char);
1127 else retspec = __fileify_retbuf;
1129 dirlen = lastdir - dir;
1130 memcpy(retspec,dir,dirlen);
1131 strcpy(&retspec[dirlen],"/000000");
1132 strcpy(&retspec[dirlen+7],lastdir);
1135 memcpy(retspec,dir,dirlen);
1136 retspec[dirlen] = '\0';
1138 /* We've picked up everything up to the directory file name.
1139 Now just add the type and version, and we're set. */
1140 strcat(retspec,".dir;1");
1143 else { /* VMS-style directory spec */
1144 char esa[NAM$C_MAXRSS+1], term, *cp;
1145 unsigned long int sts, cmplen, haslower = 0;
1146 struct FAB dirfab = cc$rms_fab;
1147 struct NAM savnam, dirnam = cc$rms_nam;
1149 dirfab.fab$b_fns = strlen(dir);
1150 dirfab.fab$l_fna = dir;
1151 dirfab.fab$l_nam = &dirnam;
1152 dirfab.fab$l_dna = ".DIR;1";
1153 dirfab.fab$b_dns = 6;
1154 dirnam.nam$b_ess = NAM$C_MAXRSS;
1155 dirnam.nam$l_esa = esa;
1157 for (cp = dir; *cp; cp++)
1158 if (islower(*cp)) { haslower = 1; break; }
1159 if (!((sts = sys$parse(&dirfab))&1)) {
1160 if (dirfab.fab$l_sts == RMS$_DIR) {
1161 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1162 sts = sys$parse(&dirfab) & 1;
1166 set_vaxc_errno(dirfab.fab$l_sts);
1172 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1173 /* Yes; fake the fnb bits so we'll check type below */
1174 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1177 if (dirfab.fab$l_sts != RMS$_FNF) {
1179 set_vaxc_errno(dirfab.fab$l_sts);
1182 dirnam = savnam; /* No; just work with potential name */
1185 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1186 cp1 = strchr(esa,']');
1187 if (!cp1) cp1 = strchr(esa,'>');
1188 if (cp1) { /* Should always be true */
1189 dirnam.nam$b_esl -= cp1 - esa - 1;
1190 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1193 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1194 /* Yep; check version while we're at it, if it's there. */
1195 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1196 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1197 /* Something other than .DIR[;1]. Bzzt. */
1199 set_vaxc_errno(RMS$_DIR);
1203 esa[dirnam.nam$b_esl] = '\0';
1204 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1205 /* They provided at least the name; we added the type, if necessary, */
1206 if (buf) retspec = buf; /* in sys$parse() */
1207 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1208 else retspec = __fileify_retbuf;
1209 strcpy(retspec,esa);
1212 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1213 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1215 dirnam.nam$b_esl -= 9;
1217 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1218 if (cp1 == NULL) return NULL; /* should never happen */
1221 retlen = strlen(esa);
1222 if ((cp1 = strrchr(esa,'.')) != NULL) {
1223 /* There's more than one directory in the path. Just roll back. */
1225 if (buf) retspec = buf;
1226 else if (ts) New(1311,retspec,retlen+7,char);
1227 else retspec = __fileify_retbuf;
1228 strcpy(retspec,esa);
1231 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1232 /* Go back and expand rooted logical name */
1233 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1234 if (!(sys$parse(&dirfab) & 1)) {
1236 set_vaxc_errno(dirfab.fab$l_sts);
1239 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1240 if (buf) retspec = buf;
1241 else if (ts) New(1312,retspec,retlen+16,char);
1242 else retspec = __fileify_retbuf;
1243 cp1 = strstr(esa,"][");
1245 memcpy(retspec,esa,dirlen);
1246 if (!strncmp(cp1+2,"000000]",7)) {
1247 retspec[dirlen-1] = '\0';
1248 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1249 if (*cp1 == '.') *cp1 = ']';
1251 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1252 memcpy(cp1+1,"000000]",7);
1256 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1257 retspec[retlen] = '\0';
1258 /* Convert last '.' to ']' */
1259 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1260 if (*cp1 == '.') *cp1 = ']';
1262 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1263 memcpy(cp1+1,"000000]",7);
1267 else { /* This is a top-level dir. Add the MFD to the path. */
1268 if (buf) retspec = buf;
1269 else if (ts) New(1312,retspec,retlen+16,char);
1270 else retspec = __fileify_retbuf;
1273 while (*cp1 != ':') *(cp2++) = *(cp1++);
1274 strcpy(cp2,":[000000]");
1279 /* We've set up the string up through the filename. Add the
1280 type and version, and we're done. */
1281 strcat(retspec,".DIR;1");
1283 /* $PARSE may have upcased filespec, so convert output to lower
1284 * case if input contained any lowercase characters. */
1285 if (haslower) __mystrtolower(retspec);
1288 } /* end of do_fileify_dirspec() */
1290 /* External entry points */
1291 char *fileify_dirspec(char *dir, char *buf)
1292 { return do_fileify_dirspec(dir,buf,0); }
1293 char *fileify_dirspec_ts(char *dir, char *buf)
1294 { return do_fileify_dirspec(dir,buf,1); }
1296 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1297 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1299 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1300 unsigned long int retlen;
1301 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1303 if (!dir || !*dir) {
1304 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1307 if (*dir) strcpy(trndir,dir);
1308 else getcwd(trndir,sizeof trndir - 1);
1310 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1311 STRLEN trnlen = strlen(trndir);
1313 /* Trap simple rooted lnms, and return lnm:[000000] */
1314 if (!strcmp(trndir+trnlen-2,".]")) {
1315 if (buf) retpath = buf;
1316 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1317 else retpath = __pathify_retbuf;
1318 strcpy(retpath,dir);
1319 strcat(retpath,":[000000]");
1325 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1326 if (*dir == '.' && (*(dir+1) == '\0' ||
1327 (*(dir+1) == '.' && *(dir+2) == '\0')))
1328 retlen = 2 + (*(dir+1) != '\0');
1330 if ( !(cp1 = strrchr(dir,'/')) &&
1331 !(cp1 = strrchr(dir,']')) &&
1332 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1333 if ((cp2 = strchr(cp1,'.')) != NULL &&
1334 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1335 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1336 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1337 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1339 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1340 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1341 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1342 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1343 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1344 (ver || *cp3)))))) {
1346 set_vaxc_errno(RMS$_DIR);
1349 retlen = cp2 - dir + 1;
1351 else { /* No file type present. Treat the filename as a directory. */
1352 retlen = strlen(dir) + 1;
1355 if (buf) retpath = buf;
1356 else if (ts) New(1313,retpath,retlen+1,char);
1357 else retpath = __pathify_retbuf;
1358 strncpy(retpath,dir,retlen-1);
1359 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1360 retpath[retlen-1] = '/'; /* with '/', add it. */
1361 retpath[retlen] = '\0';
1363 else retpath[retlen-1] = '\0';
1365 else { /* VMS-style directory spec */
1366 char esa[NAM$C_MAXRSS+1], *cp;
1367 unsigned long int sts, cmplen, haslower;
1368 struct FAB dirfab = cc$rms_fab;
1369 struct NAM savnam, dirnam = cc$rms_nam;
1371 /* If we've got an explicit filename, we can just shuffle the string. */
1372 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1373 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1374 if ((cp2 = strchr(cp1,'.')) != NULL) {
1376 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1377 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1378 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1379 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1380 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1381 (ver || *cp3)))))) {
1383 set_vaxc_errno(RMS$_DIR);
1387 else { /* No file type, so just draw name into directory part */
1388 for (cp2 = cp1; *cp2; cp2++) ;
1391 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1393 /* We've now got a VMS 'path'; fall through */
1395 dirfab.fab$b_fns = strlen(dir);
1396 dirfab.fab$l_fna = dir;
1397 if (dir[dirfab.fab$b_fns-1] == ']' ||
1398 dir[dirfab.fab$b_fns-1] == '>' ||
1399 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1400 if (buf) retpath = buf;
1401 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1402 else retpath = __pathify_retbuf;
1403 strcpy(retpath,dir);
1406 dirfab.fab$l_dna = ".DIR;1";
1407 dirfab.fab$b_dns = 6;
1408 dirfab.fab$l_nam = &dirnam;
1409 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1410 dirnam.nam$l_esa = esa;
1412 for (cp = dir; *cp; cp++)
1413 if (islower(*cp)) { haslower = 1; break; }
1415 if (!(sts = (sys$parse(&dirfab)&1))) {
1416 if (dirfab.fab$l_sts == RMS$_DIR) {
1417 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1418 sts = sys$parse(&dirfab) & 1;
1422 set_vaxc_errno(dirfab.fab$l_sts);
1428 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1429 if (dirfab.fab$l_sts != RMS$_FNF) {
1431 set_vaxc_errno(dirfab.fab$l_sts);
1434 dirnam = savnam; /* No; just work with potential name */
1437 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1438 /* Yep; check version while we're at it, if it's there. */
1439 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1440 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1441 /* Something other than .DIR[;1]. Bzzt. */
1443 set_vaxc_errno(RMS$_DIR);
1447 /* OK, the type was fine. Now pull any file name into the
1449 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1451 cp1 = strrchr(esa,'>');
1452 *dirnam.nam$l_type = '>';
1455 *(dirnam.nam$l_type + 1) = '\0';
1456 retlen = dirnam.nam$l_type - esa + 2;
1457 if (buf) retpath = buf;
1458 else if (ts) New(1314,retpath,retlen,char);
1459 else retpath = __pathify_retbuf;
1460 strcpy(retpath,esa);
1461 /* $PARSE may have upcased filespec, so convert output to lower
1462 * case if input contained any lowercase characters. */
1463 if (haslower) __mystrtolower(retpath);
1467 } /* end of do_pathify_dirspec() */
1469 /* External entry points */
1470 char *pathify_dirspec(char *dir, char *buf)
1471 { return do_pathify_dirspec(dir,buf,0); }
1472 char *pathify_dirspec_ts(char *dir, char *buf)
1473 { return do_pathify_dirspec(dir,buf,1); }
1475 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1476 static char *do_tounixspec(char *spec, char *buf, int ts)
1478 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1479 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1480 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1482 if (spec == NULL) return NULL;
1483 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1484 if (buf) rslt = buf;
1486 retlen = strlen(spec);
1487 cp1 = strchr(spec,'[');
1488 if (!cp1) cp1 = strchr(spec,'<');
1490 for (cp1++; *cp1; cp1++) {
1491 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1492 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1493 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1496 New(1315,rslt,retlen+2+2*expand,char);
1498 else rslt = __tounixspec_retbuf;
1499 if (strchr(spec,'/') != NULL) {
1506 dirend = strrchr(spec,']');
1507 if (dirend == NULL) dirend = strrchr(spec,'>');
1508 if (dirend == NULL) dirend = strchr(spec,':');
1509 if (dirend == NULL) {
1513 if (*cp2 != '[' && *cp2 != '<') {
1516 else { /* the VMS spec begins with directories */
1518 if (*cp2 == ']' || *cp2 == '>') {
1519 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1522 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1523 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1524 if (ts) Safefree(rslt);
1529 while (*cp3 != ':' && *cp3) cp3++;
1531 if (strchr(cp3,']') != NULL) break;
1532 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1534 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1535 retlen = devlen + dirlen;
1536 Renew(rslt,retlen+1+2*expand,char);
1542 *(cp1++) = *(cp3++);
1543 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1547 else if ( *cp2 == '.') {
1548 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1549 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1555 for (; cp2 <= dirend; cp2++) {
1558 if (*(cp2+1) == '[') cp2++;
1560 else if (*cp2 == ']' || *cp2 == '>') {
1561 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1563 else if (*cp2 == '.') {
1565 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1566 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1567 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1568 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1569 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1571 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1572 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1576 else if (*cp2 == '-') {
1577 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1578 while (*cp2 == '-') {
1580 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1582 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1583 if (ts) Safefree(rslt); /* filespecs like */
1584 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1588 else *(cp1++) = *cp2;
1590 else *(cp1++) = *cp2;
1592 while (*cp2) *(cp1++) = *(cp2++);
1597 } /* end of do_tounixspec() */
1599 /* External entry points */
1600 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1601 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1603 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1604 static char *do_tovmsspec(char *path, char *buf, int ts) {
1605 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1606 char *rslt, *dirend;
1607 register char *cp1, *cp2;
1608 unsigned long int infront = 0, hasdir = 1;
1610 if (path == NULL) return NULL;
1611 if (buf) rslt = buf;
1612 else if (ts) New(1316,rslt,strlen(path)+9,char);
1613 else rslt = __tovmsspec_retbuf;
1614 if (strpbrk(path,"]:>") ||
1615 (dirend = strrchr(path,'/')) == NULL) {
1616 if (path[0] == '.') {
1617 if (path[1] == '\0') strcpy(rslt,"[]");
1618 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1619 else strcpy(rslt,path); /* probably garbage */
1621 else strcpy(rslt,path);
1624 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1625 if (!*(dirend+2)) dirend +=2;
1626 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1627 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1632 char trndev[NAM$C_MAXRSS+1];
1636 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1638 if (!buf & ts) Renew(rslt,18,char);
1639 strcpy(rslt,"sys$disk:[000000]");
1642 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1644 islnm = my_trnlnm(rslt,trndev,0);
1645 trnend = islnm ? strlen(trndev) - 1 : 0;
1646 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1647 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1648 /* If the first element of the path is a logical name, determine
1649 * whether it has to be translated so we can add more directories. */
1650 if (!islnm || rooted) {
1653 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1657 if (cp2 != dirend) {
1658 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1659 strcpy(rslt,trndev);
1660 cp1 = rslt + trnend;
1673 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1674 cp2 += 2; /* skip over "./" - it's redundant */
1675 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1677 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1678 *(cp1++) = '-'; /* "../" --> "-" */
1681 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1682 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1683 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1684 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1687 if (cp2 > dirend) cp2 = dirend;
1689 else *(cp1++) = '.';
1691 for (; cp2 < dirend; cp2++) {
1693 if (*(cp2-1) == '/') continue;
1694 if (*(cp1-1) != '.') *(cp1++) = '.';
1697 else if (!infront && *cp2 == '.') {
1698 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1699 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1700 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1701 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1702 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1703 else { /* back up over previous directory name */
1705 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1706 if (*(cp1-1) == '[') {
1707 memcpy(cp1,"000000.",7);
1712 if (cp2 == dirend) break;
1714 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1715 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1716 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1717 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1719 *(cp1++) = '.'; /* Simulate trailing '/' */
1720 cp2 += 2; /* for loop will incr this to == dirend */
1722 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1724 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1727 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1728 if (*cp2 == '.') *(cp1++) = '_';
1729 else *(cp1++) = *cp2;
1733 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1734 if (hasdir) *(cp1++) = ']';
1735 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1736 while (*cp2) *(cp1++) = *(cp2++);
1741 } /* end of do_tovmsspec() */
1743 /* External entry points */
1744 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1745 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1747 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1748 static char *do_tovmspath(char *path, char *buf, int ts) {
1749 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1751 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1753 if (path == NULL) return NULL;
1754 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1755 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1756 if (buf) return buf;
1758 vmslen = strlen(vmsified);
1759 New(1317,cp,vmslen+1,char);
1760 memcpy(cp,vmsified,vmslen);
1765 strcpy(__tovmspath_retbuf,vmsified);
1766 return __tovmspath_retbuf;
1769 } /* end of do_tovmspath() */
1771 /* External entry points */
1772 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1773 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1776 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1777 static char *do_tounixpath(char *path, char *buf, int ts) {
1778 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1780 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1782 if (path == NULL) return NULL;
1783 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1784 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1785 if (buf) return buf;
1787 unixlen = strlen(unixified);
1788 New(1317,cp,unixlen+1,char);
1789 memcpy(cp,unixified,unixlen);
1794 strcpy(__tounixpath_retbuf,unixified);
1795 return __tounixpath_retbuf;
1798 } /* end of do_tounixpath() */
1800 /* External entry points */
1801 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1802 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1805 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1807 *****************************************************************************
1809 * Copyright (C) 1989-1994 by *
1810 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1812 * Permission is hereby granted for the reproduction of this software, *
1813 * on condition that this copyright notice is included in the reproduction, *
1814 * and that such reproduction is not for purposes of profit or material *
1817 * 27-Aug-1994 Modified for inclusion in perl5 *
1818 * by Charles Bailey bailey@genetics.upenn.edu *
1819 *****************************************************************************
1823 * getredirection() is intended to aid in porting C programs
1824 * to VMS (Vax-11 C). The native VMS environment does not support
1825 * '>' and '<' I/O redirection, or command line wild card expansion,
1826 * or a command line pipe mechanism using the '|' AND background
1827 * command execution '&'. All of these capabilities are provided to any
1828 * C program which calls this procedure as the first thing in the
1830 * The piping mechanism will probably work with almost any 'filter' type
1831 * of program. With suitable modification, it may useful for other
1832 * portability problems as well.
1834 * Author: Mark Pizzolato mark@infocomm.com
1838 struct list_item *next;
1842 static void add_item(struct list_item **head,
1843 struct list_item **tail,
1847 static void expand_wild_cards(char *item,
1848 struct list_item **head,
1849 struct list_item **tail,
1852 static int background_process(int argc, char **argv);
1854 static void pipe_and_fork(char **cmargv);
1856 /*{{{ void getredirection(int *ac, char ***av)*/
1858 getredirection(int *ac, char ***av)
1860 * Process vms redirection arg's. Exit if any error is seen.
1861 * If getredirection() processes an argument, it is erased
1862 * from the vector. getredirection() returns a new argc and argv value.
1863 * In the event that a background command is requested (by a trailing "&"),
1864 * this routine creates a background subprocess, and simply exits the program.
1866 * Warning: do not try to simplify the code for vms. The code
1867 * presupposes that getredirection() is called before any data is
1868 * read from stdin or written to stdout.
1870 * Normal usage is as follows:
1876 * getredirection(&argc, &argv);
1880 int argc = *ac; /* Argument Count */
1881 char **argv = *av; /* Argument Vector */
1882 char *ap; /* Argument pointer */
1883 int j; /* argv[] index */
1884 int item_count = 0; /* Count of Items in List */
1885 struct list_item *list_head = 0; /* First Item in List */
1886 struct list_item *list_tail; /* Last Item in List */
1887 char *in = NULL; /* Input File Name */
1888 char *out = NULL; /* Output File Name */
1889 char *outmode = "w"; /* Mode to Open Output File */
1890 char *err = NULL; /* Error File Name */
1891 char *errmode = "w"; /* Mode to Open Error File */
1892 int cmargc = 0; /* Piped Command Arg Count */
1893 char **cmargv = NULL;/* Piped Command Arg Vector */
1896 * First handle the case where the last thing on the line ends with
1897 * a '&'. This indicates the desire for the command to be run in a
1898 * subprocess, so we satisfy that desire.
1901 if (0 == strcmp("&", ap))
1902 exit(background_process(--argc, argv));
1903 if (*ap && '&' == ap[strlen(ap)-1])
1905 ap[strlen(ap)-1] = '\0';
1906 exit(background_process(argc, argv));
1909 * Now we handle the general redirection cases that involve '>', '>>',
1910 * '<', and pipes '|'.
1912 for (j = 0; j < argc; ++j)
1914 if (0 == strcmp("<", argv[j]))
1918 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1919 exit(LIB$_WRONUMARG);
1924 if ('<' == *(ap = argv[j]))
1929 if (0 == strcmp(">", ap))
1933 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1934 exit(LIB$_WRONUMARG);
1953 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1954 exit(LIB$_WRONUMARG);
1958 if (('2' == *ap) && ('>' == ap[1]))
1975 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1976 exit(LIB$_WRONUMARG);
1980 if (0 == strcmp("|", argv[j]))
1984 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1985 exit(LIB$_WRONUMARG);
1987 cmargc = argc-(j+1);
1988 cmargv = &argv[j+1];
1992 if ('|' == *(ap = argv[j]))
2000 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2003 * Allocate and fill in the new argument vector, Some Unix's terminate
2004 * the list with an extra null pointer.
2006 New(1302, argv, item_count+1, char *);
2008 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2009 argv[j] = list_head->value;
2015 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2016 exit(LIB$_INVARGORD);
2018 pipe_and_fork(cmargv);
2021 /* Check for input from a pipe (mailbox) */
2023 if (in == NULL && 1 == isapipe(0))
2025 char mbxname[L_tmpnam];
2027 long int dvi_item = DVI$_DEVBUFSIZ;
2028 $DESCRIPTOR(mbxnam, "");
2029 $DESCRIPTOR(mbxdevnam, "");
2031 /* Input from a pipe, reopen it in binary mode to disable */
2032 /* carriage control processing. */
2034 PerlIO_getname(stdin, mbxname);
2035 mbxnam.dsc$a_pointer = mbxname;
2036 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2037 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2038 mbxdevnam.dsc$a_pointer = mbxname;
2039 mbxdevnam.dsc$w_length = sizeof(mbxname);
2040 dvi_item = DVI$_DEVNAM;
2041 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2042 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2045 freopen(mbxname, "rb", stdin);
2048 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2052 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2054 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2057 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2059 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2064 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2066 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2070 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2075 #ifdef ARGPROC_DEBUG
2076 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2077 for (j = 0; j < *ac; ++j)
2078 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2080 /* Clear errors we may have hit expanding wildcards, so they don't
2081 show up in Perl's $! later */
2082 set_errno(0); set_vaxc_errno(1);
2083 } /* end of getredirection() */
2086 static void add_item(struct list_item **head,
2087 struct list_item **tail,
2093 New(1303,*head,1,struct list_item);
2097 New(1304,(*tail)->next,1,struct list_item);
2098 *tail = (*tail)->next;
2100 (*tail)->value = value;
2104 static void expand_wild_cards(char *item,
2105 struct list_item **head,
2106 struct list_item **tail,
2110 unsigned long int context = 0;
2116 char vmsspec[NAM$C_MAXRSS+1];
2117 $DESCRIPTOR(filespec, "");
2118 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2119 $DESCRIPTOR(resultspec, "");
2120 unsigned long int zero = 0, sts;
2122 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2124 add_item(head, tail, item, count);
2127 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2128 resultspec.dsc$b_class = DSC$K_CLASS_D;
2129 resultspec.dsc$a_pointer = NULL;
2130 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2131 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2132 if (!isunix || !filespec.dsc$a_pointer)
2133 filespec.dsc$a_pointer = item;
2134 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2136 * Only return version specs, if the caller specified a version
2138 had_version = strchr(item, ';');
2140 * Only return device and directory specs, if the caller specifed either.
2142 had_device = strchr(item, ':');
2143 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2145 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2146 &defaultspec, 0, 0, &zero))))
2151 New(1305,string,resultspec.dsc$w_length+1,char);
2152 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2153 string[resultspec.dsc$w_length] = '\0';
2154 if (NULL == had_version)
2155 *((char *)strrchr(string, ';')) = '\0';
2156 if ((!had_directory) && (had_device == NULL))
2158 if (NULL == (devdir = strrchr(string, ']')))
2159 devdir = strrchr(string, '>');
2160 strcpy(string, devdir + 1);
2163 * Be consistent with what the C RTL has already done to the rest of
2164 * the argv items and lowercase all of these names.
2166 for (c = string; *c; ++c)
2169 if (isunix) trim_unixpath(string,item,1);
2170 add_item(head, tail, string, count);
2173 if (sts != RMS$_NMF)
2175 set_vaxc_errno(sts);
2181 set_errno(ENOENT); break;
2183 set_errno(ENODEV); break;
2186 set_errno(EINVAL); break;
2188 set_errno(EACCES); break;
2190 _ckvmssts_noperl(sts);
2194 add_item(head, tail, item, count);
2195 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2196 _ckvmssts_noperl(lib$find_file_end(&context));
2199 static int child_st[2];/* Event Flag set when child process completes */
2201 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2203 static unsigned long int exit_handler(int *status)
2207 if (0 == child_st[0])
2209 #ifdef ARGPROC_DEBUG
2210 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2212 fflush(stdout); /* Have to flush pipe for binary data to */
2213 /* terminate properly -- <tp@mccall.com> */
2214 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2215 sys$dassgn(child_chan);
2217 sys$synch(0, child_st);
2222 static void sig_child(int chan)
2224 #ifdef ARGPROC_DEBUG
2225 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2227 if (child_st[0] == 0)
2231 static struct exit_control_block exit_block =
2236 &exit_block.exit_status,
2240 static void pipe_and_fork(char **cmargv)
2243 $DESCRIPTOR(cmddsc, "");
2244 static char mbxname[64];
2245 $DESCRIPTOR(mbxdsc, mbxname);
2247 unsigned long int zero = 0, one = 1;
2249 strcpy(subcmd, cmargv[0]);
2250 for (j = 1; NULL != cmargv[j]; ++j)
2252 strcat(subcmd, " \"");
2253 strcat(subcmd, cmargv[j]);
2254 strcat(subcmd, "\"");
2256 cmddsc.dsc$a_pointer = subcmd;
2257 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2259 create_mbx(&child_chan,&mbxdsc);
2260 #ifdef ARGPROC_DEBUG
2261 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2262 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2264 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2265 0, &pid, child_st, &zero, sig_child,
2267 #ifdef ARGPROC_DEBUG
2268 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2270 sys$dclexh(&exit_block);
2271 if (NULL == freopen(mbxname, "wb", stdout))
2273 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2277 static int background_process(int argc, char **argv)
2279 char command[2048] = "$";
2280 $DESCRIPTOR(value, "");
2281 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2282 static $DESCRIPTOR(null, "NLA0:");
2283 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2285 $DESCRIPTOR(pidstr, "");
2287 unsigned long int flags = 17, one = 1, retsts;
2289 strcat(command, argv[0]);
2292 strcat(command, " \"");
2293 strcat(command, *(++argv));
2294 strcat(command, "\"");
2296 value.dsc$a_pointer = command;
2297 value.dsc$w_length = strlen(value.dsc$a_pointer);
2298 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2299 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2300 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2301 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2304 _ckvmssts_noperl(retsts);
2306 #ifdef ARGPROC_DEBUG
2307 PerlIO_printf(Perl_debug_log, "%s\n", command);
2309 sprintf(pidstring, "%08X", pid);
2310 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2311 pidstr.dsc$a_pointer = pidstring;
2312 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2313 lib$set_symbol(&pidsymbol, &pidstr);
2317 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2320 /* OS-specific initialization at image activation (not thread startup) */
2321 /* Older VAXC header files lack these constants */
2322 #ifndef JPI$_RIGHTS_SIZE
2323 # define JPI$_RIGHTS_SIZE 817
2325 #ifndef KGB$M_SUBSYSTEM
2326 # define KGB$M_SUBSYSTEM 0x8
2329 /*{{{void vms_image_init(int *, char ***)*/
2331 vms_image_init(int *argcp, char ***argvp)
2333 unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
2334 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2335 unsigned short int dummy, rlen;
2336 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2337 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2338 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2341 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2343 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2344 if (iprv[i]) { /* Running image installed with privs? */
2345 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2350 /* Rights identifiers might trigger tainting as well. */
2351 if (!add_taint && (rlen || rsz)) {
2352 while (rlen < rsz) {
2353 /* We didn't get all the identifiers on the first pass. Allocate a
2354 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2355 * were needed to hold all identifiers at time of last call; we'll
2356 * allocate that many unsigned long ints), and go back and get 'em.
2358 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2359 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2360 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2361 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2364 mask = jpilist[1].bufadr;
2365 /* Check attribute flags for each identifier (2nd longword); protected
2366 * subsystem identifiers trigger tainting.
2368 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2369 if (mask[i] & KGB$M_SUBSYSTEM) {
2374 if (mask != rlst) Safefree(mask);
2376 /* We need to use this hack to tell Perl it should run with tainting,
2377 * since its tainting flag may be part of the PL_curinterp struct, which
2378 * hasn't been allocated when vms_image_init() is called.
2382 New(1320,newap,*argcp+2,char **);
2383 newap[0] = argvp[0];
2385 Copy(argvp[1],newap[2],*argcp-1,char **);
2386 /* We orphan the old argv, since we don't know where it's come from,
2387 * so we don't know how to free it.
2389 *argcp++; argvp = newap;
2391 getredirection(argcp,argvp);
2392 #if defined(USE_THREADS) && defined(__DECC)
2394 # include <reentrancy.h>
2395 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2404 * Trim Unix-style prefix off filespec, so it looks like what a shell
2405 * glob expansion would return (i.e. from specified prefix on, not
2406 * full path). Note that returned filespec is Unix-style, regardless
2407 * of whether input filespec was VMS-style or Unix-style.
2409 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2410 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2411 * vector of options; at present, only bit 0 is used, and if set tells
2412 * trim unixpath to try the current default directory as a prefix when
2413 * presented with a possibly ambiguous ... wildcard.
2415 * Returns !=0 on success, with trimmed filespec replacing contents of
2416 * fspec, and 0 on failure, with contents of fpsec unchanged.
2418 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2420 trim_unixpath(char *fspec, char *wildspec, int opts)
2422 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2423 *template, *base, *end, *cp1, *cp2;
2424 register int tmplen, reslen = 0, dirs = 0;
2426 if (!wildspec || !fspec) return 0;
2427 if (strpbrk(wildspec,"]>:") != NULL) {
2428 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2429 else template = unixwild;
2431 else template = wildspec;
2432 if (strpbrk(fspec,"]>:") != NULL) {
2433 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2434 else base = unixified;
2435 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2436 * check to see that final result fits into (isn't longer than) fspec */
2437 reslen = strlen(fspec);
2441 /* No prefix or absolute path on wildcard, so nothing to remove */
2442 if (!*template || *template == '/') {
2443 if (base == fspec) return 1;
2444 tmplen = strlen(unixified);
2445 if (tmplen > reslen) return 0; /* not enough space */
2446 /* Copy unixified resultant, including trailing NUL */
2447 memmove(fspec,unixified,tmplen+1);
2451 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2452 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2453 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2454 for (cp1 = end ;cp1 >= base; cp1--)
2455 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2457 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2461 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2462 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2463 int ells = 1, totells, segdirs, match;
2464 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2465 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2467 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2469 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2470 if (ellipsis == template && opts & 1) {
2471 /* Template begins with an ellipsis. Since we can't tell how many
2472 * directory names at the front of the resultant to keep for an
2473 * arbitrary starting point, we arbitrarily choose the current
2474 * default directory as a starting point. If it's there as a prefix,
2475 * clip it off. If not, fall through and act as if the leading
2476 * ellipsis weren't there (i.e. return shortest possible path that
2477 * could match template).
2479 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2480 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2481 if (_tolower(*cp1) != _tolower(*cp2)) break;
2482 segdirs = dirs - totells; /* Min # of dirs we must have left */
2483 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2484 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2485 memcpy(fspec,cp2+1,end - cp2);
2489 /* First off, back up over constant elements at end of path */
2491 for (front = end ; front >= base; front--)
2492 if (*front == '/' && !dirs--) { front++; break; }
2494 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2495 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2496 if (cp1 != '\0') return 0; /* Path too long. */
2498 *cp2 = '\0'; /* Pick up with memcpy later */
2499 lcfront = lcres + (front - base);
2500 /* Now skip over each ellipsis and try to match the path in front of it. */
2502 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2503 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2504 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2505 if (cp1 < template) break; /* template started with an ellipsis */
2506 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2507 ellipsis = cp1; continue;
2509 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2511 for (segdirs = 0, cp2 = tpl;
2512 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2514 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2515 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2516 if (*cp2 == '/') segdirs++;
2518 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2519 /* Back up at least as many dirs as in template before matching */
2520 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2521 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2522 for (match = 0; cp1 > lcres;) {
2523 resdsc.dsc$a_pointer = cp1;
2524 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2526 if (match == 1) lcfront = cp1;
2528 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2530 if (!match) return 0; /* Can't find prefix ??? */
2531 if (match > 1 && opts & 1) {
2532 /* This ... wildcard could cover more than one set of dirs (i.e.
2533 * a set of similar dir names is repeated). If the template
2534 * contains more than 1 ..., upstream elements could resolve the
2535 * ambiguity, but it's not worth a full backtracking setup here.
2536 * As a quick heuristic, clip off the current default directory
2537 * if it's present to find the trimmed spec, else use the
2538 * shortest string that this ... could cover.
2540 char def[NAM$C_MAXRSS+1], *st;
2542 if (getcwd(def, sizeof def,0) == NULL) return 0;
2543 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2544 if (_tolower(*cp1) != _tolower(*cp2)) break;
2545 segdirs = dirs - totells; /* Min # of dirs we must have left */
2546 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2547 if (*cp1 == '\0' && *cp2 == '/') {
2548 memcpy(fspec,cp2+1,end - cp2);
2551 /* Nope -- stick with lcfront from above and keep going. */
2554 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2559 } /* end of trim_unixpath() */
2564 * VMS readdir() routines.
2565 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2567 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2568 * Minor modifications to original routines.
2571 /* Number of elements in vms_versions array */
2572 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2575 * Open a directory, return a handle for later use.
2577 /*{{{ DIR *opendir(char*name) */
2582 char dir[NAM$C_MAXRSS+1];
2585 if (do_tovmspath(name,dir,0) == NULL) {
2588 if (flex_stat(dir,&sb) == -1) return NULL;
2589 if (!S_ISDIR(sb.st_mode)) {
2590 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2593 if (!cando_by_name(S_IRUSR,0,dir)) {
2594 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2597 /* Get memory for the handle, and the pattern. */
2599 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2601 /* Fill in the fields; mainly playing with the descriptor. */
2602 (void)sprintf(dd->pattern, "%s*.*",dir);
2605 dd->vms_wantversions = 0;
2606 dd->pat.dsc$a_pointer = dd->pattern;
2607 dd->pat.dsc$w_length = strlen(dd->pattern);
2608 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2609 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2612 } /* end of opendir() */
2616 * Set the flag to indicate we want versions or not.
2618 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2620 vmsreaddirversions(DIR *dd, int flag)
2622 dd->vms_wantversions = flag;
2627 * Free up an opened directory.
2629 /*{{{ void closedir(DIR *dd)*/
2633 (void)lib$find_file_end(&dd->context);
2634 Safefree(dd->pattern);
2635 Safefree((char *)dd);
2640 * Collect all the version numbers for the current file.
2646 struct dsc$descriptor_s pat;
2647 struct dsc$descriptor_s res;
2649 char *p, *text, buff[sizeof dd->entry.d_name];
2651 unsigned long context, tmpsts;
2653 /* Convenient shorthand. */
2656 /* Add the version wildcard, ignoring the "*.*" put on before */
2657 i = strlen(dd->pattern);
2658 New(1308,text,i + e->d_namlen + 3,char);
2659 (void)strcpy(text, dd->pattern);
2660 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2662 /* Set up the pattern descriptor. */
2663 pat.dsc$a_pointer = text;
2664 pat.dsc$w_length = i + e->d_namlen - 1;
2665 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2666 pat.dsc$b_class = DSC$K_CLASS_S;
2668 /* Set up result descriptor. */
2669 res.dsc$a_pointer = buff;
2670 res.dsc$w_length = sizeof buff - 2;
2671 res.dsc$b_dtype = DSC$K_DTYPE_T;
2672 res.dsc$b_class = DSC$K_CLASS_S;
2674 /* Read files, collecting versions. */
2675 for (context = 0, e->vms_verscount = 0;
2676 e->vms_verscount < VERSIZE(e);
2677 e->vms_verscount++) {
2678 tmpsts = lib$find_file(&pat, &res, &context);
2679 if (tmpsts == RMS$_NMF || context == 0) break;
2681 buff[sizeof buff - 1] = '\0';
2682 if ((p = strchr(buff, ';')))
2683 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2685 e->vms_versions[e->vms_verscount] = -1;
2688 _ckvmssts(lib$find_file_end(&context));
2691 } /* end of collectversions() */
2694 * Read the next entry from the directory.
2696 /*{{{ struct dirent *readdir(DIR *dd)*/
2700 struct dsc$descriptor_s res;
2701 char *p, buff[sizeof dd->entry.d_name];
2702 unsigned long int tmpsts;
2704 /* Set up result descriptor, and get next file. */
2705 res.dsc$a_pointer = buff;
2706 res.dsc$w_length = sizeof buff - 2;
2707 res.dsc$b_dtype = DSC$K_DTYPE_T;
2708 res.dsc$b_class = DSC$K_CLASS_S;
2709 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2710 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2711 if (!(tmpsts & 1)) {
2712 set_vaxc_errno(tmpsts);
2715 set_errno(EACCES); break;
2717 set_errno(ENODEV); break;
2720 set_errno(ENOENT); break;
2727 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2728 buff[sizeof buff - 1] = '\0';
2729 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2732 /* Skip any directory component and just copy the name. */
2733 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2734 else (void)strcpy(dd->entry.d_name, buff);
2736 /* Clobber the version. */
2737 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2739 dd->entry.d_namlen = strlen(dd->entry.d_name);
2740 dd->entry.vms_verscount = 0;
2741 if (dd->vms_wantversions) collectversions(dd);
2744 } /* end of readdir() */
2748 * Return something that can be used in a seekdir later.
2750 /*{{{ long telldir(DIR *dd)*/
2759 * Return to a spot where we used to be. Brute force.
2761 /*{{{ void seekdir(DIR *dd,long count)*/
2763 seekdir(DIR *dd, long count)
2765 int vms_wantversions;
2767 /* If we haven't done anything yet... */
2771 /* Remember some state, and clear it. */
2772 vms_wantversions = dd->vms_wantversions;
2773 dd->vms_wantversions = 0;
2774 _ckvmssts(lib$find_file_end(&dd->context));
2777 /* The increment is in readdir(). */
2778 for (dd->count = 0; dd->count < count; )
2781 dd->vms_wantversions = vms_wantversions;
2783 } /* end of seekdir() */
2786 /* VMS subprocess management
2788 * my_vfork() - just a vfork(), after setting a flag to record that
2789 * the current script is trying a Unix-style fork/exec.
2791 * vms_do_aexec() and vms_do_exec() are called in response to the
2792 * perl 'exec' function. If this follows a vfork call, then they
2793 * call out the the regular perl routines in doio.c which do an
2794 * execvp (for those who really want to try this under VMS).
2795 * Otherwise, they do exactly what the perl docs say exec should
2796 * do - terminate the current script and invoke a new command
2797 * (See below for notes on command syntax.)
2799 * do_aspawn() and do_spawn() implement the VMS side of the perl
2800 * 'system' function.
2802 * Note on command arguments to perl 'exec' and 'system': When handled
2803 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2804 * are concatenated to form a DCL command string. If the first arg
2805 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2806 * the the command string is hrnded off to DCL directly. Otherwise,
2807 * the first token of the command is taken as the filespec of an image
2808 * to run. The filespec is expanded using a default type of '.EXE' and
2809 * the process defaults for device, directory, etc., and the resultant
2810 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2811 * the command string as parameters. This is perhaps a bit compicated,
2812 * but I hope it will form a happy medium between what VMS folks expect
2813 * from lib$spawn and what Unix folks expect from exec.
2816 static int vfork_called;
2818 /*{{{int my_vfork()*/
2828 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2836 if (VMScmd.dsc$a_pointer) {
2837 Safefree(VMScmd.dsc$a_pointer);
2838 VMScmd.dsc$w_length = 0;
2839 VMScmd.dsc$a_pointer = Nullch;
2844 setup_argstr(SV *really, SV **mark, SV **sp)
2847 char *junk, *tmps = Nullch;
2848 register size_t cmdlen = 0;
2854 tmps = SvPV(really,rlen);
2861 for (idx++; idx <= sp; idx++) {
2863 junk = SvPVx(*idx,rlen);
2864 cmdlen += rlen ? rlen + 1 : 0;
2867 New(401,PL_Cmd,cmdlen+1,char);
2869 if (tmps && *tmps) {
2870 strcpy(PL_Cmd,tmps);
2873 else *PL_Cmd = '\0';
2874 while (++mark <= sp) {
2877 strcat(PL_Cmd,SvPVx(*mark,PL_na));
2882 } /* end of setup_argstr() */
2885 static unsigned long int
2886 setup_cmddsc(char *cmd, int check_img)
2888 char resspec[NAM$C_MAXRSS+1];
2889 $DESCRIPTOR(defdsc,".EXE");
2890 $DESCRIPTOR(resdsc,resspec);
2891 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2892 unsigned long int cxt = 0, flags = 1, retsts;
2893 register char *s, *rest, *cp;
2894 register int isdcl = 0;
2897 while (*s && isspace(*s)) s++;
2899 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2900 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2901 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2902 if (*cp == ':' || *cp == '[' || *cp == '<') {
2910 if (isdcl) { /* It's a DCL command, just do it. */
2911 VMScmd.dsc$w_length = strlen(cmd);
2912 if (cmd == PL_Cmd) {
2913 VMScmd.dsc$a_pointer = PL_Cmd;
2914 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2916 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2918 else { /* assume first token is an image spec */
2920 while (*s && !isspace(*s)) s++;
2922 imgdsc.dsc$a_pointer = cmd;
2923 imgdsc.dsc$w_length = s - cmd;
2924 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2925 if (!(retsts & 1)) {
2926 /* just hand off status values likely to be due to user error */
2927 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2928 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2929 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2930 else { _ckvmssts(retsts); }
2933 _ckvmssts(lib$find_file_end(&cxt));
2935 while (*s && !isspace(*s)) s++;
2937 if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
2938 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2939 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2940 strcat(VMScmd.dsc$a_pointer,resspec);
2941 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2942 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2946 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2948 } /* end of setup_cmddsc() */
2951 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2953 vms_do_aexec(SV *really,SV **mark,SV **sp)
2957 if (vfork_called) { /* this follows a vfork - act Unixish */
2959 if (vfork_called < 0) {
2960 warn("Internal inconsistency in tracking vforks");
2963 else return do_aexec(really,mark,sp);
2965 /* no vfork - act VMSish */
2966 return vms_do_exec(setup_argstr(really,mark,sp));
2971 } /* end of vms_do_aexec() */
2974 /* {{{bool vms_do_exec(char *cmd) */
2976 vms_do_exec(char *cmd)
2979 if (vfork_called) { /* this follows a vfork - act Unixish */
2981 if (vfork_called < 0) {
2982 warn("Internal inconsistency in tracking vforks");
2985 else return do_exec(cmd);
2988 { /* no vfork - act VMSish */
2989 unsigned long int retsts;
2992 TAINT_PROPER("exec");
2993 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2994 retsts = lib$do_command(&VMScmd);
2998 set_errno(ENOENT); break;
2999 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3000 set_errno(ENOTDIR); break;
3002 set_errno(EACCES); break;
3004 set_errno(EINVAL); break;
3006 set_errno(E2BIG); break;
3007 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3008 _ckvmssts(retsts); /* fall through */
3009 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3012 set_vaxc_errno(retsts);
3014 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
3020 } /* end of vms_do_exec() */
3023 unsigned long int do_spawn(char *);
3025 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3027 do_aspawn(void *really,void **mark,void **sp)
3030 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3033 } /* end of do_aspawn() */
3036 /* {{{unsigned long int do_spawn(char *cmd) */
3040 unsigned long int sts, substs, hadcmd = 1;
3043 TAINT_PROPER("spawn");
3044 if (!cmd || !*cmd) {
3046 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3048 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3049 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3055 set_errno(ENOENT); break;
3056 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3057 set_errno(ENOTDIR); break;
3059 set_errno(EACCES); break;
3061 set_errno(EINVAL); break;
3063 set_errno(E2BIG); break;
3064 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3065 _ckvmssts(sts); /* fall through */
3066 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3069 set_vaxc_errno(sts);
3071 warn("Can't spawn \"%s\": %s",
3072 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
3077 } /* end of do_spawn() */
3081 * A simple fwrite replacement which outputs itmsz*nitm chars without
3082 * introducing record boundaries every itmsz chars.
3084 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3086 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3088 register char *cp, *end;
3090 end = (char *)src + itmsz * nitm;
3092 while ((char *)src <= end) {
3093 for (cp = src; cp <= end; cp++) if (!*cp) break;
3094 if (fputs(src,dest) == EOF) return EOF;
3096 if (fputc('\0',dest) == EOF) return EOF;
3102 } /* end of my_fwrite() */
3105 /*{{{ int my_flush(FILE *fp)*/
3110 if ((res = fflush(fp)) == 0) {
3111 #ifdef VMS_DO_SOCKETS
3113 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3115 res = fsync(fileno(fp));
3122 * Here are replacements for the following Unix routines in the VMS environment:
3123 * getpwuid Get information for a particular UIC or UID
3124 * getpwnam Get information for a named user
3125 * getpwent Get information for each user in the rights database
3126 * setpwent Reset search to the start of the rights database
3127 * endpwent Finish searching for users in the rights database
3129 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3130 * (defined in pwd.h), which contains the following fields:-
3132 * char *pw_name; Username (in lower case)
3133 * char *pw_passwd; Hashed password
3134 * unsigned int pw_uid; UIC
3135 * unsigned int pw_gid; UIC group number
3136 * char *pw_unixdir; Default device/directory (VMS-style)
3137 * char *pw_gecos; Owner name
3138 * char *pw_dir; Default device/directory (Unix-style)
3139 * char *pw_shell; Default CLI name (eg. DCL)
3141 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3143 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3144 * not the UIC member number (eg. what's returned by getuid()),
3145 * getpwuid() can accept either as input (if uid is specified, the caller's
3146 * UIC group is used), though it won't recognise gid=0.
3148 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3149 * information about other users in your group or in other groups, respectively.
3150 * If the required privilege is not available, then these routines fill only
3151 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3154 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3157 /* sizes of various UAF record fields */
3158 #define UAI$S_USERNAME 12
3159 #define UAI$S_IDENT 31
3160 #define UAI$S_OWNER 31
3161 #define UAI$S_DEFDEV 31
3162 #define UAI$S_DEFDIR 63
3163 #define UAI$S_DEFCLI 31
3166 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3167 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3168 (uic).uic$v_group != UIC$K_WILD_GROUP)
3170 static char __empty[]= "";
3171 static struct passwd __passwd_empty=
3172 {(char *) __empty, (char *) __empty, 0, 0,
3173 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3174 static int contxt= 0;
3175 static struct passwd __pwdcache;
3176 static char __pw_namecache[UAI$S_IDENT+1];
3179 * This routine does most of the work extracting the user information.
3181 static int fillpasswd (const char *name, struct passwd *pwd)
3184 unsigned char length;
3185 char pw_gecos[UAI$S_OWNER+1];
3187 static union uicdef uic;
3189 unsigned char length;
3190 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3193 unsigned char length;
3194 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3197 unsigned char length;
3198 char pw_shell[UAI$S_DEFCLI+1];
3200 static char pw_passwd[UAI$S_PWD+1];
3202 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3203 struct dsc$descriptor_s name_desc;
3204 unsigned long int sts;
3206 static struct itmlst_3 itmlst[]= {
3207 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3208 {sizeof(uic), UAI$_UIC, &uic, &luic},
3209 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3210 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3211 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3212 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3213 {0, 0, NULL, NULL}};
3215 name_desc.dsc$w_length= strlen(name);
3216 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3217 name_desc.dsc$b_class= DSC$K_CLASS_S;
3218 name_desc.dsc$a_pointer= (char *) name;
3220 /* Note that sys$getuai returns many fields as counted strings. */
3221 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3222 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3223 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3225 else { _ckvmssts(sts); }
3226 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3228 if ((int) owner.length < lowner) lowner= (int) owner.length;
3229 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3230 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3231 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3232 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3233 owner.pw_gecos[lowner]= '\0';
3234 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3235 defcli.pw_shell[ldefcli]= '\0';
3236 if (valid_uic(uic)) {
3237 pwd->pw_uid= uic.uic$l_uic;
3238 pwd->pw_gid= uic.uic$v_group;
3241 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3242 pwd->pw_passwd= pw_passwd;
3243 pwd->pw_gecos= owner.pw_gecos;
3244 pwd->pw_dir= defdev.pw_dir;
3245 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3246 pwd->pw_shell= defcli.pw_shell;
3247 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3249 ldir= strlen(pwd->pw_unixdir) - 1;
3250 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3253 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3254 __mystrtolower(pwd->pw_unixdir);
3259 * Get information for a named user.
3261 /*{{{struct passwd *getpwnam(char *name)*/
3262 struct passwd *my_getpwnam(char *name)
3264 struct dsc$descriptor_s name_desc;
3266 unsigned long int status, sts;
3268 __pwdcache = __passwd_empty;
3269 if (!fillpasswd(name, &__pwdcache)) {
3270 /* We still may be able to determine pw_uid and pw_gid */
3271 name_desc.dsc$w_length= strlen(name);
3272 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3273 name_desc.dsc$b_class= DSC$K_CLASS_S;
3274 name_desc.dsc$a_pointer= (char *) name;
3275 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3276 __pwdcache.pw_uid= uic.uic$l_uic;
3277 __pwdcache.pw_gid= uic.uic$v_group;
3280 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3281 set_vaxc_errno(sts);
3282 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3285 else { _ckvmssts(sts); }
3288 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3289 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3290 __pwdcache.pw_name= __pw_namecache;
3292 } /* end of my_getpwnam() */
3296 * Get information for a particular UIC or UID.
3297 * Called by my_getpwent with uid=-1 to list all users.
3299 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3300 struct passwd *my_getpwuid(Uid_t uid)
3302 const $DESCRIPTOR(name_desc,__pw_namecache);
3303 unsigned short lname;
3305 unsigned long int status;
3307 if (uid == (unsigned int) -1) {
3309 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3310 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3311 set_vaxc_errno(status);
3312 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3316 else { _ckvmssts(status); }
3317 } while (!valid_uic (uic));
3321 if (!uic.uic$v_group)
3322 uic.uic$v_group= PerlProc_getgid();
3324 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3325 else status = SS$_IVIDENT;
3326 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3327 status == RMS$_PRV) {
3328 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3331 else { _ckvmssts(status); }
3333 __pw_namecache[lname]= '\0';
3334 __mystrtolower(__pw_namecache);
3336 __pwdcache = __passwd_empty;
3337 __pwdcache.pw_name = __pw_namecache;
3339 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3340 The identifier's value is usually the UIC, but it doesn't have to be,
3341 so if we can, we let fillpasswd update this. */
3342 __pwdcache.pw_uid = uic.uic$l_uic;
3343 __pwdcache.pw_gid = uic.uic$v_group;
3345 fillpasswd(__pw_namecache, &__pwdcache);
3348 } /* end of my_getpwuid() */
3352 * Get information for next user.
3354 /*{{{struct passwd *my_getpwent()*/
3355 struct passwd *my_getpwent()
3357 return (my_getpwuid((unsigned int) -1));
3362 * Finish searching rights database for users.
3364 /*{{{void my_endpwent()*/
3368 _ckvmssts(sys$finish_rdb(&contxt));
3374 #ifdef HOMEGROWN_POSIX_SIGNALS
3375 /* Signal handling routines, pulled into the core from POSIX.xs.
3377 * We need these for threads, so they've been rolled into the core,
3378 * rather than left in POSIX.xs.
3380 * (DRS, Oct 23, 1997)
3383 /* sigset_t is atomic under VMS, so these routines are easy */
3384 /*{{{int my_sigemptyset(sigset_t *) */
3385 int my_sigemptyset(sigset_t *set) {
3386 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3392 /*{{{int my_sigfillset(sigset_t *)*/
3393 int my_sigfillset(sigset_t *set) {
3395 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3396 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3402 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3403 int my_sigaddset(sigset_t *set, int sig) {
3404 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3405 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3406 *set |= (1 << (sig - 1));
3412 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3413 int my_sigdelset(sigset_t *set, int sig) {
3414 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3415 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3416 *set &= ~(1 << (sig - 1));
3422 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3423 int my_sigismember(sigset_t *set, int sig) {
3424 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3425 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3426 *set & (1 << (sig - 1));
3431 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3432 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3435 /* If set and oset are both null, then things are badly wrong. Bail out. */
3436 if ((oset == NULL) && (set == NULL)) {
3437 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3441 /* If set's null, then we're just handling a fetch. */
3443 tempmask = sigblock(0);
3448 tempmask = sigsetmask(*set);
3451 tempmask = sigblock(*set);
3454 tempmask = sigblock(0);
3455 sigsetmask(*oset & ~tempmask);
3458 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3463 /* Did they pass us an oset? If so, stick our holding mask into it */
3470 #endif /* HOMEGROWN_POSIX_SIGNALS */
3473 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3474 * my_utime(), and flex_stat(), all of which operate on UTC unless
3475 * VMSISH_TIMES is true.
3477 /* method used to handle UTC conversions:
3478 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3480 static int gmtime_emulation_type;
3481 /* number of secs to add to UTC POSIX-style time to get local time */
3482 static long int utc_offset_secs;
3484 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3485 * in vmsish.h. #undef them here so we can call the CRTL routines
3492 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3493 # define RTL_USES_UTC 1
3496 static time_t toutc_dst(time_t loc) {
3499 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3500 loc -= utc_offset_secs;
3501 if (rsltmp->tm_isdst) loc -= 3600;
3504 #define _toutc(secs) ((secs) == -1 ? -1 : \
3505 ((gmtime_emulation_type || my_time(NULL)), \
3506 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3507 ((secs) - utc_offset_secs))))
3509 static time_t toloc_dst(time_t utc) {
3512 utc += utc_offset_secs;
3513 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3514 if (rsltmp->tm_isdst) utc += 3600;
3517 #define _toloc(secs) ((secs) == -1 ? -1 : \
3518 ((gmtime_emulation_type || my_time(NULL)), \
3519 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3520 ((secs) + utc_offset_secs))))
3523 /* my_time(), my_localtime(), my_gmtime()
3524 * By default traffic in UTC time values, using CRTL gmtime() or
3525 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3526 * Note: We need to use these functions even when the CRTL has working
3527 * UTC support, since they also handle C<use vmsish qw(times);>
3529 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3530 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3533 /*{{{time_t my_time(time_t *timep)*/
3534 time_t my_time(time_t *timep)
3540 if (gmtime_emulation_type == 0) {
3542 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3543 /* results of calls to gmtime() and localtime() */
3544 /* for same &base */
3546 gmtime_emulation_type++;
3547 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3550 gmtime_emulation_type++;
3551 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3552 gmtime_emulation_type++;
3553 warn("no UTC offset information; assuming local time is UTC");
3555 else { utc_offset_secs = atol(off); }
3557 else { /* We've got a working gmtime() */
3558 struct tm gmt, local;
3561 tm_p = localtime(&base);
3563 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3564 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3565 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3566 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3572 # ifdef RTL_USES_UTC
3573 if (VMSISH_TIME) when = _toloc(when);
3575 if (!VMSISH_TIME) when = _toutc(when);
3578 if (timep != NULL) *timep = when;
3581 } /* end of my_time() */
3585 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3587 my_gmtime(const time_t *timep)
3594 if (timep == NULL) {
3595 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3598 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3602 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
3604 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
3605 return gmtime(&when);
3607 /* CRTL localtime() wants local time as input, so does no tz correction */
3608 rsltmp = localtime(&when);
3609 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
3612 } /* end of my_gmtime() */
3616 /*{{{struct tm *my_localtime(const time_t *timep)*/
3618 my_localtime(const time_t *timep)
3624 if (timep == NULL) {
3625 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3628 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3629 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3632 # ifdef RTL_USES_UTC
3634 if (VMSISH_TIME) when = _toutc(when);
3636 /* CRTL localtime() wants UTC as input, does tz correction itself */
3637 return localtime(&when);
3640 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
3643 /* CRTL localtime() wants local time as input, so does no tz correction */
3644 rsltmp = localtime(&when);
3645 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
3648 } /* end of my_localtime() */
3651 /* Reset definitions for later calls */
3652 #define gmtime(t) my_gmtime(t)
3653 #define localtime(t) my_localtime(t)
3654 #define time(t) my_time(t)
3657 /* my_utime - update modification time of a file
3658 * calling sequence is identical to POSIX utime(), but under
3659 * VMS only the modification time is changed; ODS-2 does not
3660 * maintain access times. Restrictions differ from the POSIX
3661 * definition in that the time can be changed as long as the
3662 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3663 * no separate checks are made to insure that the caller is the
3664 * owner of the file or has special privs enabled.
3665 * Code here is based on Joe Meadows' FILE utility.
3668 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3669 * to VMS epoch (01-JAN-1858 00:00:00.00)
3670 * in 100 ns intervals.
3672 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3674 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3675 int my_utime(char *file, struct utimbuf *utimes)
3679 long int bintime[2], len = 2, lowbit, unixtime,
3680 secscale = 10000000; /* seconds --> 100 ns intervals */
3681 unsigned long int chan, iosb[2], retsts;
3682 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3683 struct FAB myfab = cc$rms_fab;
3684 struct NAM mynam = cc$rms_nam;
3685 #if defined (__DECC) && defined (__VAX)
3686 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3687 * at least through VMS V6.1, which causes a type-conversion warning.
3689 # pragma message save
3690 # pragma message disable cvtdiftypes
3692 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3693 struct fibdef myfib;
3694 #if defined (__DECC) && defined (__VAX)
3695 /* This should be right after the declaration of myatr, but due
3696 * to a bug in VAX DEC C, this takes effect a statement early.
3698 # pragma message restore
3700 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3701 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3702 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3704 if (file == NULL || *file == '\0') {
3706 set_vaxc_errno(LIB$_INVARG);
3709 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3711 if (utimes != NULL) {
3712 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3713 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3714 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3715 * as input, we force the sign bit to be clear by shifting unixtime right
3716 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3718 lowbit = (utimes->modtime & 1) ? secscale : 0;
3719 unixtime = (long int) utimes->modtime;
3721 /* If input was UTC; convert to local for sys svc */
3722 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
3724 unixtime >> 1; secscale << 1;
3725 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3726 if (!(retsts & 1)) {
3728 set_vaxc_errno(retsts);
3731 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3732 if (!(retsts & 1)) {
3734 set_vaxc_errno(retsts);
3739 /* Just get the current time in VMS format directly */
3740 retsts = sys$gettim(bintime);
3741 if (!(retsts & 1)) {
3743 set_vaxc_errno(retsts);
3748 myfab.fab$l_fna = vmsspec;
3749 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3750 myfab.fab$l_nam = &mynam;
3751 mynam.nam$l_esa = esa;
3752 mynam.nam$b_ess = (unsigned char) sizeof esa;
3753 mynam.nam$l_rsa = rsa;
3754 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3756 /* Look for the file to be affected, letting RMS parse the file
3757 * specification for us as well. I have set errno using only
3758 * values documented in the utime() man page for VMS POSIX.
3760 retsts = sys$parse(&myfab,0,0);
3761 if (!(retsts & 1)) {
3762 set_vaxc_errno(retsts);
3763 if (retsts == RMS$_PRV) set_errno(EACCES);
3764 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3765 else set_errno(EVMSERR);
3768 retsts = sys$search(&myfab,0,0);
3769 if (!(retsts & 1)) {
3770 set_vaxc_errno(retsts);
3771 if (retsts == RMS$_PRV) set_errno(EACCES);
3772 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3773 else set_errno(EVMSERR);
3777 devdsc.dsc$w_length = mynam.nam$b_dev;
3778 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3780 retsts = sys$assign(&devdsc,&chan,0,0);
3781 if (!(retsts & 1)) {
3782 set_vaxc_errno(retsts);
3783 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3784 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3785 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3786 else set_errno(EVMSERR);
3790 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3791 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3793 memset((void *) &myfib, 0, sizeof myfib);
3795 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3796 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3797 /* This prevents the revision time of the file being reset to the current
3798 * time as a result of our IO$_MODIFY $QIO. */
3799 myfib.fib$l_acctl = FIB$M_NORECORD;
3801 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3802 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3803 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3805 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3806 _ckvmssts(sys$dassgn(chan));
3807 if (retsts & 1) retsts = iosb[0];
3808 if (!(retsts & 1)) {
3809 set_vaxc_errno(retsts);
3810 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3811 else set_errno(EVMSERR);
3816 } /* end of my_utime() */
3820 * flex_stat, flex_fstat
3821 * basic stat, but gets it right when asked to stat
3822 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3825 /* encode_dev packs a VMS device name string into an integer to allow
3826 * simple comparisons. This can be used, for example, to check whether two
3827 * files are located on the same device, by comparing their encoded device
3828 * names. Even a string comparison would not do, because stat() reuses the
3829 * device name buffer for each call; so without encode_dev, it would be
3830 * necessary to save the buffer and use strcmp (this would mean a number of
3831 * changes to the standard Perl code, to say nothing of what a Perl script
3834 * The device lock id, if it exists, should be unique (unless perhaps compared
3835 * with lock ids transferred from other nodes). We have a lock id if the disk is
3836 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3837 * device names. Thus we use the lock id in preference, and only if that isn't
3838 * available, do we try to pack the device name into an integer (flagged by
3839 * the sign bit (LOCKID_MASK) being set).
3841 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3842 * name and its encoded form, but it seems very unlikely that we will find
3843 * two files on different disks that share the same encoded device names,
3844 * and even more remote that they will share the same file id (if the test
3845 * is to check for the same file).
3847 * A better method might be to use sys$device_scan on the first call, and to
3848 * search for the device, returning an index into the cached array.
3849 * The number returned would be more intelligable.
3850 * This is probably not worth it, and anyway would take quite a bit longer
3851 * on the first call.
3853 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3854 static mydev_t encode_dev (const char *dev)
3857 unsigned long int f;
3862 if (!dev || !dev[0]) return 0;
3866 struct dsc$descriptor_s dev_desc;
3867 unsigned long int status, lockid, item = DVI$_LOCKID;
3869 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3870 can try that first. */
3871 dev_desc.dsc$w_length = strlen (dev);
3872 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3873 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3874 dev_desc.dsc$a_pointer = (char *) dev;
3875 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3876 if (lockid) return (lockid & ~LOCKID_MASK);
3880 /* Otherwise we try to encode the device name */
3884 for (q = dev + strlen(dev); q--; q >= dev) {
3887 else if (isalpha (toupper (*q)))
3888 c= toupper (*q) - 'A' + (char)10;
3890 continue; /* Skip '$'s */
3892 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3894 enc += f * (unsigned long int) c;
3896 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3898 } /* end of encode_dev() */
3900 static char namecache[NAM$C_MAXRSS+1];
3903 is_null_device(name)
3906 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3907 The underscore prefix, controller letter, and unit number are
3908 independently optional; for our purposes, the colon punctuation
3909 is not. The colon can be trailed by optional directory and/or
3910 filename, but two consecutive colons indicates a nodename rather
3911 than a device. [pr] */
3912 if (*name == '_') ++name;
3913 if (tolower(*name++) != 'n') return 0;
3914 if (tolower(*name++) != 'l') return 0;
3915 if (tolower(*name) == 'a') ++name;
3916 if (*name == '0') ++name;
3917 return (*name++ == ':') && (*name != ':');
3920 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
3921 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3922 * subset of the applicable information.
3924 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3926 cando(I32 bit, I32 effective, Stat_t *statbufp)
3929 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
3931 char fname[NAM$C_MAXRSS+1];
3932 unsigned long int retsts;
3933 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3934 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3936 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3937 device name on successive calls */
3938 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
3939 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
3940 namdsc.dsc$a_pointer = fname;
3941 namdsc.dsc$w_length = sizeof fname - 1;
3943 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
3944 &namdsc,&namdsc.dsc$w_length,0,0);
3946 fname[namdsc.dsc$w_length] = '\0';
3947 return cando_by_name(bit,effective,fname);
3949 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3950 warn("Can't get filespec - stale stat buffer?\n");
3954 return FALSE; /* Should never get to here */
3956 } /* end of cando() */
3960 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3962 cando_by_name(I32 bit, I32 effective, char *fname)
3964 static char usrname[L_cuserid];
3965 static struct dsc$descriptor_s usrdsc =
3966 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3967 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3968 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3969 unsigned short int retlen;
3970 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3971 union prvdef curprv;
3972 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3973 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3974 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3977 if (!fname || !*fname) return FALSE;
3978 /* Make sure we expand logical names, since sys$check_access doesn't */
3979 if (!strpbrk(fname,"/]>:")) {
3980 strcpy(fileified,fname);
3981 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3984 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3985 retlen = namdsc.dsc$w_length = strlen(vmsname);
3986 namdsc.dsc$a_pointer = vmsname;
3987 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3988 vmsname[retlen-1] == ':') {
3989 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3990 namdsc.dsc$w_length = strlen(fileified);
3991 namdsc.dsc$a_pointer = fileified;
3994 if (!usrdsc.dsc$w_length) {
3996 usrdsc.dsc$w_length = strlen(usrname);
4003 access = ARM$M_EXECUTE;
4008 access = ARM$M_READ;
4013 access = ARM$M_WRITE;
4018 access = ARM$M_DELETE;
4024 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4025 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4026 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4027 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4028 set_vaxc_errno(retsts);
4029 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4030 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4031 else set_errno(ENOENT);
4034 if (retsts == SS$_NORMAL) {
4035 if (!privused) return TRUE;
4036 /* We can get access, but only by using privs. Do we have the
4037 necessary privs currently enabled? */
4038 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4039 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4040 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4041 !curprv.prv$v_bypass) return FALSE;
4042 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4043 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4044 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4047 if (retsts == SS$_ACCONFLICT) {
4052 return FALSE; /* Should never get here */
4054 } /* end of cando_by_name() */
4058 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4060 flex_fstat(int fd, Stat_t *statbufp)
4063 if (!fstat(fd,(stat_t *) statbufp)) {
4064 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4065 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4066 # ifdef RTL_USES_UTC
4069 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4070 statbufp->st_atime = _toloc(statbufp->st_atime);
4071 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4076 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4080 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4081 statbufp->st_atime = _toutc(statbufp->st_atime);
4082 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4089 } /* end of flex_fstat() */
4092 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4094 flex_stat(char *fspec, Stat_t *statbufp)
4097 char fileified[NAM$C_MAXRSS+1];
4100 if (statbufp == (Stat_t *) &PL_statcache)
4101 do_tovmsspec(fspec,namecache,0);
4102 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4103 memset(statbufp,0,sizeof *statbufp);
4104 statbufp->st_dev = encode_dev("_NLA0:");
4105 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4106 statbufp->st_uid = 0x00010001;
4107 statbufp->st_gid = 0x0001;
4108 time((time_t *)&statbufp->st_mtime);
4109 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4113 /* Try for a directory name first. If fspec contains a filename without
4114 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4115 * and sea:[wine.dark]water. exist, we prefer the directory here.
4116 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4117 * not sea:[wine.dark]., if the latter exists. If the intended target is
4118 * the file with null type, specify this by calling flex_stat() with
4119 * a '.' at the end of fspec.
4121 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4122 retval = stat(fileified,(stat_t *) statbufp);
4123 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4124 strcpy(namecache,fileified);
4126 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4128 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4129 # ifdef RTL_USES_UTC
4132 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4133 statbufp->st_atime = _toloc(statbufp->st_atime);
4134 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4139 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4143 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4144 statbufp->st_atime = _toutc(statbufp->st_atime);
4145 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4151 } /* end of flex_stat() */
4154 /* Insures that no carriage-control translation will be done on a file. */
4155 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
4157 my_binmode(FILE *fp, char iotype)
4159 char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
4160 int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
4163 if (!fgetname(fp,filespec)) return NULL;
4164 for (s = filespec; *s; s++) {
4165 if (*s == ':') colon = s;
4166 else if (*s == ']' || *s == '>') dirend = s;
4168 /* Looks like a tmpfile, which will go away if reopened */
4169 if (s == dirend + 3) return fp;
4170 /* If we've got a non-file-structured device, clip off the trailing
4171 * junk, and don't lose sleep if we can't get a stream position. */
4172 if (dirend == Nullch) *(colon+1) = '\0';
4173 if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
4175 case '<': case 'r': acmode = "rb"; break;
4176 case '>': case 'w': case '|':
4177 /* use 'a' instead of 'w' to avoid creating new file;
4178 fsetpos below will take care of restoring file position */
4179 case 'a': acmode = "ab"; break;
4180 case '+': case 's': acmode = "rb+"; break;
4181 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
4182 /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
4183 /* since we didn't really open them and can't really */
4185 case 0: return NULL; break;
4187 warn("Unrecognized iotype %x for %s in my_binmode",iotype, filespec);
4190 if (freopen(filespec,acmode,fp) == NULL) return NULL;
4191 if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
4192 if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
4194 } /* end of my_binmode() */
4198 /*{{{char *my_getlogin()*/
4199 /* VMS cuserid == Unix getlogin, except calling sequence */
4203 static char user[L_cuserid];
4204 return cuserid(user);
4209 /* rmscopy - copy a file using VMS RMS routines
4211 * Copies contents and attributes of spec_in to spec_out, except owner
4212 * and protection information. Name and type of spec_in are used as
4213 * defaults for spec_out. The third parameter specifies whether rmscopy()
4214 * should try to propagate timestamps from the input file to the output file.
4215 * If it is less than 0, no timestamps are preserved. If it is 0, then
4216 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4217 * propagated to the output file at creation iff the output file specification
4218 * did not contain an explicit name or type, and the revision date is always
4219 * updated at the end of the copy operation. If it is greater than 0, then
4220 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4221 * other than the revision date should be propagated, and bit 1 indicates
4222 * that the revision date should be propagated.
4224 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4226 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
4227 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4228 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4229 * as part of the Perl standard distribution under the terms of the
4230 * GNU General Public License or the Perl Artistic License. Copies
4231 * of each may be found in the Perl standard distribution.
4233 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4235 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4237 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4238 rsa[NAM$C_MAXRSS], ubf[32256];
4239 unsigned long int i, sts, sts2;
4240 struct FAB fab_in, fab_out;
4241 struct RAB rab_in, rab_out;
4243 struct XABDAT xabdat;
4244 struct XABFHC xabfhc;
4245 struct XABRDT xabrdt;
4246 struct XABSUM xabsum;
4248 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4249 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4250 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4254 fab_in = cc$rms_fab;
4255 fab_in.fab$l_fna = vmsin;
4256 fab_in.fab$b_fns = strlen(vmsin);
4257 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4258 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4259 fab_in.fab$l_fop = FAB$M_SQO;
4260 fab_in.fab$l_nam = &nam;
4261 fab_in.fab$l_xab = (void *) &xabdat;
4264 nam.nam$l_rsa = rsa;
4265 nam.nam$b_rss = sizeof(rsa);
4266 nam.nam$l_esa = esa;
4267 nam.nam$b_ess = sizeof (esa);
4268 nam.nam$b_esl = nam.nam$b_rsl = 0;
4270 xabdat = cc$rms_xabdat; /* To get creation date */
4271 xabdat.xab$l_nxt = (void *) &xabfhc;
4273 xabfhc = cc$rms_xabfhc; /* To get record length */
4274 xabfhc.xab$l_nxt = (void *) &xabsum;
4276 xabsum = cc$rms_xabsum; /* To get key and area information */
4278 if (!((sts = sys$open(&fab_in)) & 1)) {
4279 set_vaxc_errno(sts);
4283 set_errno(ENOENT); break;
4285 set_errno(ENODEV); break;
4287 set_errno(EINVAL); break;
4289 set_errno(EACCES); break;
4297 fab_out.fab$w_ifi = 0;
4298 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4299 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4300 fab_out.fab$l_fop = FAB$M_SQO;
4301 fab_out.fab$l_fna = vmsout;
4302 fab_out.fab$b_fns = strlen(vmsout);
4303 fab_out.fab$l_dna = nam.nam$l_name;
4304 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4306 if (preserve_dates == 0) { /* Act like DCL COPY */
4307 nam.nam$b_nop = NAM$M_SYNCHK;
4308 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4309 if (!((sts = sys$parse(&fab_out)) & 1)) {
4310 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4311 set_vaxc_errno(sts);
4314 fab_out.fab$l_xab = (void *) &xabdat;
4315 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4317 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4318 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4319 preserve_dates =0; /* bitmask from this point forward */
4321 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4322 if (!((sts = sys$create(&fab_out)) & 1)) {
4323 set_vaxc_errno(sts);
4326 set_errno(ENOENT); break;
4328 set_errno(ENODEV); break;
4330 set_errno(EINVAL); break;
4332 set_errno(EACCES); break;
4338 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4339 if (preserve_dates & 2) {
4340 /* sys$close() will process xabrdt, not xabdat */
4341 xabrdt = cc$rms_xabrdt;
4343 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4345 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4346 * is unsigned long[2], while DECC & VAXC use a struct */
4347 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4349 fab_out.fab$l_xab = (void *) &xabrdt;
4352 rab_in = cc$rms_rab;
4353 rab_in.rab$l_fab = &fab_in;
4354 rab_in.rab$l_rop = RAB$M_BIO;
4355 rab_in.rab$l_ubf = ubf;
4356 rab_in.rab$w_usz = sizeof ubf;
4357 if (!((sts = sys$connect(&rab_in)) & 1)) {
4358 sys$close(&fab_in); sys$close(&fab_out);
4359 set_errno(EVMSERR); set_vaxc_errno(sts);
4363 rab_out = cc$rms_rab;
4364 rab_out.rab$l_fab = &fab_out;
4365 rab_out.rab$l_rbf = ubf;
4366 if (!((sts = sys$connect(&rab_out)) & 1)) {
4367 sys$close(&fab_in); sys$close(&fab_out);
4368 set_errno(EVMSERR); set_vaxc_errno(sts);
4372 while ((sts = sys$read(&rab_in))) { /* always true */
4373 if (sts == RMS$_EOF) break;
4374 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4375 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4376 sys$close(&fab_in); sys$close(&fab_out);
4377 set_errno(EVMSERR); set_vaxc_errno(sts);
4382 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4383 sys$close(&fab_in); sys$close(&fab_out);
4384 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4386 set_errno(EVMSERR); set_vaxc_errno(sts);
4392 } /* end of rmscopy() */
4396 /*** The following glue provides 'hooks' to make some of the routines
4397 * from this file available from Perl. These routines are sufficiently
4398 * basic, and are required sufficiently early in the build process,
4399 * that's it's nice to have them available to miniperl as well as the
4400 * full Perl, so they're set up here instead of in an extension. The
4401 * Perl code which handles importation of these names into a given
4402 * package lives in [.VMS]Filespec.pm in @INC.
4406 rmsexpand_fromperl(CV *cv)
4409 char *fspec, *defspec = NULL, *rslt;
4411 if (!items || items > 2)
4412 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4413 fspec = SvPV(ST(0),PL_na);
4414 if (!fspec || !*fspec) XSRETURN_UNDEF;
4415 if (items == 2) defspec = SvPV(ST(1),PL_na);
4417 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4418 ST(0) = sv_newmortal();
4419 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4424 vmsify_fromperl(CV *cv)
4429 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4430 vmsified = do_tovmsspec(SvPV(ST(0),PL_na),NULL,1);
4431 ST(0) = sv_newmortal();
4432 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4437 unixify_fromperl(CV *cv)
4442 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4443 unixified = do_tounixspec(SvPV(ST(0),PL_na),NULL,1);
4444 ST(0) = sv_newmortal();
4445 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4450 fileify_fromperl(CV *cv)
4455 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4456 fileified = do_fileify_dirspec(SvPV(ST(0),PL_na),NULL,1);
4457 ST(0) = sv_newmortal();
4458 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4463 pathify_fromperl(CV *cv)
4468 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4469 pathified = do_pathify_dirspec(SvPV(ST(0),PL_na),NULL,1);
4470 ST(0) = sv_newmortal();
4471 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4476 vmspath_fromperl(CV *cv)
4481 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4482 vmspath = do_tovmspath(SvPV(ST(0),PL_na),NULL,1);
4483 ST(0) = sv_newmortal();
4484 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4489 unixpath_fromperl(CV *cv)
4494 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4495 unixpath = do_tounixpath(SvPV(ST(0),PL_na),NULL,1);
4496 ST(0) = sv_newmortal();
4497 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4502 candelete_fromperl(CV *cv)
4505 char fspec[NAM$C_MAXRSS+1], *fsp;
4509 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4511 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4512 if (SvTYPE(mysv) == SVt_PVGV) {
4513 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4514 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4521 if (mysv != ST(0) || !(fsp = SvPV(mysv,PL_na)) || !*fsp) {
4522 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4528 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4533 rmscopy_fromperl(CV *cv)
4536 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4538 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4539 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4540 unsigned long int sts;
4544 if (items < 2 || items > 3)
4545 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4547 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4548 if (SvTYPE(mysv) == SVt_PVGV) {
4549 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4550 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4557 if (mysv != ST(0) || !(inp = SvPV(mysv,PL_na)) || !*inp) {
4558 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4563 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4564 if (SvTYPE(mysv) == SVt_PVGV) {
4565 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4566 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4573 if (mysv != ST(1) || !(outp = SvPV(mysv,PL_na)) || !*outp) {
4574 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4579 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4581 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4588 char* file = __FILE__;
4590 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4591 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4592 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4593 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4594 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4595 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4596 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4597 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4598 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
4600 #ifdef PRIME_ENV_AT_STARTUP