3 * VMS-specific routines for perl5
5 * Last revised: 27-Feb-1998 by Charles Bailey bailey@newman.upenn.edu
14 #include <climsgdef.h>
24 #include <lib$routines.h>
33 #include <str$routines.h>
38 /* Older versions of ssdef.h don't have these */
39 #ifndef SS$_INVFILFOROP
40 # define SS$_INVFILFOROP 3930
42 #ifndef SS$_NOSUCHOBJECT
43 # define SS$_NOSUCHOBJECT 2696
46 /* Don't replace system definitions of vfork, getenv, and stat,
47 * code below needs to get to the underlying CRTL routines. */
48 #define DONT_MASK_RTL_CALLS
53 /* gcc's header files don't #define direct access macros
54 * corresponding to VAXC's variant structs */
56 # define uic$v_format uic$r_uic_form.uic$v_format
57 # define uic$v_group uic$r_uic_form.uic$v_group
58 # define uic$v_member uic$r_uic_form.uic$v_member
59 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
60 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
61 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
62 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
67 unsigned short int buflen;
68 unsigned short int itmcode;
70 unsigned short int *retlen;
73 static char *__mystrtolower(char *str)
75 if (str) for (; *str; ++str) *str= tolower(*str);
80 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
82 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
83 unsigned short int eqvlen;
84 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
85 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
86 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
87 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
88 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
91 if (!lnm || idx > LNM$_MAX_INDEX) {
92 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
94 if (!eqv) eqv = __my_trnlnm_eqv;
95 lnmlst[1].bufadr = (void *)eqv;
96 lnmdsc.dsc$a_pointer = lnm;
97 lnmdsc.dsc$w_length = strlen(lnm);
98 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
99 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
100 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
102 else if (retsts & 1) {
106 _ckvmssts(retsts); /* Must be an error */
107 return 0; /* Not reached, assuming _ckvmssts() bails out */
109 } /* end of my_trnlnm */
112 * Translate a logical name. Substitute for CRTL getenv() to avoid
113 * memory leak, and to keep my_getenv() and my_setenv() in the same
114 * domain (mostly - my_getenv() need not return a translation from
115 * the process logical name table)
117 * Note: Uses Perl temp to store result so char * can be returned to
118 * caller; this pointer will be invalidated at next Perl statement
121 /*{{{ char *my_getenv(char *lnm)*/
125 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
126 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
127 unsigned long int idx = 0;
131 if (curinterp) { /* Perl interpreter running -- may be threaded */
132 /* Set up a temporary buffer for the return value; Perl will
133 * clean it up at the next statement transition */
134 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
135 if (!tmpsv) return NULL;
138 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
139 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
141 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
142 getcwd(eqv,LNM$C_NAMLENGTH);
146 if ((cp2 = strchr(uplnm,';')) != NULL) {
148 idx = strtoul(cp2+1,NULL,0);
150 trnsuccess = my_trnlnm(uplnm,eqv,idx);
151 /* If we had a translation index, we're only interested in lnms */
152 if (!trnsuccess && cp2 != NULL) return Nullch;
153 if (trnsuccess) return eqv;
155 unsigned long int retsts;
156 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
157 valdsc = {LNM$C_NAMLENGTH,DSC$K_DTYPE_T,
159 symdsc.dsc$w_length = cp1 - lnm;
160 symdsc.dsc$a_pointer = uplnm;
161 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
162 if (retsts == LIB$_INVSYMNAM) return Nullch;
163 if (retsts != LIB$_NOSUCHSYM) {
164 /* We want to return only logical names or CRTL Unix emulations */
165 if (retsts & 1) return Nullch;
168 /* Try for CRTL emulation of a Unix/POSIX name */
169 else return getenv(uplnm);
174 } /* end of my_getenv() */
177 static FILE *safe_popen(char *, char *);
179 /*{{{ void prime_env_iter() */
182 /* Fill the %ENV associative array with all logical names we can
183 * find, in preparation for iterating over it.
187 static int primed = 0; /* XXX Not thread-safe!!! */
188 HV *envhv = GvHVn(envgv);
190 char eqv[LNM$C_NAMLENGTH+1],*start,*end;
192 SV *oldrs, *linesv, *eqvsv;
194 static perl_mutex primenv_mutex = PTHREAD_MUTEX_INITIALIZER;
198 MUTEX_LOCK(&primenv_mutex);
199 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
200 /* Perform a dummy fetch as an lval to insure that the hash table is
201 * set up. Otherwise, the hv_store() will turn into a nullop */
202 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
203 /* Also, set up the four "special" keys that the CRTL defines,
204 * whether or not underlying logical names exist. */
205 (void) hv_fetch(envhv,"HOME",4,TRUE);
206 (void) hv_fetch(envhv,"TERM",4,TRUE);
207 (void) hv_fetch(envhv,"PATH",4,TRUE);
208 (void) hv_fetch(envhv,"USER",4,TRUE);
210 /* Now, go get the logical names */
211 if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp) {
212 MUTEX_UNLOCK(&primenv_mutex);
213 _ckvmssts(vaxc$errno);
215 /* We use Perl's sv_gets to read from the pipe, since safe_popen is
216 * tied to Perl's I/O layer, so it may not return a simple FILE * */
218 rs = newSVpv("\n",1);
219 linesv = newSVpv("",0);
221 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
223 SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
225 MUTEX_UNLOCK(&primenv_mutex);
228 while (*start != '"' && *start != '=' && *start) start++;
229 if (*start != '"') continue;
230 for (end = ++start; *end && *end != '"'; end++) ;
231 if (*end) *end = '\0';
233 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
234 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
236 warn("Ill-formed logical name |%s| in prime_env_iter",start);
239 else { MUTEX_UNLOCK(&primenv_mutex); _ckvmssts(vaxc$errno); }
242 eqvsv = newSVpv(eqv,eqvlen);
243 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
246 } /* end of prime_env_iter */
250 /*{{{ void my_setenv(char *lnm, char *eqv)*/
252 my_setenv(char *lnm,char *eqv)
253 /* Define a supervisor-mode logical name in the process table.
254 * In the future we'll add tables, attribs, and acmodes,
255 * probably through a different call.
258 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
259 unsigned long int retsts, usermode = PSL$C_USER;
260 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
261 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
262 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
264 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
265 lnmdsc.dsc$w_length = cp1 - lnm;
267 if (!eqv || !*eqv) { /* we're deleting a logical name */
268 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
269 if (retsts == SS$_IVLOGNAM) return;
270 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
272 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
273 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
277 eqvdsc.dsc$w_length = strlen(eqv);
278 eqvdsc.dsc$a_pointer = eqv;
280 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
283 } /* end of my_setenv() */
287 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
288 /* my_crypt - VMS password hashing
289 * my_crypt() provides an interface compatible with the Unix crypt()
290 * C library function, and uses sys$hash_password() to perform VMS
291 * password hashing. The quadword hashed password value is returned
292 * as a NUL-terminated 8 character string. my_crypt() does not change
293 * the case of its string arguments; in order to match the behavior
294 * of LOGINOUT et al., alphabetic characters in both arguments must
295 * be upcased by the caller.
298 my_crypt(const char *textpasswd, const char *usrname)
300 # ifndef UAI$C_PREFERRED_ALGORITHM
301 # define UAI$C_PREFERRED_ALGORITHM 127
303 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
304 unsigned short int salt = 0;
305 unsigned long int sts;
307 unsigned short int dsc$w_length;
308 unsigned char dsc$b_type;
309 unsigned char dsc$b_class;
310 const char * dsc$a_pointer;
311 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
312 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
313 struct itmlst_3 uailst[3] = {
314 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
315 { sizeof salt, UAI$_SALT, &salt, 0},
316 { 0, 0, NULL, NULL}};
319 usrdsc.dsc$w_length = strlen(usrname);
320 usrdsc.dsc$a_pointer = usrname;
321 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
328 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
334 if (sts != RMS$_RNF) return NULL;
337 txtdsc.dsc$w_length = strlen(textpasswd);
338 txtdsc.dsc$a_pointer = textpasswd;
339 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
340 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
343 return (char *) hash;
345 } /* end of my_crypt() */
349 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
350 static char *do_fileify_dirspec(char *, char *, int);
351 static char *do_tovmsspec(char *, char *, int);
353 /*{{{int do_rmdir(char *name)*/
357 char dirfile[NAM$C_MAXRSS+1];
361 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
362 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
363 else retval = kill_file(dirfile);
366 } /* end of do_rmdir */
370 * Delete any file to which user has control access, regardless of whether
371 * delete access is explicitly allowed.
372 * Limitations: User must have write access to parent directory.
373 * Does not block signals or ASTs; if interrupted in midstream
374 * may leave file with an altered ACL.
377 /*{{{int kill_file(char *name)*/
379 kill_file(char *name)
381 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
382 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
383 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
384 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
386 unsigned char myace$b_length;
387 unsigned char myace$b_type;
388 unsigned short int myace$w_flags;
389 unsigned long int myace$l_access;
390 unsigned long int myace$l_ident;
391 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
392 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
393 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
395 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
396 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
397 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
398 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
399 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
400 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
402 /* Expand the input spec using RMS, since the CRTL remove() and
403 * system services won't do this by themselves, so we may miss
404 * a file "hiding" behind a logical name or search list. */
405 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
406 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
407 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
408 /* If not, can changing protections help? */
409 if (vaxc$errno != RMS$_PRV) return -1;
411 /* No, so we get our own UIC to use as a rights identifier,
412 * and the insert an ACE at the head of the ACL which allows us
413 * to delete the file.
415 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
416 fildsc.dsc$w_length = strlen(rspec);
417 fildsc.dsc$a_pointer = rspec;
419 newace.myace$l_ident = oldace.myace$l_ident;
420 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
425 case SS$_NOSUCHOBJECT:
426 set_errno(ENOENT); break;
428 set_errno(ENODEV); break;
430 case SS$_INVFILFOROP:
431 set_errno(EINVAL); break;
433 set_errno(EACCES); break;
437 set_vaxc_errno(aclsts);
440 /* Grab any existing ACEs with this identifier in case we fail */
441 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
442 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
443 || fndsts == SS$_NOMOREACE ) {
444 /* Add the new ACE . . . */
445 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
447 if ((rmsts = remove(name))) {
448 /* We blew it - dir with files in it, no write priv for
449 * parent directory, etc. Put things back the way they were. */
450 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
453 addlst[0].bufadr = &oldace;
454 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
461 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
462 /* We just deleted it, so of course it's not there. Some versions of
463 * VMS seem to return success on the unlock operation anyhow (after all
464 * the unlock is successful), but others don't.
466 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
467 if (aclsts & 1) aclsts = fndsts;
470 set_vaxc_errno(aclsts);
476 } /* end of kill_file() */
480 /*{{{int my_mkdir(char *,Mode_t)*/
482 my_mkdir(char *dir, Mode_t mode)
484 STRLEN dirlen = strlen(dir);
486 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
487 * null file name/type. However, it's commonplace under Unix,
488 * so we'll allow it for a gain in portability.
490 if (dir[dirlen-1] == '/') {
491 char *newdir = savepvn(dir,dirlen-1);
492 int ret = mkdir(newdir,mode);
496 else return mkdir(dir,mode);
497 } /* end of my_mkdir */
502 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
504 static unsigned long int mbxbufsiz;
505 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
509 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
510 * preprocessor consant BUFSIZ from stdio.h as the size of the
513 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
514 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
516 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
518 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
519 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
521 } /* end of create_mbx() */
523 /*{{{ my_popen and my_pclose*/
526 struct pipe_details *next;
527 PerlIO *fp; /* stdio file pointer to pipe mailbox */
528 int pid; /* PID of subprocess */
529 int mode; /* == 'r' if pipe open for reading */
530 int done; /* subprocess has completed */
531 unsigned long int completion; /* termination status of subprocess */
534 struct exit_control_block
536 struct exit_control_block *flink;
537 unsigned long int (*exit_routine)();
538 unsigned long int arg_count;
539 unsigned long int *status_address;
540 unsigned long int exit_status;
543 static struct pipe_details *open_pipes = NULL;
544 static $DESCRIPTOR(nl_desc, "NL:");
545 static int waitpid_asleep = 0;
547 static unsigned long int
550 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
553 while (open_pipes != NULL) {
554 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
555 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
558 if (!open_pipes->done) /* We tried to be nice . . . */
559 _ckvmssts(sys$delprc(&open_pipes->pid,0));
560 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
561 else if (!(sts & 1)) retsts = sts;
566 static struct exit_control_block pipe_exitblock =
567 {(struct exit_control_block *) 0,
568 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
572 popen_completion_ast(struct pipe_details *thispipe)
574 thispipe->done = TRUE;
575 if (waitpid_asleep) {
582 safe_popen(char *cmd, char *mode)
584 static int handler_set_up = FALSE;
586 unsigned short int chan;
587 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
588 struct pipe_details *info;
589 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
590 DSC$K_CLASS_S, mbxname},
591 cmddsc = {0, DSC$K_DTYPE_T,
595 cmddsc.dsc$w_length=strlen(cmd);
596 cmddsc.dsc$a_pointer=cmd;
597 if (cmddsc.dsc$w_length > 255) {
598 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
602 New(1301,info,1,struct pipe_details);
605 create_mbx(&chan,&namdsc);
607 /* open a FILE* onto it */
608 info->fp = PerlIO_open(mbxname, mode);
610 /* give up other channel onto it */
611 _ckvmssts(sys$dassgn(chan));
621 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
622 0 /* name */, &info->pid, &info->completion,
623 0, popen_completion_ast,info,0,0,0));
626 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
627 0 /* name */, &info->pid, &info->completion,
628 0, popen_completion_ast,info,0,0,0));
631 if (!handler_set_up) {
632 _ckvmssts(sys$dclexh(&pipe_exitblock));
633 handler_set_up = TRUE;
635 info->next=open_pipes; /* prepend to list */
638 forkprocess = info->pid;
640 } /* end of safe_popen */
643 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
645 my_popen(char *cmd, char *mode)
648 TAINT_PROPER("popen");
649 return safe_popen(cmd,mode);
654 /*{{{ I32 my_pclose(FILE *fp)*/
655 I32 my_pclose(FILE *fp)
657 struct pipe_details *info, *last = NULL;
658 unsigned long int retsts;
660 for (info = open_pipes; info != NULL; last = info, info = info->next)
661 if (info->fp == fp) break;
663 if (info == NULL) { /* no such pipe open */
664 set_errno(ECHILD); /* quoth POSIX */
665 set_vaxc_errno(SS$_NONEXPR);
669 /* If we were writing to a subprocess, insure that someone reading from
670 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
671 * produce an EOF record in the mailbox. */
672 if (info->mode != 'r') {
673 char devnam[NAM$C_MAXRSS+1], *cp;
674 unsigned long int chan, iosb[2], retsts, retsts2;
675 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
677 if (fgetname(info->fp,devnam)) {
678 /* It oughta be a mailbox, so fgetname should give just the device
679 * name, but just in case . . . */
680 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
681 devdsc.dsc$w_length = strlen(devnam);
682 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
683 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
684 if (retsts & 1) retsts = iosb[0];
685 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
686 if (retsts & 1) retsts = retsts2;
689 else _ckvmssts(vaxc$errno); /* Should never happen */
691 PerlIO_close(info->fp);
693 if (info->done) retsts = info->completion;
694 else waitpid(info->pid,(int *) &retsts,0);
696 /* remove from list of open pipes */
697 if (last) last->next = info->next;
698 else open_pipes = info->next;
703 } /* end of my_pclose() */
705 /* sort-of waitpid; use only with popen() */
706 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
708 my_waitpid(Pid_t pid, int *statusp, int flags)
710 struct pipe_details *info;
712 for (info = open_pipes; info != NULL; info = info->next)
713 if (info->pid == pid) break;
715 if (info != NULL) { /* we know about this child */
716 while (!info->done) {
721 *statusp = info->completion;
724 else { /* we haven't heard of this child */
725 $DESCRIPTOR(intdsc,"0 00:00:01");
726 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
727 unsigned long int interval[2],sts;
730 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
731 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
732 if (ownerpid != mypid)
733 warn("pid %d not a child",pid);
736 _ckvmssts(sys$bintim(&intdsc,interval));
737 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
738 _ckvmssts(sys$schdwk(0,0,interval,0));
739 _ckvmssts(sys$hiber());
743 /* There's no easy way to find the termination status a child we're
744 * not aware of beforehand. If we're really interested in the future,
745 * we can go looking for a termination mailbox, or chase after the
746 * accounting record for the process.
752 } /* end of waitpid() */
757 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
759 my_gconvert(double val, int ndig, int trail, char *buf)
761 static char __gcvtbuf[DBL_DIG+1];
764 loc = buf ? buf : __gcvtbuf;
766 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
768 sprintf(loc,"%.*g",ndig,val);
774 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
775 return gcvt(val,ndig,loc);
778 loc[0] = '0'; loc[1] = '\0';
786 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
787 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
788 * to expand file specification. Allows for a single default file
789 * specification and a simple mask of options. If outbuf is non-NULL,
790 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
791 * the resultant file specification is placed. If outbuf is NULL, the
792 * resultant file specification is placed into a static buffer.
793 * The third argument, if non-NULL, is taken to be a default file
794 * specification string. The fourth argument is unused at present.
795 * rmesexpand() returns the address of the resultant string if
796 * successful, and NULL on error.
798 static char *do_tounixspec(char *, char *, int);
801 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
803 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
804 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
805 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
806 struct FAB myfab = cc$rms_fab;
807 struct NAM mynam = cc$rms_nam;
809 unsigned long int retsts, haslower = 0, isunix = 0;
811 if (!filespec || !*filespec) {
812 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
816 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
817 else outbuf = __rmsexpand_retbuf;
819 if ((isunix = (strchr(filespec,'/') != NULL))) {
820 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
824 myfab.fab$l_fna = filespec;
825 myfab.fab$b_fns = strlen(filespec);
826 myfab.fab$l_nam = &mynam;
828 if (defspec && *defspec) {
829 if (strchr(defspec,'/') != NULL) {
830 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
833 myfab.fab$l_dna = defspec;
834 myfab.fab$b_dns = strlen(defspec);
837 mynam.nam$l_esa = esa;
838 mynam.nam$b_ess = sizeof esa;
839 mynam.nam$l_rsa = outbuf;
840 mynam.nam$b_rss = NAM$C_MAXRSS;
842 retsts = sys$parse(&myfab,0,0);
844 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
845 retsts == RMS$_DEV || retsts == RMS$_DEV) {
846 mynam.nam$b_nop |= NAM$M_SYNCHK;
847 retsts = sys$parse(&myfab,0,0);
848 if (retsts & 1) goto expanded;
850 if (out) Safefree(out);
851 set_vaxc_errno(retsts);
852 if (retsts == RMS$_PRV) set_errno(EACCES);
853 else if (retsts == RMS$_DEV) set_errno(ENODEV);
854 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
855 else set_errno(EVMSERR);
858 retsts = sys$search(&myfab,0,0);
859 if (!(retsts & 1) && retsts != RMS$_FNF) {
860 if (out) Safefree(out);
861 set_vaxc_errno(retsts);
862 if (retsts == RMS$_PRV) set_errno(EACCES);
863 else set_errno(EVMSERR);
867 /* If the input filespec contained any lowercase characters,
868 * downcase the result for compatibility with Unix-minded code. */
870 for (out = myfab.fab$l_fna; *out; out++)
871 if (islower(*out)) { haslower = 1; break; }
872 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
873 else { out = esa; speclen = mynam.nam$b_esl; }
874 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
875 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
876 speclen = mynam.nam$l_ver - out;
877 /* If we just had a directory spec on input, $PARSE "helpfully"
878 * adds an empty name and type for us */
879 if (mynam.nam$l_name == mynam.nam$l_type &&
880 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
881 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
882 speclen = mynam.nam$l_name - out;
884 if (haslower) __mystrtolower(out);
886 /* Have we been working with an expanded, but not resultant, spec? */
887 /* Also, convert back to Unix syntax if necessary. */
888 if (!mynam.nam$b_rsl) {
890 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
892 else strcpy(outbuf,esa);
895 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
896 strcpy(outbuf,tmpfspec);
901 /* External entry points */
902 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
903 { return do_rmsexpand(spec,buf,0,def,opt); }
904 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
905 { return do_rmsexpand(spec,buf,1,def,opt); }
909 ** The following routines are provided to make life easier when
910 ** converting among VMS-style and Unix-style directory specifications.
911 ** All will take input specifications in either VMS or Unix syntax. On
912 ** failure, all return NULL. If successful, the routines listed below
913 ** return a pointer to a buffer containing the appropriately
914 ** reformatted spec (and, therefore, subsequent calls to that routine
915 ** will clobber the result), while the routines of the same names with
916 ** a _ts suffix appended will return a pointer to a mallocd string
917 ** containing the appropriately reformatted spec.
918 ** In all cases, only explicit syntax is altered; no check is made that
919 ** the resulting string is valid or that the directory in question
922 ** fileify_dirspec() - convert a directory spec into the name of the
923 ** directory file (i.e. what you can stat() to see if it's a dir).
924 ** The style (VMS or Unix) of the result is the same as the style
925 ** of the parameter passed in.
926 ** pathify_dirspec() - convert a directory spec into a path (i.e.
927 ** what you prepend to a filename to indicate what directory it's in).
928 ** The style (VMS or Unix) of the result is the same as the style
929 ** of the parameter passed in.
930 ** tounixpath() - convert a directory spec into a Unix-style path.
931 ** tovmspath() - convert a directory spec into a VMS-style path.
932 ** tounixspec() - convert any file spec into a Unix-style file spec.
933 ** tovmsspec() - convert any file spec into a VMS-style spec.
935 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
936 ** Permission is given to distribute this code as part of the Perl
937 ** standard distribution under the terms of the GNU General Public
938 ** License or the Perl Artistic License. Copies of each may be
939 ** found in the Perl standard distribution.
942 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
943 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
945 static char __fileify_retbuf[NAM$C_MAXRSS+1];
946 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
947 char *retspec, *cp1, *cp2, *lastdir;
948 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
951 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
953 dirlen = strlen(dir);
954 while (dir[dirlen-1] == '/') --dirlen;
955 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
956 strcpy(trndir,"/sys$disk/000000");
960 if (dirlen > NAM$C_MAXRSS) {
961 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
963 if (!strpbrk(dir+1,"/]>:")) {
964 strcpy(trndir,*dir == '/' ? dir + 1: dir);
965 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
967 dirlen = strlen(dir);
970 strncpy(trndir,dir,dirlen);
971 trndir[dirlen] = '\0';
974 /* If we were handed a rooted logical name or spec, treat it like a
975 * simple directory, so that
976 * $ Define myroot dev:[dir.]
977 * ... do_fileify_dirspec("myroot",buf,1) ...
978 * does something useful.
980 if (!strcmp(dir+dirlen-2,".]")) {
981 dir[--dirlen] = '\0';
985 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
986 /* If we've got an explicit filename, we can just shuffle the string. */
987 if (*(cp1+1)) hasfilename = 1;
988 /* Similarly, we can just back up a level if we've got multiple levels
989 of explicit directories in a VMS spec which ends with directories. */
991 for (cp2 = cp1; cp2 > dir; cp2--) {
993 *cp2 = *cp1; *cp1 = '\0';
997 if (*cp2 == '[' || *cp2 == '<') break;
1002 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1003 if (dir[0] == '.') {
1004 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1005 return do_fileify_dirspec("[]",buf,ts);
1006 else if (dir[1] == '.' &&
1007 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1008 return do_fileify_dirspec("[-]",buf,ts);
1010 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1011 dirlen -= 1; /* to last element */
1012 lastdir = strrchr(dir,'/');
1014 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1015 /* If we have "/." or "/..", VMSify it and let the VMS code
1016 * below expand it, rather than repeating the code to handle
1017 * relative components of a filespec here */
1019 if (*(cp1+2) == '.') cp1++;
1020 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1021 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1022 if (strchr(vmsdir,'/') != NULL) {
1023 /* If do_tovmsspec() returned it, it must have VMS syntax
1024 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1025 * the time to check this here only so we avoid a recursion
1026 * loop; otherwise, gigo.
1028 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1030 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1031 return do_tounixspec(trndir,buf,ts);
1034 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1036 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1037 /* Ditto for specs that end in an MFD -- let the VMS code
1038 * figure out whether it's a real device or a rooted logical. */
1039 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1040 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1041 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1042 return do_tounixspec(trndir,buf,ts);
1045 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1046 !(lastdir = cp1 = strrchr(dir,']')) &&
1047 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1048 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1050 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1051 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1052 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1053 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1054 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1055 (ver || *cp3)))))) {
1057 set_vaxc_errno(RMS$_DIR);
1063 /* If we lead off with a device or rooted logical, add the MFD
1064 if we're specifying a top-level directory. */
1065 if (lastdir && *dir == '/') {
1067 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1074 retlen = dirlen + (addmfd ? 13 : 6);
1075 if (buf) retspec = buf;
1076 else if (ts) New(1309,retspec,retlen+1,char);
1077 else retspec = __fileify_retbuf;
1079 dirlen = lastdir - dir;
1080 memcpy(retspec,dir,dirlen);
1081 strcpy(&retspec[dirlen],"/000000");
1082 strcpy(&retspec[dirlen+7],lastdir);
1085 memcpy(retspec,dir,dirlen);
1086 retspec[dirlen] = '\0';
1088 /* We've picked up everything up to the directory file name.
1089 Now just add the type and version, and we're set. */
1090 strcat(retspec,".dir;1");
1093 else { /* VMS-style directory spec */
1094 char esa[NAM$C_MAXRSS+1], term, *cp;
1095 unsigned long int sts, cmplen, haslower = 0;
1096 struct FAB dirfab = cc$rms_fab;
1097 struct NAM savnam, dirnam = cc$rms_nam;
1099 dirfab.fab$b_fns = strlen(dir);
1100 dirfab.fab$l_fna = dir;
1101 dirfab.fab$l_nam = &dirnam;
1102 dirfab.fab$l_dna = ".DIR;1";
1103 dirfab.fab$b_dns = 6;
1104 dirnam.nam$b_ess = NAM$C_MAXRSS;
1105 dirnam.nam$l_esa = esa;
1107 for (cp = dir; *cp; cp++)
1108 if (islower(*cp)) { haslower = 1; break; }
1109 if (!((sts = sys$parse(&dirfab))&1)) {
1110 if (dirfab.fab$l_sts == RMS$_DIR) {
1111 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1112 sts = sys$parse(&dirfab) & 1;
1116 set_vaxc_errno(dirfab.fab$l_sts);
1122 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1123 /* Yes; fake the fnb bits so we'll check type below */
1124 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1127 if (dirfab.fab$l_sts != RMS$_FNF) {
1129 set_vaxc_errno(dirfab.fab$l_sts);
1132 dirnam = savnam; /* No; just work with potential name */
1135 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1136 cp1 = strchr(esa,']');
1137 if (!cp1) cp1 = strchr(esa,'>');
1138 if (cp1) { /* Should always be true */
1139 dirnam.nam$b_esl -= cp1 - esa - 1;
1140 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1143 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1144 /* Yep; check version while we're at it, if it's there. */
1145 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1146 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1147 /* Something other than .DIR[;1]. Bzzt. */
1149 set_vaxc_errno(RMS$_DIR);
1153 esa[dirnam.nam$b_esl] = '\0';
1154 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1155 /* They provided at least the name; we added the type, if necessary, */
1156 if (buf) retspec = buf; /* in sys$parse() */
1157 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1158 else retspec = __fileify_retbuf;
1159 strcpy(retspec,esa);
1162 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1163 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1165 dirnam.nam$b_esl -= 9;
1167 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1168 if (cp1 == NULL) return NULL; /* should never happen */
1171 retlen = strlen(esa);
1172 if ((cp1 = strrchr(esa,'.')) != NULL) {
1173 /* There's more than one directory in the path. Just roll back. */
1175 if (buf) retspec = buf;
1176 else if (ts) New(1311,retspec,retlen+7,char);
1177 else retspec = __fileify_retbuf;
1178 strcpy(retspec,esa);
1181 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1182 /* Go back and expand rooted logical name */
1183 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1184 if (!(sys$parse(&dirfab) & 1)) {
1186 set_vaxc_errno(dirfab.fab$l_sts);
1189 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1190 if (buf) retspec = buf;
1191 else if (ts) New(1312,retspec,retlen+16,char);
1192 else retspec = __fileify_retbuf;
1193 cp1 = strstr(esa,"][");
1195 memcpy(retspec,esa,dirlen);
1196 if (!strncmp(cp1+2,"000000]",7)) {
1197 retspec[dirlen-1] = '\0';
1198 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1199 if (*cp1 == '.') *cp1 = ']';
1201 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1202 memcpy(cp1+1,"000000]",7);
1206 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1207 retspec[retlen] = '\0';
1208 /* Convert last '.' to ']' */
1209 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1210 if (*cp1 == '.') *cp1 = ']';
1212 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1213 memcpy(cp1+1,"000000]",7);
1217 else { /* This is a top-level dir. Add the MFD to the path. */
1218 if (buf) retspec = buf;
1219 else if (ts) New(1312,retspec,retlen+16,char);
1220 else retspec = __fileify_retbuf;
1223 while (*cp1 != ':') *(cp2++) = *(cp1++);
1224 strcpy(cp2,":[000000]");
1229 /* We've set up the string up through the filename. Add the
1230 type and version, and we're done. */
1231 strcat(retspec,".DIR;1");
1233 /* $PARSE may have upcased filespec, so convert output to lower
1234 * case if input contained any lowercase characters. */
1235 if (haslower) __mystrtolower(retspec);
1238 } /* end of do_fileify_dirspec() */
1240 /* External entry points */
1241 char *fileify_dirspec(char *dir, char *buf)
1242 { return do_fileify_dirspec(dir,buf,0); }
1243 char *fileify_dirspec_ts(char *dir, char *buf)
1244 { return do_fileify_dirspec(dir,buf,1); }
1246 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1247 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1249 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1250 unsigned long int retlen;
1251 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1253 if (!dir || !*dir) {
1254 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1257 if (*dir) strcpy(trndir,dir);
1258 else getcwd(trndir,sizeof trndir - 1);
1260 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1261 STRLEN trnlen = strlen(trndir);
1263 /* Trap simple rooted lnms, and return lnm:[000000] */
1264 if (!strcmp(trndir+trnlen-2,".]")) {
1265 if (buf) retpath = buf;
1266 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1267 else retpath = __pathify_retbuf;
1268 strcpy(retpath,dir);
1269 strcat(retpath,":[000000]");
1275 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1276 if (*dir == '.' && (*(dir+1) == '\0' ||
1277 (*(dir+1) == '.' && *(dir+2) == '\0')))
1278 retlen = 2 + (*(dir+1) != '\0');
1280 if ( !(cp1 = strrchr(dir,'/')) &&
1281 !(cp1 = strrchr(dir,']')) &&
1282 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1283 if ((cp2 = strchr(cp1,'.')) != NULL &&
1284 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1285 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1286 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1287 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1289 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1290 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1291 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1292 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1293 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1294 (ver || *cp3)))))) {
1296 set_vaxc_errno(RMS$_DIR);
1299 retlen = cp2 - dir + 1;
1301 else { /* No file type present. Treat the filename as a directory. */
1302 retlen = strlen(dir) + 1;
1305 if (buf) retpath = buf;
1306 else if (ts) New(1313,retpath,retlen+1,char);
1307 else retpath = __pathify_retbuf;
1308 strncpy(retpath,dir,retlen-1);
1309 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1310 retpath[retlen-1] = '/'; /* with '/', add it. */
1311 retpath[retlen] = '\0';
1313 else retpath[retlen-1] = '\0';
1315 else { /* VMS-style directory spec */
1316 char esa[NAM$C_MAXRSS+1], *cp;
1317 unsigned long int sts, cmplen, haslower;
1318 struct FAB dirfab = cc$rms_fab;
1319 struct NAM savnam, dirnam = cc$rms_nam;
1321 /* If we've got an explicit filename, we can just shuffle the string. */
1322 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1323 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1324 if ((cp2 = strchr(cp1,'.')) != NULL) {
1326 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1327 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1328 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1329 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1330 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1331 (ver || *cp3)))))) {
1333 set_vaxc_errno(RMS$_DIR);
1337 else { /* No file type, so just draw name into directory part */
1338 for (cp2 = cp1; *cp2; cp2++) ;
1341 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1343 /* We've now got a VMS 'path'; fall through */
1345 dirfab.fab$b_fns = strlen(dir);
1346 dirfab.fab$l_fna = dir;
1347 if (dir[dirfab.fab$b_fns-1] == ']' ||
1348 dir[dirfab.fab$b_fns-1] == '>' ||
1349 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1350 if (buf) retpath = buf;
1351 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1352 else retpath = __pathify_retbuf;
1353 strcpy(retpath,dir);
1356 dirfab.fab$l_dna = ".DIR;1";
1357 dirfab.fab$b_dns = 6;
1358 dirfab.fab$l_nam = &dirnam;
1359 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1360 dirnam.nam$l_esa = esa;
1362 for (cp = dir; *cp; cp++)
1363 if (islower(*cp)) { haslower = 1; break; }
1365 if (!(sts = (sys$parse(&dirfab)&1))) {
1366 if (dirfab.fab$l_sts == RMS$_DIR) {
1367 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1368 sts = sys$parse(&dirfab) & 1;
1372 set_vaxc_errno(dirfab.fab$l_sts);
1378 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1379 if (dirfab.fab$l_sts != RMS$_FNF) {
1381 set_vaxc_errno(dirfab.fab$l_sts);
1384 dirnam = savnam; /* No; just work with potential name */
1387 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1388 /* Yep; check version while we're at it, if it's there. */
1389 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1390 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1391 /* Something other than .DIR[;1]. Bzzt. */
1393 set_vaxc_errno(RMS$_DIR);
1397 /* OK, the type was fine. Now pull any file name into the
1399 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1401 cp1 = strrchr(esa,'>');
1402 *dirnam.nam$l_type = '>';
1405 *(dirnam.nam$l_type + 1) = '\0';
1406 retlen = dirnam.nam$l_type - esa + 2;
1407 if (buf) retpath = buf;
1408 else if (ts) New(1314,retpath,retlen,char);
1409 else retpath = __pathify_retbuf;
1410 strcpy(retpath,esa);
1411 /* $PARSE may have upcased filespec, so convert output to lower
1412 * case if input contained any lowercase characters. */
1413 if (haslower) __mystrtolower(retpath);
1417 } /* end of do_pathify_dirspec() */
1419 /* External entry points */
1420 char *pathify_dirspec(char *dir, char *buf)
1421 { return do_pathify_dirspec(dir,buf,0); }
1422 char *pathify_dirspec_ts(char *dir, char *buf)
1423 { return do_pathify_dirspec(dir,buf,1); }
1425 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1426 static char *do_tounixspec(char *spec, char *buf, int ts)
1428 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1429 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1430 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1432 if (spec == NULL) return NULL;
1433 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1434 if (buf) rslt = buf;
1436 retlen = strlen(spec);
1437 cp1 = strchr(spec,'[');
1438 if (!cp1) cp1 = strchr(spec,'<');
1440 for (cp1++; *cp1; cp1++) {
1441 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1442 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1443 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1446 New(1315,rslt,retlen+2+2*expand,char);
1448 else rslt = __tounixspec_retbuf;
1449 if (strchr(spec,'/') != NULL) {
1456 dirend = strrchr(spec,']');
1457 if (dirend == NULL) dirend = strrchr(spec,'>');
1458 if (dirend == NULL) dirend = strchr(spec,':');
1459 if (dirend == NULL) {
1463 if (*cp2 != '[' && *cp2 != '<') {
1466 else { /* the VMS spec begins with directories */
1468 if (*cp2 == ']' || *cp2 == '>') {
1469 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1472 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1473 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1474 if (ts) Safefree(rslt);
1479 while (*cp3 != ':' && *cp3) cp3++;
1481 if (strchr(cp3,']') != NULL) break;
1482 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1484 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1485 retlen = devlen + dirlen;
1486 Renew(rslt,retlen+1+2*expand,char);
1492 *(cp1++) = *(cp3++);
1493 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1497 else if ( *cp2 == '.') {
1498 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1499 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1505 for (; cp2 <= dirend; cp2++) {
1508 if (*(cp2+1) == '[') cp2++;
1510 else if (*cp2 == ']' || *cp2 == '>') {
1511 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1513 else if (*cp2 == '.') {
1515 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1516 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1517 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1518 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1519 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1521 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1522 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1526 else if (*cp2 == '-') {
1527 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1528 while (*cp2 == '-') {
1530 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1532 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1533 if (ts) Safefree(rslt); /* filespecs like */
1534 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1538 else *(cp1++) = *cp2;
1540 else *(cp1++) = *cp2;
1542 while (*cp2) *(cp1++) = *(cp2++);
1547 } /* end of do_tounixspec() */
1549 /* External entry points */
1550 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1551 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1553 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1554 static char *do_tovmsspec(char *path, char *buf, int ts) {
1555 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1556 char *rslt, *dirend;
1557 register char *cp1, *cp2;
1558 unsigned long int infront = 0, hasdir = 1;
1560 if (path == NULL) return NULL;
1561 if (buf) rslt = buf;
1562 else if (ts) New(1316,rslt,strlen(path)+9,char);
1563 else rslt = __tovmsspec_retbuf;
1564 if (strpbrk(path,"]:>") ||
1565 (dirend = strrchr(path,'/')) == NULL) {
1566 if (path[0] == '.') {
1567 if (path[1] == '\0') strcpy(rslt,"[]");
1568 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1569 else strcpy(rslt,path); /* probably garbage */
1571 else strcpy(rslt,path);
1574 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1575 if (!*(dirend+2)) dirend +=2;
1576 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1577 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1582 char trndev[NAM$C_MAXRSS+1];
1586 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1588 if (!buf & ts) Renew(rslt,18,char);
1589 strcpy(rslt,"sys$disk:[000000]");
1592 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1594 islnm = my_trnlnm(rslt,trndev,0);
1595 trnend = islnm ? strlen(trndev) - 1 : 0;
1596 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1597 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1598 /* If the first element of the path is a logical name, determine
1599 * whether it has to be translated so we can add more directories. */
1600 if (!islnm || rooted) {
1603 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1607 if (cp2 != dirend) {
1608 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1609 strcpy(rslt,trndev);
1610 cp1 = rslt + trnend;
1623 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1624 cp2 += 2; /* skip over "./" - it's redundant */
1625 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1627 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1628 *(cp1++) = '-'; /* "../" --> "-" */
1631 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1632 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1633 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1634 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1637 if (cp2 > dirend) cp2 = dirend;
1639 else *(cp1++) = '.';
1641 for (; cp2 < dirend; cp2++) {
1643 if (*(cp2-1) == '/') continue;
1644 if (*(cp1-1) != '.') *(cp1++) = '.';
1647 else if (!infront && *cp2 == '.') {
1648 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1649 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1650 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1651 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1652 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1653 else { /* back up over previous directory name */
1655 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1656 if (*(cp1-1) == '[') {
1657 memcpy(cp1,"000000.",7);
1662 if (cp2 == dirend) break;
1664 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1665 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1666 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1667 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1669 *(cp1++) = '.'; /* Simulate trailing '/' */
1670 cp2 += 2; /* for loop will incr this to == dirend */
1672 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1674 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1677 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1678 if (*cp2 == '.') *(cp1++) = '_';
1679 else *(cp1++) = *cp2;
1683 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1684 if (hasdir) *(cp1++) = ']';
1685 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1686 while (*cp2) *(cp1++) = *(cp2++);
1691 } /* end of do_tovmsspec() */
1693 /* External entry points */
1694 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1695 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1697 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1698 static char *do_tovmspath(char *path, char *buf, int ts) {
1699 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1701 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1703 if (path == NULL) return NULL;
1704 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1705 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1706 if (buf) return buf;
1708 vmslen = strlen(vmsified);
1709 New(1317,cp,vmslen+1,char);
1710 memcpy(cp,vmsified,vmslen);
1715 strcpy(__tovmspath_retbuf,vmsified);
1716 return __tovmspath_retbuf;
1719 } /* end of do_tovmspath() */
1721 /* External entry points */
1722 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1723 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1726 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1727 static char *do_tounixpath(char *path, char *buf, int ts) {
1728 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1730 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1732 if (path == NULL) return NULL;
1733 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1734 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1735 if (buf) return buf;
1737 unixlen = strlen(unixified);
1738 New(1317,cp,unixlen+1,char);
1739 memcpy(cp,unixified,unixlen);
1744 strcpy(__tounixpath_retbuf,unixified);
1745 return __tounixpath_retbuf;
1748 } /* end of do_tounixpath() */
1750 /* External entry points */
1751 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1752 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1755 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1757 *****************************************************************************
1759 * Copyright (C) 1989-1994 by *
1760 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1762 * Permission is hereby granted for the reproduction of this software, *
1763 * on condition that this copyright notice is included in the reproduction, *
1764 * and that such reproduction is not for purposes of profit or material *
1767 * 27-Aug-1994 Modified for inclusion in perl5 *
1768 * by Charles Bailey bailey@genetics.upenn.edu *
1769 *****************************************************************************
1773 * getredirection() is intended to aid in porting C programs
1774 * to VMS (Vax-11 C). The native VMS environment does not support
1775 * '>' and '<' I/O redirection, or command line wild card expansion,
1776 * or a command line pipe mechanism using the '|' AND background
1777 * command execution '&'. All of these capabilities are provided to any
1778 * C program which calls this procedure as the first thing in the
1780 * The piping mechanism will probably work with almost any 'filter' type
1781 * of program. With suitable modification, it may useful for other
1782 * portability problems as well.
1784 * Author: Mark Pizzolato mark@infocomm.com
1788 struct list_item *next;
1792 static void add_item(struct list_item **head,
1793 struct list_item **tail,
1797 static void expand_wild_cards(char *item,
1798 struct list_item **head,
1799 struct list_item **tail,
1802 static int background_process(int argc, char **argv);
1804 static void pipe_and_fork(char **cmargv);
1806 /*{{{ void getredirection(int *ac, char ***av)*/
1808 getredirection(int *ac, char ***av)
1810 * Process vms redirection arg's. Exit if any error is seen.
1811 * If getredirection() processes an argument, it is erased
1812 * from the vector. getredirection() returns a new argc and argv value.
1813 * In the event that a background command is requested (by a trailing "&"),
1814 * this routine creates a background subprocess, and simply exits the program.
1816 * Warning: do not try to simplify the code for vms. The code
1817 * presupposes that getredirection() is called before any data is
1818 * read from stdin or written to stdout.
1820 * Normal usage is as follows:
1826 * getredirection(&argc, &argv);
1830 int argc = *ac; /* Argument Count */
1831 char **argv = *av; /* Argument Vector */
1832 char *ap; /* Argument pointer */
1833 int j; /* argv[] index */
1834 int item_count = 0; /* Count of Items in List */
1835 struct list_item *list_head = 0; /* First Item in List */
1836 struct list_item *list_tail; /* Last Item in List */
1837 char *in = NULL; /* Input File Name */
1838 char *out = NULL; /* Output File Name */
1839 char *outmode = "w"; /* Mode to Open Output File */
1840 char *err = NULL; /* Error File Name */
1841 char *errmode = "w"; /* Mode to Open Error File */
1842 int cmargc = 0; /* Piped Command Arg Count */
1843 char **cmargv = NULL;/* Piped Command Arg Vector */
1846 * First handle the case where the last thing on the line ends with
1847 * a '&'. This indicates the desire for the command to be run in a
1848 * subprocess, so we satisfy that desire.
1851 if (0 == strcmp("&", ap))
1852 exit(background_process(--argc, argv));
1853 if (*ap && '&' == ap[strlen(ap)-1])
1855 ap[strlen(ap)-1] = '\0';
1856 exit(background_process(argc, argv));
1859 * Now we handle the general redirection cases that involve '>', '>>',
1860 * '<', and pipes '|'.
1862 for (j = 0; j < argc; ++j)
1864 if (0 == strcmp("<", argv[j]))
1868 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1869 exit(LIB$_WRONUMARG);
1874 if ('<' == *(ap = argv[j]))
1879 if (0 == strcmp(">", ap))
1883 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1884 exit(LIB$_WRONUMARG);
1903 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1904 exit(LIB$_WRONUMARG);
1908 if (('2' == *ap) && ('>' == ap[1]))
1925 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1926 exit(LIB$_WRONUMARG);
1930 if (0 == strcmp("|", argv[j]))
1934 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1935 exit(LIB$_WRONUMARG);
1937 cmargc = argc-(j+1);
1938 cmargv = &argv[j+1];
1942 if ('|' == *(ap = argv[j]))
1950 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1953 * Allocate and fill in the new argument vector, Some Unix's terminate
1954 * the list with an extra null pointer.
1956 New(1302, argv, item_count+1, char *);
1958 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1959 argv[j] = list_head->value;
1965 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1966 exit(LIB$_INVARGORD);
1968 pipe_and_fork(cmargv);
1971 /* Check for input from a pipe (mailbox) */
1973 if (in == NULL && 1 == isapipe(0))
1975 char mbxname[L_tmpnam];
1977 long int dvi_item = DVI$_DEVBUFSIZ;
1978 $DESCRIPTOR(mbxnam, "");
1979 $DESCRIPTOR(mbxdevnam, "");
1981 /* Input from a pipe, reopen it in binary mode to disable */
1982 /* carriage control processing. */
1984 PerlIO_getname(stdin, mbxname);
1985 mbxnam.dsc$a_pointer = mbxname;
1986 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1987 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1988 mbxdevnam.dsc$a_pointer = mbxname;
1989 mbxdevnam.dsc$w_length = sizeof(mbxname);
1990 dvi_item = DVI$_DEVNAM;
1991 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1992 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1995 freopen(mbxname, "rb", stdin);
1998 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2002 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2004 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2007 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2009 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2014 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2016 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2020 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2025 #ifdef ARGPROC_DEBUG
2026 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2027 for (j = 0; j < *ac; ++j)
2028 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2030 /* Clear errors we may have hit expanding wildcards, so they don't
2031 show up in Perl's $! later */
2032 set_errno(0); set_vaxc_errno(1);
2033 } /* end of getredirection() */
2036 static void add_item(struct list_item **head,
2037 struct list_item **tail,
2043 New(1303,*head,1,struct list_item);
2047 New(1304,(*tail)->next,1,struct list_item);
2048 *tail = (*tail)->next;
2050 (*tail)->value = value;
2054 static void expand_wild_cards(char *item,
2055 struct list_item **head,
2056 struct list_item **tail,
2060 unsigned long int context = 0;
2066 char vmsspec[NAM$C_MAXRSS+1];
2067 $DESCRIPTOR(filespec, "");
2068 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2069 $DESCRIPTOR(resultspec, "");
2070 unsigned long int zero = 0, sts;
2072 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2074 add_item(head, tail, item, count);
2077 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2078 resultspec.dsc$b_class = DSC$K_CLASS_D;
2079 resultspec.dsc$a_pointer = NULL;
2080 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2081 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2082 if (!isunix || !filespec.dsc$a_pointer)
2083 filespec.dsc$a_pointer = item;
2084 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2086 * Only return version specs, if the caller specified a version
2088 had_version = strchr(item, ';');
2090 * Only return device and directory specs, if the caller specifed either.
2092 had_device = strchr(item, ':');
2093 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2095 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2096 &defaultspec, 0, 0, &zero))))
2101 New(1305,string,resultspec.dsc$w_length+1,char);
2102 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2103 string[resultspec.dsc$w_length] = '\0';
2104 if (NULL == had_version)
2105 *((char *)strrchr(string, ';')) = '\0';
2106 if ((!had_directory) && (had_device == NULL))
2108 if (NULL == (devdir = strrchr(string, ']')))
2109 devdir = strrchr(string, '>');
2110 strcpy(string, devdir + 1);
2113 * Be consistent with what the C RTL has already done to the rest of
2114 * the argv items and lowercase all of these names.
2116 for (c = string; *c; ++c)
2119 if (isunix) trim_unixpath(string,item,1);
2120 add_item(head, tail, string, count);
2123 if (sts != RMS$_NMF)
2125 set_vaxc_errno(sts);
2131 set_errno(ENOENT); break;
2133 set_errno(ENODEV); break;
2136 set_errno(EINVAL); break;
2138 set_errno(EACCES); break;
2140 _ckvmssts_noperl(sts);
2144 add_item(head, tail, item, count);
2145 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2146 _ckvmssts_noperl(lib$find_file_end(&context));
2149 static int child_st[2];/* Event Flag set when child process completes */
2151 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2153 static unsigned long int exit_handler(int *status)
2157 if (0 == child_st[0])
2159 #ifdef ARGPROC_DEBUG
2160 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2162 fflush(stdout); /* Have to flush pipe for binary data to */
2163 /* terminate properly -- <tp@mccall.com> */
2164 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2165 sys$dassgn(child_chan);
2167 sys$synch(0, child_st);
2172 static void sig_child(int chan)
2174 #ifdef ARGPROC_DEBUG
2175 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2177 if (child_st[0] == 0)
2181 static struct exit_control_block exit_block =
2186 &exit_block.exit_status,
2190 static void pipe_and_fork(char **cmargv)
2193 $DESCRIPTOR(cmddsc, "");
2194 static char mbxname[64];
2195 $DESCRIPTOR(mbxdsc, mbxname);
2197 unsigned long int zero = 0, one = 1;
2199 strcpy(subcmd, cmargv[0]);
2200 for (j = 1; NULL != cmargv[j]; ++j)
2202 strcat(subcmd, " \"");
2203 strcat(subcmd, cmargv[j]);
2204 strcat(subcmd, "\"");
2206 cmddsc.dsc$a_pointer = subcmd;
2207 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2209 create_mbx(&child_chan,&mbxdsc);
2210 #ifdef ARGPROC_DEBUG
2211 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2212 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2214 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2215 0, &pid, child_st, &zero, sig_child,
2217 #ifdef ARGPROC_DEBUG
2218 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2220 sys$dclexh(&exit_block);
2221 if (NULL == freopen(mbxname, "wb", stdout))
2223 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2227 static int background_process(int argc, char **argv)
2229 char command[2048] = "$";
2230 $DESCRIPTOR(value, "");
2231 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2232 static $DESCRIPTOR(null, "NLA0:");
2233 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2235 $DESCRIPTOR(pidstr, "");
2237 unsigned long int flags = 17, one = 1, retsts;
2239 strcat(command, argv[0]);
2242 strcat(command, " \"");
2243 strcat(command, *(++argv));
2244 strcat(command, "\"");
2246 value.dsc$a_pointer = command;
2247 value.dsc$w_length = strlen(value.dsc$a_pointer);
2248 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2249 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2250 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2251 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2254 _ckvmssts_noperl(retsts);
2256 #ifdef ARGPROC_DEBUG
2257 PerlIO_printf(Perl_debug_log, "%s\n", command);
2259 sprintf(pidstring, "%08X", pid);
2260 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2261 pidstr.dsc$a_pointer = pidstring;
2262 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2263 lib$set_symbol(&pidsymbol, &pidstr);
2267 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2270 /* OS-specific initialization at image activation (not thread startup) */
2271 /* Older VAXC header files lack these constants */
2272 #ifndef JPI$_RIGHTS_SIZE
2273 # define JPI$_RIGHTS_SIZE 817
2275 #ifndef KGB$M_SUBSYSTEM
2276 # define KGB$M_SUBSYSTEM 0x8
2279 /*{{{void vms_image_init(int *, char ***)*/
2281 vms_image_init(int *argcp, char ***argvp)
2283 unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
2284 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2285 unsigned short int dummy, rlen;
2286 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2287 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2288 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2291 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2293 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2294 if (iprv[i]) { /* Running image installed with privs? */
2295 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2300 /* Rights identifiers might trigger tainting as well. */
2301 if (!add_taint && (rlen || rsz)) {
2302 while (rlen < rsz) {
2303 /* We didn't get all the identifiers on the first pass. Allocate a
2304 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2305 * were needed to hold all identifiers at time of last call; we'll
2306 * allocate that many unsigned long ints), and go back and get 'em.
2308 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2309 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2310 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2311 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2314 mask = jpilist[1].bufadr;
2315 /* Check attribute flags for each identifier (2nd longword); protected
2316 * subsystem identifiers trigger tainting.
2318 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2319 if (mask[i] & KGB$M_SUBSYSTEM) {
2324 if (mask != rlst) Safefree(mask);
2326 /* We need to use this hack to tell Perl it should run with tainting,
2327 * since its tainting flag may be part of the curinterp struct, which
2328 * hasn't been allocated when vms_image_init() is called.
2332 New(1320,newap,*argcp+2,char **);
2333 newap[0] = argvp[0];
2335 Copy(argvp[1],newap[2],*argcp-1,char **);
2336 /* We orphan the old argv, since we don't know where it's come from,
2337 * so we don't know how to free it.
2339 *argcp++; argvp = newap;
2341 getredirection(argcp,argvp);
2342 #if defined(USE_THREADS) && defined(__DECC)
2344 # include <reentrancy.h>
2345 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2354 * Trim Unix-style prefix off filespec, so it looks like what a shell
2355 * glob expansion would return (i.e. from specified prefix on, not
2356 * full path). Note that returned filespec is Unix-style, regardless
2357 * of whether input filespec was VMS-style or Unix-style.
2359 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2360 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2361 * vector of options; at present, only bit 0 is used, and if set tells
2362 * trim unixpath to try the current default directory as a prefix when
2363 * presented with a possibly ambiguous ... wildcard.
2365 * Returns !=0 on success, with trimmed filespec replacing contents of
2366 * fspec, and 0 on failure, with contents of fpsec unchanged.
2368 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2370 trim_unixpath(char *fspec, char *wildspec, int opts)
2372 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2373 *template, *base, *end, *cp1, *cp2;
2374 register int tmplen, reslen = 0, dirs = 0;
2376 if (!wildspec || !fspec) return 0;
2377 if (strpbrk(wildspec,"]>:") != NULL) {
2378 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2379 else template = unixwild;
2381 else template = wildspec;
2382 if (strpbrk(fspec,"]>:") != NULL) {
2383 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2384 else base = unixified;
2385 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2386 * check to see that final result fits into (isn't longer than) fspec */
2387 reslen = strlen(fspec);
2391 /* No prefix or absolute path on wildcard, so nothing to remove */
2392 if (!*template || *template == '/') {
2393 if (base == fspec) return 1;
2394 tmplen = strlen(unixified);
2395 if (tmplen > reslen) return 0; /* not enough space */
2396 /* Copy unixified resultant, including trailing NUL */
2397 memmove(fspec,unixified,tmplen+1);
2401 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2402 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2403 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2404 for (cp1 = end ;cp1 >= base; cp1--)
2405 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2407 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2411 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2412 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2413 int ells = 1, totells, segdirs, match;
2414 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2415 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2417 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2419 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2420 if (ellipsis == template && opts & 1) {
2421 /* Template begins with an ellipsis. Since we can't tell how many
2422 * directory names at the front of the resultant to keep for an
2423 * arbitrary starting point, we arbitrarily choose the current
2424 * default directory as a starting point. If it's there as a prefix,
2425 * clip it off. If not, fall through and act as if the leading
2426 * ellipsis weren't there (i.e. return shortest possible path that
2427 * could match template).
2429 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2430 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2431 if (_tolower(*cp1) != _tolower(*cp2)) break;
2432 segdirs = dirs - totells; /* Min # of dirs we must have left */
2433 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2434 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2435 memcpy(fspec,cp2+1,end - cp2);
2439 /* First off, back up over constant elements at end of path */
2441 for (front = end ; front >= base; front--)
2442 if (*front == '/' && !dirs--) { front++; break; }
2444 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2445 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2446 if (cp1 != '\0') return 0; /* Path too long. */
2448 *cp2 = '\0'; /* Pick up with memcpy later */
2449 lcfront = lcres + (front - base);
2450 /* Now skip over each ellipsis and try to match the path in front of it. */
2452 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2453 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2454 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2455 if (cp1 < template) break; /* template started with an ellipsis */
2456 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2457 ellipsis = cp1; continue;
2459 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2461 for (segdirs = 0, cp2 = tpl;
2462 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2464 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2465 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2466 if (*cp2 == '/') segdirs++;
2468 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2469 /* Back up at least as many dirs as in template before matching */
2470 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2471 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2472 for (match = 0; cp1 > lcres;) {
2473 resdsc.dsc$a_pointer = cp1;
2474 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2476 if (match == 1) lcfront = cp1;
2478 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2480 if (!match) return 0; /* Can't find prefix ??? */
2481 if (match > 1 && opts & 1) {
2482 /* This ... wildcard could cover more than one set of dirs (i.e.
2483 * a set of similar dir names is repeated). If the template
2484 * contains more than 1 ..., upstream elements could resolve the
2485 * ambiguity, but it's not worth a full backtracking setup here.
2486 * As a quick heuristic, clip off the current default directory
2487 * if it's present to find the trimmed spec, else use the
2488 * shortest string that this ... could cover.
2490 char def[NAM$C_MAXRSS+1], *st;
2492 if (getcwd(def, sizeof def,0) == NULL) return 0;
2493 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2494 if (_tolower(*cp1) != _tolower(*cp2)) break;
2495 segdirs = dirs - totells; /* Min # of dirs we must have left */
2496 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2497 if (*cp1 == '\0' && *cp2 == '/') {
2498 memcpy(fspec,cp2+1,end - cp2);
2501 /* Nope -- stick with lcfront from above and keep going. */
2504 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2509 } /* end of trim_unixpath() */
2514 * VMS readdir() routines.
2515 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2517 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2518 * Minor modifications to original routines.
2521 /* Number of elements in vms_versions array */
2522 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2525 * Open a directory, return a handle for later use.
2527 /*{{{ DIR *opendir(char*name) */
2532 char dir[NAM$C_MAXRSS+1];
2535 if (do_tovmspath(name,dir,0) == NULL) {
2538 if (flex_stat(dir,&sb) == -1) return NULL;
2539 if (!S_ISDIR(sb.st_mode)) {
2540 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2543 if (!cando_by_name(S_IRUSR,0,dir)) {
2544 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2547 /* Get memory for the handle, and the pattern. */
2549 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2551 /* Fill in the fields; mainly playing with the descriptor. */
2552 (void)sprintf(dd->pattern, "%s*.*",dir);
2555 dd->vms_wantversions = 0;
2556 dd->pat.dsc$a_pointer = dd->pattern;
2557 dd->pat.dsc$w_length = strlen(dd->pattern);
2558 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2559 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2562 } /* end of opendir() */
2566 * Set the flag to indicate we want versions or not.
2568 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2570 vmsreaddirversions(DIR *dd, int flag)
2572 dd->vms_wantversions = flag;
2577 * Free up an opened directory.
2579 /*{{{ void closedir(DIR *dd)*/
2583 (void)lib$find_file_end(&dd->context);
2584 Safefree(dd->pattern);
2585 Safefree((char *)dd);
2590 * Collect all the version numbers for the current file.
2596 struct dsc$descriptor_s pat;
2597 struct dsc$descriptor_s res;
2599 char *p, *text, buff[sizeof dd->entry.d_name];
2601 unsigned long context, tmpsts;
2603 /* Convenient shorthand. */
2606 /* Add the version wildcard, ignoring the "*.*" put on before */
2607 i = strlen(dd->pattern);
2608 New(1308,text,i + e->d_namlen + 3,char);
2609 (void)strcpy(text, dd->pattern);
2610 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2612 /* Set up the pattern descriptor. */
2613 pat.dsc$a_pointer = text;
2614 pat.dsc$w_length = i + e->d_namlen - 1;
2615 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2616 pat.dsc$b_class = DSC$K_CLASS_S;
2618 /* Set up result descriptor. */
2619 res.dsc$a_pointer = buff;
2620 res.dsc$w_length = sizeof buff - 2;
2621 res.dsc$b_dtype = DSC$K_DTYPE_T;
2622 res.dsc$b_class = DSC$K_CLASS_S;
2624 /* Read files, collecting versions. */
2625 for (context = 0, e->vms_verscount = 0;
2626 e->vms_verscount < VERSIZE(e);
2627 e->vms_verscount++) {
2628 tmpsts = lib$find_file(&pat, &res, &context);
2629 if (tmpsts == RMS$_NMF || context == 0) break;
2631 buff[sizeof buff - 1] = '\0';
2632 if ((p = strchr(buff, ';')))
2633 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2635 e->vms_versions[e->vms_verscount] = -1;
2638 _ckvmssts(lib$find_file_end(&context));
2641 } /* end of collectversions() */
2644 * Read the next entry from the directory.
2646 /*{{{ struct dirent *readdir(DIR *dd)*/
2650 struct dsc$descriptor_s res;
2651 char *p, buff[sizeof dd->entry.d_name];
2652 unsigned long int tmpsts;
2654 /* Set up result descriptor, and get next file. */
2655 res.dsc$a_pointer = buff;
2656 res.dsc$w_length = sizeof buff - 2;
2657 res.dsc$b_dtype = DSC$K_DTYPE_T;
2658 res.dsc$b_class = DSC$K_CLASS_S;
2659 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2660 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2661 if (!(tmpsts & 1)) {
2662 set_vaxc_errno(tmpsts);
2665 set_errno(EACCES); break;
2667 set_errno(ENODEV); break;
2670 set_errno(ENOENT); break;
2677 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2678 buff[sizeof buff - 1] = '\0';
2679 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2682 /* Skip any directory component and just copy the name. */
2683 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2684 else (void)strcpy(dd->entry.d_name, buff);
2686 /* Clobber the version. */
2687 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2689 dd->entry.d_namlen = strlen(dd->entry.d_name);
2690 dd->entry.vms_verscount = 0;
2691 if (dd->vms_wantversions) collectversions(dd);
2694 } /* end of readdir() */
2698 * Return something that can be used in a seekdir later.
2700 /*{{{ long telldir(DIR *dd)*/
2709 * Return to a spot where we used to be. Brute force.
2711 /*{{{ void seekdir(DIR *dd,long count)*/
2713 seekdir(DIR *dd, long count)
2715 int vms_wantversions;
2717 /* If we haven't done anything yet... */
2721 /* Remember some state, and clear it. */
2722 vms_wantversions = dd->vms_wantversions;
2723 dd->vms_wantversions = 0;
2724 _ckvmssts(lib$find_file_end(&dd->context));
2727 /* The increment is in readdir(). */
2728 for (dd->count = 0; dd->count < count; )
2731 dd->vms_wantversions = vms_wantversions;
2733 } /* end of seekdir() */
2736 /* VMS subprocess management
2738 * my_vfork() - just a vfork(), after setting a flag to record that
2739 * the current script is trying a Unix-style fork/exec.
2741 * vms_do_aexec() and vms_do_exec() are called in response to the
2742 * perl 'exec' function. If this follows a vfork call, then they
2743 * call out the the regular perl routines in doio.c which do an
2744 * execvp (for those who really want to try this under VMS).
2745 * Otherwise, they do exactly what the perl docs say exec should
2746 * do - terminate the current script and invoke a new command
2747 * (See below for notes on command syntax.)
2749 * do_aspawn() and do_spawn() implement the VMS side of the perl
2750 * 'system' function.
2752 * Note on command arguments to perl 'exec' and 'system': When handled
2753 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2754 * are concatenated to form a DCL command string. If the first arg
2755 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2756 * the the command string is hrnded off to DCL directly. Otherwise,
2757 * the first token of the command is taken as the filespec of an image
2758 * to run. The filespec is expanded using a default type of '.EXE' and
2759 * the process defaults for device, directory, etc., and the resultant
2760 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2761 * the command string as parameters. This is perhaps a bit compicated,
2762 * but I hope it will form a happy medium between what VMS folks expect
2763 * from lib$spawn and what Unix folks expect from exec.
2766 static int vfork_called;
2768 /*{{{int my_vfork()*/
2778 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2786 if (VMScmd.dsc$a_pointer) {
2787 Safefree(VMScmd.dsc$a_pointer);
2788 VMScmd.dsc$w_length = 0;
2789 VMScmd.dsc$a_pointer = Nullch;
2794 setup_argstr(SV *really, SV **mark, SV **sp)
2797 char *junk, *tmps = Nullch;
2798 register size_t cmdlen = 0;
2804 tmps = SvPV(really,rlen);
2811 for (idx++; idx <= sp; idx++) {
2813 junk = SvPVx(*idx,rlen);
2814 cmdlen += rlen ? rlen + 1 : 0;
2817 New(401,Cmd,cmdlen+1,char);
2819 if (tmps && *tmps) {
2824 while (++mark <= sp) {
2827 strcat(Cmd,SvPVx(*mark,na));
2832 } /* end of setup_argstr() */
2835 static unsigned long int
2836 setup_cmddsc(char *cmd, int check_img)
2838 char resspec[NAM$C_MAXRSS+1];
2839 $DESCRIPTOR(defdsc,".EXE");
2840 $DESCRIPTOR(resdsc,resspec);
2841 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2842 unsigned long int cxt = 0, flags = 1, retsts;
2843 register char *s, *rest, *cp;
2844 register int isdcl = 0;
2847 while (*s && isspace(*s)) s++;
2849 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2850 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2851 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2852 if (*cp == ':' || *cp == '[' || *cp == '<') {
2860 if (isdcl) { /* It's a DCL command, just do it. */
2861 VMScmd.dsc$w_length = strlen(cmd);
2863 VMScmd.dsc$a_pointer = Cmd;
2864 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2866 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2868 else { /* assume first token is an image spec */
2870 while (*s && !isspace(*s)) s++;
2872 imgdsc.dsc$a_pointer = cmd;
2873 imgdsc.dsc$w_length = s - cmd;
2874 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2875 if (!(retsts & 1)) {
2876 /* just hand off status values likely to be due to user error */
2877 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2878 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2879 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2880 else { _ckvmssts(retsts); }
2883 _ckvmssts(lib$find_file_end(&cxt));
2885 while (*s && !isspace(*s)) s++;
2887 if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
2888 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2889 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2890 strcat(VMScmd.dsc$a_pointer,resspec);
2891 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2892 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2896 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2898 } /* end of setup_cmddsc() */
2901 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2903 vms_do_aexec(SV *really,SV **mark,SV **sp)
2907 if (vfork_called) { /* this follows a vfork - act Unixish */
2909 if (vfork_called < 0) {
2910 warn("Internal inconsistency in tracking vforks");
2913 else return do_aexec(really,mark,sp);
2915 /* no vfork - act VMSish */
2916 return vms_do_exec(setup_argstr(really,mark,sp));
2921 } /* end of vms_do_aexec() */
2924 /* {{{bool vms_do_exec(char *cmd) */
2926 vms_do_exec(char *cmd)
2929 if (vfork_called) { /* this follows a vfork - act Unixish */
2931 if (vfork_called < 0) {
2932 warn("Internal inconsistency in tracking vforks");
2935 else return do_exec(cmd);
2938 { /* no vfork - act VMSish */
2939 unsigned long int retsts;
2942 TAINT_PROPER("exec");
2943 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2944 retsts = lib$do_command(&VMScmd);
2948 set_errno(ENOENT); break;
2949 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
2950 set_errno(ENOTDIR); break;
2952 set_errno(EACCES); break;
2954 set_errno(EINVAL); break;
2956 set_errno(E2BIG); break;
2957 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2958 _ckvmssts(retsts); /* fall through */
2959 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2962 set_vaxc_errno(retsts);
2964 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2970 } /* end of vms_do_exec() */
2973 unsigned long int do_spawn(char *);
2975 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
2977 do_aspawn(void *really,void **mark,void **sp)
2980 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
2983 } /* end of do_aspawn() */
2986 /* {{{unsigned long int do_spawn(char *cmd) */
2990 unsigned long int sts, substs, hadcmd = 1;
2993 TAINT_PROPER("spawn");
2994 if (!cmd || !*cmd) {
2996 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
2998 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
2999 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3005 set_errno(ENOENT); break;
3006 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3007 set_errno(ENOTDIR); break;
3009 set_errno(EACCES); break;
3011 set_errno(EINVAL); break;
3013 set_errno(E2BIG); break;
3014 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3015 _ckvmssts(sts); /* fall through */
3016 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3019 set_vaxc_errno(sts);
3021 warn("Can't spawn \"%s\": %s",
3022 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
3027 } /* end of do_spawn() */
3031 * A simple fwrite replacement which outputs itmsz*nitm chars without
3032 * introducing record boundaries every itmsz chars.
3034 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3036 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3038 register char *cp, *end;
3040 end = (char *)src + itmsz * nitm;
3042 while ((char *)src <= end) {
3043 for (cp = src; cp <= end; cp++) if (!*cp) break;
3044 if (fputs(src,dest) == EOF) return EOF;
3046 if (fputc('\0',dest) == EOF) return EOF;
3052 } /* end of my_fwrite() */
3055 /*{{{ int my_flush(FILE *fp)*/
3060 if ((res = fflush(fp)) == 0) {
3061 #ifdef VMS_DO_SOCKETS
3063 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3065 res = fsync(fileno(fp));
3072 * Here are replacements for the following Unix routines in the VMS environment:
3073 * getpwuid Get information for a particular UIC or UID
3074 * getpwnam Get information for a named user
3075 * getpwent Get information for each user in the rights database
3076 * setpwent Reset search to the start of the rights database
3077 * endpwent Finish searching for users in the rights database
3079 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3080 * (defined in pwd.h), which contains the following fields:-
3082 * char *pw_name; Username (in lower case)
3083 * char *pw_passwd; Hashed password
3084 * unsigned int pw_uid; UIC
3085 * unsigned int pw_gid; UIC group number
3086 * char *pw_unixdir; Default device/directory (VMS-style)
3087 * char *pw_gecos; Owner name
3088 * char *pw_dir; Default device/directory (Unix-style)
3089 * char *pw_shell; Default CLI name (eg. DCL)
3091 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3093 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3094 * not the UIC member number (eg. what's returned by getuid()),
3095 * getpwuid() can accept either as input (if uid is specified, the caller's
3096 * UIC group is used), though it won't recognise gid=0.
3098 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3099 * information about other users in your group or in other groups, respectively.
3100 * If the required privilege is not available, then these routines fill only
3101 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3104 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3107 /* sizes of various UAF record fields */
3108 #define UAI$S_USERNAME 12
3109 #define UAI$S_IDENT 31
3110 #define UAI$S_OWNER 31
3111 #define UAI$S_DEFDEV 31
3112 #define UAI$S_DEFDIR 63
3113 #define UAI$S_DEFCLI 31
3116 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3117 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3118 (uic).uic$v_group != UIC$K_WILD_GROUP)
3120 static char __empty[]= "";
3121 static struct passwd __passwd_empty=
3122 {(char *) __empty, (char *) __empty, 0, 0,
3123 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3124 static int contxt= 0;
3125 static struct passwd __pwdcache;
3126 static char __pw_namecache[UAI$S_IDENT+1];
3129 * This routine does most of the work extracting the user information.
3131 static int fillpasswd (const char *name, struct passwd *pwd)
3134 unsigned char length;
3135 char pw_gecos[UAI$S_OWNER+1];
3137 static union uicdef uic;
3139 unsigned char length;
3140 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3143 unsigned char length;
3144 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3147 unsigned char length;
3148 char pw_shell[UAI$S_DEFCLI+1];
3150 static char pw_passwd[UAI$S_PWD+1];
3152 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3153 struct dsc$descriptor_s name_desc;
3154 unsigned long int sts;
3156 static struct itmlst_3 itmlst[]= {
3157 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3158 {sizeof(uic), UAI$_UIC, &uic, &luic},
3159 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3160 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3161 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3162 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3163 {0, 0, NULL, NULL}};
3165 name_desc.dsc$w_length= strlen(name);
3166 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3167 name_desc.dsc$b_class= DSC$K_CLASS_S;
3168 name_desc.dsc$a_pointer= (char *) name;
3170 /* Note that sys$getuai returns many fields as counted strings. */
3171 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3172 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3173 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3175 else { _ckvmssts(sts); }
3176 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3178 if ((int) owner.length < lowner) lowner= (int) owner.length;
3179 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3180 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3181 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3182 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3183 owner.pw_gecos[lowner]= '\0';
3184 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3185 defcli.pw_shell[ldefcli]= '\0';
3186 if (valid_uic(uic)) {
3187 pwd->pw_uid= uic.uic$l_uic;
3188 pwd->pw_gid= uic.uic$v_group;
3191 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3192 pwd->pw_passwd= pw_passwd;
3193 pwd->pw_gecos= owner.pw_gecos;
3194 pwd->pw_dir= defdev.pw_dir;
3195 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3196 pwd->pw_shell= defcli.pw_shell;
3197 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3199 ldir= strlen(pwd->pw_unixdir) - 1;
3200 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3203 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3204 __mystrtolower(pwd->pw_unixdir);
3209 * Get information for a named user.
3211 /*{{{struct passwd *getpwnam(char *name)*/
3212 struct passwd *my_getpwnam(char *name)
3214 struct dsc$descriptor_s name_desc;
3216 unsigned long int status, sts;
3218 __pwdcache = __passwd_empty;
3219 if (!fillpasswd(name, &__pwdcache)) {
3220 /* We still may be able to determine pw_uid and pw_gid */
3221 name_desc.dsc$w_length= strlen(name);
3222 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3223 name_desc.dsc$b_class= DSC$K_CLASS_S;
3224 name_desc.dsc$a_pointer= (char *) name;
3225 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3226 __pwdcache.pw_uid= uic.uic$l_uic;
3227 __pwdcache.pw_gid= uic.uic$v_group;
3230 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3231 set_vaxc_errno(sts);
3232 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3235 else { _ckvmssts(sts); }
3238 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3239 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3240 __pwdcache.pw_name= __pw_namecache;
3242 } /* end of my_getpwnam() */
3246 * Get information for a particular UIC or UID.
3247 * Called by my_getpwent with uid=-1 to list all users.
3249 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3250 struct passwd *my_getpwuid(Uid_t uid)
3252 const $DESCRIPTOR(name_desc,__pw_namecache);
3253 unsigned short lname;
3255 unsigned long int status;
3257 if (uid == (unsigned int) -1) {
3259 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3260 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3261 set_vaxc_errno(status);
3262 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3266 else { _ckvmssts(status); }
3267 } while (!valid_uic (uic));
3271 if (!uic.uic$v_group)
3272 uic.uic$v_group= getgid();
3274 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3275 else status = SS$_IVIDENT;
3276 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3277 status == RMS$_PRV) {
3278 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3281 else { _ckvmssts(status); }
3283 __pw_namecache[lname]= '\0';
3284 __mystrtolower(__pw_namecache);
3286 __pwdcache = __passwd_empty;
3287 __pwdcache.pw_name = __pw_namecache;
3289 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3290 The identifier's value is usually the UIC, but it doesn't have to be,
3291 so if we can, we let fillpasswd update this. */
3292 __pwdcache.pw_uid = uic.uic$l_uic;
3293 __pwdcache.pw_gid = uic.uic$v_group;
3295 fillpasswd(__pw_namecache, &__pwdcache);
3298 } /* end of my_getpwuid() */
3302 * Get information for next user.
3304 /*{{{struct passwd *my_getpwent()*/
3305 struct passwd *my_getpwent()
3307 return (my_getpwuid((unsigned int) -1));
3312 * Finish searching rights database for users.
3314 /*{{{void my_endpwent()*/
3318 _ckvmssts(sys$finish_rdb(&contxt));
3324 #ifdef HOMEGROWN_POSIX_SIGNALS
3325 /* Signal handling routines, pulled into the core from POSIX.xs.
3327 * We need these for threads, so they've been rolled into the core,
3328 * rather than left in POSIX.xs.
3330 * (DRS, Oct 23, 1997)
3333 /* sigset_t is atomic under VMS, so these routines are easy */
3334 /*{{{int my_sigemptyset(sigset_t *) */
3335 int my_sigemptyset(sigset_t *set) {
3336 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3342 /*{{{int my_sigfillset(sigset_t *)*/
3343 int my_sigfillset(sigset_t *set) {
3345 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3346 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3352 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3353 int my_sigaddset(sigset_t *set, int sig) {
3354 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3355 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3356 *set |= (1 << (sig - 1));
3362 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3363 int my_sigdelset(sigset_t *set, int sig) {
3364 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3365 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3366 *set &= ~(1 << (sig - 1));
3372 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3373 int my_sigismember(sigset_t *set, int sig) {
3374 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3375 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3376 *set & (1 << (sig - 1));
3381 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3382 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3385 /* If set and oset are both null, then things are badly wrong. Bail out. */
3386 if ((oset == NULL) && (set == NULL)) {
3387 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3391 /* If set's null, then we're just handling a fetch. */
3393 tempmask = sigblock(0);
3398 tempmask = sigsetmask(*set);
3401 tempmask = sigblock(*set);
3404 tempmask = sigblock(0);
3405 sigsetmask(*oset & ~tempmask);
3408 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3413 /* Did they pass us an oset? If so, stick our holding mask into it */
3420 #endif /* HOMEGROWN_POSIX_SIGNALS */
3423 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3424 * my_utime(), and flex_stat(), all of which operate on UTC unless
3425 * VMSISH_TIMES is true.
3427 /* method used to handle UTC conversions:
3428 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3430 static int gmtime_emulation_type;
3431 /* number of secs to add to UTC POSIX-style time to get local time */
3432 static long int utc_offset_secs;
3434 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3435 * in vmsish.h. #undef them here so we can call the CRTL routines
3442 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3443 # define RTL_USES_UTC 1
3446 static time_t toutc_dst(time_t loc) {
3449 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3450 loc -= utc_offset_secs;
3451 if (rsltmp->tm_isdst) loc -= 3600;
3454 #define _toutc(secs) ((secs) == -1 ? -1 : \
3455 ((gmtime_emulation_type || my_time(NULL)), \
3456 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3457 ((secs) - utc_offset_secs))))
3459 static time_t toloc_dst(time_t utc) {
3462 utc += utc_offset_secs;
3463 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3464 if (rsltmp->tm_isdst) utc += 3600;
3467 #define _toloc(secs) ((secs) == -1 ? -1 : \
3468 ((gmtime_emulation_type || my_time(NULL)), \
3469 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3470 ((secs) + utc_offset_secs))))
3473 /* my_time(), my_localtime(), my_gmtime()
3474 * By default traffic in UTC time values, using CRTL gmtime() or
3475 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3476 * Note: We need to use these functions even when the CRTL has working
3477 * UTC support, since they also handle C<use vmsish qw(times);>
3479 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3480 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3483 /*{{{time_t my_time(time_t *timep)*/
3484 time_t my_time(time_t *timep)
3490 if (gmtime_emulation_type == 0) {
3492 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3493 /* results of calls to gmtime() and localtime() */
3494 /* for same &base */
3496 gmtime_emulation_type++;
3497 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3500 gmtime_emulation_type++;
3501 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3502 gmtime_emulation_type++;
3503 warn("no UTC offset information; assuming local time is UTC");
3505 else { utc_offset_secs = atol(off); }
3507 else { /* We've got a working gmtime() */
3508 struct tm gmt, local;
3511 tm_p = localtime(&base);
3513 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3514 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3515 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3516 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3522 # ifdef RTL_USES_UTC
3523 if (VMSISH_TIME) when = _toloc(when);
3525 if (!VMSISH_TIME) when = _toutc(when);
3528 if (timep != NULL) *timep = when;
3531 } /* end of my_time() */
3535 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3537 my_gmtime(const time_t *timep)
3544 if (timep == NULL) {
3545 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3548 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3552 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
3554 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
3555 return gmtime(&when);
3557 /* CRTL localtime() wants local time as input, so does no tz correction */
3558 rsltmp = localtime(&when);
3559 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
3562 } /* end of my_gmtime() */
3566 /*{{{struct tm *my_localtime(const time_t *timep)*/
3568 my_localtime(const time_t *timep)
3574 if (timep == NULL) {
3575 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3578 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3579 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3582 # ifdef RTL_USES_UTC
3584 if (VMSISH_TIME) when = _toutc(when);
3586 /* CRTL localtime() wants UTC as input, does tz correction itself */
3587 return localtime(&when);
3590 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
3593 /* CRTL localtime() wants local time as input, so does no tz correction */
3594 rsltmp = localtime(&when);
3595 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
3598 } /* end of my_localtime() */
3601 /* Reset definitions for later calls */
3602 #define gmtime(t) my_gmtime(t)
3603 #define localtime(t) my_localtime(t)
3604 #define time(t) my_time(t)
3607 /* my_utime - update modification time of a file
3608 * calling sequence is identical to POSIX utime(), but under
3609 * VMS only the modification time is changed; ODS-2 does not
3610 * maintain access times. Restrictions differ from the POSIX
3611 * definition in that the time can be changed as long as the
3612 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3613 * no separate checks are made to insure that the caller is the
3614 * owner of the file or has special privs enabled.
3615 * Code here is based on Joe Meadows' FILE utility.
3618 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3619 * to VMS epoch (01-JAN-1858 00:00:00.00)
3620 * in 100 ns intervals.
3622 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3624 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3625 int my_utime(char *file, struct utimbuf *utimes)
3629 long int bintime[2], len = 2, lowbit, unixtime,
3630 secscale = 10000000; /* seconds --> 100 ns intervals */
3631 unsigned long int chan, iosb[2], retsts;
3632 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3633 struct FAB myfab = cc$rms_fab;
3634 struct NAM mynam = cc$rms_nam;
3635 #if defined (__DECC) && defined (__VAX)
3636 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3637 * at least through VMS V6.1, which causes a type-conversion warning.
3639 # pragma message save
3640 # pragma message disable cvtdiftypes
3642 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3643 struct fibdef myfib;
3644 #if defined (__DECC) && defined (__VAX)
3645 /* This should be right after the declaration of myatr, but due
3646 * to a bug in VAX DEC C, this takes effect a statement early.
3648 # pragma message restore
3650 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3651 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3652 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3654 if (file == NULL || *file == '\0') {
3656 set_vaxc_errno(LIB$_INVARG);
3659 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3661 if (utimes != NULL) {
3662 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3663 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3664 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3665 * as input, we force the sign bit to be clear by shifting unixtime right
3666 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3668 lowbit = (utimes->modtime & 1) ? secscale : 0;
3669 unixtime = (long int) utimes->modtime;
3671 /* If input was UTC; convert to local for sys svc */
3672 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
3674 unixtime >> 1; secscale << 1;
3675 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3676 if (!(retsts & 1)) {
3678 set_vaxc_errno(retsts);
3681 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3682 if (!(retsts & 1)) {
3684 set_vaxc_errno(retsts);
3689 /* Just get the current time in VMS format directly */
3690 retsts = sys$gettim(bintime);
3691 if (!(retsts & 1)) {
3693 set_vaxc_errno(retsts);
3698 myfab.fab$l_fna = vmsspec;
3699 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3700 myfab.fab$l_nam = &mynam;
3701 mynam.nam$l_esa = esa;
3702 mynam.nam$b_ess = (unsigned char) sizeof esa;
3703 mynam.nam$l_rsa = rsa;
3704 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3706 /* Look for the file to be affected, letting RMS parse the file
3707 * specification for us as well. I have set errno using only
3708 * values documented in the utime() man page for VMS POSIX.
3710 retsts = sys$parse(&myfab,0,0);
3711 if (!(retsts & 1)) {
3712 set_vaxc_errno(retsts);
3713 if (retsts == RMS$_PRV) set_errno(EACCES);
3714 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3715 else set_errno(EVMSERR);
3718 retsts = sys$search(&myfab,0,0);
3719 if (!(retsts & 1)) {
3720 set_vaxc_errno(retsts);
3721 if (retsts == RMS$_PRV) set_errno(EACCES);
3722 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3723 else set_errno(EVMSERR);
3727 devdsc.dsc$w_length = mynam.nam$b_dev;
3728 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3730 retsts = sys$assign(&devdsc,&chan,0,0);
3731 if (!(retsts & 1)) {
3732 set_vaxc_errno(retsts);
3733 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3734 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3735 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3736 else set_errno(EVMSERR);
3740 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3741 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3743 memset((void *) &myfib, 0, sizeof myfib);
3745 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3746 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3747 /* This prevents the revision time of the file being reset to the current
3748 * time as a result of our IO$_MODIFY $QIO. */
3749 myfib.fib$l_acctl = FIB$M_NORECORD;
3751 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3752 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3753 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3755 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3756 _ckvmssts(sys$dassgn(chan));
3757 if (retsts & 1) retsts = iosb[0];
3758 if (!(retsts & 1)) {
3759 set_vaxc_errno(retsts);
3760 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3761 else set_errno(EVMSERR);
3766 } /* end of my_utime() */
3770 * flex_stat, flex_fstat
3771 * basic stat, but gets it right when asked to stat
3772 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3775 /* encode_dev packs a VMS device name string into an integer to allow
3776 * simple comparisons. This can be used, for example, to check whether two
3777 * files are located on the same device, by comparing their encoded device
3778 * names. Even a string comparison would not do, because stat() reuses the
3779 * device name buffer for each call; so without encode_dev, it would be
3780 * necessary to save the buffer and use strcmp (this would mean a number of
3781 * changes to the standard Perl code, to say nothing of what a Perl script
3784 * The device lock id, if it exists, should be unique (unless perhaps compared
3785 * with lock ids transferred from other nodes). We have a lock id if the disk is
3786 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3787 * device names. Thus we use the lock id in preference, and only if that isn't
3788 * available, do we try to pack the device name into an integer (flagged by
3789 * the sign bit (LOCKID_MASK) being set).
3791 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3792 * name and its encoded form, but it seems very unlikely that we will find
3793 * two files on different disks that share the same encoded device names,
3794 * and even more remote that they will share the same file id (if the test
3795 * is to check for the same file).
3797 * A better method might be to use sys$device_scan on the first call, and to
3798 * search for the device, returning an index into the cached array.
3799 * The number returned would be more intelligable.
3800 * This is probably not worth it, and anyway would take quite a bit longer
3801 * on the first call.
3803 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3804 static mydev_t encode_dev (const char *dev)
3807 unsigned long int f;
3812 if (!dev || !dev[0]) return 0;
3816 struct dsc$descriptor_s dev_desc;
3817 unsigned long int status, lockid, item = DVI$_LOCKID;
3819 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3820 can try that first. */
3821 dev_desc.dsc$w_length = strlen (dev);
3822 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3823 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3824 dev_desc.dsc$a_pointer = (char *) dev;
3825 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3826 if (lockid) return (lockid & ~LOCKID_MASK);
3830 /* Otherwise we try to encode the device name */
3834 for (q = dev + strlen(dev); q--; q >= dev) {
3837 else if (isalpha (toupper (*q)))
3838 c= toupper (*q) - 'A' + (char)10;
3840 continue; /* Skip '$'s */
3842 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3844 enc += f * (unsigned long int) c;
3846 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3848 } /* end of encode_dev() */
3850 static char namecache[NAM$C_MAXRSS+1];
3853 is_null_device(name)
3856 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3857 The underscore prefix, controller letter, and unit number are
3858 independently optional; for our purposes, the colon punctuation
3859 is not. The colon can be trailed by optional directory and/or
3860 filename, but two consecutive colons indicates a nodename rather
3861 than a device. [pr] */
3862 if (*name == '_') ++name;
3863 if (tolower(*name++) != 'n') return 0;
3864 if (tolower(*name++) != 'l') return 0;
3865 if (tolower(*name) == 'a') ++name;
3866 if (*name == '0') ++name;
3867 return (*name++ == ':') && (*name != ':');
3870 /* Do the permissions allow some operation? Assumes statcache already set. */
3871 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3872 * subset of the applicable information.
3874 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3876 cando(I32 bit, I32 effective, Stat_t *statbufp)
3878 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3880 char fname[NAM$C_MAXRSS+1];
3881 unsigned long int retsts;
3882 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3883 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3885 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3886 device name on successive calls */
3887 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
3888 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
3889 namdsc.dsc$a_pointer = fname;
3890 namdsc.dsc$w_length = sizeof fname - 1;
3892 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
3893 &namdsc,&namdsc.dsc$w_length,0,0);
3895 fname[namdsc.dsc$w_length] = '\0';
3896 return cando_by_name(bit,effective,fname);
3898 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3899 warn("Can't get filespec - stale stat buffer?\n");
3903 return FALSE; /* Should never get to here */
3905 } /* end of cando() */
3909 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3911 cando_by_name(I32 bit, I32 effective, char *fname)
3913 static char usrname[L_cuserid];
3914 static struct dsc$descriptor_s usrdsc =
3915 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3916 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3917 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3918 unsigned short int retlen;
3919 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3920 union prvdef curprv;
3921 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3922 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3923 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3926 if (!fname || !*fname) return FALSE;
3927 /* Make sure we expand logical names, since sys$check_access doesn't */
3928 if (!strpbrk(fname,"/]>:")) {
3929 strcpy(fileified,fname);
3930 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3933 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3934 retlen = namdsc.dsc$w_length = strlen(vmsname);
3935 namdsc.dsc$a_pointer = vmsname;
3936 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3937 vmsname[retlen-1] == ':') {
3938 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3939 namdsc.dsc$w_length = strlen(fileified);
3940 namdsc.dsc$a_pointer = fileified;
3943 if (!usrdsc.dsc$w_length) {
3945 usrdsc.dsc$w_length = strlen(usrname);
3952 access = ARM$M_EXECUTE;
3957 access = ARM$M_READ;
3962 access = ARM$M_WRITE;
3967 access = ARM$M_DELETE;
3973 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3974 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3975 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
3976 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3977 set_vaxc_errno(retsts);
3978 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3979 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3980 else set_errno(ENOENT);
3983 if (retsts == SS$_NORMAL) {
3984 if (!privused) return TRUE;
3985 /* We can get access, but only by using privs. Do we have the
3986 necessary privs currently enabled? */
3987 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3988 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3989 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3990 !curprv.prv$v_bypass) return FALSE;
3991 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3992 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3993 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3998 return FALSE; /* Should never get here */
4000 } /* end of cando_by_name() */
4004 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4006 flex_fstat(int fd, Stat_t *statbufp)
4009 if (!fstat(fd,(stat_t *) statbufp)) {
4010 if (statbufp == (Stat_t *) &statcache) *namecache == '\0';
4011 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4012 # ifdef RTL_USES_UTC
4015 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4016 statbufp->st_atime = _toloc(statbufp->st_atime);
4017 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4022 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4026 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4027 statbufp->st_atime = _toutc(statbufp->st_atime);
4028 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4035 } /* end of flex_fstat() */
4038 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4040 flex_stat(char *fspec, Stat_t *statbufp)
4043 char fileified[NAM$C_MAXRSS+1];
4046 if (statbufp == (Stat_t *) &statcache)
4047 do_tovmsspec(fspec,namecache,0);
4048 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4049 memset(statbufp,0,sizeof *statbufp);
4050 statbufp->st_dev = encode_dev("_NLA0:");
4051 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4052 statbufp->st_uid = 0x00010001;
4053 statbufp->st_gid = 0x0001;
4054 time((time_t *)&statbufp->st_mtime);
4055 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4059 /* Try for a directory name first. If fspec contains a filename without
4060 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4061 * and sea:[wine.dark]water. exist, we prefer the directory here.
4062 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4063 * not sea:[wine.dark]., if the latter exists. If the intended target is
4064 * the file with null type, specify this by calling flex_stat() with
4065 * a '.' at the end of fspec.
4067 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4068 retval = stat(fileified,(stat_t *) statbufp);
4069 if (!retval && statbufp == (Stat_t *) &statcache)
4070 strcpy(namecache,fileified);
4072 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4074 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4075 # ifdef RTL_USES_UTC
4078 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4079 statbufp->st_atime = _toloc(statbufp->st_atime);
4080 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4085 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4089 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4090 statbufp->st_atime = _toutc(statbufp->st_atime);
4091 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4097 } /* end of flex_stat() */
4100 /* Insures that no carriage-control translation will be done on a file. */
4101 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
4103 my_binmode(FILE *fp, char iotype)
4105 char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
4106 int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
4109 if (!fgetname(fp,filespec)) return NULL;
4110 for (s = filespec; *s; s++) {
4111 if (*s == ':') colon = s;
4112 else if (*s == ']' || *s == '>') dirend = s;
4114 /* Looks like a tmpfile, which will go away if reopened */
4115 if (s == dirend + 3) return fp;
4116 /* If we've got a non-file-structured device, clip off the trailing
4117 * junk, and don't lose sleep if we can't get a stream position. */
4118 if (dirend == Nullch) *(colon+1) = '\0';
4119 if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
4121 case '<': case 'r': acmode = "rb"; break;
4123 /* use 'a' instead of 'w' to avoid creating new file;
4124 fsetpos below will take care of restoring file position */
4125 case 'a': acmode = "ab"; break;
4126 case '+': case '|': case 's': acmode = "rb+"; break;
4127 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
4129 warn("Unrecognized iotype %c in my_binmode",iotype);
4132 if (freopen(filespec,acmode,fp) == NULL) return NULL;
4133 if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
4134 if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
4136 } /* end of my_binmode() */
4140 /*{{{char *my_getlogin()*/
4141 /* VMS cuserid == Unix getlogin, except calling sequence */
4145 static char user[L_cuserid];
4146 return cuserid(user);
4151 /* rmscopy - copy a file using VMS RMS routines
4153 * Copies contents and attributes of spec_in to spec_out, except owner
4154 * and protection information. Name and type of spec_in are used as
4155 * defaults for spec_out. The third parameter specifies whether rmscopy()
4156 * should try to propagate timestamps from the input file to the output file.
4157 * If it is less than 0, no timestamps are preserved. If it is 0, then
4158 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4159 * propagated to the output file at creation iff the output file specification
4160 * did not contain an explicit name or type, and the revision date is always
4161 * updated at the end of the copy operation. If it is greater than 0, then
4162 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4163 * other than the revision date should be propagated, and bit 1 indicates
4164 * that the revision date should be propagated.
4166 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4168 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
4169 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4170 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4171 * as part of the Perl standard distribution under the terms of the
4172 * GNU General Public License or the Perl Artistic License. Copies
4173 * of each may be found in the Perl standard distribution.
4175 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4177 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4179 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4180 rsa[NAM$C_MAXRSS], ubf[32256];
4181 unsigned long int i, sts, sts2;
4182 struct FAB fab_in, fab_out;
4183 struct RAB rab_in, rab_out;
4185 struct XABDAT xabdat;
4186 struct XABFHC xabfhc;
4187 struct XABRDT xabrdt;
4188 struct XABSUM xabsum;
4190 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4191 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4192 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4196 fab_in = cc$rms_fab;
4197 fab_in.fab$l_fna = vmsin;
4198 fab_in.fab$b_fns = strlen(vmsin);
4199 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4200 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4201 fab_in.fab$l_fop = FAB$M_SQO;
4202 fab_in.fab$l_nam = &nam;
4203 fab_in.fab$l_xab = (void *) &xabdat;
4206 nam.nam$l_rsa = rsa;
4207 nam.nam$b_rss = sizeof(rsa);
4208 nam.nam$l_esa = esa;
4209 nam.nam$b_ess = sizeof (esa);
4210 nam.nam$b_esl = nam.nam$b_rsl = 0;
4212 xabdat = cc$rms_xabdat; /* To get creation date */
4213 xabdat.xab$l_nxt = (void *) &xabfhc;
4215 xabfhc = cc$rms_xabfhc; /* To get record length */
4216 xabfhc.xab$l_nxt = (void *) &xabsum;
4218 xabsum = cc$rms_xabsum; /* To get key and area information */
4220 if (!((sts = sys$open(&fab_in)) & 1)) {
4221 set_vaxc_errno(sts);
4225 set_errno(ENOENT); break;
4227 set_errno(ENODEV); break;
4229 set_errno(EINVAL); break;
4231 set_errno(EACCES); break;
4239 fab_out.fab$w_ifi = 0;
4240 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4241 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4242 fab_out.fab$l_fop = FAB$M_SQO;
4243 fab_out.fab$l_fna = vmsout;
4244 fab_out.fab$b_fns = strlen(vmsout);
4245 fab_out.fab$l_dna = nam.nam$l_name;
4246 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4248 if (preserve_dates == 0) { /* Act like DCL COPY */
4249 nam.nam$b_nop = NAM$M_SYNCHK;
4250 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4251 if (!((sts = sys$parse(&fab_out)) & 1)) {
4252 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4253 set_vaxc_errno(sts);
4256 fab_out.fab$l_xab = (void *) &xabdat;
4257 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4259 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4260 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4261 preserve_dates =0; /* bitmask from this point forward */
4263 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4264 if (!((sts = sys$create(&fab_out)) & 1)) {
4265 set_vaxc_errno(sts);
4268 set_errno(ENOENT); break;
4270 set_errno(ENODEV); break;
4272 set_errno(EINVAL); break;
4274 set_errno(EACCES); break;
4280 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4281 if (preserve_dates & 2) {
4282 /* sys$close() will process xabrdt, not xabdat */
4283 xabrdt = cc$rms_xabrdt;
4285 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4287 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4288 * is unsigned long[2], while DECC & VAXC use a struct */
4289 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4291 fab_out.fab$l_xab = (void *) &xabrdt;
4294 rab_in = cc$rms_rab;
4295 rab_in.rab$l_fab = &fab_in;
4296 rab_in.rab$l_rop = RAB$M_BIO;
4297 rab_in.rab$l_ubf = ubf;
4298 rab_in.rab$w_usz = sizeof ubf;
4299 if (!((sts = sys$connect(&rab_in)) & 1)) {
4300 sys$close(&fab_in); sys$close(&fab_out);
4301 set_errno(EVMSERR); set_vaxc_errno(sts);
4305 rab_out = cc$rms_rab;
4306 rab_out.rab$l_fab = &fab_out;
4307 rab_out.rab$l_rbf = ubf;
4308 if (!((sts = sys$connect(&rab_out)) & 1)) {
4309 sys$close(&fab_in); sys$close(&fab_out);
4310 set_errno(EVMSERR); set_vaxc_errno(sts);
4314 while ((sts = sys$read(&rab_in))) { /* always true */
4315 if (sts == RMS$_EOF) break;
4316 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4317 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4318 sys$close(&fab_in); sys$close(&fab_out);
4319 set_errno(EVMSERR); set_vaxc_errno(sts);
4324 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4325 sys$close(&fab_in); sys$close(&fab_out);
4326 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4328 set_errno(EVMSERR); set_vaxc_errno(sts);
4334 } /* end of rmscopy() */
4338 /*** The following glue provides 'hooks' to make some of the routines
4339 * from this file available from Perl. These routines are sufficiently
4340 * basic, and are required sufficiently early in the build process,
4341 * that's it's nice to have them available to miniperl as well as the
4342 * full Perl, so they're set up here instead of in an extension. The
4343 * Perl code which handles importation of these names into a given
4344 * package lives in [.VMS]Filespec.pm in @INC.
4348 rmsexpand_fromperl(CV *cv)
4351 char *fspec, *defspec = NULL, *rslt;
4353 if (!items || items > 2)
4354 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4355 fspec = SvPV(ST(0),na);
4356 if (!fspec || !*fspec) XSRETURN_UNDEF;
4357 if (items == 2) defspec = SvPV(ST(1),na);
4359 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4360 ST(0) = sv_newmortal();
4361 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4366 vmsify_fromperl(CV *cv)
4371 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4372 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4373 ST(0) = sv_newmortal();
4374 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4379 unixify_fromperl(CV *cv)
4384 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4385 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4386 ST(0) = sv_newmortal();
4387 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4392 fileify_fromperl(CV *cv)
4397 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4398 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4399 ST(0) = sv_newmortal();
4400 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4405 pathify_fromperl(CV *cv)
4410 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4411 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4412 ST(0) = sv_newmortal();
4413 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4418 vmspath_fromperl(CV *cv)
4423 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4424 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4425 ST(0) = sv_newmortal();
4426 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4431 unixpath_fromperl(CV *cv)
4436 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4437 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4438 ST(0) = sv_newmortal();
4439 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4444 candelete_fromperl(CV *cv)
4447 char fspec[NAM$C_MAXRSS+1], *fsp;
4451 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4453 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4454 if (SvTYPE(mysv) == SVt_PVGV) {
4455 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4456 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4463 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4464 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4470 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4475 rmscopy_fromperl(CV *cv)
4478 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4480 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4481 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4482 unsigned long int sts;
4486 if (items < 2 || items > 3)
4487 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4489 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4490 if (SvTYPE(mysv) == SVt_PVGV) {
4491 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4492 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4499 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4500 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4505 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4506 if (SvTYPE(mysv) == SVt_PVGV) {
4507 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4508 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4515 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4516 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4521 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4523 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4530 char* file = __FILE__;
4532 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4533 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4534 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4535 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4536 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4537 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4538 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4539 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4540 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);