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 (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(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 = PTHREAD_MUTEX_INITIALIZER;
210 MUTEX_LOCK(&primenv_mutex);
211 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
212 /* Perform a dummy fetch as an lval to insure that the hash table is
213 * set up. Otherwise, the hv_store() will turn into a nullop. */
214 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
215 /* Also, set up any "special" keys that the CRTL defines,
216 * either by itself or becasue we were called from a C program
217 * using exec[lv]e() */
218 for (i = 0; environ[i]; i++) {
219 if (!(start = strchr(environ[i],'='))) {
220 warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]);
224 (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0);
228 /* Now, go get the logical names */
229 create_mbx(&chan,&mbxdsc);
230 if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
231 if ((retsts = sys$dassgn(chan)) & 1) {
232 /* Be certain that subprocess is using the CLI and command tables we
233 * expect, and don't pass symbols through so that we insure that
234 * "Show Logical" can't be subverted.
237 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
238 0,&riseandshine,0,0,&clidsc,&tabdsc);
239 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
240 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
243 if (sholog == Nullfp || !(retsts & 1)) {
244 if (sholog != Nullfp) PerlIO_close(sholog);
245 MUTEX_UNLOCK(&primenv_mutex);
246 _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
248 /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
249 * tied to Perl's I/O layer, so it may not return a simple FILE * */
251 rs = newSVpv("\n",1);
252 linesv = newSVpv("",0);
254 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
255 PerlIO_close(sholog);
256 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
258 /* Wait for subprocess to clean up (we know subproc won't return 0) */
259 while (substs == 0) { sys$hiber(); wakect++;}
260 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
262 MUTEX_UNLOCK(&primenv_mutex);
265 while (*start != '"' && *start != '=' && *start) start++;
266 if (*start != '"') continue;
267 for (end = ++start; *end && *end != '"'; end++) ;
268 if (*end) *end = '\0';
270 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
271 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
273 warn("Ill-formed logical name |%s| in prime_env_iter",start);
276 else { MUTEX_UNLOCK(&primenv_mutex); _ckvmssts(vaxc$errno); }
279 eqvsv = newSVpv(eqv,eqvlen);
280 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
283 } /* end of prime_env_iter */
287 /*{{{ void my_setenv(char *lnm, char *eqv)*/
289 my_setenv(char *lnm,char *eqv)
290 /* Define a supervisor-mode logical name in the process table.
291 * In the future we'll add tables, attribs, and acmodes,
292 * probably through a different call.
295 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
296 unsigned long int retsts, usermode = PSL$C_USER;
297 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
298 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
299 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
301 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
302 lnmdsc.dsc$w_length = cp1 - lnm;
304 if (!eqv || !*eqv) { /* we're deleting a logical name */
305 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
306 if (retsts == SS$_IVLOGNAM) return;
307 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
309 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
310 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
314 eqvdsc.dsc$w_length = strlen(eqv);
315 eqvdsc.dsc$a_pointer = eqv;
317 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
320 } /* end of my_setenv() */
324 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
325 /* my_crypt - VMS password hashing
326 * my_crypt() provides an interface compatible with the Unix crypt()
327 * C library function, and uses sys$hash_password() to perform VMS
328 * password hashing. The quadword hashed password value is returned
329 * as a NUL-terminated 8 character string. my_crypt() does not change
330 * the case of its string arguments; in order to match the behavior
331 * of LOGINOUT et al., alphabetic characters in both arguments must
332 * be upcased by the caller.
335 my_crypt(const char *textpasswd, const char *usrname)
337 # ifndef UAI$C_PREFERRED_ALGORITHM
338 # define UAI$C_PREFERRED_ALGORITHM 127
340 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
341 unsigned short int salt = 0;
342 unsigned long int sts;
344 unsigned short int dsc$w_length;
345 unsigned char dsc$b_type;
346 unsigned char dsc$b_class;
347 const char * dsc$a_pointer;
348 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
349 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
350 struct itmlst_3 uailst[3] = {
351 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
352 { sizeof salt, UAI$_SALT, &salt, 0},
353 { 0, 0, NULL, NULL}};
356 usrdsc.dsc$w_length = strlen(usrname);
357 usrdsc.dsc$a_pointer = usrname;
358 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
365 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
371 if (sts != RMS$_RNF) return NULL;
374 txtdsc.dsc$w_length = strlen(textpasswd);
375 txtdsc.dsc$a_pointer = textpasswd;
376 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
377 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
380 return (char *) hash;
382 } /* end of my_crypt() */
386 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
387 static char *do_fileify_dirspec(char *, char *, int);
388 static char *do_tovmsspec(char *, char *, int);
390 /*{{{int do_rmdir(char *name)*/
394 char dirfile[NAM$C_MAXRSS+1];
398 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
399 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
400 else retval = kill_file(dirfile);
403 } /* end of do_rmdir */
407 * Delete any file to which user has control access, regardless of whether
408 * delete access is explicitly allowed.
409 * Limitations: User must have write access to parent directory.
410 * Does not block signals or ASTs; if interrupted in midstream
411 * may leave file with an altered ACL.
414 /*{{{int kill_file(char *name)*/
416 kill_file(char *name)
418 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
419 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
420 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
421 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
423 unsigned char myace$b_length;
424 unsigned char myace$b_type;
425 unsigned short int myace$w_flags;
426 unsigned long int myace$l_access;
427 unsigned long int myace$l_ident;
428 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
429 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
430 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
432 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
433 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
434 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
435 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
436 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
437 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
439 /* Expand the input spec using RMS, since the CRTL remove() and
440 * system services won't do this by themselves, so we may miss
441 * a file "hiding" behind a logical name or search list. */
442 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
443 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
444 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
445 /* If not, can changing protections help? */
446 if (vaxc$errno != RMS$_PRV) return -1;
448 /* No, so we get our own UIC to use as a rights identifier,
449 * and the insert an ACE at the head of the ACL which allows us
450 * to delete the file.
452 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
453 fildsc.dsc$w_length = strlen(rspec);
454 fildsc.dsc$a_pointer = rspec;
456 newace.myace$l_ident = oldace.myace$l_ident;
457 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
462 case SS$_NOSUCHOBJECT:
463 set_errno(ENOENT); break;
465 set_errno(ENODEV); break;
467 case SS$_INVFILFOROP:
468 set_errno(EINVAL); break;
470 set_errno(EACCES); break;
474 set_vaxc_errno(aclsts);
477 /* Grab any existing ACEs with this identifier in case we fail */
478 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
479 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
480 || fndsts == SS$_NOMOREACE ) {
481 /* Add the new ACE . . . */
482 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
484 if ((rmsts = remove(name))) {
485 /* We blew it - dir with files in it, no write priv for
486 * parent directory, etc. Put things back the way they were. */
487 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
490 addlst[0].bufadr = &oldace;
491 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
498 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
499 /* We just deleted it, so of course it's not there. Some versions of
500 * VMS seem to return success on the unlock operation anyhow (after all
501 * the unlock is successful), but others don't.
503 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
504 if (aclsts & 1) aclsts = fndsts;
507 set_vaxc_errno(aclsts);
513 } /* end of kill_file() */
517 /*{{{int my_mkdir(char *,Mode_t)*/
519 my_mkdir(char *dir, Mode_t mode)
521 STRLEN dirlen = strlen(dir);
523 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
524 * null file name/type. However, it's commonplace under Unix,
525 * so we'll allow it for a gain in portability.
527 if (dir[dirlen-1] == '/') {
528 char *newdir = savepvn(dir,dirlen-1);
529 int ret = mkdir(newdir,mode);
533 else return mkdir(dir,mode);
534 } /* end of my_mkdir */
539 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
541 static unsigned long int mbxbufsiz;
542 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
546 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
547 * preprocessor consant BUFSIZ from stdio.h as the size of the
550 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
551 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
553 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
555 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
556 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
558 } /* end of create_mbx() */
560 /*{{{ my_popen and my_pclose*/
563 struct pipe_details *next;
564 PerlIO *fp; /* stdio file pointer to pipe mailbox */
565 int pid; /* PID of subprocess */
566 int mode; /* == 'r' if pipe open for reading */
567 int done; /* subprocess has completed */
568 unsigned long int completion; /* termination status of subprocess */
571 struct exit_control_block
573 struct exit_control_block *flink;
574 unsigned long int (*exit_routine)();
575 unsigned long int arg_count;
576 unsigned long int *status_address;
577 unsigned long int exit_status;
580 static struct pipe_details *open_pipes = NULL;
581 static $DESCRIPTOR(nl_desc, "NL:");
582 static int waitpid_asleep = 0;
584 static unsigned long int
587 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
590 while (open_pipes != NULL) {
591 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
592 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
595 if (!open_pipes->done) /* We tried to be nice . . . */
596 _ckvmssts(sys$delprc(&open_pipes->pid,0));
597 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
598 else if (!(sts & 1)) retsts = sts;
603 static struct exit_control_block pipe_exitblock =
604 {(struct exit_control_block *) 0,
605 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
609 popen_completion_ast(struct pipe_details *thispipe)
611 thispipe->done = TRUE;
612 if (waitpid_asleep) {
619 safe_popen(char *cmd, char *mode)
621 static int handler_set_up = FALSE;
623 unsigned short int chan;
624 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
625 struct pipe_details *info;
626 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
627 DSC$K_CLASS_S, mbxname},
628 cmddsc = {0, DSC$K_DTYPE_T,
632 cmddsc.dsc$w_length=strlen(cmd);
633 cmddsc.dsc$a_pointer=cmd;
634 if (cmddsc.dsc$w_length > 255) {
635 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
639 New(1301,info,1,struct pipe_details);
642 create_mbx(&chan,&namdsc);
644 /* open a FILE* onto it */
645 info->fp = PerlIO_open(mbxname, mode);
647 /* give up other channel onto it */
648 _ckvmssts(sys$dassgn(chan));
658 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
659 0 /* name */, &info->pid, &info->completion,
660 0, popen_completion_ast,info,0,0,0));
663 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
664 0 /* name */, &info->pid, &info->completion,
665 0, popen_completion_ast,info,0,0,0));
668 if (!handler_set_up) {
669 _ckvmssts(sys$dclexh(&pipe_exitblock));
670 handler_set_up = TRUE;
672 info->next=open_pipes; /* prepend to list */
675 forkprocess = info->pid;
677 } /* end of safe_popen */
680 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
682 my_popen(char *cmd, char *mode)
685 TAINT_PROPER("popen");
686 return safe_popen(cmd,mode);
691 /*{{{ I32 my_pclose(FILE *fp)*/
692 I32 my_pclose(FILE *fp)
694 struct pipe_details *info, *last = NULL;
695 unsigned long int retsts;
697 for (info = open_pipes; info != NULL; last = info, info = info->next)
698 if (info->fp == fp) break;
700 if (info == NULL) { /* no such pipe open */
701 set_errno(ECHILD); /* quoth POSIX */
702 set_vaxc_errno(SS$_NONEXPR);
706 /* If we were writing to a subprocess, insure that someone reading from
707 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
708 * produce an EOF record in the mailbox. */
709 if (info->mode != 'r') {
710 char devnam[NAM$C_MAXRSS+1], *cp;
711 unsigned long int chan, iosb[2], retsts, retsts2;
712 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
714 if (fgetname(info->fp,devnam)) {
715 /* It oughta be a mailbox, so fgetname should give just the device
716 * name, but just in case . . . */
717 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
718 devdsc.dsc$w_length = strlen(devnam);
719 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
720 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
721 if (retsts & 1) retsts = iosb[0];
722 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
723 if (retsts & 1) retsts = retsts2;
726 else _ckvmssts(vaxc$errno); /* Should never happen */
728 PerlIO_close(info->fp);
730 if (info->done) retsts = info->completion;
731 else waitpid(info->pid,(int *) &retsts,0);
733 /* remove from list of open pipes */
734 if (last) last->next = info->next;
735 else open_pipes = info->next;
740 } /* end of my_pclose() */
742 /* sort-of waitpid; use only with popen() */
743 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
745 my_waitpid(Pid_t pid, int *statusp, int flags)
747 struct pipe_details *info;
749 for (info = open_pipes; info != NULL; info = info->next)
750 if (info->pid == pid) break;
752 if (info != NULL) { /* we know about this child */
753 while (!info->done) {
758 *statusp = info->completion;
761 else { /* we haven't heard of this child */
762 $DESCRIPTOR(intdsc,"0 00:00:01");
763 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
764 unsigned long int interval[2],sts;
767 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
768 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
769 if (ownerpid != mypid)
770 warn("pid %d not a child",pid);
773 _ckvmssts(sys$bintim(&intdsc,interval));
774 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
775 _ckvmssts(sys$schdwk(0,0,interval,0));
776 _ckvmssts(sys$hiber());
780 /* There's no easy way to find the termination status a child we're
781 * not aware of beforehand. If we're really interested in the future,
782 * we can go looking for a termination mailbox, or chase after the
783 * accounting record for the process.
789 } /* end of waitpid() */
794 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
796 my_gconvert(double val, int ndig, int trail, char *buf)
798 static char __gcvtbuf[DBL_DIG+1];
801 loc = buf ? buf : __gcvtbuf;
803 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
805 sprintf(loc,"%.*g",ndig,val);
811 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
812 return gcvt(val,ndig,loc);
815 loc[0] = '0'; loc[1] = '\0';
823 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
824 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
825 * to expand file specification. Allows for a single default file
826 * specification and a simple mask of options. If outbuf is non-NULL,
827 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
828 * the resultant file specification is placed. If outbuf is NULL, the
829 * resultant file specification is placed into a static buffer.
830 * The third argument, if non-NULL, is taken to be a default file
831 * specification string. The fourth argument is unused at present.
832 * rmesexpand() returns the address of the resultant string if
833 * successful, and NULL on error.
835 static char *do_tounixspec(char *, char *, int);
838 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
840 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
841 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
842 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
843 struct FAB myfab = cc$rms_fab;
844 struct NAM mynam = cc$rms_nam;
846 unsigned long int retsts, haslower = 0, isunix = 0;
848 if (!filespec || !*filespec) {
849 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
853 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
854 else outbuf = __rmsexpand_retbuf;
856 if ((isunix = (strchr(filespec,'/') != NULL))) {
857 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
861 myfab.fab$l_fna = filespec;
862 myfab.fab$b_fns = strlen(filespec);
863 myfab.fab$l_nam = &mynam;
865 if (defspec && *defspec) {
866 if (strchr(defspec,'/') != NULL) {
867 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
870 myfab.fab$l_dna = defspec;
871 myfab.fab$b_dns = strlen(defspec);
874 mynam.nam$l_esa = esa;
875 mynam.nam$b_ess = sizeof esa;
876 mynam.nam$l_rsa = outbuf;
877 mynam.nam$b_rss = NAM$C_MAXRSS;
879 retsts = sys$parse(&myfab,0,0);
881 mynam.nam$b_nop |= NAM$M_SYNCHK;
882 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
883 retsts == RMS$_DEV || retsts == RMS$_DEV) {
884 retsts = sys$parse(&myfab,0,0);
885 if (retsts & 1) goto expanded;
887 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
888 (void) sys$parse(&myfab,0,0); /* Free search context */
889 if (out) Safefree(out);
890 set_vaxc_errno(retsts);
891 if (retsts == RMS$_PRV) set_errno(EACCES);
892 else if (retsts == RMS$_DEV) set_errno(ENODEV);
893 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
894 else set_errno(EVMSERR);
897 retsts = sys$search(&myfab,0,0);
898 if (!(retsts & 1) && retsts != RMS$_FNF) {
899 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
900 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
901 if (out) Safefree(out);
902 set_vaxc_errno(retsts);
903 if (retsts == RMS$_PRV) set_errno(EACCES);
904 else set_errno(EVMSERR);
908 /* If the input filespec contained any lowercase characters,
909 * downcase the result for compatibility with Unix-minded code. */
911 for (out = myfab.fab$l_fna; *out; out++)
912 if (islower(*out)) { haslower = 1; break; }
913 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
914 else { out = esa; speclen = mynam.nam$b_esl; }
915 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
916 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
917 speclen = mynam.nam$l_ver - out;
918 if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
919 (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' ||
920 defspec[myfab.fab$b_dns-2] == '.'))
921 speclen = mynam.nam$l_type - out;
922 /* If we just had a directory spec on input, $PARSE "helpfully"
923 * adds an empty name and type for us */
924 if (mynam.nam$l_name == mynam.nam$l_type &&
925 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
926 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
927 speclen = mynam.nam$l_name - out;
929 if (haslower) __mystrtolower(out);
931 /* Have we been working with an expanded, but not resultant, spec? */
932 /* Also, convert back to Unix syntax if necessary. */
933 if (!mynam.nam$b_rsl) {
935 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
937 else strcpy(outbuf,esa);
940 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
941 strcpy(outbuf,tmpfspec);
943 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
944 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
945 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
949 /* External entry points */
950 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
951 { return do_rmsexpand(spec,buf,0,def,opt); }
952 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
953 { return do_rmsexpand(spec,buf,1,def,opt); }
957 ** The following routines are provided to make life easier when
958 ** converting among VMS-style and Unix-style directory specifications.
959 ** All will take input specifications in either VMS or Unix syntax. On
960 ** failure, all return NULL. If successful, the routines listed below
961 ** return a pointer to a buffer containing the appropriately
962 ** reformatted spec (and, therefore, subsequent calls to that routine
963 ** will clobber the result), while the routines of the same names with
964 ** a _ts suffix appended will return a pointer to a mallocd string
965 ** containing the appropriately reformatted spec.
966 ** In all cases, only explicit syntax is altered; no check is made that
967 ** the resulting string is valid or that the directory in question
970 ** fileify_dirspec() - convert a directory spec into the name of the
971 ** directory file (i.e. what you can stat() to see if it's a dir).
972 ** The style (VMS or Unix) of the result is the same as the style
973 ** of the parameter passed in.
974 ** pathify_dirspec() - convert a directory spec into a path (i.e.
975 ** what you prepend to a filename to indicate what directory it's in).
976 ** The style (VMS or Unix) of the result is the same as the style
977 ** of the parameter passed in.
978 ** tounixpath() - convert a directory spec into a Unix-style path.
979 ** tovmspath() - convert a directory spec into a VMS-style path.
980 ** tounixspec() - convert any file spec into a Unix-style file spec.
981 ** tovmsspec() - convert any file spec into a VMS-style spec.
983 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
984 ** Permission is given to distribute this code as part of the Perl
985 ** standard distribution under the terms of the GNU General Public
986 ** License or the Perl Artistic License. Copies of each may be
987 ** found in the Perl standard distribution.
990 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
991 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
993 static char __fileify_retbuf[NAM$C_MAXRSS+1];
994 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
995 char *retspec, *cp1, *cp2, *lastdir;
996 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
999 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1001 dirlen = strlen(dir);
1002 while (dir[dirlen-1] == '/') --dirlen;
1003 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1004 strcpy(trndir,"/sys$disk/000000");
1008 if (dirlen > NAM$C_MAXRSS) {
1009 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1011 if (!strpbrk(dir+1,"/]>:")) {
1012 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1013 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1015 dirlen = strlen(dir);
1018 strncpy(trndir,dir,dirlen);
1019 trndir[dirlen] = '\0';
1022 /* If we were handed a rooted logical name or spec, treat it like a
1023 * simple directory, so that
1024 * $ Define myroot dev:[dir.]
1025 * ... do_fileify_dirspec("myroot",buf,1) ...
1026 * does something useful.
1028 if (!strcmp(dir+dirlen-2,".]")) {
1029 dir[--dirlen] = '\0';
1030 dir[dirlen-1] = ']';
1033 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1034 /* If we've got an explicit filename, we can just shuffle the string. */
1035 if (*(cp1+1)) hasfilename = 1;
1036 /* Similarly, we can just back up a level if we've got multiple levels
1037 of explicit directories in a VMS spec which ends with directories. */
1039 for (cp2 = cp1; cp2 > dir; cp2--) {
1041 *cp2 = *cp1; *cp1 = '\0';
1045 if (*cp2 == '[' || *cp2 == '<') break;
1050 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1051 if (dir[0] == '.') {
1052 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1053 return do_fileify_dirspec("[]",buf,ts);
1054 else if (dir[1] == '.' &&
1055 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1056 return do_fileify_dirspec("[-]",buf,ts);
1058 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1059 dirlen -= 1; /* to last element */
1060 lastdir = strrchr(dir,'/');
1062 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1063 /* If we have "/." or "/..", VMSify it and let the VMS code
1064 * below expand it, rather than repeating the code to handle
1065 * relative components of a filespec here */
1067 if (*(cp1+2) == '.') cp1++;
1068 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1069 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1070 if (strchr(vmsdir,'/') != NULL) {
1071 /* If do_tovmsspec() returned it, it must have VMS syntax
1072 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1073 * the time to check this here only so we avoid a recursion
1074 * loop; otherwise, gigo.
1076 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1078 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1079 return do_tounixspec(trndir,buf,ts);
1082 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1083 lastdir = strrchr(dir,'/');
1085 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1086 /* Ditto for specs that end in an MFD -- let the VMS code
1087 * figure out whether it's a real device or a rooted logical. */
1088 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1089 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1090 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1091 return do_tounixspec(trndir,buf,ts);
1094 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1095 !(lastdir = cp1 = strrchr(dir,']')) &&
1096 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1097 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1099 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1100 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1101 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1102 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1103 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1104 (ver || *cp3)))))) {
1106 set_vaxc_errno(RMS$_DIR);
1112 /* If we lead off with a device or rooted logical, add the MFD
1113 if we're specifying a top-level directory. */
1114 if (lastdir && *dir == '/') {
1116 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1123 retlen = dirlen + (addmfd ? 13 : 6);
1124 if (buf) retspec = buf;
1125 else if (ts) New(1309,retspec,retlen+1,char);
1126 else retspec = __fileify_retbuf;
1128 dirlen = lastdir - dir;
1129 memcpy(retspec,dir,dirlen);
1130 strcpy(&retspec[dirlen],"/000000");
1131 strcpy(&retspec[dirlen+7],lastdir);
1134 memcpy(retspec,dir,dirlen);
1135 retspec[dirlen] = '\0';
1137 /* We've picked up everything up to the directory file name.
1138 Now just add the type and version, and we're set. */
1139 strcat(retspec,".dir;1");
1142 else { /* VMS-style directory spec */
1143 char esa[NAM$C_MAXRSS+1], term, *cp;
1144 unsigned long int sts, cmplen, haslower = 0;
1145 struct FAB dirfab = cc$rms_fab;
1146 struct NAM savnam, dirnam = cc$rms_nam;
1148 dirfab.fab$b_fns = strlen(dir);
1149 dirfab.fab$l_fna = dir;
1150 dirfab.fab$l_nam = &dirnam;
1151 dirfab.fab$l_dna = ".DIR;1";
1152 dirfab.fab$b_dns = 6;
1153 dirnam.nam$b_ess = NAM$C_MAXRSS;
1154 dirnam.nam$l_esa = esa;
1156 for (cp = dir; *cp; cp++)
1157 if (islower(*cp)) { haslower = 1; break; }
1158 if (!((sts = sys$parse(&dirfab))&1)) {
1159 if (dirfab.fab$l_sts == RMS$_DIR) {
1160 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1161 sts = sys$parse(&dirfab) & 1;
1165 set_vaxc_errno(dirfab.fab$l_sts);
1171 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1172 /* Yes; fake the fnb bits so we'll check type below */
1173 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1176 if (dirfab.fab$l_sts != RMS$_FNF) {
1178 set_vaxc_errno(dirfab.fab$l_sts);
1181 dirnam = savnam; /* No; just work with potential name */
1184 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1185 cp1 = strchr(esa,']');
1186 if (!cp1) cp1 = strchr(esa,'>');
1187 if (cp1) { /* Should always be true */
1188 dirnam.nam$b_esl -= cp1 - esa - 1;
1189 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1192 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1193 /* Yep; check version while we're at it, if it's there. */
1194 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1195 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1196 /* Something other than .DIR[;1]. Bzzt. */
1198 set_vaxc_errno(RMS$_DIR);
1202 esa[dirnam.nam$b_esl] = '\0';
1203 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1204 /* They provided at least the name; we added the type, if necessary, */
1205 if (buf) retspec = buf; /* in sys$parse() */
1206 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1207 else retspec = __fileify_retbuf;
1208 strcpy(retspec,esa);
1211 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1212 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1214 dirnam.nam$b_esl -= 9;
1216 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1217 if (cp1 == NULL) return NULL; /* should never happen */
1220 retlen = strlen(esa);
1221 if ((cp1 = strrchr(esa,'.')) != NULL) {
1222 /* There's more than one directory in the path. Just roll back. */
1224 if (buf) retspec = buf;
1225 else if (ts) New(1311,retspec,retlen+7,char);
1226 else retspec = __fileify_retbuf;
1227 strcpy(retspec,esa);
1230 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1231 /* Go back and expand rooted logical name */
1232 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1233 if (!(sys$parse(&dirfab) & 1)) {
1235 set_vaxc_errno(dirfab.fab$l_sts);
1238 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1239 if (buf) retspec = buf;
1240 else if (ts) New(1312,retspec,retlen+16,char);
1241 else retspec = __fileify_retbuf;
1242 cp1 = strstr(esa,"][");
1244 memcpy(retspec,esa,dirlen);
1245 if (!strncmp(cp1+2,"000000]",7)) {
1246 retspec[dirlen-1] = '\0';
1247 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1248 if (*cp1 == '.') *cp1 = ']';
1250 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1251 memcpy(cp1+1,"000000]",7);
1255 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1256 retspec[retlen] = '\0';
1257 /* Convert last '.' to ']' */
1258 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1259 if (*cp1 == '.') *cp1 = ']';
1261 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1262 memcpy(cp1+1,"000000]",7);
1266 else { /* This is a top-level dir. Add the MFD to the path. */
1267 if (buf) retspec = buf;
1268 else if (ts) New(1312,retspec,retlen+16,char);
1269 else retspec = __fileify_retbuf;
1272 while (*cp1 != ':') *(cp2++) = *(cp1++);
1273 strcpy(cp2,":[000000]");
1278 /* We've set up the string up through the filename. Add the
1279 type and version, and we're done. */
1280 strcat(retspec,".DIR;1");
1282 /* $PARSE may have upcased filespec, so convert output to lower
1283 * case if input contained any lowercase characters. */
1284 if (haslower) __mystrtolower(retspec);
1287 } /* end of do_fileify_dirspec() */
1289 /* External entry points */
1290 char *fileify_dirspec(char *dir, char *buf)
1291 { return do_fileify_dirspec(dir,buf,0); }
1292 char *fileify_dirspec_ts(char *dir, char *buf)
1293 { return do_fileify_dirspec(dir,buf,1); }
1295 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1296 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1298 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1299 unsigned long int retlen;
1300 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1302 if (!dir || !*dir) {
1303 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1306 if (*dir) strcpy(trndir,dir);
1307 else getcwd(trndir,sizeof trndir - 1);
1309 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1310 STRLEN trnlen = strlen(trndir);
1312 /* Trap simple rooted lnms, and return lnm:[000000] */
1313 if (!strcmp(trndir+trnlen-2,".]")) {
1314 if (buf) retpath = buf;
1315 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1316 else retpath = __pathify_retbuf;
1317 strcpy(retpath,dir);
1318 strcat(retpath,":[000000]");
1324 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1325 if (*dir == '.' && (*(dir+1) == '\0' ||
1326 (*(dir+1) == '.' && *(dir+2) == '\0')))
1327 retlen = 2 + (*(dir+1) != '\0');
1329 if ( !(cp1 = strrchr(dir,'/')) &&
1330 !(cp1 = strrchr(dir,']')) &&
1331 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1332 if ((cp2 = strchr(cp1,'.')) != NULL &&
1333 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1334 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1335 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1336 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1338 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1339 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1340 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1341 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1342 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1343 (ver || *cp3)))))) {
1345 set_vaxc_errno(RMS$_DIR);
1348 retlen = cp2 - dir + 1;
1350 else { /* No file type present. Treat the filename as a directory. */
1351 retlen = strlen(dir) + 1;
1354 if (buf) retpath = buf;
1355 else if (ts) New(1313,retpath,retlen+1,char);
1356 else retpath = __pathify_retbuf;
1357 strncpy(retpath,dir,retlen-1);
1358 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1359 retpath[retlen-1] = '/'; /* with '/', add it. */
1360 retpath[retlen] = '\0';
1362 else retpath[retlen-1] = '\0';
1364 else { /* VMS-style directory spec */
1365 char esa[NAM$C_MAXRSS+1], *cp;
1366 unsigned long int sts, cmplen, haslower;
1367 struct FAB dirfab = cc$rms_fab;
1368 struct NAM savnam, dirnam = cc$rms_nam;
1370 /* If we've got an explicit filename, we can just shuffle the string. */
1371 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1372 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1373 if ((cp2 = strchr(cp1,'.')) != NULL) {
1375 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1376 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1377 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1378 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1379 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1380 (ver || *cp3)))))) {
1382 set_vaxc_errno(RMS$_DIR);
1386 else { /* No file type, so just draw name into directory part */
1387 for (cp2 = cp1; *cp2; cp2++) ;
1390 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1392 /* We've now got a VMS 'path'; fall through */
1394 dirfab.fab$b_fns = strlen(dir);
1395 dirfab.fab$l_fna = dir;
1396 if (dir[dirfab.fab$b_fns-1] == ']' ||
1397 dir[dirfab.fab$b_fns-1] == '>' ||
1398 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1399 if (buf) retpath = buf;
1400 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1401 else retpath = __pathify_retbuf;
1402 strcpy(retpath,dir);
1405 dirfab.fab$l_dna = ".DIR;1";
1406 dirfab.fab$b_dns = 6;
1407 dirfab.fab$l_nam = &dirnam;
1408 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1409 dirnam.nam$l_esa = esa;
1411 for (cp = dir; *cp; cp++)
1412 if (islower(*cp)) { haslower = 1; break; }
1414 if (!(sts = (sys$parse(&dirfab)&1))) {
1415 if (dirfab.fab$l_sts == RMS$_DIR) {
1416 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1417 sts = sys$parse(&dirfab) & 1;
1421 set_vaxc_errno(dirfab.fab$l_sts);
1427 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1428 if (dirfab.fab$l_sts != RMS$_FNF) {
1430 set_vaxc_errno(dirfab.fab$l_sts);
1433 dirnam = savnam; /* No; just work with potential name */
1436 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1437 /* Yep; check version while we're at it, if it's there. */
1438 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1439 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1440 /* Something other than .DIR[;1]. Bzzt. */
1442 set_vaxc_errno(RMS$_DIR);
1446 /* OK, the type was fine. Now pull any file name into the
1448 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1450 cp1 = strrchr(esa,'>');
1451 *dirnam.nam$l_type = '>';
1454 *(dirnam.nam$l_type + 1) = '\0';
1455 retlen = dirnam.nam$l_type - esa + 2;
1456 if (buf) retpath = buf;
1457 else if (ts) New(1314,retpath,retlen,char);
1458 else retpath = __pathify_retbuf;
1459 strcpy(retpath,esa);
1460 /* $PARSE may have upcased filespec, so convert output to lower
1461 * case if input contained any lowercase characters. */
1462 if (haslower) __mystrtolower(retpath);
1466 } /* end of do_pathify_dirspec() */
1468 /* External entry points */
1469 char *pathify_dirspec(char *dir, char *buf)
1470 { return do_pathify_dirspec(dir,buf,0); }
1471 char *pathify_dirspec_ts(char *dir, char *buf)
1472 { return do_pathify_dirspec(dir,buf,1); }
1474 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1475 static char *do_tounixspec(char *spec, char *buf, int ts)
1477 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1478 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1479 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1481 if (spec == NULL) return NULL;
1482 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1483 if (buf) rslt = buf;
1485 retlen = strlen(spec);
1486 cp1 = strchr(spec,'[');
1487 if (!cp1) cp1 = strchr(spec,'<');
1489 for (cp1++; *cp1; cp1++) {
1490 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1491 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1492 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1495 New(1315,rslt,retlen+2+2*expand,char);
1497 else rslt = __tounixspec_retbuf;
1498 if (strchr(spec,'/') != NULL) {
1505 dirend = strrchr(spec,']');
1506 if (dirend == NULL) dirend = strrchr(spec,'>');
1507 if (dirend == NULL) dirend = strchr(spec,':');
1508 if (dirend == NULL) {
1512 if (*cp2 != '[' && *cp2 != '<') {
1515 else { /* the VMS spec begins with directories */
1517 if (*cp2 == ']' || *cp2 == '>') {
1518 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1521 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1522 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1523 if (ts) Safefree(rslt);
1528 while (*cp3 != ':' && *cp3) cp3++;
1530 if (strchr(cp3,']') != NULL) break;
1531 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1533 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1534 retlen = devlen + dirlen;
1535 Renew(rslt,retlen+1+2*expand,char);
1541 *(cp1++) = *(cp3++);
1542 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1546 else if ( *cp2 == '.') {
1547 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1548 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1554 for (; cp2 <= dirend; cp2++) {
1557 if (*(cp2+1) == '[') cp2++;
1559 else if (*cp2 == ']' || *cp2 == '>') {
1560 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1562 else if (*cp2 == '.') {
1564 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1565 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1566 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1567 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1568 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1570 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1571 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1575 else if (*cp2 == '-') {
1576 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1577 while (*cp2 == '-') {
1579 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1581 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1582 if (ts) Safefree(rslt); /* filespecs like */
1583 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1587 else *(cp1++) = *cp2;
1589 else *(cp1++) = *cp2;
1591 while (*cp2) *(cp1++) = *(cp2++);
1596 } /* end of do_tounixspec() */
1598 /* External entry points */
1599 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1600 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1602 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1603 static char *do_tovmsspec(char *path, char *buf, int ts) {
1604 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1605 char *rslt, *dirend;
1606 register char *cp1, *cp2;
1607 unsigned long int infront = 0, hasdir = 1;
1609 if (path == NULL) return NULL;
1610 if (buf) rslt = buf;
1611 else if (ts) New(1316,rslt,strlen(path)+9,char);
1612 else rslt = __tovmsspec_retbuf;
1613 if (strpbrk(path,"]:>") ||
1614 (dirend = strrchr(path,'/')) == NULL) {
1615 if (path[0] == '.') {
1616 if (path[1] == '\0') strcpy(rslt,"[]");
1617 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1618 else strcpy(rslt,path); /* probably garbage */
1620 else strcpy(rslt,path);
1623 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1624 if (!*(dirend+2)) dirend +=2;
1625 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1626 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1631 char trndev[NAM$C_MAXRSS+1];
1635 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1637 if (!buf & ts) Renew(rslt,18,char);
1638 strcpy(rslt,"sys$disk:[000000]");
1641 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1643 islnm = my_trnlnm(rslt,trndev,0);
1644 trnend = islnm ? strlen(trndev) - 1 : 0;
1645 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1646 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1647 /* If the first element of the path is a logical name, determine
1648 * whether it has to be translated so we can add more directories. */
1649 if (!islnm || rooted) {
1652 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1656 if (cp2 != dirend) {
1657 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1658 strcpy(rslt,trndev);
1659 cp1 = rslt + trnend;
1672 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1673 cp2 += 2; /* skip over "./" - it's redundant */
1674 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1676 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1677 *(cp1++) = '-'; /* "../" --> "-" */
1680 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1681 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1682 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1683 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1686 if (cp2 > dirend) cp2 = dirend;
1688 else *(cp1++) = '.';
1690 for (; cp2 < dirend; cp2++) {
1692 if (*(cp2-1) == '/') continue;
1693 if (*(cp1-1) != '.') *(cp1++) = '.';
1696 else if (!infront && *cp2 == '.') {
1697 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1698 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1699 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1700 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1701 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1702 else { /* back up over previous directory name */
1704 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1705 if (*(cp1-1) == '[') {
1706 memcpy(cp1,"000000.",7);
1711 if (cp2 == dirend) break;
1713 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1714 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1715 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1716 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1718 *(cp1++) = '.'; /* Simulate trailing '/' */
1719 cp2 += 2; /* for loop will incr this to == dirend */
1721 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1723 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1726 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1727 if (*cp2 == '.') *(cp1++) = '_';
1728 else *(cp1++) = *cp2;
1732 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1733 if (hasdir) *(cp1++) = ']';
1734 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1735 while (*cp2) *(cp1++) = *(cp2++);
1740 } /* end of do_tovmsspec() */
1742 /* External entry points */
1743 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1744 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1746 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1747 static char *do_tovmspath(char *path, char *buf, int ts) {
1748 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1750 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1752 if (path == NULL) return NULL;
1753 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1754 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1755 if (buf) return buf;
1757 vmslen = strlen(vmsified);
1758 New(1317,cp,vmslen+1,char);
1759 memcpy(cp,vmsified,vmslen);
1764 strcpy(__tovmspath_retbuf,vmsified);
1765 return __tovmspath_retbuf;
1768 } /* end of do_tovmspath() */
1770 /* External entry points */
1771 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1772 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1775 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1776 static char *do_tounixpath(char *path, char *buf, int ts) {
1777 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1779 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1781 if (path == NULL) return NULL;
1782 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1783 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1784 if (buf) return buf;
1786 unixlen = strlen(unixified);
1787 New(1317,cp,unixlen+1,char);
1788 memcpy(cp,unixified,unixlen);
1793 strcpy(__tounixpath_retbuf,unixified);
1794 return __tounixpath_retbuf;
1797 } /* end of do_tounixpath() */
1799 /* External entry points */
1800 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1801 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1804 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1806 *****************************************************************************
1808 * Copyright (C) 1989-1994 by *
1809 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1811 * Permission is hereby granted for the reproduction of this software, *
1812 * on condition that this copyright notice is included in the reproduction, *
1813 * and that such reproduction is not for purposes of profit or material *
1816 * 27-Aug-1994 Modified for inclusion in perl5 *
1817 * by Charles Bailey bailey@genetics.upenn.edu *
1818 *****************************************************************************
1822 * getredirection() is intended to aid in porting C programs
1823 * to VMS (Vax-11 C). The native VMS environment does not support
1824 * '>' and '<' I/O redirection, or command line wild card expansion,
1825 * or a command line pipe mechanism using the '|' AND background
1826 * command execution '&'. All of these capabilities are provided to any
1827 * C program which calls this procedure as the first thing in the
1829 * The piping mechanism will probably work with almost any 'filter' type
1830 * of program. With suitable modification, it may useful for other
1831 * portability problems as well.
1833 * Author: Mark Pizzolato mark@infocomm.com
1837 struct list_item *next;
1841 static void add_item(struct list_item **head,
1842 struct list_item **tail,
1846 static void expand_wild_cards(char *item,
1847 struct list_item **head,
1848 struct list_item **tail,
1851 static int background_process(int argc, char **argv);
1853 static void pipe_and_fork(char **cmargv);
1855 /*{{{ void getredirection(int *ac, char ***av)*/
1857 getredirection(int *ac, char ***av)
1859 * Process vms redirection arg's. Exit if any error is seen.
1860 * If getredirection() processes an argument, it is erased
1861 * from the vector. getredirection() returns a new argc and argv value.
1862 * In the event that a background command is requested (by a trailing "&"),
1863 * this routine creates a background subprocess, and simply exits the program.
1865 * Warning: do not try to simplify the code for vms. The code
1866 * presupposes that getredirection() is called before any data is
1867 * read from stdin or written to stdout.
1869 * Normal usage is as follows:
1875 * getredirection(&argc, &argv);
1879 int argc = *ac; /* Argument Count */
1880 char **argv = *av; /* Argument Vector */
1881 char *ap; /* Argument pointer */
1882 int j; /* argv[] index */
1883 int item_count = 0; /* Count of Items in List */
1884 struct list_item *list_head = 0; /* First Item in List */
1885 struct list_item *list_tail; /* Last Item in List */
1886 char *in = NULL; /* Input File Name */
1887 char *out = NULL; /* Output File Name */
1888 char *outmode = "w"; /* Mode to Open Output File */
1889 char *err = NULL; /* Error File Name */
1890 char *errmode = "w"; /* Mode to Open Error File */
1891 int cmargc = 0; /* Piped Command Arg Count */
1892 char **cmargv = NULL;/* Piped Command Arg Vector */
1895 * First handle the case where the last thing on the line ends with
1896 * a '&'. This indicates the desire for the command to be run in a
1897 * subprocess, so we satisfy that desire.
1900 if (0 == strcmp("&", ap))
1901 exit(background_process(--argc, argv));
1902 if (*ap && '&' == ap[strlen(ap)-1])
1904 ap[strlen(ap)-1] = '\0';
1905 exit(background_process(argc, argv));
1908 * Now we handle the general redirection cases that involve '>', '>>',
1909 * '<', and pipes '|'.
1911 for (j = 0; j < argc; ++j)
1913 if (0 == strcmp("<", argv[j]))
1917 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1918 exit(LIB$_WRONUMARG);
1923 if ('<' == *(ap = argv[j]))
1928 if (0 == strcmp(">", ap))
1932 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1933 exit(LIB$_WRONUMARG);
1952 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1953 exit(LIB$_WRONUMARG);
1957 if (('2' == *ap) && ('>' == ap[1]))
1974 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1975 exit(LIB$_WRONUMARG);
1979 if (0 == strcmp("|", argv[j]))
1983 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1984 exit(LIB$_WRONUMARG);
1986 cmargc = argc-(j+1);
1987 cmargv = &argv[j+1];
1991 if ('|' == *(ap = argv[j]))
1999 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2002 * Allocate and fill in the new argument vector, Some Unix's terminate
2003 * the list with an extra null pointer.
2005 New(1302, argv, item_count+1, char *);
2007 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2008 argv[j] = list_head->value;
2014 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2015 exit(LIB$_INVARGORD);
2017 pipe_and_fork(cmargv);
2020 /* Check for input from a pipe (mailbox) */
2022 if (in == NULL && 1 == isapipe(0))
2024 char mbxname[L_tmpnam];
2026 long int dvi_item = DVI$_DEVBUFSIZ;
2027 $DESCRIPTOR(mbxnam, "");
2028 $DESCRIPTOR(mbxdevnam, "");
2030 /* Input from a pipe, reopen it in binary mode to disable */
2031 /* carriage control processing. */
2033 PerlIO_getname(stdin, mbxname);
2034 mbxnam.dsc$a_pointer = mbxname;
2035 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2036 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2037 mbxdevnam.dsc$a_pointer = mbxname;
2038 mbxdevnam.dsc$w_length = sizeof(mbxname);
2039 dvi_item = DVI$_DEVNAM;
2040 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2041 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2044 freopen(mbxname, "rb", stdin);
2047 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2051 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2053 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2056 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2058 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2063 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2065 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2069 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2074 #ifdef ARGPROC_DEBUG
2075 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2076 for (j = 0; j < *ac; ++j)
2077 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2079 /* Clear errors we may have hit expanding wildcards, so they don't
2080 show up in Perl's $! later */
2081 set_errno(0); set_vaxc_errno(1);
2082 } /* end of getredirection() */
2085 static void add_item(struct list_item **head,
2086 struct list_item **tail,
2092 New(1303,*head,1,struct list_item);
2096 New(1304,(*tail)->next,1,struct list_item);
2097 *tail = (*tail)->next;
2099 (*tail)->value = value;
2103 static void expand_wild_cards(char *item,
2104 struct list_item **head,
2105 struct list_item **tail,
2109 unsigned long int context = 0;
2115 char vmsspec[NAM$C_MAXRSS+1];
2116 $DESCRIPTOR(filespec, "");
2117 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2118 $DESCRIPTOR(resultspec, "");
2119 unsigned long int zero = 0, sts;
2121 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2123 add_item(head, tail, item, count);
2126 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2127 resultspec.dsc$b_class = DSC$K_CLASS_D;
2128 resultspec.dsc$a_pointer = NULL;
2129 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2130 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2131 if (!isunix || !filespec.dsc$a_pointer)
2132 filespec.dsc$a_pointer = item;
2133 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2135 * Only return version specs, if the caller specified a version
2137 had_version = strchr(item, ';');
2139 * Only return device and directory specs, if the caller specifed either.
2141 had_device = strchr(item, ':');
2142 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2144 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2145 &defaultspec, 0, 0, &zero))))
2150 New(1305,string,resultspec.dsc$w_length+1,char);
2151 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2152 string[resultspec.dsc$w_length] = '\0';
2153 if (NULL == had_version)
2154 *((char *)strrchr(string, ';')) = '\0';
2155 if ((!had_directory) && (had_device == NULL))
2157 if (NULL == (devdir = strrchr(string, ']')))
2158 devdir = strrchr(string, '>');
2159 strcpy(string, devdir + 1);
2162 * Be consistent with what the C RTL has already done to the rest of
2163 * the argv items and lowercase all of these names.
2165 for (c = string; *c; ++c)
2168 if (isunix) trim_unixpath(string,item,1);
2169 add_item(head, tail, string, count);
2172 if (sts != RMS$_NMF)
2174 set_vaxc_errno(sts);
2180 set_errno(ENOENT); break;
2182 set_errno(ENODEV); break;
2185 set_errno(EINVAL); break;
2187 set_errno(EACCES); break;
2189 _ckvmssts_noperl(sts);
2193 add_item(head, tail, item, count);
2194 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2195 _ckvmssts_noperl(lib$find_file_end(&context));
2198 static int child_st[2];/* Event Flag set when child process completes */
2200 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2202 static unsigned long int exit_handler(int *status)
2206 if (0 == child_st[0])
2208 #ifdef ARGPROC_DEBUG
2209 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2211 fflush(stdout); /* Have to flush pipe for binary data to */
2212 /* terminate properly -- <tp@mccall.com> */
2213 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2214 sys$dassgn(child_chan);
2216 sys$synch(0, child_st);
2221 static void sig_child(int chan)
2223 #ifdef ARGPROC_DEBUG
2224 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2226 if (child_st[0] == 0)
2230 static struct exit_control_block exit_block =
2235 &exit_block.exit_status,
2239 static void pipe_and_fork(char **cmargv)
2242 $DESCRIPTOR(cmddsc, "");
2243 static char mbxname[64];
2244 $DESCRIPTOR(mbxdsc, mbxname);
2246 unsigned long int zero = 0, one = 1;
2248 strcpy(subcmd, cmargv[0]);
2249 for (j = 1; NULL != cmargv[j]; ++j)
2251 strcat(subcmd, " \"");
2252 strcat(subcmd, cmargv[j]);
2253 strcat(subcmd, "\"");
2255 cmddsc.dsc$a_pointer = subcmd;
2256 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2258 create_mbx(&child_chan,&mbxdsc);
2259 #ifdef ARGPROC_DEBUG
2260 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2261 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2263 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2264 0, &pid, child_st, &zero, sig_child,
2266 #ifdef ARGPROC_DEBUG
2267 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2269 sys$dclexh(&exit_block);
2270 if (NULL == freopen(mbxname, "wb", stdout))
2272 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2276 static int background_process(int argc, char **argv)
2278 char command[2048] = "$";
2279 $DESCRIPTOR(value, "");
2280 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2281 static $DESCRIPTOR(null, "NLA0:");
2282 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2284 $DESCRIPTOR(pidstr, "");
2286 unsigned long int flags = 17, one = 1, retsts;
2288 strcat(command, argv[0]);
2291 strcat(command, " \"");
2292 strcat(command, *(++argv));
2293 strcat(command, "\"");
2295 value.dsc$a_pointer = command;
2296 value.dsc$w_length = strlen(value.dsc$a_pointer);
2297 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2298 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2299 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2300 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2303 _ckvmssts_noperl(retsts);
2305 #ifdef ARGPROC_DEBUG
2306 PerlIO_printf(Perl_debug_log, "%s\n", command);
2308 sprintf(pidstring, "%08X", pid);
2309 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2310 pidstr.dsc$a_pointer = pidstring;
2311 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2312 lib$set_symbol(&pidsymbol, &pidstr);
2316 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2319 /* OS-specific initialization at image activation (not thread startup) */
2320 /* Older VAXC header files lack these constants */
2321 #ifndef JPI$_RIGHTS_SIZE
2322 # define JPI$_RIGHTS_SIZE 817
2324 #ifndef KGB$M_SUBSYSTEM
2325 # define KGB$M_SUBSYSTEM 0x8
2328 /*{{{void vms_image_init(int *, char ***)*/
2330 vms_image_init(int *argcp, char ***argvp)
2332 unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
2333 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2334 unsigned short int dummy, rlen;
2335 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2336 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2337 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2340 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2342 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2343 if (iprv[i]) { /* Running image installed with privs? */
2344 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2349 /* Rights identifiers might trigger tainting as well. */
2350 if (!add_taint && (rlen || rsz)) {
2351 while (rlen < rsz) {
2352 /* We didn't get all the identifiers on the first pass. Allocate a
2353 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2354 * were needed to hold all identifiers at time of last call; we'll
2355 * allocate that many unsigned long ints), and go back and get 'em.
2357 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2358 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2359 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2360 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2363 mask = jpilist[1].bufadr;
2364 /* Check attribute flags for each identifier (2nd longword); protected
2365 * subsystem identifiers trigger tainting.
2367 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2368 if (mask[i] & KGB$M_SUBSYSTEM) {
2373 if (mask != rlst) Safefree(mask);
2375 /* We need to use this hack to tell Perl it should run with tainting,
2376 * since its tainting flag may be part of the curinterp struct, which
2377 * hasn't been allocated when vms_image_init() is called.
2381 New(1320,newap,*argcp+2,char **);
2382 newap[0] = argvp[0];
2384 Copy(argvp[1],newap[2],*argcp-1,char **);
2385 /* We orphan the old argv, since we don't know where it's come from,
2386 * so we don't know how to free it.
2388 *argcp++; argvp = newap;
2390 getredirection(argcp,argvp);
2391 #if defined(USE_THREADS) && defined(__DECC)
2393 # include <reentrancy.h>
2394 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2403 * Trim Unix-style prefix off filespec, so it looks like what a shell
2404 * glob expansion would return (i.e. from specified prefix on, not
2405 * full path). Note that returned filespec is Unix-style, regardless
2406 * of whether input filespec was VMS-style or Unix-style.
2408 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2409 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2410 * vector of options; at present, only bit 0 is used, and if set tells
2411 * trim unixpath to try the current default directory as a prefix when
2412 * presented with a possibly ambiguous ... wildcard.
2414 * Returns !=0 on success, with trimmed filespec replacing contents of
2415 * fspec, and 0 on failure, with contents of fpsec unchanged.
2417 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2419 trim_unixpath(char *fspec, char *wildspec, int opts)
2421 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2422 *template, *base, *end, *cp1, *cp2;
2423 register int tmplen, reslen = 0, dirs = 0;
2425 if (!wildspec || !fspec) return 0;
2426 if (strpbrk(wildspec,"]>:") != NULL) {
2427 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2428 else template = unixwild;
2430 else template = wildspec;
2431 if (strpbrk(fspec,"]>:") != NULL) {
2432 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2433 else base = unixified;
2434 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2435 * check to see that final result fits into (isn't longer than) fspec */
2436 reslen = strlen(fspec);
2440 /* No prefix or absolute path on wildcard, so nothing to remove */
2441 if (!*template || *template == '/') {
2442 if (base == fspec) return 1;
2443 tmplen = strlen(unixified);
2444 if (tmplen > reslen) return 0; /* not enough space */
2445 /* Copy unixified resultant, including trailing NUL */
2446 memmove(fspec,unixified,tmplen+1);
2450 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2451 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2452 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2453 for (cp1 = end ;cp1 >= base; cp1--)
2454 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2456 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2460 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2461 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2462 int ells = 1, totells, segdirs, match;
2463 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2464 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2466 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2468 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2469 if (ellipsis == template && opts & 1) {
2470 /* Template begins with an ellipsis. Since we can't tell how many
2471 * directory names at the front of the resultant to keep for an
2472 * arbitrary starting point, we arbitrarily choose the current
2473 * default directory as a starting point. If it's there as a prefix,
2474 * clip it off. If not, fall through and act as if the leading
2475 * ellipsis weren't there (i.e. return shortest possible path that
2476 * could match template).
2478 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2479 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2480 if (_tolower(*cp1) != _tolower(*cp2)) break;
2481 segdirs = dirs - totells; /* Min # of dirs we must have left */
2482 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2483 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2484 memcpy(fspec,cp2+1,end - cp2);
2488 /* First off, back up over constant elements at end of path */
2490 for (front = end ; front >= base; front--)
2491 if (*front == '/' && !dirs--) { front++; break; }
2493 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2494 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2495 if (cp1 != '\0') return 0; /* Path too long. */
2497 *cp2 = '\0'; /* Pick up with memcpy later */
2498 lcfront = lcres + (front - base);
2499 /* Now skip over each ellipsis and try to match the path in front of it. */
2501 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2502 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2503 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2504 if (cp1 < template) break; /* template started with an ellipsis */
2505 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2506 ellipsis = cp1; continue;
2508 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2510 for (segdirs = 0, cp2 = tpl;
2511 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2513 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2514 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2515 if (*cp2 == '/') segdirs++;
2517 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2518 /* Back up at least as many dirs as in template before matching */
2519 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2520 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2521 for (match = 0; cp1 > lcres;) {
2522 resdsc.dsc$a_pointer = cp1;
2523 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2525 if (match == 1) lcfront = cp1;
2527 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2529 if (!match) return 0; /* Can't find prefix ??? */
2530 if (match > 1 && opts & 1) {
2531 /* This ... wildcard could cover more than one set of dirs (i.e.
2532 * a set of similar dir names is repeated). If the template
2533 * contains more than 1 ..., upstream elements could resolve the
2534 * ambiguity, but it's not worth a full backtracking setup here.
2535 * As a quick heuristic, clip off the current default directory
2536 * if it's present to find the trimmed spec, else use the
2537 * shortest string that this ... could cover.
2539 char def[NAM$C_MAXRSS+1], *st;
2541 if (getcwd(def, sizeof def,0) == NULL) return 0;
2542 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2543 if (_tolower(*cp1) != _tolower(*cp2)) break;
2544 segdirs = dirs - totells; /* Min # of dirs we must have left */
2545 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2546 if (*cp1 == '\0' && *cp2 == '/') {
2547 memcpy(fspec,cp2+1,end - cp2);
2550 /* Nope -- stick with lcfront from above and keep going. */
2553 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2558 } /* end of trim_unixpath() */
2563 * VMS readdir() routines.
2564 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2566 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2567 * Minor modifications to original routines.
2570 /* Number of elements in vms_versions array */
2571 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2574 * Open a directory, return a handle for later use.
2576 /*{{{ DIR *opendir(char*name) */
2581 char dir[NAM$C_MAXRSS+1];
2584 if (do_tovmspath(name,dir,0) == NULL) {
2587 if (flex_stat(dir,&sb) == -1) return NULL;
2588 if (!S_ISDIR(sb.st_mode)) {
2589 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2592 if (!cando_by_name(S_IRUSR,0,dir)) {
2593 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2596 /* Get memory for the handle, and the pattern. */
2598 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2600 /* Fill in the fields; mainly playing with the descriptor. */
2601 (void)sprintf(dd->pattern, "%s*.*",dir);
2604 dd->vms_wantversions = 0;
2605 dd->pat.dsc$a_pointer = dd->pattern;
2606 dd->pat.dsc$w_length = strlen(dd->pattern);
2607 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2608 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2611 } /* end of opendir() */
2615 * Set the flag to indicate we want versions or not.
2617 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2619 vmsreaddirversions(DIR *dd, int flag)
2621 dd->vms_wantversions = flag;
2626 * Free up an opened directory.
2628 /*{{{ void closedir(DIR *dd)*/
2632 (void)lib$find_file_end(&dd->context);
2633 Safefree(dd->pattern);
2634 Safefree((char *)dd);
2639 * Collect all the version numbers for the current file.
2645 struct dsc$descriptor_s pat;
2646 struct dsc$descriptor_s res;
2648 char *p, *text, buff[sizeof dd->entry.d_name];
2650 unsigned long context, tmpsts;
2652 /* Convenient shorthand. */
2655 /* Add the version wildcard, ignoring the "*.*" put on before */
2656 i = strlen(dd->pattern);
2657 New(1308,text,i + e->d_namlen + 3,char);
2658 (void)strcpy(text, dd->pattern);
2659 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2661 /* Set up the pattern descriptor. */
2662 pat.dsc$a_pointer = text;
2663 pat.dsc$w_length = i + e->d_namlen - 1;
2664 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2665 pat.dsc$b_class = DSC$K_CLASS_S;
2667 /* Set up result descriptor. */
2668 res.dsc$a_pointer = buff;
2669 res.dsc$w_length = sizeof buff - 2;
2670 res.dsc$b_dtype = DSC$K_DTYPE_T;
2671 res.dsc$b_class = DSC$K_CLASS_S;
2673 /* Read files, collecting versions. */
2674 for (context = 0, e->vms_verscount = 0;
2675 e->vms_verscount < VERSIZE(e);
2676 e->vms_verscount++) {
2677 tmpsts = lib$find_file(&pat, &res, &context);
2678 if (tmpsts == RMS$_NMF || context == 0) break;
2680 buff[sizeof buff - 1] = '\0';
2681 if ((p = strchr(buff, ';')))
2682 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2684 e->vms_versions[e->vms_verscount] = -1;
2687 _ckvmssts(lib$find_file_end(&context));
2690 } /* end of collectversions() */
2693 * Read the next entry from the directory.
2695 /*{{{ struct dirent *readdir(DIR *dd)*/
2699 struct dsc$descriptor_s res;
2700 char *p, buff[sizeof dd->entry.d_name];
2701 unsigned long int tmpsts;
2703 /* Set up result descriptor, and get next file. */
2704 res.dsc$a_pointer = buff;
2705 res.dsc$w_length = sizeof buff - 2;
2706 res.dsc$b_dtype = DSC$K_DTYPE_T;
2707 res.dsc$b_class = DSC$K_CLASS_S;
2708 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2709 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2710 if (!(tmpsts & 1)) {
2711 set_vaxc_errno(tmpsts);
2714 set_errno(EACCES); break;
2716 set_errno(ENODEV); break;
2719 set_errno(ENOENT); break;
2726 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2727 buff[sizeof buff - 1] = '\0';
2728 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2731 /* Skip any directory component and just copy the name. */
2732 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2733 else (void)strcpy(dd->entry.d_name, buff);
2735 /* Clobber the version. */
2736 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2738 dd->entry.d_namlen = strlen(dd->entry.d_name);
2739 dd->entry.vms_verscount = 0;
2740 if (dd->vms_wantversions) collectversions(dd);
2743 } /* end of readdir() */
2747 * Return something that can be used in a seekdir later.
2749 /*{{{ long telldir(DIR *dd)*/
2758 * Return to a spot where we used to be. Brute force.
2760 /*{{{ void seekdir(DIR *dd,long count)*/
2762 seekdir(DIR *dd, long count)
2764 int vms_wantversions;
2766 /* If we haven't done anything yet... */
2770 /* Remember some state, and clear it. */
2771 vms_wantversions = dd->vms_wantversions;
2772 dd->vms_wantversions = 0;
2773 _ckvmssts(lib$find_file_end(&dd->context));
2776 /* The increment is in readdir(). */
2777 for (dd->count = 0; dd->count < count; )
2780 dd->vms_wantversions = vms_wantversions;
2782 } /* end of seekdir() */
2785 /* VMS subprocess management
2787 * my_vfork() - just a vfork(), after setting a flag to record that
2788 * the current script is trying a Unix-style fork/exec.
2790 * vms_do_aexec() and vms_do_exec() are called in response to the
2791 * perl 'exec' function. If this follows a vfork call, then they
2792 * call out the the regular perl routines in doio.c which do an
2793 * execvp (for those who really want to try this under VMS).
2794 * Otherwise, they do exactly what the perl docs say exec should
2795 * do - terminate the current script and invoke a new command
2796 * (See below for notes on command syntax.)
2798 * do_aspawn() and do_spawn() implement the VMS side of the perl
2799 * 'system' function.
2801 * Note on command arguments to perl 'exec' and 'system': When handled
2802 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2803 * are concatenated to form a DCL command string. If the first arg
2804 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2805 * the the command string is hrnded off to DCL directly. Otherwise,
2806 * the first token of the command is taken as the filespec of an image
2807 * to run. The filespec is expanded using a default type of '.EXE' and
2808 * the process defaults for device, directory, etc., and the resultant
2809 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2810 * the command string as parameters. This is perhaps a bit compicated,
2811 * but I hope it will form a happy medium between what VMS folks expect
2812 * from lib$spawn and what Unix folks expect from exec.
2815 static int vfork_called;
2817 /*{{{int my_vfork()*/
2827 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2835 if (VMScmd.dsc$a_pointer) {
2836 Safefree(VMScmd.dsc$a_pointer);
2837 VMScmd.dsc$w_length = 0;
2838 VMScmd.dsc$a_pointer = Nullch;
2843 setup_argstr(SV *really, SV **mark, SV **sp)
2846 char *junk, *tmps = Nullch;
2847 register size_t cmdlen = 0;
2853 tmps = SvPV(really,rlen);
2860 for (idx++; idx <= sp; idx++) {
2862 junk = SvPVx(*idx,rlen);
2863 cmdlen += rlen ? rlen + 1 : 0;
2866 New(401,Cmd,cmdlen+1,char);
2868 if (tmps && *tmps) {
2873 while (++mark <= sp) {
2876 strcat(Cmd,SvPVx(*mark,na));
2881 } /* end of setup_argstr() */
2884 static unsigned long int
2885 setup_cmddsc(char *cmd, int check_img)
2887 char resspec[NAM$C_MAXRSS+1];
2888 $DESCRIPTOR(defdsc,".EXE");
2889 $DESCRIPTOR(resdsc,resspec);
2890 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2891 unsigned long int cxt = 0, flags = 1, retsts;
2892 register char *s, *rest, *cp;
2893 register int isdcl = 0;
2896 while (*s && isspace(*s)) s++;
2898 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2899 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2900 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2901 if (*cp == ':' || *cp == '[' || *cp == '<') {
2909 if (isdcl) { /* It's a DCL command, just do it. */
2910 VMScmd.dsc$w_length = strlen(cmd);
2912 VMScmd.dsc$a_pointer = Cmd;
2913 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2915 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2917 else { /* assume first token is an image spec */
2919 while (*s && !isspace(*s)) s++;
2921 imgdsc.dsc$a_pointer = cmd;
2922 imgdsc.dsc$w_length = s - cmd;
2923 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2924 if (!(retsts & 1)) {
2925 /* just hand off status values likely to be due to user error */
2926 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2927 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2928 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2929 else { _ckvmssts(retsts); }
2932 _ckvmssts(lib$find_file_end(&cxt));
2934 while (*s && !isspace(*s)) s++;
2936 if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
2937 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2938 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2939 strcat(VMScmd.dsc$a_pointer,resspec);
2940 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2941 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2945 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2947 } /* end of setup_cmddsc() */
2950 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2952 vms_do_aexec(SV *really,SV **mark,SV **sp)
2956 if (vfork_called) { /* this follows a vfork - act Unixish */
2958 if (vfork_called < 0) {
2959 warn("Internal inconsistency in tracking vforks");
2962 else return do_aexec(really,mark,sp);
2964 /* no vfork - act VMSish */
2965 return vms_do_exec(setup_argstr(really,mark,sp));
2970 } /* end of vms_do_aexec() */
2973 /* {{{bool vms_do_exec(char *cmd) */
2975 vms_do_exec(char *cmd)
2978 if (vfork_called) { /* this follows a vfork - act Unixish */
2980 if (vfork_called < 0) {
2981 warn("Internal inconsistency in tracking vforks");
2984 else return do_exec(cmd);
2987 { /* no vfork - act VMSish */
2988 unsigned long int retsts;
2991 TAINT_PROPER("exec");
2992 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2993 retsts = lib$do_command(&VMScmd);
2997 set_errno(ENOENT); break;
2998 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
2999 set_errno(ENOTDIR); break;
3001 set_errno(EACCES); break;
3003 set_errno(EINVAL); break;
3005 set_errno(E2BIG); break;
3006 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3007 _ckvmssts(retsts); /* fall through */
3008 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3011 set_vaxc_errno(retsts);
3013 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
3019 } /* end of vms_do_exec() */
3022 unsigned long int do_spawn(char *);
3024 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3026 do_aspawn(void *really,void **mark,void **sp)
3029 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3032 } /* end of do_aspawn() */
3035 /* {{{unsigned long int do_spawn(char *cmd) */
3039 unsigned long int sts, substs, hadcmd = 1;
3042 TAINT_PROPER("spawn");
3043 if (!cmd || !*cmd) {
3045 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3047 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3048 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3054 set_errno(ENOENT); break;
3055 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3056 set_errno(ENOTDIR); break;
3058 set_errno(EACCES); break;
3060 set_errno(EINVAL); break;
3062 set_errno(E2BIG); break;
3063 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3064 _ckvmssts(sts); /* fall through */
3065 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3068 set_vaxc_errno(sts);
3070 warn("Can't spawn \"%s\": %s",
3071 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
3076 } /* end of do_spawn() */
3080 * A simple fwrite replacement which outputs itmsz*nitm chars without
3081 * introducing record boundaries every itmsz chars.
3083 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3085 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3087 register char *cp, *end;
3089 end = (char *)src + itmsz * nitm;
3091 while ((char *)src <= end) {
3092 for (cp = src; cp <= end; cp++) if (!*cp) break;
3093 if (fputs(src,dest) == EOF) return EOF;
3095 if (fputc('\0',dest) == EOF) return EOF;
3101 } /* end of my_fwrite() */
3104 /*{{{ int my_flush(FILE *fp)*/
3109 if ((res = fflush(fp)) == 0) {
3110 #ifdef VMS_DO_SOCKETS
3112 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3114 res = fsync(fileno(fp));
3121 * Here are replacements for the following Unix routines in the VMS environment:
3122 * getpwuid Get information for a particular UIC or UID
3123 * getpwnam Get information for a named user
3124 * getpwent Get information for each user in the rights database
3125 * setpwent Reset search to the start of the rights database
3126 * endpwent Finish searching for users in the rights database
3128 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3129 * (defined in pwd.h), which contains the following fields:-
3131 * char *pw_name; Username (in lower case)
3132 * char *pw_passwd; Hashed password
3133 * unsigned int pw_uid; UIC
3134 * unsigned int pw_gid; UIC group number
3135 * char *pw_unixdir; Default device/directory (VMS-style)
3136 * char *pw_gecos; Owner name
3137 * char *pw_dir; Default device/directory (Unix-style)
3138 * char *pw_shell; Default CLI name (eg. DCL)
3140 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3142 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3143 * not the UIC member number (eg. what's returned by getuid()),
3144 * getpwuid() can accept either as input (if uid is specified, the caller's
3145 * UIC group is used), though it won't recognise gid=0.
3147 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3148 * information about other users in your group or in other groups, respectively.
3149 * If the required privilege is not available, then these routines fill only
3150 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3153 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3156 /* sizes of various UAF record fields */
3157 #define UAI$S_USERNAME 12
3158 #define UAI$S_IDENT 31
3159 #define UAI$S_OWNER 31
3160 #define UAI$S_DEFDEV 31
3161 #define UAI$S_DEFDIR 63
3162 #define UAI$S_DEFCLI 31
3165 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3166 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3167 (uic).uic$v_group != UIC$K_WILD_GROUP)
3169 static char __empty[]= "";
3170 static struct passwd __passwd_empty=
3171 {(char *) __empty, (char *) __empty, 0, 0,
3172 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3173 static int contxt= 0;
3174 static struct passwd __pwdcache;
3175 static char __pw_namecache[UAI$S_IDENT+1];
3178 * This routine does most of the work extracting the user information.
3180 static int fillpasswd (const char *name, struct passwd *pwd)
3183 unsigned char length;
3184 char pw_gecos[UAI$S_OWNER+1];
3186 static union uicdef uic;
3188 unsigned char length;
3189 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3192 unsigned char length;
3193 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3196 unsigned char length;
3197 char pw_shell[UAI$S_DEFCLI+1];
3199 static char pw_passwd[UAI$S_PWD+1];
3201 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3202 struct dsc$descriptor_s name_desc;
3203 unsigned long int sts;
3205 static struct itmlst_3 itmlst[]= {
3206 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3207 {sizeof(uic), UAI$_UIC, &uic, &luic},
3208 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3209 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3210 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3211 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3212 {0, 0, NULL, NULL}};
3214 name_desc.dsc$w_length= strlen(name);
3215 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3216 name_desc.dsc$b_class= DSC$K_CLASS_S;
3217 name_desc.dsc$a_pointer= (char *) name;
3219 /* Note that sys$getuai returns many fields as counted strings. */
3220 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3221 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3222 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3224 else { _ckvmssts(sts); }
3225 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3227 if ((int) owner.length < lowner) lowner= (int) owner.length;
3228 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3229 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3230 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3231 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3232 owner.pw_gecos[lowner]= '\0';
3233 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3234 defcli.pw_shell[ldefcli]= '\0';
3235 if (valid_uic(uic)) {
3236 pwd->pw_uid= uic.uic$l_uic;
3237 pwd->pw_gid= uic.uic$v_group;
3240 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3241 pwd->pw_passwd= pw_passwd;
3242 pwd->pw_gecos= owner.pw_gecos;
3243 pwd->pw_dir= defdev.pw_dir;
3244 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3245 pwd->pw_shell= defcli.pw_shell;
3246 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3248 ldir= strlen(pwd->pw_unixdir) - 1;
3249 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3252 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3253 __mystrtolower(pwd->pw_unixdir);
3258 * Get information for a named user.
3260 /*{{{struct passwd *getpwnam(char *name)*/
3261 struct passwd *my_getpwnam(char *name)
3263 struct dsc$descriptor_s name_desc;
3265 unsigned long int status, sts;
3267 __pwdcache = __passwd_empty;
3268 if (!fillpasswd(name, &__pwdcache)) {
3269 /* We still may be able to determine pw_uid and pw_gid */
3270 name_desc.dsc$w_length= strlen(name);
3271 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3272 name_desc.dsc$b_class= DSC$K_CLASS_S;
3273 name_desc.dsc$a_pointer= (char *) name;
3274 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3275 __pwdcache.pw_uid= uic.uic$l_uic;
3276 __pwdcache.pw_gid= uic.uic$v_group;
3279 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3280 set_vaxc_errno(sts);
3281 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3284 else { _ckvmssts(sts); }
3287 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3288 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3289 __pwdcache.pw_name= __pw_namecache;
3291 } /* end of my_getpwnam() */
3295 * Get information for a particular UIC or UID.
3296 * Called by my_getpwent with uid=-1 to list all users.
3298 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3299 struct passwd *my_getpwuid(Uid_t uid)
3301 const $DESCRIPTOR(name_desc,__pw_namecache);
3302 unsigned short lname;
3304 unsigned long int status;
3306 if (uid == (unsigned int) -1) {
3308 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3309 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3310 set_vaxc_errno(status);
3311 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3315 else { _ckvmssts(status); }
3316 } while (!valid_uic (uic));
3320 if (!uic.uic$v_group)
3321 uic.uic$v_group= PerlProc_getgid();
3323 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3324 else status = SS$_IVIDENT;
3325 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3326 status == RMS$_PRV) {
3327 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3330 else { _ckvmssts(status); }
3332 __pw_namecache[lname]= '\0';
3333 __mystrtolower(__pw_namecache);
3335 __pwdcache = __passwd_empty;
3336 __pwdcache.pw_name = __pw_namecache;
3338 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3339 The identifier's value is usually the UIC, but it doesn't have to be,
3340 so if we can, we let fillpasswd update this. */
3341 __pwdcache.pw_uid = uic.uic$l_uic;
3342 __pwdcache.pw_gid = uic.uic$v_group;
3344 fillpasswd(__pw_namecache, &__pwdcache);
3347 } /* end of my_getpwuid() */
3351 * Get information for next user.
3353 /*{{{struct passwd *my_getpwent()*/
3354 struct passwd *my_getpwent()
3356 return (my_getpwuid((unsigned int) -1));
3361 * Finish searching rights database for users.
3363 /*{{{void my_endpwent()*/
3367 _ckvmssts(sys$finish_rdb(&contxt));
3373 #ifdef HOMEGROWN_POSIX_SIGNALS
3374 /* Signal handling routines, pulled into the core from POSIX.xs.
3376 * We need these for threads, so they've been rolled into the core,
3377 * rather than left in POSIX.xs.
3379 * (DRS, Oct 23, 1997)
3382 /* sigset_t is atomic under VMS, so these routines are easy */
3383 /*{{{int my_sigemptyset(sigset_t *) */
3384 int my_sigemptyset(sigset_t *set) {
3385 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3391 /*{{{int my_sigfillset(sigset_t *)*/
3392 int my_sigfillset(sigset_t *set) {
3394 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3395 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3401 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3402 int my_sigaddset(sigset_t *set, int sig) {
3403 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3404 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3405 *set |= (1 << (sig - 1));
3411 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3412 int my_sigdelset(sigset_t *set, int sig) {
3413 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3414 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3415 *set &= ~(1 << (sig - 1));
3421 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3422 int my_sigismember(sigset_t *set, int sig) {
3423 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3424 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3425 *set & (1 << (sig - 1));
3430 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3431 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3434 /* If set and oset are both null, then things are badly wrong. Bail out. */
3435 if ((oset == NULL) && (set == NULL)) {
3436 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3440 /* If set's null, then we're just handling a fetch. */
3442 tempmask = sigblock(0);
3447 tempmask = sigsetmask(*set);
3450 tempmask = sigblock(*set);
3453 tempmask = sigblock(0);
3454 sigsetmask(*oset & ~tempmask);
3457 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3462 /* Did they pass us an oset? If so, stick our holding mask into it */
3469 #endif /* HOMEGROWN_POSIX_SIGNALS */
3472 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3473 * my_utime(), and flex_stat(), all of which operate on UTC unless
3474 * VMSISH_TIMES is true.
3476 /* method used to handle UTC conversions:
3477 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3479 static int gmtime_emulation_type;
3480 /* number of secs to add to UTC POSIX-style time to get local time */
3481 static long int utc_offset_secs;
3483 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3484 * in vmsish.h. #undef them here so we can call the CRTL routines
3491 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3492 # define RTL_USES_UTC 1
3495 static time_t toutc_dst(time_t loc) {
3498 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3499 loc -= utc_offset_secs;
3500 if (rsltmp->tm_isdst) loc -= 3600;
3503 #define _toutc(secs) ((secs) == -1 ? -1 : \
3504 ((gmtime_emulation_type || my_time(NULL)), \
3505 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3506 ((secs) - utc_offset_secs))))
3508 static time_t toloc_dst(time_t utc) {
3511 utc += utc_offset_secs;
3512 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3513 if (rsltmp->tm_isdst) utc += 3600;
3516 #define _toloc(secs) ((secs) == -1 ? -1 : \
3517 ((gmtime_emulation_type || my_time(NULL)), \
3518 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3519 ((secs) + utc_offset_secs))))
3522 /* my_time(), my_localtime(), my_gmtime()
3523 * By default traffic in UTC time values, using CRTL gmtime() or
3524 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3525 * Note: We need to use these functions even when the CRTL has working
3526 * UTC support, since they also handle C<use vmsish qw(times);>
3528 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3529 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3532 /*{{{time_t my_time(time_t *timep)*/
3533 time_t my_time(time_t *timep)
3539 if (gmtime_emulation_type == 0) {
3541 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3542 /* results of calls to gmtime() and localtime() */
3543 /* for same &base */
3545 gmtime_emulation_type++;
3546 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3549 gmtime_emulation_type++;
3550 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3551 gmtime_emulation_type++;
3552 warn("no UTC offset information; assuming local time is UTC");
3554 else { utc_offset_secs = atol(off); }
3556 else { /* We've got a working gmtime() */
3557 struct tm gmt, local;
3560 tm_p = localtime(&base);
3562 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3563 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3564 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3565 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3571 # ifdef RTL_USES_UTC
3572 if (VMSISH_TIME) when = _toloc(when);
3574 if (!VMSISH_TIME) when = _toutc(when);
3577 if (timep != NULL) *timep = when;
3580 } /* end of my_time() */
3584 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3586 my_gmtime(const time_t *timep)
3593 if (timep == NULL) {
3594 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3597 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3601 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
3603 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
3604 return gmtime(&when);
3606 /* CRTL localtime() wants local time as input, so does no tz correction */
3607 rsltmp = localtime(&when);
3608 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
3611 } /* end of my_gmtime() */
3615 /*{{{struct tm *my_localtime(const time_t *timep)*/
3617 my_localtime(const time_t *timep)
3623 if (timep == NULL) {
3624 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3627 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3628 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3631 # ifdef RTL_USES_UTC
3633 if (VMSISH_TIME) when = _toutc(when);
3635 /* CRTL localtime() wants UTC as input, does tz correction itself */
3636 return localtime(&when);
3639 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
3642 /* CRTL localtime() wants local time as input, so does no tz correction */
3643 rsltmp = localtime(&when);
3644 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
3647 } /* end of my_localtime() */
3650 /* Reset definitions for later calls */
3651 #define gmtime(t) my_gmtime(t)
3652 #define localtime(t) my_localtime(t)
3653 #define time(t) my_time(t)
3656 /* my_utime - update modification time of a file
3657 * calling sequence is identical to POSIX utime(), but under
3658 * VMS only the modification time is changed; ODS-2 does not
3659 * maintain access times. Restrictions differ from the POSIX
3660 * definition in that the time can be changed as long as the
3661 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3662 * no separate checks are made to insure that the caller is the
3663 * owner of the file or has special privs enabled.
3664 * Code here is based on Joe Meadows' FILE utility.
3667 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3668 * to VMS epoch (01-JAN-1858 00:00:00.00)
3669 * in 100 ns intervals.
3671 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3673 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3674 int my_utime(char *file, struct utimbuf *utimes)
3678 long int bintime[2], len = 2, lowbit, unixtime,
3679 secscale = 10000000; /* seconds --> 100 ns intervals */
3680 unsigned long int chan, iosb[2], retsts;
3681 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3682 struct FAB myfab = cc$rms_fab;
3683 struct NAM mynam = cc$rms_nam;
3684 #if defined (__DECC) && defined (__VAX)
3685 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3686 * at least through VMS V6.1, which causes a type-conversion warning.
3688 # pragma message save
3689 # pragma message disable cvtdiftypes
3691 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3692 struct fibdef myfib;
3693 #if defined (__DECC) && defined (__VAX)
3694 /* This should be right after the declaration of myatr, but due
3695 * to a bug in VAX DEC C, this takes effect a statement early.
3697 # pragma message restore
3699 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3700 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3701 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3703 if (file == NULL || *file == '\0') {
3705 set_vaxc_errno(LIB$_INVARG);
3708 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3710 if (utimes != NULL) {
3711 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3712 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3713 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3714 * as input, we force the sign bit to be clear by shifting unixtime right
3715 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3717 lowbit = (utimes->modtime & 1) ? secscale : 0;
3718 unixtime = (long int) utimes->modtime;
3720 /* If input was UTC; convert to local for sys svc */
3721 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
3723 unixtime >> 1; secscale << 1;
3724 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3725 if (!(retsts & 1)) {
3727 set_vaxc_errno(retsts);
3730 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3731 if (!(retsts & 1)) {
3733 set_vaxc_errno(retsts);
3738 /* Just get the current time in VMS format directly */
3739 retsts = sys$gettim(bintime);
3740 if (!(retsts & 1)) {
3742 set_vaxc_errno(retsts);
3747 myfab.fab$l_fna = vmsspec;
3748 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3749 myfab.fab$l_nam = &mynam;
3750 mynam.nam$l_esa = esa;
3751 mynam.nam$b_ess = (unsigned char) sizeof esa;
3752 mynam.nam$l_rsa = rsa;
3753 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3755 /* Look for the file to be affected, letting RMS parse the file
3756 * specification for us as well. I have set errno using only
3757 * values documented in the utime() man page for VMS POSIX.
3759 retsts = sys$parse(&myfab,0,0);
3760 if (!(retsts & 1)) {
3761 set_vaxc_errno(retsts);
3762 if (retsts == RMS$_PRV) set_errno(EACCES);
3763 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3764 else set_errno(EVMSERR);
3767 retsts = sys$search(&myfab,0,0);
3768 if (!(retsts & 1)) {
3769 set_vaxc_errno(retsts);
3770 if (retsts == RMS$_PRV) set_errno(EACCES);
3771 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3772 else set_errno(EVMSERR);
3776 devdsc.dsc$w_length = mynam.nam$b_dev;
3777 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3779 retsts = sys$assign(&devdsc,&chan,0,0);
3780 if (!(retsts & 1)) {
3781 set_vaxc_errno(retsts);
3782 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3783 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3784 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3785 else set_errno(EVMSERR);
3789 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3790 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3792 memset((void *) &myfib, 0, sizeof myfib);
3794 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3795 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3796 /* This prevents the revision time of the file being reset to the current
3797 * time as a result of our IO$_MODIFY $QIO. */
3798 myfib.fib$l_acctl = FIB$M_NORECORD;
3800 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3801 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3802 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3804 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3805 _ckvmssts(sys$dassgn(chan));
3806 if (retsts & 1) retsts = iosb[0];
3807 if (!(retsts & 1)) {
3808 set_vaxc_errno(retsts);
3809 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3810 else set_errno(EVMSERR);
3815 } /* end of my_utime() */
3819 * flex_stat, flex_fstat
3820 * basic stat, but gets it right when asked to stat
3821 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3824 /* encode_dev packs a VMS device name string into an integer to allow
3825 * simple comparisons. This can be used, for example, to check whether two
3826 * files are located on the same device, by comparing their encoded device
3827 * names. Even a string comparison would not do, because stat() reuses the
3828 * device name buffer for each call; so without encode_dev, it would be
3829 * necessary to save the buffer and use strcmp (this would mean a number of
3830 * changes to the standard Perl code, to say nothing of what a Perl script
3833 * The device lock id, if it exists, should be unique (unless perhaps compared
3834 * with lock ids transferred from other nodes). We have a lock id if the disk is
3835 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3836 * device names. Thus we use the lock id in preference, and only if that isn't
3837 * available, do we try to pack the device name into an integer (flagged by
3838 * the sign bit (LOCKID_MASK) being set).
3840 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3841 * name and its encoded form, but it seems very unlikely that we will find
3842 * two files on different disks that share the same encoded device names,
3843 * and even more remote that they will share the same file id (if the test
3844 * is to check for the same file).
3846 * A better method might be to use sys$device_scan on the first call, and to
3847 * search for the device, returning an index into the cached array.
3848 * The number returned would be more intelligable.
3849 * This is probably not worth it, and anyway would take quite a bit longer
3850 * on the first call.
3852 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3853 static mydev_t encode_dev (const char *dev)
3856 unsigned long int f;
3861 if (!dev || !dev[0]) return 0;
3865 struct dsc$descriptor_s dev_desc;
3866 unsigned long int status, lockid, item = DVI$_LOCKID;
3868 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3869 can try that first. */
3870 dev_desc.dsc$w_length = strlen (dev);
3871 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3872 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3873 dev_desc.dsc$a_pointer = (char *) dev;
3874 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3875 if (lockid) return (lockid & ~LOCKID_MASK);
3879 /* Otherwise we try to encode the device name */
3883 for (q = dev + strlen(dev); q--; q >= dev) {
3886 else if (isalpha (toupper (*q)))
3887 c= toupper (*q) - 'A' + (char)10;
3889 continue; /* Skip '$'s */
3891 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3893 enc += f * (unsigned long int) c;
3895 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3897 } /* end of encode_dev() */
3899 static char namecache[NAM$C_MAXRSS+1];
3902 is_null_device(name)
3905 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3906 The underscore prefix, controller letter, and unit number are
3907 independently optional; for our purposes, the colon punctuation
3908 is not. The colon can be trailed by optional directory and/or
3909 filename, but two consecutive colons indicates a nodename rather
3910 than a device. [pr] */
3911 if (*name == '_') ++name;
3912 if (tolower(*name++) != 'n') return 0;
3913 if (tolower(*name++) != 'l') return 0;
3914 if (tolower(*name) == 'a') ++name;
3915 if (*name == '0') ++name;
3916 return (*name++ == ':') && (*name != ':');
3919 /* Do the permissions allow some operation? Assumes statcache already set. */
3920 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3921 * subset of the applicable information.
3923 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3925 cando(I32 bit, I32 effective, Stat_t *statbufp)
3927 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3929 char fname[NAM$C_MAXRSS+1];
3930 unsigned long int retsts;
3931 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3932 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3934 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3935 device name on successive calls */
3936 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
3937 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
3938 namdsc.dsc$a_pointer = fname;
3939 namdsc.dsc$w_length = sizeof fname - 1;
3941 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
3942 &namdsc,&namdsc.dsc$w_length,0,0);
3944 fname[namdsc.dsc$w_length] = '\0';
3945 return cando_by_name(bit,effective,fname);
3947 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3948 warn("Can't get filespec - stale stat buffer?\n");
3952 return FALSE; /* Should never get to here */
3954 } /* end of cando() */
3958 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3960 cando_by_name(I32 bit, I32 effective, char *fname)
3962 static char usrname[L_cuserid];
3963 static struct dsc$descriptor_s usrdsc =
3964 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3965 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3966 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3967 unsigned short int retlen;
3968 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3969 union prvdef curprv;
3970 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3971 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3972 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3975 if (!fname || !*fname) return FALSE;
3976 /* Make sure we expand logical names, since sys$check_access doesn't */
3977 if (!strpbrk(fname,"/]>:")) {
3978 strcpy(fileified,fname);
3979 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3982 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3983 retlen = namdsc.dsc$w_length = strlen(vmsname);
3984 namdsc.dsc$a_pointer = vmsname;
3985 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3986 vmsname[retlen-1] == ':') {
3987 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3988 namdsc.dsc$w_length = strlen(fileified);
3989 namdsc.dsc$a_pointer = fileified;
3992 if (!usrdsc.dsc$w_length) {
3994 usrdsc.dsc$w_length = strlen(usrname);
4001 access = ARM$M_EXECUTE;
4006 access = ARM$M_READ;
4011 access = ARM$M_WRITE;
4016 access = ARM$M_DELETE;
4022 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4023 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4024 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4025 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4026 set_vaxc_errno(retsts);
4027 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4028 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4029 else set_errno(ENOENT);
4032 if (retsts == SS$_NORMAL) {
4033 if (!privused) return TRUE;
4034 /* We can get access, but only by using privs. Do we have the
4035 necessary privs currently enabled? */
4036 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4037 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4038 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4039 !curprv.prv$v_bypass) return FALSE;
4040 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4041 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4042 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4047 return FALSE; /* Should never get here */
4049 } /* end of cando_by_name() */
4053 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4055 flex_fstat(int fd, Stat_t *statbufp)
4058 if (!fstat(fd,(stat_t *) statbufp)) {
4059 if (statbufp == (Stat_t *) &statcache) *namecache == '\0';
4060 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4061 # ifdef RTL_USES_UTC
4064 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4065 statbufp->st_atime = _toloc(statbufp->st_atime);
4066 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4071 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4075 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4076 statbufp->st_atime = _toutc(statbufp->st_atime);
4077 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4084 } /* end of flex_fstat() */
4087 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4089 flex_stat(char *fspec, Stat_t *statbufp)
4092 char fileified[NAM$C_MAXRSS+1];
4095 if (statbufp == (Stat_t *) &statcache)
4096 do_tovmsspec(fspec,namecache,0);
4097 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4098 memset(statbufp,0,sizeof *statbufp);
4099 statbufp->st_dev = encode_dev("_NLA0:");
4100 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4101 statbufp->st_uid = 0x00010001;
4102 statbufp->st_gid = 0x0001;
4103 time((time_t *)&statbufp->st_mtime);
4104 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4108 /* Try for a directory name first. If fspec contains a filename without
4109 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4110 * and sea:[wine.dark]water. exist, we prefer the directory here.
4111 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4112 * not sea:[wine.dark]., if the latter exists. If the intended target is
4113 * the file with null type, specify this by calling flex_stat() with
4114 * a '.' at the end of fspec.
4116 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4117 retval = stat(fileified,(stat_t *) statbufp);
4118 if (!retval && statbufp == (Stat_t *) &statcache)
4119 strcpy(namecache,fileified);
4121 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4123 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4124 # ifdef RTL_USES_UTC
4127 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4128 statbufp->st_atime = _toloc(statbufp->st_atime);
4129 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4134 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4138 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4139 statbufp->st_atime = _toutc(statbufp->st_atime);
4140 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4146 } /* end of flex_stat() */
4149 /* Insures that no carriage-control translation will be done on a file. */
4150 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
4152 my_binmode(FILE *fp, char iotype)
4154 char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
4155 int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
4158 if (!fgetname(fp,filespec)) return NULL;
4159 for (s = filespec; *s; s++) {
4160 if (*s == ':') colon = s;
4161 else if (*s == ']' || *s == '>') dirend = s;
4163 /* Looks like a tmpfile, which will go away if reopened */
4164 if (s == dirend + 3) return fp;
4165 /* If we've got a non-file-structured device, clip off the trailing
4166 * junk, and don't lose sleep if we can't get a stream position. */
4167 if (dirend == Nullch) *(colon+1) = '\0';
4168 if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
4170 case '<': case 'r': acmode = "rb"; break;
4171 case '>': case 'w': case '|':
4172 /* use 'a' instead of 'w' to avoid creating new file;
4173 fsetpos below will take care of restoring file position */
4174 case 'a': acmode = "ab"; break;
4175 case '+': case 's': acmode = "rb+"; break;
4176 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
4178 warn("Unrecognized iotype %c in my_binmode",iotype);
4181 if (freopen(filespec,acmode,fp) == NULL) return NULL;
4182 if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
4183 if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
4185 } /* end of my_binmode() */
4189 /*{{{char *my_getlogin()*/
4190 /* VMS cuserid == Unix getlogin, except calling sequence */
4194 static char user[L_cuserid];
4195 return cuserid(user);
4200 /* rmscopy - copy a file using VMS RMS routines
4202 * Copies contents and attributes of spec_in to spec_out, except owner
4203 * and protection information. Name and type of spec_in are used as
4204 * defaults for spec_out. The third parameter specifies whether rmscopy()
4205 * should try to propagate timestamps from the input file to the output file.
4206 * If it is less than 0, no timestamps are preserved. If it is 0, then
4207 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4208 * propagated to the output file at creation iff the output file specification
4209 * did not contain an explicit name or type, and the revision date is always
4210 * updated at the end of the copy operation. If it is greater than 0, then
4211 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4212 * other than the revision date should be propagated, and bit 1 indicates
4213 * that the revision date should be propagated.
4215 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4217 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
4218 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4219 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4220 * as part of the Perl standard distribution under the terms of the
4221 * GNU General Public License or the Perl Artistic License. Copies
4222 * of each may be found in the Perl standard distribution.
4224 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4226 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4228 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4229 rsa[NAM$C_MAXRSS], ubf[32256];
4230 unsigned long int i, sts, sts2;
4231 struct FAB fab_in, fab_out;
4232 struct RAB rab_in, rab_out;
4234 struct XABDAT xabdat;
4235 struct XABFHC xabfhc;
4236 struct XABRDT xabrdt;
4237 struct XABSUM xabsum;
4239 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4240 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4241 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4245 fab_in = cc$rms_fab;
4246 fab_in.fab$l_fna = vmsin;
4247 fab_in.fab$b_fns = strlen(vmsin);
4248 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4249 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4250 fab_in.fab$l_fop = FAB$M_SQO;
4251 fab_in.fab$l_nam = &nam;
4252 fab_in.fab$l_xab = (void *) &xabdat;
4255 nam.nam$l_rsa = rsa;
4256 nam.nam$b_rss = sizeof(rsa);
4257 nam.nam$l_esa = esa;
4258 nam.nam$b_ess = sizeof (esa);
4259 nam.nam$b_esl = nam.nam$b_rsl = 0;
4261 xabdat = cc$rms_xabdat; /* To get creation date */
4262 xabdat.xab$l_nxt = (void *) &xabfhc;
4264 xabfhc = cc$rms_xabfhc; /* To get record length */
4265 xabfhc.xab$l_nxt = (void *) &xabsum;
4267 xabsum = cc$rms_xabsum; /* To get key and area information */
4269 if (!((sts = sys$open(&fab_in)) & 1)) {
4270 set_vaxc_errno(sts);
4274 set_errno(ENOENT); break;
4276 set_errno(ENODEV); break;
4278 set_errno(EINVAL); break;
4280 set_errno(EACCES); break;
4288 fab_out.fab$w_ifi = 0;
4289 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4290 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4291 fab_out.fab$l_fop = FAB$M_SQO;
4292 fab_out.fab$l_fna = vmsout;
4293 fab_out.fab$b_fns = strlen(vmsout);
4294 fab_out.fab$l_dna = nam.nam$l_name;
4295 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4297 if (preserve_dates == 0) { /* Act like DCL COPY */
4298 nam.nam$b_nop = NAM$M_SYNCHK;
4299 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4300 if (!((sts = sys$parse(&fab_out)) & 1)) {
4301 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4302 set_vaxc_errno(sts);
4305 fab_out.fab$l_xab = (void *) &xabdat;
4306 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4308 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4309 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4310 preserve_dates =0; /* bitmask from this point forward */
4312 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4313 if (!((sts = sys$create(&fab_out)) & 1)) {
4314 set_vaxc_errno(sts);
4317 set_errno(ENOENT); break;
4319 set_errno(ENODEV); break;
4321 set_errno(EINVAL); break;
4323 set_errno(EACCES); break;
4329 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4330 if (preserve_dates & 2) {
4331 /* sys$close() will process xabrdt, not xabdat */
4332 xabrdt = cc$rms_xabrdt;
4334 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4336 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4337 * is unsigned long[2], while DECC & VAXC use a struct */
4338 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4340 fab_out.fab$l_xab = (void *) &xabrdt;
4343 rab_in = cc$rms_rab;
4344 rab_in.rab$l_fab = &fab_in;
4345 rab_in.rab$l_rop = RAB$M_BIO;
4346 rab_in.rab$l_ubf = ubf;
4347 rab_in.rab$w_usz = sizeof ubf;
4348 if (!((sts = sys$connect(&rab_in)) & 1)) {
4349 sys$close(&fab_in); sys$close(&fab_out);
4350 set_errno(EVMSERR); set_vaxc_errno(sts);
4354 rab_out = cc$rms_rab;
4355 rab_out.rab$l_fab = &fab_out;
4356 rab_out.rab$l_rbf = ubf;
4357 if (!((sts = sys$connect(&rab_out)) & 1)) {
4358 sys$close(&fab_in); sys$close(&fab_out);
4359 set_errno(EVMSERR); set_vaxc_errno(sts);
4363 while ((sts = sys$read(&rab_in))) { /* always true */
4364 if (sts == RMS$_EOF) break;
4365 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4366 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4367 sys$close(&fab_in); sys$close(&fab_out);
4368 set_errno(EVMSERR); set_vaxc_errno(sts);
4373 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4374 sys$close(&fab_in); sys$close(&fab_out);
4375 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4377 set_errno(EVMSERR); set_vaxc_errno(sts);
4383 } /* end of rmscopy() */
4387 /*** The following glue provides 'hooks' to make some of the routines
4388 * from this file available from Perl. These routines are sufficiently
4389 * basic, and are required sufficiently early in the build process,
4390 * that's it's nice to have them available to miniperl as well as the
4391 * full Perl, so they're set up here instead of in an extension. The
4392 * Perl code which handles importation of these names into a given
4393 * package lives in [.VMS]Filespec.pm in @INC.
4397 rmsexpand_fromperl(CV *cv)
4400 char *fspec, *defspec = NULL, *rslt;
4402 if (!items || items > 2)
4403 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4404 fspec = SvPV(ST(0),na);
4405 if (!fspec || !*fspec) XSRETURN_UNDEF;
4406 if (items == 2) defspec = SvPV(ST(1),na);
4408 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4409 ST(0) = sv_newmortal();
4410 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4415 vmsify_fromperl(CV *cv)
4420 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4421 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4422 ST(0) = sv_newmortal();
4423 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4428 unixify_fromperl(CV *cv)
4433 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4434 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4435 ST(0) = sv_newmortal();
4436 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4441 fileify_fromperl(CV *cv)
4446 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4447 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4448 ST(0) = sv_newmortal();
4449 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4454 pathify_fromperl(CV *cv)
4459 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4460 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4461 ST(0) = sv_newmortal();
4462 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4467 vmspath_fromperl(CV *cv)
4472 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4473 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4474 ST(0) = sv_newmortal();
4475 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4480 unixpath_fromperl(CV *cv)
4485 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4486 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4487 ST(0) = sv_newmortal();
4488 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4493 candelete_fromperl(CV *cv)
4496 char fspec[NAM$C_MAXRSS+1], *fsp;
4500 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4502 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4503 if (SvTYPE(mysv) == SVt_PVGV) {
4504 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4505 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4512 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4513 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4519 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4524 rmscopy_fromperl(CV *cv)
4527 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4529 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4530 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4531 unsigned long int sts;
4535 if (items < 2 || items > 3)
4536 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4538 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4539 if (SvTYPE(mysv) == SVt_PVGV) {
4540 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4541 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4548 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4549 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4554 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4555 if (SvTYPE(mysv) == SVt_PVGV) {
4556 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4557 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4564 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4565 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4570 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4572 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4579 char* file = __FILE__;
4581 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4582 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4583 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4584 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4585 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4586 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4587 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4588 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4589 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
4591 #ifdef PRIME_ENV_AT_STARTUP