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 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 the four "special" keys that the CRTL defines,
216 * whether or not underlying logical names exist. */
217 (void) hv_fetch(envhv,"HOME",4,TRUE);
218 (void) hv_fetch(envhv,"TERM",4,TRUE);
219 (void) hv_fetch(envhv,"PATH",4,TRUE);
220 (void) hv_fetch(envhv,"USER",4,TRUE);
222 /* Now, go get the logical names */
223 create_mbx(&chan,&mbxdsc);
224 if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
225 if ((retsts = sys$dassgn(chan)) & 1) {
226 /* Be certain that subprocess is using the CLI and command tables we
227 * expect, and don't pass symbols through so that we insure that
228 * "Show Logical" can't be subverted.
231 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
232 0,&riseandshine,0,0,&clidsc,&tabdsc);
233 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
234 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
237 if (sholog == Nullfp || !(retsts & 1)) {
238 if (sholog != Nullfp) PerlIO_close(sholog);
239 MUTEX_UNLOCK(&primenv_mutex);
240 _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
242 /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
243 * tied to Perl's I/O layer, so it may not return a simple FILE * */
245 rs = newSVpv("\n",1);
246 linesv = newSVpv("",0);
248 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
249 PerlIO_close(sholog);
250 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
252 /* Wait for subprocess to clean up (we know subproc won't return 0) */
253 while (substs == 0) { sys$hiber(); wakect++;}
254 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
256 MUTEX_UNLOCK(&primenv_mutex);
259 while (*start != '"' && *start != '=' && *start) start++;
260 if (*start != '"') continue;
261 for (end = ++start; *end && *end != '"'; end++) ;
262 if (*end) *end = '\0';
264 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
265 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
267 warn("Ill-formed logical name |%s| in prime_env_iter",start);
270 else { MUTEX_UNLOCK(&primenv_mutex); _ckvmssts(vaxc$errno); }
273 eqvsv = newSVpv(eqv,eqvlen);
274 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
277 } /* end of prime_env_iter */
281 /*{{{ void my_setenv(char *lnm, char *eqv)*/
283 my_setenv(char *lnm,char *eqv)
284 /* Define a supervisor-mode logical name in the process table.
285 * In the future we'll add tables, attribs, and acmodes,
286 * probably through a different call.
289 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
290 unsigned long int retsts, usermode = PSL$C_USER;
291 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
292 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
293 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
295 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
296 lnmdsc.dsc$w_length = cp1 - lnm;
298 if (!eqv || !*eqv) { /* we're deleting a logical name */
299 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
300 if (retsts == SS$_IVLOGNAM) return;
301 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
303 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
304 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
308 eqvdsc.dsc$w_length = strlen(eqv);
309 eqvdsc.dsc$a_pointer = eqv;
311 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
314 } /* end of my_setenv() */
318 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
319 /* my_crypt - VMS password hashing
320 * my_crypt() provides an interface compatible with the Unix crypt()
321 * C library function, and uses sys$hash_password() to perform VMS
322 * password hashing. The quadword hashed password value is returned
323 * as a NUL-terminated 8 character string. my_crypt() does not change
324 * the case of its string arguments; in order to match the behavior
325 * of LOGINOUT et al., alphabetic characters in both arguments must
326 * be upcased by the caller.
329 my_crypt(const char *textpasswd, const char *usrname)
331 # ifndef UAI$C_PREFERRED_ALGORITHM
332 # define UAI$C_PREFERRED_ALGORITHM 127
334 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
335 unsigned short int salt = 0;
336 unsigned long int sts;
338 unsigned short int dsc$w_length;
339 unsigned char dsc$b_type;
340 unsigned char dsc$b_class;
341 const char * dsc$a_pointer;
342 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
343 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
344 struct itmlst_3 uailst[3] = {
345 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
346 { sizeof salt, UAI$_SALT, &salt, 0},
347 { 0, 0, NULL, NULL}};
350 usrdsc.dsc$w_length = strlen(usrname);
351 usrdsc.dsc$a_pointer = usrname;
352 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
359 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
365 if (sts != RMS$_RNF) return NULL;
368 txtdsc.dsc$w_length = strlen(textpasswd);
369 txtdsc.dsc$a_pointer = textpasswd;
370 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
371 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
374 return (char *) hash;
376 } /* end of my_crypt() */
380 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
381 static char *do_fileify_dirspec(char *, char *, int);
382 static char *do_tovmsspec(char *, char *, int);
384 /*{{{int do_rmdir(char *name)*/
388 char dirfile[NAM$C_MAXRSS+1];
392 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
393 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
394 else retval = kill_file(dirfile);
397 } /* end of do_rmdir */
401 * Delete any file to which user has control access, regardless of whether
402 * delete access is explicitly allowed.
403 * Limitations: User must have write access to parent directory.
404 * Does not block signals or ASTs; if interrupted in midstream
405 * may leave file with an altered ACL.
408 /*{{{int kill_file(char *name)*/
410 kill_file(char *name)
412 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
413 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
414 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
415 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
417 unsigned char myace$b_length;
418 unsigned char myace$b_type;
419 unsigned short int myace$w_flags;
420 unsigned long int myace$l_access;
421 unsigned long int myace$l_ident;
422 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
423 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
424 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
426 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
427 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
428 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
429 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
430 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
431 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
433 /* Expand the input spec using RMS, since the CRTL remove() and
434 * system services won't do this by themselves, so we may miss
435 * a file "hiding" behind a logical name or search list. */
436 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
437 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
438 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
439 /* If not, can changing protections help? */
440 if (vaxc$errno != RMS$_PRV) return -1;
442 /* No, so we get our own UIC to use as a rights identifier,
443 * and the insert an ACE at the head of the ACL which allows us
444 * to delete the file.
446 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
447 fildsc.dsc$w_length = strlen(rspec);
448 fildsc.dsc$a_pointer = rspec;
450 newace.myace$l_ident = oldace.myace$l_ident;
451 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
456 case SS$_NOSUCHOBJECT:
457 set_errno(ENOENT); break;
459 set_errno(ENODEV); break;
461 case SS$_INVFILFOROP:
462 set_errno(EINVAL); break;
464 set_errno(EACCES); break;
468 set_vaxc_errno(aclsts);
471 /* Grab any existing ACEs with this identifier in case we fail */
472 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
473 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
474 || fndsts == SS$_NOMOREACE ) {
475 /* Add the new ACE . . . */
476 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
478 if ((rmsts = remove(name))) {
479 /* We blew it - dir with files in it, no write priv for
480 * parent directory, etc. Put things back the way they were. */
481 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
484 addlst[0].bufadr = &oldace;
485 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
492 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
493 /* We just deleted it, so of course it's not there. Some versions of
494 * VMS seem to return success on the unlock operation anyhow (after all
495 * the unlock is successful), but others don't.
497 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
498 if (aclsts & 1) aclsts = fndsts;
501 set_vaxc_errno(aclsts);
507 } /* end of kill_file() */
511 /*{{{int my_mkdir(char *,Mode_t)*/
513 my_mkdir(char *dir, Mode_t mode)
515 STRLEN dirlen = strlen(dir);
517 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
518 * null file name/type. However, it's commonplace under Unix,
519 * so we'll allow it for a gain in portability.
521 if (dir[dirlen-1] == '/') {
522 char *newdir = savepvn(dir,dirlen-1);
523 int ret = mkdir(newdir,mode);
527 else return mkdir(dir,mode);
528 } /* end of my_mkdir */
533 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
535 static unsigned long int mbxbufsiz;
536 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
540 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
541 * preprocessor consant BUFSIZ from stdio.h as the size of the
544 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
545 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
547 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
549 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
550 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
552 } /* end of create_mbx() */
554 /*{{{ my_popen and my_pclose*/
557 struct pipe_details *next;
558 PerlIO *fp; /* stdio file pointer to pipe mailbox */
559 int pid; /* PID of subprocess */
560 int mode; /* == 'r' if pipe open for reading */
561 int done; /* subprocess has completed */
562 unsigned long int completion; /* termination status of subprocess */
565 struct exit_control_block
567 struct exit_control_block *flink;
568 unsigned long int (*exit_routine)();
569 unsigned long int arg_count;
570 unsigned long int *status_address;
571 unsigned long int exit_status;
574 static struct pipe_details *open_pipes = NULL;
575 static $DESCRIPTOR(nl_desc, "NL:");
576 static int waitpid_asleep = 0;
578 static unsigned long int
581 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
584 while (open_pipes != NULL) {
585 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
586 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
589 if (!open_pipes->done) /* We tried to be nice . . . */
590 _ckvmssts(sys$delprc(&open_pipes->pid,0));
591 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
592 else if (!(sts & 1)) retsts = sts;
597 static struct exit_control_block pipe_exitblock =
598 {(struct exit_control_block *) 0,
599 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
603 popen_completion_ast(struct pipe_details *thispipe)
605 thispipe->done = TRUE;
606 if (waitpid_asleep) {
613 safe_popen(char *cmd, char *mode)
615 static int handler_set_up = FALSE;
617 unsigned short int chan;
618 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
619 struct pipe_details *info;
620 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
621 DSC$K_CLASS_S, mbxname},
622 cmddsc = {0, DSC$K_DTYPE_T,
626 cmddsc.dsc$w_length=strlen(cmd);
627 cmddsc.dsc$a_pointer=cmd;
628 if (cmddsc.dsc$w_length > 255) {
629 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
633 New(1301,info,1,struct pipe_details);
636 create_mbx(&chan,&namdsc);
638 /* open a FILE* onto it */
639 info->fp = PerlIO_open(mbxname, mode);
641 /* give up other channel onto it */
642 _ckvmssts(sys$dassgn(chan));
652 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
653 0 /* name */, &info->pid, &info->completion,
654 0, popen_completion_ast,info,0,0,0));
657 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
658 0 /* name */, &info->pid, &info->completion,
659 0, popen_completion_ast,info,0,0,0));
662 if (!handler_set_up) {
663 _ckvmssts(sys$dclexh(&pipe_exitblock));
664 handler_set_up = TRUE;
666 info->next=open_pipes; /* prepend to list */
669 forkprocess = info->pid;
671 } /* end of safe_popen */
674 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
676 my_popen(char *cmd, char *mode)
679 TAINT_PROPER("popen");
680 return safe_popen(cmd,mode);
685 /*{{{ I32 my_pclose(FILE *fp)*/
686 I32 my_pclose(FILE *fp)
688 struct pipe_details *info, *last = NULL;
689 unsigned long int retsts;
691 for (info = open_pipes; info != NULL; last = info, info = info->next)
692 if (info->fp == fp) break;
694 if (info == NULL) { /* no such pipe open */
695 set_errno(ECHILD); /* quoth POSIX */
696 set_vaxc_errno(SS$_NONEXPR);
700 /* If we were writing to a subprocess, insure that someone reading from
701 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
702 * produce an EOF record in the mailbox. */
703 if (info->mode != 'r') {
704 char devnam[NAM$C_MAXRSS+1], *cp;
705 unsigned long int chan, iosb[2], retsts, retsts2;
706 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
708 if (fgetname(info->fp,devnam)) {
709 /* It oughta be a mailbox, so fgetname should give just the device
710 * name, but just in case . . . */
711 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
712 devdsc.dsc$w_length = strlen(devnam);
713 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
714 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
715 if (retsts & 1) retsts = iosb[0];
716 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
717 if (retsts & 1) retsts = retsts2;
720 else _ckvmssts(vaxc$errno); /* Should never happen */
722 PerlIO_close(info->fp);
724 if (info->done) retsts = info->completion;
725 else waitpid(info->pid,(int *) &retsts,0);
727 /* remove from list of open pipes */
728 if (last) last->next = info->next;
729 else open_pipes = info->next;
734 } /* end of my_pclose() */
736 /* sort-of waitpid; use only with popen() */
737 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
739 my_waitpid(Pid_t pid, int *statusp, int flags)
741 struct pipe_details *info;
743 for (info = open_pipes; info != NULL; info = info->next)
744 if (info->pid == pid) break;
746 if (info != NULL) { /* we know about this child */
747 while (!info->done) {
752 *statusp = info->completion;
755 else { /* we haven't heard of this child */
756 $DESCRIPTOR(intdsc,"0 00:00:01");
757 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
758 unsigned long int interval[2],sts;
761 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
762 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
763 if (ownerpid != mypid)
764 warn("pid %d not a child",pid);
767 _ckvmssts(sys$bintim(&intdsc,interval));
768 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
769 _ckvmssts(sys$schdwk(0,0,interval,0));
770 _ckvmssts(sys$hiber());
774 /* There's no easy way to find the termination status a child we're
775 * not aware of beforehand. If we're really interested in the future,
776 * we can go looking for a termination mailbox, or chase after the
777 * accounting record for the process.
783 } /* end of waitpid() */
788 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
790 my_gconvert(double val, int ndig, int trail, char *buf)
792 static char __gcvtbuf[DBL_DIG+1];
795 loc = buf ? buf : __gcvtbuf;
797 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
799 sprintf(loc,"%.*g",ndig,val);
805 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
806 return gcvt(val,ndig,loc);
809 loc[0] = '0'; loc[1] = '\0';
817 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
818 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
819 * to expand file specification. Allows for a single default file
820 * specification and a simple mask of options. If outbuf is non-NULL,
821 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
822 * the resultant file specification is placed. If outbuf is NULL, the
823 * resultant file specification is placed into a static buffer.
824 * The third argument, if non-NULL, is taken to be a default file
825 * specification string. The fourth argument is unused at present.
826 * rmesexpand() returns the address of the resultant string if
827 * successful, and NULL on error.
829 static char *do_tounixspec(char *, char *, int);
832 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
834 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
835 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
836 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
837 struct FAB myfab = cc$rms_fab;
838 struct NAM mynam = cc$rms_nam;
840 unsigned long int retsts, haslower = 0, isunix = 0;
842 if (!filespec || !*filespec) {
843 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
847 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
848 else outbuf = __rmsexpand_retbuf;
850 if ((isunix = (strchr(filespec,'/') != NULL))) {
851 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
855 myfab.fab$l_fna = filespec;
856 myfab.fab$b_fns = strlen(filespec);
857 myfab.fab$l_nam = &mynam;
859 if (defspec && *defspec) {
860 if (strchr(defspec,'/') != NULL) {
861 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
864 myfab.fab$l_dna = defspec;
865 myfab.fab$b_dns = strlen(defspec);
868 mynam.nam$l_esa = esa;
869 mynam.nam$b_ess = sizeof esa;
870 mynam.nam$l_rsa = outbuf;
871 mynam.nam$b_rss = NAM$C_MAXRSS;
873 retsts = sys$parse(&myfab,0,0);
875 mynam.nam$b_nop |= NAM$M_SYNCHK;
876 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
877 retsts == RMS$_DEV || retsts == RMS$_DEV) {
878 retsts = sys$parse(&myfab,0,0);
879 if (retsts & 1) goto expanded;
881 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
882 (void) sys$parse(&myfab,0,0); /* Free search context */
883 if (out) Safefree(out);
884 set_vaxc_errno(retsts);
885 if (retsts == RMS$_PRV) set_errno(EACCES);
886 else if (retsts == RMS$_DEV) set_errno(ENODEV);
887 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
888 else set_errno(EVMSERR);
891 retsts = sys$search(&myfab,0,0);
892 if (!(retsts & 1) && retsts != RMS$_FNF) {
893 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
894 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
895 if (out) Safefree(out);
896 set_vaxc_errno(retsts);
897 if (retsts == RMS$_PRV) set_errno(EACCES);
898 else set_errno(EVMSERR);
902 /* If the input filespec contained any lowercase characters,
903 * downcase the result for compatibility with Unix-minded code. */
905 for (out = myfab.fab$l_fna; *out; out++)
906 if (islower(*out)) { haslower = 1; break; }
907 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
908 else { out = esa; speclen = mynam.nam$b_esl; }
909 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
910 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
911 speclen = mynam.nam$l_ver - out;
912 if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
913 (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' ||
914 defspec[myfab.fab$b_dns-2] == '.'))
915 speclen = mynam.nam$l_type - out;
916 /* If we just had a directory spec on input, $PARSE "helpfully"
917 * adds an empty name and type for us */
918 if (mynam.nam$l_name == mynam.nam$l_type &&
919 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
920 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
921 speclen = mynam.nam$l_name - out;
923 if (haslower) __mystrtolower(out);
925 /* Have we been working with an expanded, but not resultant, spec? */
926 /* Also, convert back to Unix syntax if necessary. */
927 if (!mynam.nam$b_rsl) {
929 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
931 else strcpy(outbuf,esa);
934 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
935 strcpy(outbuf,tmpfspec);
937 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
938 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
939 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
943 /* External entry points */
944 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
945 { return do_rmsexpand(spec,buf,0,def,opt); }
946 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
947 { return do_rmsexpand(spec,buf,1,def,opt); }
951 ** The following routines are provided to make life easier when
952 ** converting among VMS-style and Unix-style directory specifications.
953 ** All will take input specifications in either VMS or Unix syntax. On
954 ** failure, all return NULL. If successful, the routines listed below
955 ** return a pointer to a buffer containing the appropriately
956 ** reformatted spec (and, therefore, subsequent calls to that routine
957 ** will clobber the result), while the routines of the same names with
958 ** a _ts suffix appended will return a pointer to a mallocd string
959 ** containing the appropriately reformatted spec.
960 ** In all cases, only explicit syntax is altered; no check is made that
961 ** the resulting string is valid or that the directory in question
964 ** fileify_dirspec() - convert a directory spec into the name of the
965 ** directory file (i.e. what you can stat() to see if it's a dir).
966 ** The style (VMS or Unix) of the result is the same as the style
967 ** of the parameter passed in.
968 ** pathify_dirspec() - convert a directory spec into a path (i.e.
969 ** what you prepend to a filename to indicate what directory it's in).
970 ** The style (VMS or Unix) of the result is the same as the style
971 ** of the parameter passed in.
972 ** tounixpath() - convert a directory spec into a Unix-style path.
973 ** tovmspath() - convert a directory spec into a VMS-style path.
974 ** tounixspec() - convert any file spec into a Unix-style file spec.
975 ** tovmsspec() - convert any file spec into a VMS-style spec.
977 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
978 ** Permission is given to distribute this code as part of the Perl
979 ** standard distribution under the terms of the GNU General Public
980 ** License or the Perl Artistic License. Copies of each may be
981 ** found in the Perl standard distribution.
984 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
985 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
987 static char __fileify_retbuf[NAM$C_MAXRSS+1];
988 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
989 char *retspec, *cp1, *cp2, *lastdir;
990 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
993 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
995 dirlen = strlen(dir);
996 while (dir[dirlen-1] == '/') --dirlen;
997 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
998 strcpy(trndir,"/sys$disk/000000");
1002 if (dirlen > NAM$C_MAXRSS) {
1003 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1005 if (!strpbrk(dir+1,"/]>:")) {
1006 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1007 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1009 dirlen = strlen(dir);
1012 strncpy(trndir,dir,dirlen);
1013 trndir[dirlen] = '\0';
1016 /* If we were handed a rooted logical name or spec, treat it like a
1017 * simple directory, so that
1018 * $ Define myroot dev:[dir.]
1019 * ... do_fileify_dirspec("myroot",buf,1) ...
1020 * does something useful.
1022 if (!strcmp(dir+dirlen-2,".]")) {
1023 dir[--dirlen] = '\0';
1024 dir[dirlen-1] = ']';
1027 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1028 /* If we've got an explicit filename, we can just shuffle the string. */
1029 if (*(cp1+1)) hasfilename = 1;
1030 /* Similarly, we can just back up a level if we've got multiple levels
1031 of explicit directories in a VMS spec which ends with directories. */
1033 for (cp2 = cp1; cp2 > dir; cp2--) {
1035 *cp2 = *cp1; *cp1 = '\0';
1039 if (*cp2 == '[' || *cp2 == '<') break;
1044 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1045 if (dir[0] == '.') {
1046 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1047 return do_fileify_dirspec("[]",buf,ts);
1048 else if (dir[1] == '.' &&
1049 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1050 return do_fileify_dirspec("[-]",buf,ts);
1052 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1053 dirlen -= 1; /* to last element */
1054 lastdir = strrchr(dir,'/');
1056 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1057 /* If we have "/." or "/..", VMSify it and let the VMS code
1058 * below expand it, rather than repeating the code to handle
1059 * relative components of a filespec here */
1061 if (*(cp1+2) == '.') cp1++;
1062 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1063 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1064 if (strchr(vmsdir,'/') != NULL) {
1065 /* If do_tovmsspec() returned it, it must have VMS syntax
1066 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1067 * the time to check this here only so we avoid a recursion
1068 * loop; otherwise, gigo.
1070 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1072 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1073 return do_tounixspec(trndir,buf,ts);
1076 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1077 lastdir = strrchr(dir,'/');
1079 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1080 /* Ditto for specs that end in an MFD -- let the VMS code
1081 * figure out whether it's a real device or a rooted logical. */
1082 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1083 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1084 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1085 return do_tounixspec(trndir,buf,ts);
1088 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1089 !(lastdir = cp1 = strrchr(dir,']')) &&
1090 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1091 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1093 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1094 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1095 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1096 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1097 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1098 (ver || *cp3)))))) {
1100 set_vaxc_errno(RMS$_DIR);
1106 /* If we lead off with a device or rooted logical, add the MFD
1107 if we're specifying a top-level directory. */
1108 if (lastdir && *dir == '/') {
1110 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1117 retlen = dirlen + (addmfd ? 13 : 6);
1118 if (buf) retspec = buf;
1119 else if (ts) New(1309,retspec,retlen+1,char);
1120 else retspec = __fileify_retbuf;
1122 dirlen = lastdir - dir;
1123 memcpy(retspec,dir,dirlen);
1124 strcpy(&retspec[dirlen],"/000000");
1125 strcpy(&retspec[dirlen+7],lastdir);
1128 memcpy(retspec,dir,dirlen);
1129 retspec[dirlen] = '\0';
1131 /* We've picked up everything up to the directory file name.
1132 Now just add the type and version, and we're set. */
1133 strcat(retspec,".dir;1");
1136 else { /* VMS-style directory spec */
1137 char esa[NAM$C_MAXRSS+1], term, *cp;
1138 unsigned long int sts, cmplen, haslower = 0;
1139 struct FAB dirfab = cc$rms_fab;
1140 struct NAM savnam, dirnam = cc$rms_nam;
1142 dirfab.fab$b_fns = strlen(dir);
1143 dirfab.fab$l_fna = dir;
1144 dirfab.fab$l_nam = &dirnam;
1145 dirfab.fab$l_dna = ".DIR;1";
1146 dirfab.fab$b_dns = 6;
1147 dirnam.nam$b_ess = NAM$C_MAXRSS;
1148 dirnam.nam$l_esa = esa;
1150 for (cp = dir; *cp; cp++)
1151 if (islower(*cp)) { haslower = 1; break; }
1152 if (!((sts = sys$parse(&dirfab))&1)) {
1153 if (dirfab.fab$l_sts == RMS$_DIR) {
1154 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1155 sts = sys$parse(&dirfab) & 1;
1159 set_vaxc_errno(dirfab.fab$l_sts);
1165 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1166 /* Yes; fake the fnb bits so we'll check type below */
1167 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1170 if (dirfab.fab$l_sts != RMS$_FNF) {
1172 set_vaxc_errno(dirfab.fab$l_sts);
1175 dirnam = savnam; /* No; just work with potential name */
1178 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1179 cp1 = strchr(esa,']');
1180 if (!cp1) cp1 = strchr(esa,'>');
1181 if (cp1) { /* Should always be true */
1182 dirnam.nam$b_esl -= cp1 - esa - 1;
1183 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1186 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1187 /* Yep; check version while we're at it, if it's there. */
1188 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1189 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1190 /* Something other than .DIR[;1]. Bzzt. */
1192 set_vaxc_errno(RMS$_DIR);
1196 esa[dirnam.nam$b_esl] = '\0';
1197 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1198 /* They provided at least the name; we added the type, if necessary, */
1199 if (buf) retspec = buf; /* in sys$parse() */
1200 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1201 else retspec = __fileify_retbuf;
1202 strcpy(retspec,esa);
1205 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1206 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1208 dirnam.nam$b_esl -= 9;
1210 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1211 if (cp1 == NULL) return NULL; /* should never happen */
1214 retlen = strlen(esa);
1215 if ((cp1 = strrchr(esa,'.')) != NULL) {
1216 /* There's more than one directory in the path. Just roll back. */
1218 if (buf) retspec = buf;
1219 else if (ts) New(1311,retspec,retlen+7,char);
1220 else retspec = __fileify_retbuf;
1221 strcpy(retspec,esa);
1224 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1225 /* Go back and expand rooted logical name */
1226 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1227 if (!(sys$parse(&dirfab) & 1)) {
1229 set_vaxc_errno(dirfab.fab$l_sts);
1232 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1233 if (buf) retspec = buf;
1234 else if (ts) New(1312,retspec,retlen+16,char);
1235 else retspec = __fileify_retbuf;
1236 cp1 = strstr(esa,"][");
1238 memcpy(retspec,esa,dirlen);
1239 if (!strncmp(cp1+2,"000000]",7)) {
1240 retspec[dirlen-1] = '\0';
1241 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1242 if (*cp1 == '.') *cp1 = ']';
1244 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1245 memcpy(cp1+1,"000000]",7);
1249 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1250 retspec[retlen] = '\0';
1251 /* Convert last '.' to ']' */
1252 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1253 if (*cp1 == '.') *cp1 = ']';
1255 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1256 memcpy(cp1+1,"000000]",7);
1260 else { /* This is a top-level dir. Add the MFD to the path. */
1261 if (buf) retspec = buf;
1262 else if (ts) New(1312,retspec,retlen+16,char);
1263 else retspec = __fileify_retbuf;
1266 while (*cp1 != ':') *(cp2++) = *(cp1++);
1267 strcpy(cp2,":[000000]");
1272 /* We've set up the string up through the filename. Add the
1273 type and version, and we're done. */
1274 strcat(retspec,".DIR;1");
1276 /* $PARSE may have upcased filespec, so convert output to lower
1277 * case if input contained any lowercase characters. */
1278 if (haslower) __mystrtolower(retspec);
1281 } /* end of do_fileify_dirspec() */
1283 /* External entry points */
1284 char *fileify_dirspec(char *dir, char *buf)
1285 { return do_fileify_dirspec(dir,buf,0); }
1286 char *fileify_dirspec_ts(char *dir, char *buf)
1287 { return do_fileify_dirspec(dir,buf,1); }
1289 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1290 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1292 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1293 unsigned long int retlen;
1294 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1296 if (!dir || !*dir) {
1297 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1300 if (*dir) strcpy(trndir,dir);
1301 else getcwd(trndir,sizeof trndir - 1);
1303 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1304 STRLEN trnlen = strlen(trndir);
1306 /* Trap simple rooted lnms, and return lnm:[000000] */
1307 if (!strcmp(trndir+trnlen-2,".]")) {
1308 if (buf) retpath = buf;
1309 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1310 else retpath = __pathify_retbuf;
1311 strcpy(retpath,dir);
1312 strcat(retpath,":[000000]");
1318 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1319 if (*dir == '.' && (*(dir+1) == '\0' ||
1320 (*(dir+1) == '.' && *(dir+2) == '\0')))
1321 retlen = 2 + (*(dir+1) != '\0');
1323 if ( !(cp1 = strrchr(dir,'/')) &&
1324 !(cp1 = strrchr(dir,']')) &&
1325 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1326 if ((cp2 = strchr(cp1,'.')) != NULL &&
1327 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1328 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1329 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1330 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1332 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1333 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1334 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1335 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1336 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1337 (ver || *cp3)))))) {
1339 set_vaxc_errno(RMS$_DIR);
1342 retlen = cp2 - dir + 1;
1344 else { /* No file type present. Treat the filename as a directory. */
1345 retlen = strlen(dir) + 1;
1348 if (buf) retpath = buf;
1349 else if (ts) New(1313,retpath,retlen+1,char);
1350 else retpath = __pathify_retbuf;
1351 strncpy(retpath,dir,retlen-1);
1352 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1353 retpath[retlen-1] = '/'; /* with '/', add it. */
1354 retpath[retlen] = '\0';
1356 else retpath[retlen-1] = '\0';
1358 else { /* VMS-style directory spec */
1359 char esa[NAM$C_MAXRSS+1], *cp;
1360 unsigned long int sts, cmplen, haslower;
1361 struct FAB dirfab = cc$rms_fab;
1362 struct NAM savnam, dirnam = cc$rms_nam;
1364 /* If we've got an explicit filename, we can just shuffle the string. */
1365 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1366 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1367 if ((cp2 = strchr(cp1,'.')) != NULL) {
1369 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1370 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1371 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1372 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1373 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1374 (ver || *cp3)))))) {
1376 set_vaxc_errno(RMS$_DIR);
1380 else { /* No file type, so just draw name into directory part */
1381 for (cp2 = cp1; *cp2; cp2++) ;
1384 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1386 /* We've now got a VMS 'path'; fall through */
1388 dirfab.fab$b_fns = strlen(dir);
1389 dirfab.fab$l_fna = dir;
1390 if (dir[dirfab.fab$b_fns-1] == ']' ||
1391 dir[dirfab.fab$b_fns-1] == '>' ||
1392 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1393 if (buf) retpath = buf;
1394 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1395 else retpath = __pathify_retbuf;
1396 strcpy(retpath,dir);
1399 dirfab.fab$l_dna = ".DIR;1";
1400 dirfab.fab$b_dns = 6;
1401 dirfab.fab$l_nam = &dirnam;
1402 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1403 dirnam.nam$l_esa = esa;
1405 for (cp = dir; *cp; cp++)
1406 if (islower(*cp)) { haslower = 1; break; }
1408 if (!(sts = (sys$parse(&dirfab)&1))) {
1409 if (dirfab.fab$l_sts == RMS$_DIR) {
1410 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1411 sts = sys$parse(&dirfab) & 1;
1415 set_vaxc_errno(dirfab.fab$l_sts);
1421 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1422 if (dirfab.fab$l_sts != RMS$_FNF) {
1424 set_vaxc_errno(dirfab.fab$l_sts);
1427 dirnam = savnam; /* No; just work with potential name */
1430 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1431 /* Yep; check version while we're at it, if it's there. */
1432 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1433 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1434 /* Something other than .DIR[;1]. Bzzt. */
1436 set_vaxc_errno(RMS$_DIR);
1440 /* OK, the type was fine. Now pull any file name into the
1442 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1444 cp1 = strrchr(esa,'>');
1445 *dirnam.nam$l_type = '>';
1448 *(dirnam.nam$l_type + 1) = '\0';
1449 retlen = dirnam.nam$l_type - esa + 2;
1450 if (buf) retpath = buf;
1451 else if (ts) New(1314,retpath,retlen,char);
1452 else retpath = __pathify_retbuf;
1453 strcpy(retpath,esa);
1454 /* $PARSE may have upcased filespec, so convert output to lower
1455 * case if input contained any lowercase characters. */
1456 if (haslower) __mystrtolower(retpath);
1460 } /* end of do_pathify_dirspec() */
1462 /* External entry points */
1463 char *pathify_dirspec(char *dir, char *buf)
1464 { return do_pathify_dirspec(dir,buf,0); }
1465 char *pathify_dirspec_ts(char *dir, char *buf)
1466 { return do_pathify_dirspec(dir,buf,1); }
1468 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1469 static char *do_tounixspec(char *spec, char *buf, int ts)
1471 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1472 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1473 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1475 if (spec == NULL) return NULL;
1476 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1477 if (buf) rslt = buf;
1479 retlen = strlen(spec);
1480 cp1 = strchr(spec,'[');
1481 if (!cp1) cp1 = strchr(spec,'<');
1483 for (cp1++; *cp1; cp1++) {
1484 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1485 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1486 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1489 New(1315,rslt,retlen+2+2*expand,char);
1491 else rslt = __tounixspec_retbuf;
1492 if (strchr(spec,'/') != NULL) {
1499 dirend = strrchr(spec,']');
1500 if (dirend == NULL) dirend = strrchr(spec,'>');
1501 if (dirend == NULL) dirend = strchr(spec,':');
1502 if (dirend == NULL) {
1506 if (*cp2 != '[' && *cp2 != '<') {
1509 else { /* the VMS spec begins with directories */
1511 if (*cp2 == ']' || *cp2 == '>') {
1512 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1515 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1516 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1517 if (ts) Safefree(rslt);
1522 while (*cp3 != ':' && *cp3) cp3++;
1524 if (strchr(cp3,']') != NULL) break;
1525 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1527 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1528 retlen = devlen + dirlen;
1529 Renew(rslt,retlen+1+2*expand,char);
1535 *(cp1++) = *(cp3++);
1536 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1540 else if ( *cp2 == '.') {
1541 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1542 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1548 for (; cp2 <= dirend; cp2++) {
1551 if (*(cp2+1) == '[') cp2++;
1553 else if (*cp2 == ']' || *cp2 == '>') {
1554 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1556 else if (*cp2 == '.') {
1558 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1559 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1560 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1561 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1562 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1564 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1565 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1569 else if (*cp2 == '-') {
1570 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1571 while (*cp2 == '-') {
1573 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1575 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1576 if (ts) Safefree(rslt); /* filespecs like */
1577 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1581 else *(cp1++) = *cp2;
1583 else *(cp1++) = *cp2;
1585 while (*cp2) *(cp1++) = *(cp2++);
1590 } /* end of do_tounixspec() */
1592 /* External entry points */
1593 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1594 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1596 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1597 static char *do_tovmsspec(char *path, char *buf, int ts) {
1598 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1599 char *rslt, *dirend;
1600 register char *cp1, *cp2;
1601 unsigned long int infront = 0, hasdir = 1;
1603 if (path == NULL) return NULL;
1604 if (buf) rslt = buf;
1605 else if (ts) New(1316,rslt,strlen(path)+9,char);
1606 else rslt = __tovmsspec_retbuf;
1607 if (strpbrk(path,"]:>") ||
1608 (dirend = strrchr(path,'/')) == NULL) {
1609 if (path[0] == '.') {
1610 if (path[1] == '\0') strcpy(rslt,"[]");
1611 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1612 else strcpy(rslt,path); /* probably garbage */
1614 else strcpy(rslt,path);
1617 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1618 if (!*(dirend+2)) dirend +=2;
1619 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1620 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1625 char trndev[NAM$C_MAXRSS+1];
1629 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1631 if (!buf & ts) Renew(rslt,18,char);
1632 strcpy(rslt,"sys$disk:[000000]");
1635 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1637 islnm = my_trnlnm(rslt,trndev,0);
1638 trnend = islnm ? strlen(trndev) - 1 : 0;
1639 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1640 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1641 /* If the first element of the path is a logical name, determine
1642 * whether it has to be translated so we can add more directories. */
1643 if (!islnm || rooted) {
1646 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1650 if (cp2 != dirend) {
1651 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1652 strcpy(rslt,trndev);
1653 cp1 = rslt + trnend;
1666 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1667 cp2 += 2; /* skip over "./" - it's redundant */
1668 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1670 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1671 *(cp1++) = '-'; /* "../" --> "-" */
1674 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1675 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1676 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1677 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1680 if (cp2 > dirend) cp2 = dirend;
1682 else *(cp1++) = '.';
1684 for (; cp2 < dirend; cp2++) {
1686 if (*(cp2-1) == '/') continue;
1687 if (*(cp1-1) != '.') *(cp1++) = '.';
1690 else if (!infront && *cp2 == '.') {
1691 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1692 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1693 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1694 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1695 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1696 else { /* back up over previous directory name */
1698 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1699 if (*(cp1-1) == '[') {
1700 memcpy(cp1,"000000.",7);
1705 if (cp2 == dirend) break;
1707 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1708 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1709 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1710 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1712 *(cp1++) = '.'; /* Simulate trailing '/' */
1713 cp2 += 2; /* for loop will incr this to == dirend */
1715 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1717 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1720 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1721 if (*cp2 == '.') *(cp1++) = '_';
1722 else *(cp1++) = *cp2;
1726 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1727 if (hasdir) *(cp1++) = ']';
1728 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1729 while (*cp2) *(cp1++) = *(cp2++);
1734 } /* end of do_tovmsspec() */
1736 /* External entry points */
1737 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1738 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1740 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1741 static char *do_tovmspath(char *path, char *buf, int ts) {
1742 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1744 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1746 if (path == NULL) return NULL;
1747 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1748 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1749 if (buf) return buf;
1751 vmslen = strlen(vmsified);
1752 New(1317,cp,vmslen+1,char);
1753 memcpy(cp,vmsified,vmslen);
1758 strcpy(__tovmspath_retbuf,vmsified);
1759 return __tovmspath_retbuf;
1762 } /* end of do_tovmspath() */
1764 /* External entry points */
1765 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1766 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1769 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1770 static char *do_tounixpath(char *path, char *buf, int ts) {
1771 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1773 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1775 if (path == NULL) return NULL;
1776 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1777 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1778 if (buf) return buf;
1780 unixlen = strlen(unixified);
1781 New(1317,cp,unixlen+1,char);
1782 memcpy(cp,unixified,unixlen);
1787 strcpy(__tounixpath_retbuf,unixified);
1788 return __tounixpath_retbuf;
1791 } /* end of do_tounixpath() */
1793 /* External entry points */
1794 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1795 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1798 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1800 *****************************************************************************
1802 * Copyright (C) 1989-1994 by *
1803 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1805 * Permission is hereby granted for the reproduction of this software, *
1806 * on condition that this copyright notice is included in the reproduction, *
1807 * and that such reproduction is not for purposes of profit or material *
1810 * 27-Aug-1994 Modified for inclusion in perl5 *
1811 * by Charles Bailey bailey@genetics.upenn.edu *
1812 *****************************************************************************
1816 * getredirection() is intended to aid in porting C programs
1817 * to VMS (Vax-11 C). The native VMS environment does not support
1818 * '>' and '<' I/O redirection, or command line wild card expansion,
1819 * or a command line pipe mechanism using the '|' AND background
1820 * command execution '&'. All of these capabilities are provided to any
1821 * C program which calls this procedure as the first thing in the
1823 * The piping mechanism will probably work with almost any 'filter' type
1824 * of program. With suitable modification, it may useful for other
1825 * portability problems as well.
1827 * Author: Mark Pizzolato mark@infocomm.com
1831 struct list_item *next;
1835 static void add_item(struct list_item **head,
1836 struct list_item **tail,
1840 static void expand_wild_cards(char *item,
1841 struct list_item **head,
1842 struct list_item **tail,
1845 static int background_process(int argc, char **argv);
1847 static void pipe_and_fork(char **cmargv);
1849 /*{{{ void getredirection(int *ac, char ***av)*/
1851 getredirection(int *ac, char ***av)
1853 * Process vms redirection arg's. Exit if any error is seen.
1854 * If getredirection() processes an argument, it is erased
1855 * from the vector. getredirection() returns a new argc and argv value.
1856 * In the event that a background command is requested (by a trailing "&"),
1857 * this routine creates a background subprocess, and simply exits the program.
1859 * Warning: do not try to simplify the code for vms. The code
1860 * presupposes that getredirection() is called before any data is
1861 * read from stdin or written to stdout.
1863 * Normal usage is as follows:
1869 * getredirection(&argc, &argv);
1873 int argc = *ac; /* Argument Count */
1874 char **argv = *av; /* Argument Vector */
1875 char *ap; /* Argument pointer */
1876 int j; /* argv[] index */
1877 int item_count = 0; /* Count of Items in List */
1878 struct list_item *list_head = 0; /* First Item in List */
1879 struct list_item *list_tail; /* Last Item in List */
1880 char *in = NULL; /* Input File Name */
1881 char *out = NULL; /* Output File Name */
1882 char *outmode = "w"; /* Mode to Open Output File */
1883 char *err = NULL; /* Error File Name */
1884 char *errmode = "w"; /* Mode to Open Error File */
1885 int cmargc = 0; /* Piped Command Arg Count */
1886 char **cmargv = NULL;/* Piped Command Arg Vector */
1889 * First handle the case where the last thing on the line ends with
1890 * a '&'. This indicates the desire for the command to be run in a
1891 * subprocess, so we satisfy that desire.
1894 if (0 == strcmp("&", ap))
1895 exit(background_process(--argc, argv));
1896 if (*ap && '&' == ap[strlen(ap)-1])
1898 ap[strlen(ap)-1] = '\0';
1899 exit(background_process(argc, argv));
1902 * Now we handle the general redirection cases that involve '>', '>>',
1903 * '<', and pipes '|'.
1905 for (j = 0; j < argc; ++j)
1907 if (0 == strcmp("<", argv[j]))
1911 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1912 exit(LIB$_WRONUMARG);
1917 if ('<' == *(ap = argv[j]))
1922 if (0 == strcmp(">", ap))
1926 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1927 exit(LIB$_WRONUMARG);
1946 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1947 exit(LIB$_WRONUMARG);
1951 if (('2' == *ap) && ('>' == ap[1]))
1968 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1969 exit(LIB$_WRONUMARG);
1973 if (0 == strcmp("|", argv[j]))
1977 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1978 exit(LIB$_WRONUMARG);
1980 cmargc = argc-(j+1);
1981 cmargv = &argv[j+1];
1985 if ('|' == *(ap = argv[j]))
1993 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1996 * Allocate and fill in the new argument vector, Some Unix's terminate
1997 * the list with an extra null pointer.
1999 New(1302, argv, item_count+1, char *);
2001 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2002 argv[j] = list_head->value;
2008 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2009 exit(LIB$_INVARGORD);
2011 pipe_and_fork(cmargv);
2014 /* Check for input from a pipe (mailbox) */
2016 if (in == NULL && 1 == isapipe(0))
2018 char mbxname[L_tmpnam];
2020 long int dvi_item = DVI$_DEVBUFSIZ;
2021 $DESCRIPTOR(mbxnam, "");
2022 $DESCRIPTOR(mbxdevnam, "");
2024 /* Input from a pipe, reopen it in binary mode to disable */
2025 /* carriage control processing. */
2027 PerlIO_getname(stdin, mbxname);
2028 mbxnam.dsc$a_pointer = mbxname;
2029 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2030 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2031 mbxdevnam.dsc$a_pointer = mbxname;
2032 mbxdevnam.dsc$w_length = sizeof(mbxname);
2033 dvi_item = DVI$_DEVNAM;
2034 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2035 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2038 freopen(mbxname, "rb", stdin);
2041 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2045 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2047 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2050 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2052 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2057 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2059 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2063 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2068 #ifdef ARGPROC_DEBUG
2069 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2070 for (j = 0; j < *ac; ++j)
2071 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2073 /* Clear errors we may have hit expanding wildcards, so they don't
2074 show up in Perl's $! later */
2075 set_errno(0); set_vaxc_errno(1);
2076 } /* end of getredirection() */
2079 static void add_item(struct list_item **head,
2080 struct list_item **tail,
2086 New(1303,*head,1,struct list_item);
2090 New(1304,(*tail)->next,1,struct list_item);
2091 *tail = (*tail)->next;
2093 (*tail)->value = value;
2097 static void expand_wild_cards(char *item,
2098 struct list_item **head,
2099 struct list_item **tail,
2103 unsigned long int context = 0;
2109 char vmsspec[NAM$C_MAXRSS+1];
2110 $DESCRIPTOR(filespec, "");
2111 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2112 $DESCRIPTOR(resultspec, "");
2113 unsigned long int zero = 0, sts;
2115 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2117 add_item(head, tail, item, count);
2120 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2121 resultspec.dsc$b_class = DSC$K_CLASS_D;
2122 resultspec.dsc$a_pointer = NULL;
2123 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2124 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2125 if (!isunix || !filespec.dsc$a_pointer)
2126 filespec.dsc$a_pointer = item;
2127 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2129 * Only return version specs, if the caller specified a version
2131 had_version = strchr(item, ';');
2133 * Only return device and directory specs, if the caller specifed either.
2135 had_device = strchr(item, ':');
2136 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2138 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2139 &defaultspec, 0, 0, &zero))))
2144 New(1305,string,resultspec.dsc$w_length+1,char);
2145 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2146 string[resultspec.dsc$w_length] = '\0';
2147 if (NULL == had_version)
2148 *((char *)strrchr(string, ';')) = '\0';
2149 if ((!had_directory) && (had_device == NULL))
2151 if (NULL == (devdir = strrchr(string, ']')))
2152 devdir = strrchr(string, '>');
2153 strcpy(string, devdir + 1);
2156 * Be consistent with what the C RTL has already done to the rest of
2157 * the argv items and lowercase all of these names.
2159 for (c = string; *c; ++c)
2162 if (isunix) trim_unixpath(string,item,1);
2163 add_item(head, tail, string, count);
2166 if (sts != RMS$_NMF)
2168 set_vaxc_errno(sts);
2174 set_errno(ENOENT); break;
2176 set_errno(ENODEV); break;
2179 set_errno(EINVAL); break;
2181 set_errno(EACCES); break;
2183 _ckvmssts_noperl(sts);
2187 add_item(head, tail, item, count);
2188 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2189 _ckvmssts_noperl(lib$find_file_end(&context));
2192 static int child_st[2];/* Event Flag set when child process completes */
2194 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2196 static unsigned long int exit_handler(int *status)
2200 if (0 == child_st[0])
2202 #ifdef ARGPROC_DEBUG
2203 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2205 fflush(stdout); /* Have to flush pipe for binary data to */
2206 /* terminate properly -- <tp@mccall.com> */
2207 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2208 sys$dassgn(child_chan);
2210 sys$synch(0, child_st);
2215 static void sig_child(int chan)
2217 #ifdef ARGPROC_DEBUG
2218 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2220 if (child_st[0] == 0)
2224 static struct exit_control_block exit_block =
2229 &exit_block.exit_status,
2233 static void pipe_and_fork(char **cmargv)
2236 $DESCRIPTOR(cmddsc, "");
2237 static char mbxname[64];
2238 $DESCRIPTOR(mbxdsc, mbxname);
2240 unsigned long int zero = 0, one = 1;
2242 strcpy(subcmd, cmargv[0]);
2243 for (j = 1; NULL != cmargv[j]; ++j)
2245 strcat(subcmd, " \"");
2246 strcat(subcmd, cmargv[j]);
2247 strcat(subcmd, "\"");
2249 cmddsc.dsc$a_pointer = subcmd;
2250 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2252 create_mbx(&child_chan,&mbxdsc);
2253 #ifdef ARGPROC_DEBUG
2254 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2255 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2257 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2258 0, &pid, child_st, &zero, sig_child,
2260 #ifdef ARGPROC_DEBUG
2261 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2263 sys$dclexh(&exit_block);
2264 if (NULL == freopen(mbxname, "wb", stdout))
2266 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2270 static int background_process(int argc, char **argv)
2272 char command[2048] = "$";
2273 $DESCRIPTOR(value, "");
2274 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2275 static $DESCRIPTOR(null, "NLA0:");
2276 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2278 $DESCRIPTOR(pidstr, "");
2280 unsigned long int flags = 17, one = 1, retsts;
2282 strcat(command, argv[0]);
2285 strcat(command, " \"");
2286 strcat(command, *(++argv));
2287 strcat(command, "\"");
2289 value.dsc$a_pointer = command;
2290 value.dsc$w_length = strlen(value.dsc$a_pointer);
2291 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2292 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2293 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2294 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2297 _ckvmssts_noperl(retsts);
2299 #ifdef ARGPROC_DEBUG
2300 PerlIO_printf(Perl_debug_log, "%s\n", command);
2302 sprintf(pidstring, "%08X", pid);
2303 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2304 pidstr.dsc$a_pointer = pidstring;
2305 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2306 lib$set_symbol(&pidsymbol, &pidstr);
2310 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2313 /* OS-specific initialization at image activation (not thread startup) */
2314 /* Older VAXC header files lack these constants */
2315 #ifndef JPI$_RIGHTS_SIZE
2316 # define JPI$_RIGHTS_SIZE 817
2318 #ifndef KGB$M_SUBSYSTEM
2319 # define KGB$M_SUBSYSTEM 0x8
2322 /*{{{void vms_image_init(int *, char ***)*/
2324 vms_image_init(int *argcp, char ***argvp)
2326 unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
2327 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2328 unsigned short int dummy, rlen;
2329 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2330 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2331 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2334 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2336 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2337 if (iprv[i]) { /* Running image installed with privs? */
2338 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2343 /* Rights identifiers might trigger tainting as well. */
2344 if (!add_taint && (rlen || rsz)) {
2345 while (rlen < rsz) {
2346 /* We didn't get all the identifiers on the first pass. Allocate a
2347 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2348 * were needed to hold all identifiers at time of last call; we'll
2349 * allocate that many unsigned long ints), and go back and get 'em.
2351 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2352 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2353 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2354 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2357 mask = jpilist[1].bufadr;
2358 /* Check attribute flags for each identifier (2nd longword); protected
2359 * subsystem identifiers trigger tainting.
2361 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2362 if (mask[i] & KGB$M_SUBSYSTEM) {
2367 if (mask != rlst) Safefree(mask);
2369 /* We need to use this hack to tell Perl it should run with tainting,
2370 * since its tainting flag may be part of the curinterp struct, which
2371 * hasn't been allocated when vms_image_init() is called.
2375 New(1320,newap,*argcp+2,char **);
2376 newap[0] = argvp[0];
2378 Copy(argvp[1],newap[2],*argcp-1,char **);
2379 /* We orphan the old argv, since we don't know where it's come from,
2380 * so we don't know how to free it.
2382 *argcp++; argvp = newap;
2384 getredirection(argcp,argvp);
2385 #if defined(USE_THREADS) && defined(__DECC)
2387 # include <reentrancy.h>
2388 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2397 * Trim Unix-style prefix off filespec, so it looks like what a shell
2398 * glob expansion would return (i.e. from specified prefix on, not
2399 * full path). Note that returned filespec is Unix-style, regardless
2400 * of whether input filespec was VMS-style or Unix-style.
2402 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2403 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2404 * vector of options; at present, only bit 0 is used, and if set tells
2405 * trim unixpath to try the current default directory as a prefix when
2406 * presented with a possibly ambiguous ... wildcard.
2408 * Returns !=0 on success, with trimmed filespec replacing contents of
2409 * fspec, and 0 on failure, with contents of fpsec unchanged.
2411 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2413 trim_unixpath(char *fspec, char *wildspec, int opts)
2415 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2416 *template, *base, *end, *cp1, *cp2;
2417 register int tmplen, reslen = 0, dirs = 0;
2419 if (!wildspec || !fspec) return 0;
2420 if (strpbrk(wildspec,"]>:") != NULL) {
2421 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2422 else template = unixwild;
2424 else template = wildspec;
2425 if (strpbrk(fspec,"]>:") != NULL) {
2426 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2427 else base = unixified;
2428 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2429 * check to see that final result fits into (isn't longer than) fspec */
2430 reslen = strlen(fspec);
2434 /* No prefix or absolute path on wildcard, so nothing to remove */
2435 if (!*template || *template == '/') {
2436 if (base == fspec) return 1;
2437 tmplen = strlen(unixified);
2438 if (tmplen > reslen) return 0; /* not enough space */
2439 /* Copy unixified resultant, including trailing NUL */
2440 memmove(fspec,unixified,tmplen+1);
2444 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2445 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2446 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2447 for (cp1 = end ;cp1 >= base; cp1--)
2448 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2450 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2454 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2455 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2456 int ells = 1, totells, segdirs, match;
2457 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2458 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2460 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2462 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2463 if (ellipsis == template && opts & 1) {
2464 /* Template begins with an ellipsis. Since we can't tell how many
2465 * directory names at the front of the resultant to keep for an
2466 * arbitrary starting point, we arbitrarily choose the current
2467 * default directory as a starting point. If it's there as a prefix,
2468 * clip it off. If not, fall through and act as if the leading
2469 * ellipsis weren't there (i.e. return shortest possible path that
2470 * could match template).
2472 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2473 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2474 if (_tolower(*cp1) != _tolower(*cp2)) break;
2475 segdirs = dirs - totells; /* Min # of dirs we must have left */
2476 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2477 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2478 memcpy(fspec,cp2+1,end - cp2);
2482 /* First off, back up over constant elements at end of path */
2484 for (front = end ; front >= base; front--)
2485 if (*front == '/' && !dirs--) { front++; break; }
2487 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2488 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2489 if (cp1 != '\0') return 0; /* Path too long. */
2491 *cp2 = '\0'; /* Pick up with memcpy later */
2492 lcfront = lcres + (front - base);
2493 /* Now skip over each ellipsis and try to match the path in front of it. */
2495 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2496 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2497 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2498 if (cp1 < template) break; /* template started with an ellipsis */
2499 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2500 ellipsis = cp1; continue;
2502 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2504 for (segdirs = 0, cp2 = tpl;
2505 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2507 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2508 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2509 if (*cp2 == '/') segdirs++;
2511 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2512 /* Back up at least as many dirs as in template before matching */
2513 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2514 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2515 for (match = 0; cp1 > lcres;) {
2516 resdsc.dsc$a_pointer = cp1;
2517 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2519 if (match == 1) lcfront = cp1;
2521 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2523 if (!match) return 0; /* Can't find prefix ??? */
2524 if (match > 1 && opts & 1) {
2525 /* This ... wildcard could cover more than one set of dirs (i.e.
2526 * a set of similar dir names is repeated). If the template
2527 * contains more than 1 ..., upstream elements could resolve the
2528 * ambiguity, but it's not worth a full backtracking setup here.
2529 * As a quick heuristic, clip off the current default directory
2530 * if it's present to find the trimmed spec, else use the
2531 * shortest string that this ... could cover.
2533 char def[NAM$C_MAXRSS+1], *st;
2535 if (getcwd(def, sizeof def,0) == NULL) return 0;
2536 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2537 if (_tolower(*cp1) != _tolower(*cp2)) break;
2538 segdirs = dirs - totells; /* Min # of dirs we must have left */
2539 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2540 if (*cp1 == '\0' && *cp2 == '/') {
2541 memcpy(fspec,cp2+1,end - cp2);
2544 /* Nope -- stick with lcfront from above and keep going. */
2547 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2552 } /* end of trim_unixpath() */
2557 * VMS readdir() routines.
2558 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2560 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2561 * Minor modifications to original routines.
2564 /* Number of elements in vms_versions array */
2565 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2568 * Open a directory, return a handle for later use.
2570 /*{{{ DIR *opendir(char*name) */
2575 char dir[NAM$C_MAXRSS+1];
2578 if (do_tovmspath(name,dir,0) == NULL) {
2581 if (flex_stat(dir,&sb) == -1) return NULL;
2582 if (!S_ISDIR(sb.st_mode)) {
2583 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2586 if (!cando_by_name(S_IRUSR,0,dir)) {
2587 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2590 /* Get memory for the handle, and the pattern. */
2592 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2594 /* Fill in the fields; mainly playing with the descriptor. */
2595 (void)sprintf(dd->pattern, "%s*.*",dir);
2598 dd->vms_wantversions = 0;
2599 dd->pat.dsc$a_pointer = dd->pattern;
2600 dd->pat.dsc$w_length = strlen(dd->pattern);
2601 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2602 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2605 } /* end of opendir() */
2609 * Set the flag to indicate we want versions or not.
2611 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2613 vmsreaddirversions(DIR *dd, int flag)
2615 dd->vms_wantversions = flag;
2620 * Free up an opened directory.
2622 /*{{{ void closedir(DIR *dd)*/
2626 (void)lib$find_file_end(&dd->context);
2627 Safefree(dd->pattern);
2628 Safefree((char *)dd);
2633 * Collect all the version numbers for the current file.
2639 struct dsc$descriptor_s pat;
2640 struct dsc$descriptor_s res;
2642 char *p, *text, buff[sizeof dd->entry.d_name];
2644 unsigned long context, tmpsts;
2646 /* Convenient shorthand. */
2649 /* Add the version wildcard, ignoring the "*.*" put on before */
2650 i = strlen(dd->pattern);
2651 New(1308,text,i + e->d_namlen + 3,char);
2652 (void)strcpy(text, dd->pattern);
2653 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2655 /* Set up the pattern descriptor. */
2656 pat.dsc$a_pointer = text;
2657 pat.dsc$w_length = i + e->d_namlen - 1;
2658 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2659 pat.dsc$b_class = DSC$K_CLASS_S;
2661 /* Set up result descriptor. */
2662 res.dsc$a_pointer = buff;
2663 res.dsc$w_length = sizeof buff - 2;
2664 res.dsc$b_dtype = DSC$K_DTYPE_T;
2665 res.dsc$b_class = DSC$K_CLASS_S;
2667 /* Read files, collecting versions. */
2668 for (context = 0, e->vms_verscount = 0;
2669 e->vms_verscount < VERSIZE(e);
2670 e->vms_verscount++) {
2671 tmpsts = lib$find_file(&pat, &res, &context);
2672 if (tmpsts == RMS$_NMF || context == 0) break;
2674 buff[sizeof buff - 1] = '\0';
2675 if ((p = strchr(buff, ';')))
2676 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2678 e->vms_versions[e->vms_verscount] = -1;
2681 _ckvmssts(lib$find_file_end(&context));
2684 } /* end of collectversions() */
2687 * Read the next entry from the directory.
2689 /*{{{ struct dirent *readdir(DIR *dd)*/
2693 struct dsc$descriptor_s res;
2694 char *p, buff[sizeof dd->entry.d_name];
2695 unsigned long int tmpsts;
2697 /* Set up result descriptor, and get next file. */
2698 res.dsc$a_pointer = buff;
2699 res.dsc$w_length = sizeof buff - 2;
2700 res.dsc$b_dtype = DSC$K_DTYPE_T;
2701 res.dsc$b_class = DSC$K_CLASS_S;
2702 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2703 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2704 if (!(tmpsts & 1)) {
2705 set_vaxc_errno(tmpsts);
2708 set_errno(EACCES); break;
2710 set_errno(ENODEV); break;
2713 set_errno(ENOENT); break;
2720 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2721 buff[sizeof buff - 1] = '\0';
2722 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2725 /* Skip any directory component and just copy the name. */
2726 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2727 else (void)strcpy(dd->entry.d_name, buff);
2729 /* Clobber the version. */
2730 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2732 dd->entry.d_namlen = strlen(dd->entry.d_name);
2733 dd->entry.vms_verscount = 0;
2734 if (dd->vms_wantversions) collectversions(dd);
2737 } /* end of readdir() */
2741 * Return something that can be used in a seekdir later.
2743 /*{{{ long telldir(DIR *dd)*/
2752 * Return to a spot where we used to be. Brute force.
2754 /*{{{ void seekdir(DIR *dd,long count)*/
2756 seekdir(DIR *dd, long count)
2758 int vms_wantversions;
2760 /* If we haven't done anything yet... */
2764 /* Remember some state, and clear it. */
2765 vms_wantversions = dd->vms_wantversions;
2766 dd->vms_wantversions = 0;
2767 _ckvmssts(lib$find_file_end(&dd->context));
2770 /* The increment is in readdir(). */
2771 for (dd->count = 0; dd->count < count; )
2774 dd->vms_wantversions = vms_wantversions;
2776 } /* end of seekdir() */
2779 /* VMS subprocess management
2781 * my_vfork() - just a vfork(), after setting a flag to record that
2782 * the current script is trying a Unix-style fork/exec.
2784 * vms_do_aexec() and vms_do_exec() are called in response to the
2785 * perl 'exec' function. If this follows a vfork call, then they
2786 * call out the the regular perl routines in doio.c which do an
2787 * execvp (for those who really want to try this under VMS).
2788 * Otherwise, they do exactly what the perl docs say exec should
2789 * do - terminate the current script and invoke a new command
2790 * (See below for notes on command syntax.)
2792 * do_aspawn() and do_spawn() implement the VMS side of the perl
2793 * 'system' function.
2795 * Note on command arguments to perl 'exec' and 'system': When handled
2796 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2797 * are concatenated to form a DCL command string. If the first arg
2798 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2799 * the the command string is hrnded off to DCL directly. Otherwise,
2800 * the first token of the command is taken as the filespec of an image
2801 * to run. The filespec is expanded using a default type of '.EXE' and
2802 * the process defaults for device, directory, etc., and the resultant
2803 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2804 * the command string as parameters. This is perhaps a bit compicated,
2805 * but I hope it will form a happy medium between what VMS folks expect
2806 * from lib$spawn and what Unix folks expect from exec.
2809 static int vfork_called;
2811 /*{{{int my_vfork()*/
2821 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2829 if (VMScmd.dsc$a_pointer) {
2830 Safefree(VMScmd.dsc$a_pointer);
2831 VMScmd.dsc$w_length = 0;
2832 VMScmd.dsc$a_pointer = Nullch;
2837 setup_argstr(SV *really, SV **mark, SV **sp)
2840 char *junk, *tmps = Nullch;
2841 register size_t cmdlen = 0;
2847 tmps = SvPV(really,rlen);
2854 for (idx++; idx <= sp; idx++) {
2856 junk = SvPVx(*idx,rlen);
2857 cmdlen += rlen ? rlen + 1 : 0;
2860 New(401,Cmd,cmdlen+1,char);
2862 if (tmps && *tmps) {
2867 while (++mark <= sp) {
2870 strcat(Cmd,SvPVx(*mark,na));
2875 } /* end of setup_argstr() */
2878 static unsigned long int
2879 setup_cmddsc(char *cmd, int check_img)
2881 char resspec[NAM$C_MAXRSS+1];
2882 $DESCRIPTOR(defdsc,".EXE");
2883 $DESCRIPTOR(resdsc,resspec);
2884 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2885 unsigned long int cxt = 0, flags = 1, retsts;
2886 register char *s, *rest, *cp;
2887 register int isdcl = 0;
2890 while (*s && isspace(*s)) s++;
2892 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2893 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2894 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2895 if (*cp == ':' || *cp == '[' || *cp == '<') {
2903 if (isdcl) { /* It's a DCL command, just do it. */
2904 VMScmd.dsc$w_length = strlen(cmd);
2906 VMScmd.dsc$a_pointer = Cmd;
2907 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2909 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2911 else { /* assume first token is an image spec */
2913 while (*s && !isspace(*s)) s++;
2915 imgdsc.dsc$a_pointer = cmd;
2916 imgdsc.dsc$w_length = s - cmd;
2917 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2918 if (!(retsts & 1)) {
2919 /* just hand off status values likely to be due to user error */
2920 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2921 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2922 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2923 else { _ckvmssts(retsts); }
2926 _ckvmssts(lib$find_file_end(&cxt));
2928 while (*s && !isspace(*s)) s++;
2930 if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
2931 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2932 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2933 strcat(VMScmd.dsc$a_pointer,resspec);
2934 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2935 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2939 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2941 } /* end of setup_cmddsc() */
2944 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2946 vms_do_aexec(SV *really,SV **mark,SV **sp)
2950 if (vfork_called) { /* this follows a vfork - act Unixish */
2952 if (vfork_called < 0) {
2953 warn("Internal inconsistency in tracking vforks");
2956 else return do_aexec(really,mark,sp);
2958 /* no vfork - act VMSish */
2959 return vms_do_exec(setup_argstr(really,mark,sp));
2964 } /* end of vms_do_aexec() */
2967 /* {{{bool vms_do_exec(char *cmd) */
2969 vms_do_exec(char *cmd)
2972 if (vfork_called) { /* this follows a vfork - act Unixish */
2974 if (vfork_called < 0) {
2975 warn("Internal inconsistency in tracking vforks");
2978 else return do_exec(cmd);
2981 { /* no vfork - act VMSish */
2982 unsigned long int retsts;
2985 TAINT_PROPER("exec");
2986 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2987 retsts = lib$do_command(&VMScmd);
2991 set_errno(ENOENT); break;
2992 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
2993 set_errno(ENOTDIR); break;
2995 set_errno(EACCES); break;
2997 set_errno(EINVAL); break;
2999 set_errno(E2BIG); break;
3000 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3001 _ckvmssts(retsts); /* fall through */
3002 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3005 set_vaxc_errno(retsts);
3007 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
3013 } /* end of vms_do_exec() */
3016 unsigned long int do_spawn(char *);
3018 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3020 do_aspawn(void *really,void **mark,void **sp)
3023 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3026 } /* end of do_aspawn() */
3029 /* {{{unsigned long int do_spawn(char *cmd) */
3033 unsigned long int sts, substs, hadcmd = 1;
3036 TAINT_PROPER("spawn");
3037 if (!cmd || !*cmd) {
3039 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3041 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3042 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3048 set_errno(ENOENT); break;
3049 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3050 set_errno(ENOTDIR); break;
3052 set_errno(EACCES); break;
3054 set_errno(EINVAL); break;
3056 set_errno(E2BIG); break;
3057 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3058 _ckvmssts(sts); /* fall through */
3059 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3062 set_vaxc_errno(sts);
3064 warn("Can't spawn \"%s\": %s",
3065 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
3070 } /* end of do_spawn() */
3074 * A simple fwrite replacement which outputs itmsz*nitm chars without
3075 * introducing record boundaries every itmsz chars.
3077 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3079 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3081 register char *cp, *end;
3083 end = (char *)src + itmsz * nitm;
3085 while ((char *)src <= end) {
3086 for (cp = src; cp <= end; cp++) if (!*cp) break;
3087 if (fputs(src,dest) == EOF) return EOF;
3089 if (fputc('\0',dest) == EOF) return EOF;
3095 } /* end of my_fwrite() */
3098 /*{{{ int my_flush(FILE *fp)*/
3103 if ((res = fflush(fp)) == 0) {
3104 #ifdef VMS_DO_SOCKETS
3106 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3108 res = fsync(fileno(fp));
3115 * Here are replacements for the following Unix routines in the VMS environment:
3116 * getpwuid Get information for a particular UIC or UID
3117 * getpwnam Get information for a named user
3118 * getpwent Get information for each user in the rights database
3119 * setpwent Reset search to the start of the rights database
3120 * endpwent Finish searching for users in the rights database
3122 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3123 * (defined in pwd.h), which contains the following fields:-
3125 * char *pw_name; Username (in lower case)
3126 * char *pw_passwd; Hashed password
3127 * unsigned int pw_uid; UIC
3128 * unsigned int pw_gid; UIC group number
3129 * char *pw_unixdir; Default device/directory (VMS-style)
3130 * char *pw_gecos; Owner name
3131 * char *pw_dir; Default device/directory (Unix-style)
3132 * char *pw_shell; Default CLI name (eg. DCL)
3134 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3136 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3137 * not the UIC member number (eg. what's returned by getuid()),
3138 * getpwuid() can accept either as input (if uid is specified, the caller's
3139 * UIC group is used), though it won't recognise gid=0.
3141 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3142 * information about other users in your group or in other groups, respectively.
3143 * If the required privilege is not available, then these routines fill only
3144 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3147 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3150 /* sizes of various UAF record fields */
3151 #define UAI$S_USERNAME 12
3152 #define UAI$S_IDENT 31
3153 #define UAI$S_OWNER 31
3154 #define UAI$S_DEFDEV 31
3155 #define UAI$S_DEFDIR 63
3156 #define UAI$S_DEFCLI 31
3159 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3160 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3161 (uic).uic$v_group != UIC$K_WILD_GROUP)
3163 static char __empty[]= "";
3164 static struct passwd __passwd_empty=
3165 {(char *) __empty, (char *) __empty, 0, 0,
3166 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3167 static int contxt= 0;
3168 static struct passwd __pwdcache;
3169 static char __pw_namecache[UAI$S_IDENT+1];
3172 * This routine does most of the work extracting the user information.
3174 static int fillpasswd (const char *name, struct passwd *pwd)
3177 unsigned char length;
3178 char pw_gecos[UAI$S_OWNER+1];
3180 static union uicdef uic;
3182 unsigned char length;
3183 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3186 unsigned char length;
3187 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3190 unsigned char length;
3191 char pw_shell[UAI$S_DEFCLI+1];
3193 static char pw_passwd[UAI$S_PWD+1];
3195 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3196 struct dsc$descriptor_s name_desc;
3197 unsigned long int sts;
3199 static struct itmlst_3 itmlst[]= {
3200 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3201 {sizeof(uic), UAI$_UIC, &uic, &luic},
3202 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3203 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3204 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3205 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3206 {0, 0, NULL, NULL}};
3208 name_desc.dsc$w_length= strlen(name);
3209 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3210 name_desc.dsc$b_class= DSC$K_CLASS_S;
3211 name_desc.dsc$a_pointer= (char *) name;
3213 /* Note that sys$getuai returns many fields as counted strings. */
3214 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3215 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3216 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3218 else { _ckvmssts(sts); }
3219 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3221 if ((int) owner.length < lowner) lowner= (int) owner.length;
3222 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3223 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3224 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3225 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3226 owner.pw_gecos[lowner]= '\0';
3227 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3228 defcli.pw_shell[ldefcli]= '\0';
3229 if (valid_uic(uic)) {
3230 pwd->pw_uid= uic.uic$l_uic;
3231 pwd->pw_gid= uic.uic$v_group;
3234 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3235 pwd->pw_passwd= pw_passwd;
3236 pwd->pw_gecos= owner.pw_gecos;
3237 pwd->pw_dir= defdev.pw_dir;
3238 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3239 pwd->pw_shell= defcli.pw_shell;
3240 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3242 ldir= strlen(pwd->pw_unixdir) - 1;
3243 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3246 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3247 __mystrtolower(pwd->pw_unixdir);
3252 * Get information for a named user.
3254 /*{{{struct passwd *getpwnam(char *name)*/
3255 struct passwd *my_getpwnam(char *name)
3257 struct dsc$descriptor_s name_desc;
3259 unsigned long int status, sts;
3261 __pwdcache = __passwd_empty;
3262 if (!fillpasswd(name, &__pwdcache)) {
3263 /* We still may be able to determine pw_uid and pw_gid */
3264 name_desc.dsc$w_length= strlen(name);
3265 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3266 name_desc.dsc$b_class= DSC$K_CLASS_S;
3267 name_desc.dsc$a_pointer= (char *) name;
3268 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3269 __pwdcache.pw_uid= uic.uic$l_uic;
3270 __pwdcache.pw_gid= uic.uic$v_group;
3273 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3274 set_vaxc_errno(sts);
3275 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3278 else { _ckvmssts(sts); }
3281 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3282 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3283 __pwdcache.pw_name= __pw_namecache;
3285 } /* end of my_getpwnam() */
3289 * Get information for a particular UIC or UID.
3290 * Called by my_getpwent with uid=-1 to list all users.
3292 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3293 struct passwd *my_getpwuid(Uid_t uid)
3295 const $DESCRIPTOR(name_desc,__pw_namecache);
3296 unsigned short lname;
3298 unsigned long int status;
3300 if (uid == (unsigned int) -1) {
3302 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3303 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3304 set_vaxc_errno(status);
3305 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3309 else { _ckvmssts(status); }
3310 } while (!valid_uic (uic));
3314 if (!uic.uic$v_group)
3315 uic.uic$v_group= getgid();
3317 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3318 else status = SS$_IVIDENT;
3319 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3320 status == RMS$_PRV) {
3321 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3324 else { _ckvmssts(status); }
3326 __pw_namecache[lname]= '\0';
3327 __mystrtolower(__pw_namecache);
3329 __pwdcache = __passwd_empty;
3330 __pwdcache.pw_name = __pw_namecache;
3332 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3333 The identifier's value is usually the UIC, but it doesn't have to be,
3334 so if we can, we let fillpasswd update this. */
3335 __pwdcache.pw_uid = uic.uic$l_uic;
3336 __pwdcache.pw_gid = uic.uic$v_group;
3338 fillpasswd(__pw_namecache, &__pwdcache);
3341 } /* end of my_getpwuid() */
3345 * Get information for next user.
3347 /*{{{struct passwd *my_getpwent()*/
3348 struct passwd *my_getpwent()
3350 return (my_getpwuid((unsigned int) -1));
3355 * Finish searching rights database for users.
3357 /*{{{void my_endpwent()*/
3361 _ckvmssts(sys$finish_rdb(&contxt));
3367 #ifdef HOMEGROWN_POSIX_SIGNALS
3368 /* Signal handling routines, pulled into the core from POSIX.xs.
3370 * We need these for threads, so they've been rolled into the core,
3371 * rather than left in POSIX.xs.
3373 * (DRS, Oct 23, 1997)
3376 /* sigset_t is atomic under VMS, so these routines are easy */
3377 /*{{{int my_sigemptyset(sigset_t *) */
3378 int my_sigemptyset(sigset_t *set) {
3379 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3385 /*{{{int my_sigfillset(sigset_t *)*/
3386 int my_sigfillset(sigset_t *set) {
3388 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3389 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3395 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3396 int my_sigaddset(sigset_t *set, int sig) {
3397 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3398 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3399 *set |= (1 << (sig - 1));
3405 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3406 int my_sigdelset(sigset_t *set, int sig) {
3407 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3408 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3409 *set &= ~(1 << (sig - 1));
3415 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3416 int my_sigismember(sigset_t *set, int sig) {
3417 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3418 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3419 *set & (1 << (sig - 1));
3424 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3425 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3428 /* If set and oset are both null, then things are badly wrong. Bail out. */
3429 if ((oset == NULL) && (set == NULL)) {
3430 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3434 /* If set's null, then we're just handling a fetch. */
3436 tempmask = sigblock(0);
3441 tempmask = sigsetmask(*set);
3444 tempmask = sigblock(*set);
3447 tempmask = sigblock(0);
3448 sigsetmask(*oset & ~tempmask);
3451 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3456 /* Did they pass us an oset? If so, stick our holding mask into it */
3463 #endif /* HOMEGROWN_POSIX_SIGNALS */
3466 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3467 * my_utime(), and flex_stat(), all of which operate on UTC unless
3468 * VMSISH_TIMES is true.
3470 /* method used to handle UTC conversions:
3471 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3473 static int gmtime_emulation_type;
3474 /* number of secs to add to UTC POSIX-style time to get local time */
3475 static long int utc_offset_secs;
3477 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3478 * in vmsish.h. #undef them here so we can call the CRTL routines
3485 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3486 # define RTL_USES_UTC 1
3489 static time_t toutc_dst(time_t loc) {
3492 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3493 loc -= utc_offset_secs;
3494 if (rsltmp->tm_isdst) loc -= 3600;
3497 #define _toutc(secs) ((secs) == -1 ? -1 : \
3498 ((gmtime_emulation_type || my_time(NULL)), \
3499 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3500 ((secs) - utc_offset_secs))))
3502 static time_t toloc_dst(time_t utc) {
3505 utc += utc_offset_secs;
3506 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3507 if (rsltmp->tm_isdst) utc += 3600;
3510 #define _toloc(secs) ((secs) == -1 ? -1 : \
3511 ((gmtime_emulation_type || my_time(NULL)), \
3512 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3513 ((secs) + utc_offset_secs))))
3516 /* my_time(), my_localtime(), my_gmtime()
3517 * By default traffic in UTC time values, using CRTL gmtime() or
3518 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3519 * Note: We need to use these functions even when the CRTL has working
3520 * UTC support, since they also handle C<use vmsish qw(times);>
3522 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3523 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3526 /*{{{time_t my_time(time_t *timep)*/
3527 time_t my_time(time_t *timep)
3533 if (gmtime_emulation_type == 0) {
3535 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3536 /* results of calls to gmtime() and localtime() */
3537 /* for same &base */
3539 gmtime_emulation_type++;
3540 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3543 gmtime_emulation_type++;
3544 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3545 gmtime_emulation_type++;
3546 warn("no UTC offset information; assuming local time is UTC");
3548 else { utc_offset_secs = atol(off); }
3550 else { /* We've got a working gmtime() */
3551 struct tm gmt, local;
3554 tm_p = localtime(&base);
3556 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3557 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3558 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3559 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3565 # ifdef RTL_USES_UTC
3566 if (VMSISH_TIME) when = _toloc(when);
3568 if (!VMSISH_TIME) when = _toutc(when);
3571 if (timep != NULL) *timep = when;
3574 } /* end of my_time() */
3578 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3580 my_gmtime(const time_t *timep)
3587 if (timep == NULL) {
3588 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3591 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3595 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
3597 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
3598 return gmtime(&when);
3600 /* CRTL localtime() wants local time as input, so does no tz correction */
3601 rsltmp = localtime(&when);
3602 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
3605 } /* end of my_gmtime() */
3609 /*{{{struct tm *my_localtime(const time_t *timep)*/
3611 my_localtime(const time_t *timep)
3617 if (timep == NULL) {
3618 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3621 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3622 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3625 # ifdef RTL_USES_UTC
3627 if (VMSISH_TIME) when = _toutc(when);
3629 /* CRTL localtime() wants UTC as input, does tz correction itself */
3630 return localtime(&when);
3633 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
3636 /* CRTL localtime() wants local time as input, so does no tz correction */
3637 rsltmp = localtime(&when);
3638 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
3641 } /* end of my_localtime() */
3644 /* Reset definitions for later calls */
3645 #define gmtime(t) my_gmtime(t)
3646 #define localtime(t) my_localtime(t)
3647 #define time(t) my_time(t)
3650 /* my_utime - update modification time of a file
3651 * calling sequence is identical to POSIX utime(), but under
3652 * VMS only the modification time is changed; ODS-2 does not
3653 * maintain access times. Restrictions differ from the POSIX
3654 * definition in that the time can be changed as long as the
3655 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3656 * no separate checks are made to insure that the caller is the
3657 * owner of the file or has special privs enabled.
3658 * Code here is based on Joe Meadows' FILE utility.
3661 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3662 * to VMS epoch (01-JAN-1858 00:00:00.00)
3663 * in 100 ns intervals.
3665 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3667 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3668 int my_utime(char *file, struct utimbuf *utimes)
3672 long int bintime[2], len = 2, lowbit, unixtime,
3673 secscale = 10000000; /* seconds --> 100 ns intervals */
3674 unsigned long int chan, iosb[2], retsts;
3675 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3676 struct FAB myfab = cc$rms_fab;
3677 struct NAM mynam = cc$rms_nam;
3678 #if defined (__DECC) && defined (__VAX)
3679 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3680 * at least through VMS V6.1, which causes a type-conversion warning.
3682 # pragma message save
3683 # pragma message disable cvtdiftypes
3685 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3686 struct fibdef myfib;
3687 #if defined (__DECC) && defined (__VAX)
3688 /* This should be right after the declaration of myatr, but due
3689 * to a bug in VAX DEC C, this takes effect a statement early.
3691 # pragma message restore
3693 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3694 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3695 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3697 if (file == NULL || *file == '\0') {
3699 set_vaxc_errno(LIB$_INVARG);
3702 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3704 if (utimes != NULL) {
3705 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3706 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3707 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3708 * as input, we force the sign bit to be clear by shifting unixtime right
3709 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3711 lowbit = (utimes->modtime & 1) ? secscale : 0;
3712 unixtime = (long int) utimes->modtime;
3714 /* If input was UTC; convert to local for sys svc */
3715 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
3717 unixtime >> 1; secscale << 1;
3718 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3719 if (!(retsts & 1)) {
3721 set_vaxc_errno(retsts);
3724 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3725 if (!(retsts & 1)) {
3727 set_vaxc_errno(retsts);
3732 /* Just get the current time in VMS format directly */
3733 retsts = sys$gettim(bintime);
3734 if (!(retsts & 1)) {
3736 set_vaxc_errno(retsts);
3741 myfab.fab$l_fna = vmsspec;
3742 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3743 myfab.fab$l_nam = &mynam;
3744 mynam.nam$l_esa = esa;
3745 mynam.nam$b_ess = (unsigned char) sizeof esa;
3746 mynam.nam$l_rsa = rsa;
3747 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3749 /* Look for the file to be affected, letting RMS parse the file
3750 * specification for us as well. I have set errno using only
3751 * values documented in the utime() man page for VMS POSIX.
3753 retsts = sys$parse(&myfab,0,0);
3754 if (!(retsts & 1)) {
3755 set_vaxc_errno(retsts);
3756 if (retsts == RMS$_PRV) set_errno(EACCES);
3757 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3758 else set_errno(EVMSERR);
3761 retsts = sys$search(&myfab,0,0);
3762 if (!(retsts & 1)) {
3763 set_vaxc_errno(retsts);
3764 if (retsts == RMS$_PRV) set_errno(EACCES);
3765 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3766 else set_errno(EVMSERR);
3770 devdsc.dsc$w_length = mynam.nam$b_dev;
3771 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3773 retsts = sys$assign(&devdsc,&chan,0,0);
3774 if (!(retsts & 1)) {
3775 set_vaxc_errno(retsts);
3776 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3777 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3778 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3779 else set_errno(EVMSERR);
3783 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3784 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3786 memset((void *) &myfib, 0, sizeof myfib);
3788 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3789 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3790 /* This prevents the revision time of the file being reset to the current
3791 * time as a result of our IO$_MODIFY $QIO. */
3792 myfib.fib$l_acctl = FIB$M_NORECORD;
3794 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3795 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3796 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3798 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3799 _ckvmssts(sys$dassgn(chan));
3800 if (retsts & 1) retsts = iosb[0];
3801 if (!(retsts & 1)) {
3802 set_vaxc_errno(retsts);
3803 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3804 else set_errno(EVMSERR);
3809 } /* end of my_utime() */
3813 * flex_stat, flex_fstat
3814 * basic stat, but gets it right when asked to stat
3815 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3818 /* encode_dev packs a VMS device name string into an integer to allow
3819 * simple comparisons. This can be used, for example, to check whether two
3820 * files are located on the same device, by comparing their encoded device
3821 * names. Even a string comparison would not do, because stat() reuses the
3822 * device name buffer for each call; so without encode_dev, it would be
3823 * necessary to save the buffer and use strcmp (this would mean a number of
3824 * changes to the standard Perl code, to say nothing of what a Perl script
3827 * The device lock id, if it exists, should be unique (unless perhaps compared
3828 * with lock ids transferred from other nodes). We have a lock id if the disk is
3829 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3830 * device names. Thus we use the lock id in preference, and only if that isn't
3831 * available, do we try to pack the device name into an integer (flagged by
3832 * the sign bit (LOCKID_MASK) being set).
3834 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3835 * name and its encoded form, but it seems very unlikely that we will find
3836 * two files on different disks that share the same encoded device names,
3837 * and even more remote that they will share the same file id (if the test
3838 * is to check for the same file).
3840 * A better method might be to use sys$device_scan on the first call, and to
3841 * search for the device, returning an index into the cached array.
3842 * The number returned would be more intelligable.
3843 * This is probably not worth it, and anyway would take quite a bit longer
3844 * on the first call.
3846 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3847 static mydev_t encode_dev (const char *dev)
3850 unsigned long int f;
3855 if (!dev || !dev[0]) return 0;
3859 struct dsc$descriptor_s dev_desc;
3860 unsigned long int status, lockid, item = DVI$_LOCKID;
3862 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3863 can try that first. */
3864 dev_desc.dsc$w_length = strlen (dev);
3865 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3866 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3867 dev_desc.dsc$a_pointer = (char *) dev;
3868 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3869 if (lockid) return (lockid & ~LOCKID_MASK);
3873 /* Otherwise we try to encode the device name */
3877 for (q = dev + strlen(dev); q--; q >= dev) {
3880 else if (isalpha (toupper (*q)))
3881 c= toupper (*q) - 'A' + (char)10;
3883 continue; /* Skip '$'s */
3885 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3887 enc += f * (unsigned long int) c;
3889 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3891 } /* end of encode_dev() */
3893 static char namecache[NAM$C_MAXRSS+1];
3896 is_null_device(name)
3899 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3900 The underscore prefix, controller letter, and unit number are
3901 independently optional; for our purposes, the colon punctuation
3902 is not. The colon can be trailed by optional directory and/or
3903 filename, but two consecutive colons indicates a nodename rather
3904 than a device. [pr] */
3905 if (*name == '_') ++name;
3906 if (tolower(*name++) != 'n') return 0;
3907 if (tolower(*name++) != 'l') return 0;
3908 if (tolower(*name) == 'a') ++name;
3909 if (*name == '0') ++name;
3910 return (*name++ == ':') && (*name != ':');
3913 /* Do the permissions allow some operation? Assumes statcache already set. */
3914 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3915 * subset of the applicable information.
3917 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3919 cando(I32 bit, I32 effective, Stat_t *statbufp)
3921 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3923 char fname[NAM$C_MAXRSS+1];
3924 unsigned long int retsts;
3925 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3926 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3928 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3929 device name on successive calls */
3930 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
3931 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
3932 namdsc.dsc$a_pointer = fname;
3933 namdsc.dsc$w_length = sizeof fname - 1;
3935 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
3936 &namdsc,&namdsc.dsc$w_length,0,0);
3938 fname[namdsc.dsc$w_length] = '\0';
3939 return cando_by_name(bit,effective,fname);
3941 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3942 warn("Can't get filespec - stale stat buffer?\n");
3946 return FALSE; /* Should never get to here */
3948 } /* end of cando() */
3952 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3954 cando_by_name(I32 bit, I32 effective, char *fname)
3956 static char usrname[L_cuserid];
3957 static struct dsc$descriptor_s usrdsc =
3958 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3959 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3960 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3961 unsigned short int retlen;
3962 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3963 union prvdef curprv;
3964 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3965 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3966 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3969 if (!fname || !*fname) return FALSE;
3970 /* Make sure we expand logical names, since sys$check_access doesn't */
3971 if (!strpbrk(fname,"/]>:")) {
3972 strcpy(fileified,fname);
3973 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3976 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3977 retlen = namdsc.dsc$w_length = strlen(vmsname);
3978 namdsc.dsc$a_pointer = vmsname;
3979 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3980 vmsname[retlen-1] == ':') {
3981 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3982 namdsc.dsc$w_length = strlen(fileified);
3983 namdsc.dsc$a_pointer = fileified;
3986 if (!usrdsc.dsc$w_length) {
3988 usrdsc.dsc$w_length = strlen(usrname);
3995 access = ARM$M_EXECUTE;
4000 access = ARM$M_READ;
4005 access = ARM$M_WRITE;
4010 access = ARM$M_DELETE;
4016 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4017 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4018 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4019 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4020 set_vaxc_errno(retsts);
4021 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4022 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4023 else set_errno(ENOENT);
4026 if (retsts == SS$_NORMAL) {
4027 if (!privused) return TRUE;
4028 /* We can get access, but only by using privs. Do we have the
4029 necessary privs currently enabled? */
4030 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4031 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4032 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4033 !curprv.prv$v_bypass) return FALSE;
4034 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4035 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4036 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4041 return FALSE; /* Should never get here */
4043 } /* end of cando_by_name() */
4047 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4049 flex_fstat(int fd, Stat_t *statbufp)
4052 if (!fstat(fd,(stat_t *) statbufp)) {
4053 if (statbufp == (Stat_t *) &statcache) *namecache == '\0';
4054 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4055 # ifdef RTL_USES_UTC
4058 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4059 statbufp->st_atime = _toloc(statbufp->st_atime);
4060 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4065 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4069 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4070 statbufp->st_atime = _toutc(statbufp->st_atime);
4071 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4078 } /* end of flex_fstat() */
4081 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4083 flex_stat(char *fspec, Stat_t *statbufp)
4086 char fileified[NAM$C_MAXRSS+1];
4089 if (statbufp == (Stat_t *) &statcache)
4090 do_tovmsspec(fspec,namecache,0);
4091 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4092 memset(statbufp,0,sizeof *statbufp);
4093 statbufp->st_dev = encode_dev("_NLA0:");
4094 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4095 statbufp->st_uid = 0x00010001;
4096 statbufp->st_gid = 0x0001;
4097 time((time_t *)&statbufp->st_mtime);
4098 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4102 /* Try for a directory name first. If fspec contains a filename without
4103 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4104 * and sea:[wine.dark]water. exist, we prefer the directory here.
4105 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4106 * not sea:[wine.dark]., if the latter exists. If the intended target is
4107 * the file with null type, specify this by calling flex_stat() with
4108 * a '.' at the end of fspec.
4110 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4111 retval = stat(fileified,(stat_t *) statbufp);
4112 if (!retval && statbufp == (Stat_t *) &statcache)
4113 strcpy(namecache,fileified);
4115 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4117 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4118 # ifdef RTL_USES_UTC
4121 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4122 statbufp->st_atime = _toloc(statbufp->st_atime);
4123 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4128 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4132 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4133 statbufp->st_atime = _toutc(statbufp->st_atime);
4134 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4140 } /* end of flex_stat() */
4143 /* Insures that no carriage-control translation will be done on a file. */
4144 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
4146 my_binmode(FILE *fp, char iotype)
4148 char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
4149 int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
4152 if (!fgetname(fp,filespec)) return NULL;
4153 for (s = filespec; *s; s++) {
4154 if (*s == ':') colon = s;
4155 else if (*s == ']' || *s == '>') dirend = s;
4157 /* Looks like a tmpfile, which will go away if reopened */
4158 if (s == dirend + 3) return fp;
4159 /* If we've got a non-file-structured device, clip off the trailing
4160 * junk, and don't lose sleep if we can't get a stream position. */
4161 if (dirend == Nullch) *(colon+1) = '\0';
4162 if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
4164 case '<': case 'r': acmode = "rb"; break;
4165 case '>': case 'w': case '|':
4166 /* use 'a' instead of 'w' to avoid creating new file;
4167 fsetpos below will take care of restoring file position */
4168 case 'a': acmode = "ab"; break;
4169 case '+': case 's': acmode = "rb+"; break;
4170 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
4172 warn("Unrecognized iotype %c in my_binmode",iotype);
4175 if (freopen(filespec,acmode,fp) == NULL) return NULL;
4176 if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
4177 if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
4179 } /* end of my_binmode() */
4183 /*{{{char *my_getlogin()*/
4184 /* VMS cuserid == Unix getlogin, except calling sequence */
4188 static char user[L_cuserid];
4189 return cuserid(user);
4194 /* rmscopy - copy a file using VMS RMS routines
4196 * Copies contents and attributes of spec_in to spec_out, except owner
4197 * and protection information. Name and type of spec_in are used as
4198 * defaults for spec_out. The third parameter specifies whether rmscopy()
4199 * should try to propagate timestamps from the input file to the output file.
4200 * If it is less than 0, no timestamps are preserved. If it is 0, then
4201 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4202 * propagated to the output file at creation iff the output file specification
4203 * did not contain an explicit name or type, and the revision date is always
4204 * updated at the end of the copy operation. If it is greater than 0, then
4205 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4206 * other than the revision date should be propagated, and bit 1 indicates
4207 * that the revision date should be propagated.
4209 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4211 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
4212 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4213 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4214 * as part of the Perl standard distribution under the terms of the
4215 * GNU General Public License or the Perl Artistic License. Copies
4216 * of each may be found in the Perl standard distribution.
4218 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4220 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4222 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4223 rsa[NAM$C_MAXRSS], ubf[32256];
4224 unsigned long int i, sts, sts2;
4225 struct FAB fab_in, fab_out;
4226 struct RAB rab_in, rab_out;
4228 struct XABDAT xabdat;
4229 struct XABFHC xabfhc;
4230 struct XABRDT xabrdt;
4231 struct XABSUM xabsum;
4233 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4234 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4235 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4239 fab_in = cc$rms_fab;
4240 fab_in.fab$l_fna = vmsin;
4241 fab_in.fab$b_fns = strlen(vmsin);
4242 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4243 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4244 fab_in.fab$l_fop = FAB$M_SQO;
4245 fab_in.fab$l_nam = &nam;
4246 fab_in.fab$l_xab = (void *) &xabdat;
4249 nam.nam$l_rsa = rsa;
4250 nam.nam$b_rss = sizeof(rsa);
4251 nam.nam$l_esa = esa;
4252 nam.nam$b_ess = sizeof (esa);
4253 nam.nam$b_esl = nam.nam$b_rsl = 0;
4255 xabdat = cc$rms_xabdat; /* To get creation date */
4256 xabdat.xab$l_nxt = (void *) &xabfhc;
4258 xabfhc = cc$rms_xabfhc; /* To get record length */
4259 xabfhc.xab$l_nxt = (void *) &xabsum;
4261 xabsum = cc$rms_xabsum; /* To get key and area information */
4263 if (!((sts = sys$open(&fab_in)) & 1)) {
4264 set_vaxc_errno(sts);
4268 set_errno(ENOENT); break;
4270 set_errno(ENODEV); break;
4272 set_errno(EINVAL); break;
4274 set_errno(EACCES); break;
4282 fab_out.fab$w_ifi = 0;
4283 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4284 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4285 fab_out.fab$l_fop = FAB$M_SQO;
4286 fab_out.fab$l_fna = vmsout;
4287 fab_out.fab$b_fns = strlen(vmsout);
4288 fab_out.fab$l_dna = nam.nam$l_name;
4289 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4291 if (preserve_dates == 0) { /* Act like DCL COPY */
4292 nam.nam$b_nop = NAM$M_SYNCHK;
4293 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4294 if (!((sts = sys$parse(&fab_out)) & 1)) {
4295 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4296 set_vaxc_errno(sts);
4299 fab_out.fab$l_xab = (void *) &xabdat;
4300 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4302 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4303 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4304 preserve_dates =0; /* bitmask from this point forward */
4306 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4307 if (!((sts = sys$create(&fab_out)) & 1)) {
4308 set_vaxc_errno(sts);
4311 set_errno(ENOENT); break;
4313 set_errno(ENODEV); break;
4315 set_errno(EINVAL); break;
4317 set_errno(EACCES); break;
4323 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4324 if (preserve_dates & 2) {
4325 /* sys$close() will process xabrdt, not xabdat */
4326 xabrdt = cc$rms_xabrdt;
4328 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4330 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4331 * is unsigned long[2], while DECC & VAXC use a struct */
4332 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4334 fab_out.fab$l_xab = (void *) &xabrdt;
4337 rab_in = cc$rms_rab;
4338 rab_in.rab$l_fab = &fab_in;
4339 rab_in.rab$l_rop = RAB$M_BIO;
4340 rab_in.rab$l_ubf = ubf;
4341 rab_in.rab$w_usz = sizeof ubf;
4342 if (!((sts = sys$connect(&rab_in)) & 1)) {
4343 sys$close(&fab_in); sys$close(&fab_out);
4344 set_errno(EVMSERR); set_vaxc_errno(sts);
4348 rab_out = cc$rms_rab;
4349 rab_out.rab$l_fab = &fab_out;
4350 rab_out.rab$l_rbf = ubf;
4351 if (!((sts = sys$connect(&rab_out)) & 1)) {
4352 sys$close(&fab_in); sys$close(&fab_out);
4353 set_errno(EVMSERR); set_vaxc_errno(sts);
4357 while ((sts = sys$read(&rab_in))) { /* always true */
4358 if (sts == RMS$_EOF) break;
4359 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4360 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4361 sys$close(&fab_in); sys$close(&fab_out);
4362 set_errno(EVMSERR); set_vaxc_errno(sts);
4367 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4368 sys$close(&fab_in); sys$close(&fab_out);
4369 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4371 set_errno(EVMSERR); set_vaxc_errno(sts);
4377 } /* end of rmscopy() */
4381 /*** The following glue provides 'hooks' to make some of the routines
4382 * from this file available from Perl. These routines are sufficiently
4383 * basic, and are required sufficiently early in the build process,
4384 * that's it's nice to have them available to miniperl as well as the
4385 * full Perl, so they're set up here instead of in an extension. The
4386 * Perl code which handles importation of these names into a given
4387 * package lives in [.VMS]Filespec.pm in @INC.
4391 rmsexpand_fromperl(CV *cv)
4394 char *fspec, *defspec = NULL, *rslt;
4396 if (!items || items > 2)
4397 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4398 fspec = SvPV(ST(0),na);
4399 if (!fspec || !*fspec) XSRETURN_UNDEF;
4400 if (items == 2) defspec = SvPV(ST(1),na);
4402 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4403 ST(0) = sv_newmortal();
4404 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4409 vmsify_fromperl(CV *cv)
4414 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4415 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4416 ST(0) = sv_newmortal();
4417 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4422 unixify_fromperl(CV *cv)
4427 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4428 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4429 ST(0) = sv_newmortal();
4430 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4435 fileify_fromperl(CV *cv)
4440 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4441 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4442 ST(0) = sv_newmortal();
4443 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4448 pathify_fromperl(CV *cv)
4453 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4454 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4455 ST(0) = sv_newmortal();
4456 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4461 vmspath_fromperl(CV *cv)
4466 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4467 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4468 ST(0) = sv_newmortal();
4469 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4474 unixpath_fromperl(CV *cv)
4479 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4480 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4481 ST(0) = sv_newmortal();
4482 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4487 candelete_fromperl(CV *cv)
4490 char fspec[NAM$C_MAXRSS+1], *fsp;
4494 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4496 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4497 if (SvTYPE(mysv) == SVt_PVGV) {
4498 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4499 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4506 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4507 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4513 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4518 rmscopy_fromperl(CV *cv)
4521 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4523 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4524 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4525 unsigned long int sts;
4529 if (items < 2 || items > 3)
4530 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4532 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4533 if (SvTYPE(mysv) == SVt_PVGV) {
4534 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4535 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4542 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4543 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4548 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4549 if (SvTYPE(mysv) == SVt_PVGV) {
4550 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4551 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4558 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4559 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4564 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4566 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4573 char* file = __FILE__;
4575 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4576 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4577 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4578 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4579 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4580 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4581 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4582 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4583 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
4585 #ifdef PRIME_ENV_AT_STARTUP