3 * VMS-specific routines for perl5
5 * Last revised: 9-Nov-1997 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 (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1023 return do_tounixspec(trndir,buf,ts);
1026 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1028 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1029 /* Ditto for specs that end in an MFD -- let the VMS code
1030 * figure out whether it's a real device or a rooted logical. */
1031 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1032 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1033 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1034 return do_tounixspec(trndir,buf,ts);
1037 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1038 !(lastdir = cp1 = strrchr(dir,']')) &&
1039 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1040 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1042 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1043 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1044 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1045 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1046 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1047 (ver || *cp3)))))) {
1049 set_vaxc_errno(RMS$_DIR);
1055 /* If we lead off with a device or rooted logical, add the MFD
1056 if we're specifying a top-level directory. */
1057 if (lastdir && *dir == '/') {
1059 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1066 retlen = dirlen + (addmfd ? 13 : 6);
1067 if (buf) retspec = buf;
1068 else if (ts) New(1309,retspec,retlen+1,char);
1069 else retspec = __fileify_retbuf;
1071 dirlen = lastdir - dir;
1072 memcpy(retspec,dir,dirlen);
1073 strcpy(&retspec[dirlen],"/000000");
1074 strcpy(&retspec[dirlen+7],lastdir);
1077 memcpy(retspec,dir,dirlen);
1078 retspec[dirlen] = '\0';
1080 /* We've picked up everything up to the directory file name.
1081 Now just add the type and version, and we're set. */
1082 strcat(retspec,".dir;1");
1085 else { /* VMS-style directory spec */
1086 char esa[NAM$C_MAXRSS+1], term, *cp;
1087 unsigned long int sts, cmplen, haslower = 0;
1088 struct FAB dirfab = cc$rms_fab;
1089 struct NAM savnam, dirnam = cc$rms_nam;
1091 dirfab.fab$b_fns = strlen(dir);
1092 dirfab.fab$l_fna = dir;
1093 dirfab.fab$l_nam = &dirnam;
1094 dirfab.fab$l_dna = ".DIR;1";
1095 dirfab.fab$b_dns = 6;
1096 dirnam.nam$b_ess = NAM$C_MAXRSS;
1097 dirnam.nam$l_esa = esa;
1099 for (cp = dir; *cp; cp++)
1100 if (islower(*cp)) { haslower = 1; break; }
1101 if (!((sts = sys$parse(&dirfab))&1)) {
1102 if (dirfab.fab$l_sts == RMS$_DIR) {
1103 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1104 sts = sys$parse(&dirfab) & 1;
1108 set_vaxc_errno(dirfab.fab$l_sts);
1114 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1115 /* Yes; fake the fnb bits so we'll check type below */
1116 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1119 if (dirfab.fab$l_sts != RMS$_FNF) {
1121 set_vaxc_errno(dirfab.fab$l_sts);
1124 dirnam = savnam; /* No; just work with potential name */
1127 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1128 cp1 = strchr(esa,']');
1129 if (!cp1) cp1 = strchr(esa,'>');
1130 if (cp1) { /* Should always be true */
1131 dirnam.nam$b_esl -= cp1 - esa - 1;
1132 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1135 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1136 /* Yep; check version while we're at it, if it's there. */
1137 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1138 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1139 /* Something other than .DIR[;1]. Bzzt. */
1141 set_vaxc_errno(RMS$_DIR);
1145 esa[dirnam.nam$b_esl] = '\0';
1146 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1147 /* They provided at least the name; we added the type, if necessary, */
1148 if (buf) retspec = buf; /* in sys$parse() */
1149 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1150 else retspec = __fileify_retbuf;
1151 strcpy(retspec,esa);
1154 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1155 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1157 dirnam.nam$b_esl -= 9;
1159 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1160 if (cp1 == NULL) return NULL; /* should never happen */
1163 retlen = strlen(esa);
1164 if ((cp1 = strrchr(esa,'.')) != NULL) {
1165 /* There's more than one directory in the path. Just roll back. */
1167 if (buf) retspec = buf;
1168 else if (ts) New(1311,retspec,retlen+7,char);
1169 else retspec = __fileify_retbuf;
1170 strcpy(retspec,esa);
1173 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1174 /* Go back and expand rooted logical name */
1175 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1176 if (!(sys$parse(&dirfab) & 1)) {
1178 set_vaxc_errno(dirfab.fab$l_sts);
1181 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1182 if (buf) retspec = buf;
1183 else if (ts) New(1312,retspec,retlen+16,char);
1184 else retspec = __fileify_retbuf;
1185 cp1 = strstr(esa,"][");
1187 memcpy(retspec,esa,dirlen);
1188 if (!strncmp(cp1+2,"000000]",7)) {
1189 retspec[dirlen-1] = '\0';
1190 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1191 if (*cp1 == '.') *cp1 = ']';
1193 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1194 memcpy(cp1+1,"000000]",7);
1198 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1199 retspec[retlen] = '\0';
1200 /* Convert last '.' to ']' */
1201 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1202 if (*cp1 == '.') *cp1 = ']';
1204 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1205 memcpy(cp1+1,"000000]",7);
1209 else { /* This is a top-level dir. Add the MFD to the path. */
1210 if (buf) retspec = buf;
1211 else if (ts) New(1312,retspec,retlen+16,char);
1212 else retspec = __fileify_retbuf;
1215 while (*cp1 != ':') *(cp2++) = *(cp1++);
1216 strcpy(cp2,":[000000]");
1221 /* We've set up the string up through the filename. Add the
1222 type and version, and we're done. */
1223 strcat(retspec,".DIR;1");
1225 /* $PARSE may have upcased filespec, so convert output to lower
1226 * case if input contained any lowercase characters. */
1227 if (haslower) __mystrtolower(retspec);
1230 } /* end of do_fileify_dirspec() */
1232 /* External entry points */
1233 char *fileify_dirspec(char *dir, char *buf)
1234 { return do_fileify_dirspec(dir,buf,0); }
1235 char *fileify_dirspec_ts(char *dir, char *buf)
1236 { return do_fileify_dirspec(dir,buf,1); }
1238 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1239 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1241 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1242 unsigned long int retlen;
1243 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1245 if (!dir || !*dir) {
1246 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1249 if (*dir) strcpy(trndir,dir);
1250 else getcwd(trndir,sizeof trndir - 1);
1252 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1253 STRLEN trnlen = strlen(trndir);
1255 /* Trap simple rooted lnms, and return lnm:[000000] */
1256 if (!strcmp(trndir+trnlen-2,".]")) {
1257 if (buf) retpath = buf;
1258 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1259 else retpath = __pathify_retbuf;
1260 strcpy(retpath,dir);
1261 strcat(retpath,":[000000]");
1267 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1268 if (*dir == '.' && (*(dir+1) == '\0' ||
1269 (*(dir+1) == '.' && *(dir+2) == '\0')))
1270 retlen = 2 + (*(dir+1) != '\0');
1272 if ( !(cp1 = strrchr(dir,'/')) &&
1273 !(cp1 = strrchr(dir,']')) &&
1274 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1275 if ((cp2 = strchr(cp1,'.')) != NULL &&
1276 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1277 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1278 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1279 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1281 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1282 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1283 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1284 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1285 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1286 (ver || *cp3)))))) {
1288 set_vaxc_errno(RMS$_DIR);
1291 retlen = cp2 - dir + 1;
1293 else { /* No file type present. Treat the filename as a directory. */
1294 retlen = strlen(dir) + 1;
1297 if (buf) retpath = buf;
1298 else if (ts) New(1313,retpath,retlen+1,char);
1299 else retpath = __pathify_retbuf;
1300 strncpy(retpath,dir,retlen-1);
1301 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1302 retpath[retlen-1] = '/'; /* with '/', add it. */
1303 retpath[retlen] = '\0';
1305 else retpath[retlen-1] = '\0';
1307 else { /* VMS-style directory spec */
1308 char esa[NAM$C_MAXRSS+1], *cp;
1309 unsigned long int sts, cmplen, haslower;
1310 struct FAB dirfab = cc$rms_fab;
1311 struct NAM savnam, dirnam = cc$rms_nam;
1313 /* If we've got an explicit filename, we can just shuffle the string. */
1314 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1315 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1316 if ((cp2 = strchr(cp1,'.')) != NULL) {
1318 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1319 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1320 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1321 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1322 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1323 (ver || *cp3)))))) {
1325 set_vaxc_errno(RMS$_DIR);
1329 else { /* No file type, so just draw name into directory part */
1330 for (cp2 = cp1; *cp2; cp2++) ;
1333 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1335 /* We've now got a VMS 'path'; fall through */
1337 dirfab.fab$b_fns = strlen(dir);
1338 dirfab.fab$l_fna = dir;
1339 if (dir[dirfab.fab$b_fns-1] == ']' ||
1340 dir[dirfab.fab$b_fns-1] == '>' ||
1341 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1342 if (buf) retpath = buf;
1343 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1344 else retpath = __pathify_retbuf;
1345 strcpy(retpath,dir);
1348 dirfab.fab$l_dna = ".DIR;1";
1349 dirfab.fab$b_dns = 6;
1350 dirfab.fab$l_nam = &dirnam;
1351 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1352 dirnam.nam$l_esa = esa;
1354 for (cp = dir; *cp; cp++)
1355 if (islower(*cp)) { haslower = 1; break; }
1357 if (!(sts = (sys$parse(&dirfab)&1))) {
1358 if (dirfab.fab$l_sts == RMS$_DIR) {
1359 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1360 sts = sys$parse(&dirfab) & 1;
1364 set_vaxc_errno(dirfab.fab$l_sts);
1370 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1371 if (dirfab.fab$l_sts != RMS$_FNF) {
1373 set_vaxc_errno(dirfab.fab$l_sts);
1376 dirnam = savnam; /* No; just work with potential name */
1379 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1380 /* Yep; check version while we're at it, if it's there. */
1381 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1382 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1383 /* Something other than .DIR[;1]. Bzzt. */
1385 set_vaxc_errno(RMS$_DIR);
1389 /* OK, the type was fine. Now pull any file name into the
1391 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1393 cp1 = strrchr(esa,'>');
1394 *dirnam.nam$l_type = '>';
1397 *(dirnam.nam$l_type + 1) = '\0';
1398 retlen = dirnam.nam$l_type - esa + 2;
1399 if (buf) retpath = buf;
1400 else if (ts) New(1314,retpath,retlen,char);
1401 else retpath = __pathify_retbuf;
1402 strcpy(retpath,esa);
1403 /* $PARSE may have upcased filespec, so convert output to lower
1404 * case if input contained any lowercase characters. */
1405 if (haslower) __mystrtolower(retpath);
1409 } /* end of do_pathify_dirspec() */
1411 /* External entry points */
1412 char *pathify_dirspec(char *dir, char *buf)
1413 { return do_pathify_dirspec(dir,buf,0); }
1414 char *pathify_dirspec_ts(char *dir, char *buf)
1415 { return do_pathify_dirspec(dir,buf,1); }
1417 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1418 static char *do_tounixspec(char *spec, char *buf, int ts)
1420 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1421 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1422 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1424 if (spec == NULL) return NULL;
1425 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1426 if (buf) rslt = buf;
1428 retlen = strlen(spec);
1429 cp1 = strchr(spec,'[');
1430 if (!cp1) cp1 = strchr(spec,'<');
1432 for (cp1++; *cp1; cp1++) {
1433 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1434 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1435 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1438 New(1315,rslt,retlen+2+2*expand,char);
1440 else rslt = __tounixspec_retbuf;
1441 if (strchr(spec,'/') != NULL) {
1448 dirend = strrchr(spec,']');
1449 if (dirend == NULL) dirend = strrchr(spec,'>');
1450 if (dirend == NULL) dirend = strchr(spec,':');
1451 if (dirend == NULL) {
1455 if (*cp2 != '[' && *cp2 != '<') {
1458 else { /* the VMS spec begins with directories */
1460 if (*cp2 == ']' || *cp2 == '>') {
1461 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1464 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1465 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1466 if (ts) Safefree(rslt);
1471 while (*cp3 != ':' && *cp3) cp3++;
1473 if (strchr(cp3,']') != NULL) break;
1474 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1476 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1477 retlen = devlen + dirlen;
1478 Renew(rslt,retlen+1+2*expand,char);
1484 *(cp1++) = *(cp3++);
1485 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1489 else if ( *cp2 == '.') {
1490 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1491 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1497 for (; cp2 <= dirend; cp2++) {
1500 if (*(cp2+1) == '[') cp2++;
1502 else if (*cp2 == ']' || *cp2 == '>') {
1503 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1505 else if (*cp2 == '.') {
1507 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1508 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1509 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1510 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1511 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1513 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1514 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1518 else if (*cp2 == '-') {
1519 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1520 while (*cp2 == '-') {
1522 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1524 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1525 if (ts) Safefree(rslt); /* filespecs like */
1526 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1530 else *(cp1++) = *cp2;
1532 else *(cp1++) = *cp2;
1534 while (*cp2) *(cp1++) = *(cp2++);
1539 } /* end of do_tounixspec() */
1541 /* External entry points */
1542 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1543 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1545 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1546 static char *do_tovmsspec(char *path, char *buf, int ts) {
1547 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1548 char *rslt, *dirend;
1549 register char *cp1, *cp2;
1550 unsigned long int infront = 0, hasdir = 1;
1552 if (path == NULL) return NULL;
1553 if (buf) rslt = buf;
1554 else if (ts) New(1316,rslt,strlen(path)+9,char);
1555 else rslt = __tovmsspec_retbuf;
1556 if (strpbrk(path,"]:>") ||
1557 (dirend = strrchr(path,'/')) == NULL) {
1558 if (path[0] == '.') {
1559 if (path[1] == '\0') strcpy(rslt,"[]");
1560 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1561 else strcpy(rslt,path); /* probably garbage */
1563 else strcpy(rslt,path);
1566 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1567 if (!*(dirend+2)) dirend +=2;
1568 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1569 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1574 char trndev[NAM$C_MAXRSS+1];
1578 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1580 if (!buf & ts) Renew(rslt,18,char);
1581 strcpy(rslt,"sys$disk:[000000]");
1584 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1586 islnm = my_trnlnm(rslt,trndev,0);
1587 trnend = islnm ? strlen(trndev) - 1 : 0;
1588 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1589 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1590 /* If the first element of the path is a logical name, determine
1591 * whether it has to be translated so we can add more directories. */
1592 if (!islnm || rooted) {
1595 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1599 if (cp2 != dirend) {
1600 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1601 strcpy(rslt,trndev);
1602 cp1 = rslt + trnend;
1615 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1616 cp2 += 2; /* skip over "./" - it's redundant */
1617 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1619 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1620 *(cp1++) = '-'; /* "../" --> "-" */
1623 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1624 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1625 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1626 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1629 if (cp2 > dirend) cp2 = dirend;
1631 else *(cp1++) = '.';
1633 for (; cp2 < dirend; cp2++) {
1635 if (*(cp2-1) == '/') continue;
1636 if (*(cp1-1) != '.') *(cp1++) = '.';
1639 else if (!infront && *cp2 == '.') {
1640 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1641 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1642 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1643 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1644 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1645 else { /* back up over previous directory name */
1647 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1648 if (*(cp1-1) == '[') {
1649 memcpy(cp1,"000000.",7);
1654 if (cp2 == dirend) break;
1656 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1657 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1658 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1659 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1661 *(cp1++) = '.'; /* Simulate trailing '/' */
1662 cp2 += 2; /* for loop will incr this to == dirend */
1664 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1666 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1669 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1670 if (*cp2 == '.') *(cp1++) = '_';
1671 else *(cp1++) = *cp2;
1675 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1676 if (hasdir) *(cp1++) = ']';
1677 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1678 while (*cp2) *(cp1++) = *(cp2++);
1683 } /* end of do_tovmsspec() */
1685 /* External entry points */
1686 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1687 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1689 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1690 static char *do_tovmspath(char *path, char *buf, int ts) {
1691 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1693 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1695 if (path == NULL) return NULL;
1696 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1697 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1698 if (buf) return buf;
1700 vmslen = strlen(vmsified);
1701 New(1317,cp,vmslen+1,char);
1702 memcpy(cp,vmsified,vmslen);
1707 strcpy(__tovmspath_retbuf,vmsified);
1708 return __tovmspath_retbuf;
1711 } /* end of do_tovmspath() */
1713 /* External entry points */
1714 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1715 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1718 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1719 static char *do_tounixpath(char *path, char *buf, int ts) {
1720 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1722 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1724 if (path == NULL) return NULL;
1725 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1726 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1727 if (buf) return buf;
1729 unixlen = strlen(unixified);
1730 New(1317,cp,unixlen+1,char);
1731 memcpy(cp,unixified,unixlen);
1736 strcpy(__tounixpath_retbuf,unixified);
1737 return __tounixpath_retbuf;
1740 } /* end of do_tounixpath() */
1742 /* External entry points */
1743 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1744 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1747 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1749 *****************************************************************************
1751 * Copyright (C) 1989-1994 by *
1752 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1754 * Permission is hereby granted for the reproduction of this software, *
1755 * on condition that this copyright notice is included in the reproduction, *
1756 * and that such reproduction is not for purposes of profit or material *
1759 * 27-Aug-1994 Modified for inclusion in perl5 *
1760 * by Charles Bailey bailey@genetics.upenn.edu *
1761 *****************************************************************************
1765 * getredirection() is intended to aid in porting C programs
1766 * to VMS (Vax-11 C). The native VMS environment does not support
1767 * '>' and '<' I/O redirection, or command line wild card expansion,
1768 * or a command line pipe mechanism using the '|' AND background
1769 * command execution '&'. All of these capabilities are provided to any
1770 * C program which calls this procedure as the first thing in the
1772 * The piping mechanism will probably work with almost any 'filter' type
1773 * of program. With suitable modification, it may useful for other
1774 * portability problems as well.
1776 * Author: Mark Pizzolato mark@infocomm.com
1780 struct list_item *next;
1784 static void add_item(struct list_item **head,
1785 struct list_item **tail,
1789 static void expand_wild_cards(char *item,
1790 struct list_item **head,
1791 struct list_item **tail,
1794 static int background_process(int argc, char **argv);
1796 static void pipe_and_fork(char **cmargv);
1798 /*{{{ void getredirection(int *ac, char ***av)*/
1800 getredirection(int *ac, char ***av)
1802 * Process vms redirection arg's. Exit if any error is seen.
1803 * If getredirection() processes an argument, it is erased
1804 * from the vector. getredirection() returns a new argc and argv value.
1805 * In the event that a background command is requested (by a trailing "&"),
1806 * this routine creates a background subprocess, and simply exits the program.
1808 * Warning: do not try to simplify the code for vms. The code
1809 * presupposes that getredirection() is called before any data is
1810 * read from stdin or written to stdout.
1812 * Normal usage is as follows:
1818 * getredirection(&argc, &argv);
1822 int argc = *ac; /* Argument Count */
1823 char **argv = *av; /* Argument Vector */
1824 char *ap; /* Argument pointer */
1825 int j; /* argv[] index */
1826 int item_count = 0; /* Count of Items in List */
1827 struct list_item *list_head = 0; /* First Item in List */
1828 struct list_item *list_tail; /* Last Item in List */
1829 char *in = NULL; /* Input File Name */
1830 char *out = NULL; /* Output File Name */
1831 char *outmode = "w"; /* Mode to Open Output File */
1832 char *err = NULL; /* Error File Name */
1833 char *errmode = "w"; /* Mode to Open Error File */
1834 int cmargc = 0; /* Piped Command Arg Count */
1835 char **cmargv = NULL;/* Piped Command Arg Vector */
1838 * First handle the case where the last thing on the line ends with
1839 * a '&'. This indicates the desire for the command to be run in a
1840 * subprocess, so we satisfy that desire.
1843 if (0 == strcmp("&", ap))
1844 exit(background_process(--argc, argv));
1845 if (*ap && '&' == ap[strlen(ap)-1])
1847 ap[strlen(ap)-1] = '\0';
1848 exit(background_process(argc, argv));
1851 * Now we handle the general redirection cases that involve '>', '>>',
1852 * '<', and pipes '|'.
1854 for (j = 0; j < argc; ++j)
1856 if (0 == strcmp("<", argv[j]))
1860 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1861 exit(LIB$_WRONUMARG);
1866 if ('<' == *(ap = argv[j]))
1871 if (0 == strcmp(">", ap))
1875 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1876 exit(LIB$_WRONUMARG);
1895 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1896 exit(LIB$_WRONUMARG);
1900 if (('2' == *ap) && ('>' == ap[1]))
1917 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1918 exit(LIB$_WRONUMARG);
1922 if (0 == strcmp("|", argv[j]))
1926 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1927 exit(LIB$_WRONUMARG);
1929 cmargc = argc-(j+1);
1930 cmargv = &argv[j+1];
1934 if ('|' == *(ap = argv[j]))
1942 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1945 * Allocate and fill in the new argument vector, Some Unix's terminate
1946 * the list with an extra null pointer.
1948 New(1302, argv, item_count+1, char *);
1950 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1951 argv[j] = list_head->value;
1957 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
1958 exit(LIB$_INVARGORD);
1960 pipe_and_fork(cmargv);
1963 /* Check for input from a pipe (mailbox) */
1965 if (in == NULL && 1 == isapipe(0))
1967 char mbxname[L_tmpnam];
1969 long int dvi_item = DVI$_DEVBUFSIZ;
1970 $DESCRIPTOR(mbxnam, "");
1971 $DESCRIPTOR(mbxdevnam, "");
1973 /* Input from a pipe, reopen it in binary mode to disable */
1974 /* carriage control processing. */
1976 PerlIO_getname(stdin, mbxname);
1977 mbxnam.dsc$a_pointer = mbxname;
1978 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1979 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1980 mbxdevnam.dsc$a_pointer = mbxname;
1981 mbxdevnam.dsc$w_length = sizeof(mbxname);
1982 dvi_item = DVI$_DEVNAM;
1983 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1984 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1987 freopen(mbxname, "rb", stdin);
1990 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1994 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1996 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
1999 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2001 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2006 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2008 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2012 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2017 #ifdef ARGPROC_DEBUG
2018 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2019 for (j = 0; j < *ac; ++j)
2020 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2022 /* Clear errors we may have hit expanding wildcards, so they don't
2023 show up in Perl's $! later */
2024 set_errno(0); set_vaxc_errno(1);
2025 } /* end of getredirection() */
2028 static void add_item(struct list_item **head,
2029 struct list_item **tail,
2035 New(1303,*head,1,struct list_item);
2039 New(1304,(*tail)->next,1,struct list_item);
2040 *tail = (*tail)->next;
2042 (*tail)->value = value;
2046 static void expand_wild_cards(char *item,
2047 struct list_item **head,
2048 struct list_item **tail,
2052 unsigned long int context = 0;
2058 char vmsspec[NAM$C_MAXRSS+1];
2059 $DESCRIPTOR(filespec, "");
2060 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2061 $DESCRIPTOR(resultspec, "");
2062 unsigned long int zero = 0, sts;
2064 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2066 add_item(head, tail, item, count);
2069 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2070 resultspec.dsc$b_class = DSC$K_CLASS_D;
2071 resultspec.dsc$a_pointer = NULL;
2072 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2073 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2074 if (!isunix || !filespec.dsc$a_pointer)
2075 filespec.dsc$a_pointer = item;
2076 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2078 * Only return version specs, if the caller specified a version
2080 had_version = strchr(item, ';');
2082 * Only return device and directory specs, if the caller specifed either.
2084 had_device = strchr(item, ':');
2085 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2087 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2088 &defaultspec, 0, 0, &zero))))
2093 New(1305,string,resultspec.dsc$w_length+1,char);
2094 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2095 string[resultspec.dsc$w_length] = '\0';
2096 if (NULL == had_version)
2097 *((char *)strrchr(string, ';')) = '\0';
2098 if ((!had_directory) && (had_device == NULL))
2100 if (NULL == (devdir = strrchr(string, ']')))
2101 devdir = strrchr(string, '>');
2102 strcpy(string, devdir + 1);
2105 * Be consistent with what the C RTL has already done to the rest of
2106 * the argv items and lowercase all of these names.
2108 for (c = string; *c; ++c)
2111 if (isunix) trim_unixpath(string,item,1);
2112 add_item(head, tail, string, count);
2115 if (sts != RMS$_NMF)
2117 set_vaxc_errno(sts);
2123 set_errno(ENOENT); break;
2125 set_errno(ENODEV); break;
2128 set_errno(EINVAL); break;
2130 set_errno(EACCES); break;
2132 _ckvmssts_noperl(sts);
2136 add_item(head, tail, item, count);
2137 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2138 _ckvmssts_noperl(lib$find_file_end(&context));
2141 static int child_st[2];/* Event Flag set when child process completes */
2143 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2145 static unsigned long int exit_handler(int *status)
2149 if (0 == child_st[0])
2151 #ifdef ARGPROC_DEBUG
2152 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2154 fflush(stdout); /* Have to flush pipe for binary data to */
2155 /* terminate properly -- <tp@mccall.com> */
2156 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2157 sys$dassgn(child_chan);
2159 sys$synch(0, child_st);
2164 static void sig_child(int chan)
2166 #ifdef ARGPROC_DEBUG
2167 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2169 if (child_st[0] == 0)
2173 static struct exit_control_block exit_block =
2178 &exit_block.exit_status,
2182 static void pipe_and_fork(char **cmargv)
2185 $DESCRIPTOR(cmddsc, "");
2186 static char mbxname[64];
2187 $DESCRIPTOR(mbxdsc, mbxname);
2189 unsigned long int zero = 0, one = 1;
2191 strcpy(subcmd, cmargv[0]);
2192 for (j = 1; NULL != cmargv[j]; ++j)
2194 strcat(subcmd, " \"");
2195 strcat(subcmd, cmargv[j]);
2196 strcat(subcmd, "\"");
2198 cmddsc.dsc$a_pointer = subcmd;
2199 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2201 create_mbx(&child_chan,&mbxdsc);
2202 #ifdef ARGPROC_DEBUG
2203 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2204 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2206 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2207 0, &pid, child_st, &zero, sig_child,
2209 #ifdef ARGPROC_DEBUG
2210 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2212 sys$dclexh(&exit_block);
2213 if (NULL == freopen(mbxname, "wb", stdout))
2215 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2219 static int background_process(int argc, char **argv)
2221 char command[2048] = "$";
2222 $DESCRIPTOR(value, "");
2223 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2224 static $DESCRIPTOR(null, "NLA0:");
2225 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2227 $DESCRIPTOR(pidstr, "");
2229 unsigned long int flags = 17, one = 1, retsts;
2231 strcat(command, argv[0]);
2234 strcat(command, " \"");
2235 strcat(command, *(++argv));
2236 strcat(command, "\"");
2238 value.dsc$a_pointer = command;
2239 value.dsc$w_length = strlen(value.dsc$a_pointer);
2240 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2241 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2242 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2243 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2246 _ckvmssts_noperl(retsts);
2248 #ifdef ARGPROC_DEBUG
2249 PerlIO_printf(Perl_debug_log, "%s\n", command);
2251 sprintf(pidstring, "%08X", pid);
2252 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2253 pidstr.dsc$a_pointer = pidstring;
2254 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2255 lib$set_symbol(&pidsymbol, &pidstr);
2259 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2262 /* OS-specific initialization at image activation (not thread startup) */
2263 /* Older VAXC header files lack these constants */
2264 #ifndef JPI$_RIGHTS_SIZE
2265 # define JPI$_RIGHTS_SIZE 817
2267 #ifndef KGB$M_SUBSYSTEM
2268 # define KGB$M_SUBSYSTEM 0x8
2271 /*{{{void vms_image_init(int *, char ***)*/
2273 vms_image_init(int *argcp, char ***argvp)
2275 unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
2276 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2277 unsigned short int dummy, rlen;
2278 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2279 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2280 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2283 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2285 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2286 if (iprv[i]) { /* Running image installed with privs? */
2287 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2292 /* Rights identifiers might trigger tainting as well. */
2293 if (!add_taint && (rlen || rsz)) {
2294 while (rlen < rsz) {
2295 /* We didn't get all the identifiers on the first pass. Allocate a
2296 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2297 * were needed to hold all identifiers at time of last call; we'll
2298 * allocate that many unsigned long ints), and go back and get 'em.
2300 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2301 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2302 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2303 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2306 mask = jpilist[1].bufadr;
2307 /* Check attribute flags for each identifier (2nd longword); protected
2308 * subsystem identifiers trigger tainting.
2310 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2311 if (mask[i] & KGB$M_SUBSYSTEM) {
2316 if (mask != rlst) Safefree(mask);
2318 /* We need to use this hack to tell Perl it should run with tainting,
2319 * since its tainting flag may be part of the curinterp struct, which
2320 * hasn't been allocated when vms_image_init() is called.
2324 New(1320,newap,*argcp+2,char **);
2325 newap[0] = argvp[0];
2327 Copy(argvp[1],newap[2],*argcp-1,char **);
2328 /* We orphan the old argv, since we don't know where it's come from,
2329 * so we don't know how to free it.
2331 *argcp++; argvp = newap;
2333 getredirection(argcp,argvp);
2340 * Trim Unix-style prefix off filespec, so it looks like what a shell
2341 * glob expansion would return (i.e. from specified prefix on, not
2342 * full path). Note that returned filespec is Unix-style, regardless
2343 * of whether input filespec was VMS-style or Unix-style.
2345 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2346 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2347 * vector of options; at present, only bit 0 is used, and if set tells
2348 * trim unixpath to try the current default directory as a prefix when
2349 * presented with a possibly ambiguous ... wildcard.
2351 * Returns !=0 on success, with trimmed filespec replacing contents of
2352 * fspec, and 0 on failure, with contents of fpsec unchanged.
2354 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2356 trim_unixpath(char *fspec, char *wildspec, int opts)
2358 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2359 *template, *base, *end, *cp1, *cp2;
2360 register int tmplen, reslen = 0, dirs = 0;
2362 if (!wildspec || !fspec) return 0;
2363 if (strpbrk(wildspec,"]>:") != NULL) {
2364 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2365 else template = unixwild;
2367 else template = wildspec;
2368 if (strpbrk(fspec,"]>:") != NULL) {
2369 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2370 else base = unixified;
2371 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2372 * check to see that final result fits into (isn't longer than) fspec */
2373 reslen = strlen(fspec);
2377 /* No prefix or absolute path on wildcard, so nothing to remove */
2378 if (!*template || *template == '/') {
2379 if (base == fspec) return 1;
2380 tmplen = strlen(unixified);
2381 if (tmplen > reslen) return 0; /* not enough space */
2382 /* Copy unixified resultant, including trailing NUL */
2383 memmove(fspec,unixified,tmplen+1);
2387 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2388 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2389 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2390 for (cp1 = end ;cp1 >= base; cp1--)
2391 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2393 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2397 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2398 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2399 int ells = 1, totells, segdirs, match;
2400 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2401 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2403 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2405 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2406 if (ellipsis == template && opts & 1) {
2407 /* Template begins with an ellipsis. Since we can't tell how many
2408 * directory names at the front of the resultant to keep for an
2409 * arbitrary starting point, we arbitrarily choose the current
2410 * default directory as a starting point. If it's there as a prefix,
2411 * clip it off. If not, fall through and act as if the leading
2412 * ellipsis weren't there (i.e. return shortest possible path that
2413 * could match template).
2415 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2416 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2417 if (_tolower(*cp1) != _tolower(*cp2)) break;
2418 segdirs = dirs - totells; /* Min # of dirs we must have left */
2419 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2420 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2421 memcpy(fspec,cp2+1,end - cp2);
2425 /* First off, back up over constant elements at end of path */
2427 for (front = end ; front >= base; front--)
2428 if (*front == '/' && !dirs--) { front++; break; }
2430 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
2431 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2432 if (cp1 != '\0') return 0; /* Path too long. */
2434 *cp2 = '\0'; /* Pick up with memcpy later */
2435 lcfront = lcres + (front - base);
2436 /* Now skip over each ellipsis and try to match the path in front of it. */
2438 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2439 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2440 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2441 if (cp1 < template) break; /* template started with an ellipsis */
2442 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2443 ellipsis = cp1; continue;
2445 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2447 for (segdirs = 0, cp2 = tpl;
2448 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2450 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2451 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2452 if (*cp2 == '/') segdirs++;
2454 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2455 /* Back up at least as many dirs as in template before matching */
2456 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2457 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2458 for (match = 0; cp1 > lcres;) {
2459 resdsc.dsc$a_pointer = cp1;
2460 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2462 if (match == 1) lcfront = cp1;
2464 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2466 if (!match) return 0; /* Can't find prefix ??? */
2467 if (match > 1 && opts & 1) {
2468 /* This ... wildcard could cover more than one set of dirs (i.e.
2469 * a set of similar dir names is repeated). If the template
2470 * contains more than 1 ..., upstream elements could resolve the
2471 * ambiguity, but it's not worth a full backtracking setup here.
2472 * As a quick heuristic, clip off the current default directory
2473 * if it's present to find the trimmed spec, else use the
2474 * shortest string that this ... could cover.
2476 char def[NAM$C_MAXRSS+1], *st;
2478 if (getcwd(def, sizeof def,0) == NULL) return 0;
2479 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2480 if (_tolower(*cp1) != _tolower(*cp2)) break;
2481 segdirs = dirs - totells; /* Min # of dirs we must have left */
2482 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2483 if (*cp1 == '\0' && *cp2 == '/') {
2484 memcpy(fspec,cp2+1,end - cp2);
2487 /* Nope -- stick with lcfront from above and keep going. */
2490 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2495 } /* end of trim_unixpath() */
2500 * VMS readdir() routines.
2501 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2503 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2504 * Minor modifications to original routines.
2507 /* Number of elements in vms_versions array */
2508 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2511 * Open a directory, return a handle for later use.
2513 /*{{{ DIR *opendir(char*name) */
2518 char dir[NAM$C_MAXRSS+1];
2521 if (do_tovmspath(name,dir,0) == NULL) {
2524 if (flex_stat(dir,&sb) == -1) return NULL;
2525 if (!S_ISDIR(sb.st_mode)) {
2526 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2529 if (!cando_by_name(S_IRUSR,0,dir)) {
2530 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2533 /* Get memory for the handle, and the pattern. */
2535 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2537 /* Fill in the fields; mainly playing with the descriptor. */
2538 (void)sprintf(dd->pattern, "%s*.*",dir);
2541 dd->vms_wantversions = 0;
2542 dd->pat.dsc$a_pointer = dd->pattern;
2543 dd->pat.dsc$w_length = strlen(dd->pattern);
2544 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2545 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2548 } /* end of opendir() */
2552 * Set the flag to indicate we want versions or not.
2554 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2556 vmsreaddirversions(DIR *dd, int flag)
2558 dd->vms_wantversions = flag;
2563 * Free up an opened directory.
2565 /*{{{ void closedir(DIR *dd)*/
2569 (void)lib$find_file_end(&dd->context);
2570 Safefree(dd->pattern);
2571 Safefree((char *)dd);
2576 * Collect all the version numbers for the current file.
2582 struct dsc$descriptor_s pat;
2583 struct dsc$descriptor_s res;
2585 char *p, *text, buff[sizeof dd->entry.d_name];
2587 unsigned long context, tmpsts;
2589 /* Convenient shorthand. */
2592 /* Add the version wildcard, ignoring the "*.*" put on before */
2593 i = strlen(dd->pattern);
2594 New(1308,text,i + e->d_namlen + 3,char);
2595 (void)strcpy(text, dd->pattern);
2596 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2598 /* Set up the pattern descriptor. */
2599 pat.dsc$a_pointer = text;
2600 pat.dsc$w_length = i + e->d_namlen - 1;
2601 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2602 pat.dsc$b_class = DSC$K_CLASS_S;
2604 /* Set up result descriptor. */
2605 res.dsc$a_pointer = buff;
2606 res.dsc$w_length = sizeof buff - 2;
2607 res.dsc$b_dtype = DSC$K_DTYPE_T;
2608 res.dsc$b_class = DSC$K_CLASS_S;
2610 /* Read files, collecting versions. */
2611 for (context = 0, e->vms_verscount = 0;
2612 e->vms_verscount < VERSIZE(e);
2613 e->vms_verscount++) {
2614 tmpsts = lib$find_file(&pat, &res, &context);
2615 if (tmpsts == RMS$_NMF || context == 0) break;
2617 buff[sizeof buff - 1] = '\0';
2618 if ((p = strchr(buff, ';')))
2619 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2621 e->vms_versions[e->vms_verscount] = -1;
2624 _ckvmssts(lib$find_file_end(&context));
2627 } /* end of collectversions() */
2630 * Read the next entry from the directory.
2632 /*{{{ struct dirent *readdir(DIR *dd)*/
2636 struct dsc$descriptor_s res;
2637 char *p, buff[sizeof dd->entry.d_name];
2638 unsigned long int tmpsts;
2640 /* Set up result descriptor, and get next file. */
2641 res.dsc$a_pointer = buff;
2642 res.dsc$w_length = sizeof buff - 2;
2643 res.dsc$b_dtype = DSC$K_DTYPE_T;
2644 res.dsc$b_class = DSC$K_CLASS_S;
2645 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2646 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2647 if (!(tmpsts & 1)) {
2648 set_vaxc_errno(tmpsts);
2651 set_errno(EACCES); break;
2653 set_errno(ENODEV); break;
2656 set_errno(ENOENT); break;
2663 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2664 buff[sizeof buff - 1] = '\0';
2665 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2668 /* Skip any directory component and just copy the name. */
2669 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2670 else (void)strcpy(dd->entry.d_name, buff);
2672 /* Clobber the version. */
2673 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2675 dd->entry.d_namlen = strlen(dd->entry.d_name);
2676 dd->entry.vms_verscount = 0;
2677 if (dd->vms_wantversions) collectversions(dd);
2680 } /* end of readdir() */
2684 * Return something that can be used in a seekdir later.
2686 /*{{{ long telldir(DIR *dd)*/
2695 * Return to a spot where we used to be. Brute force.
2697 /*{{{ void seekdir(DIR *dd,long count)*/
2699 seekdir(DIR *dd, long count)
2701 int vms_wantversions;
2703 /* If we haven't done anything yet... */
2707 /* Remember some state, and clear it. */
2708 vms_wantversions = dd->vms_wantversions;
2709 dd->vms_wantversions = 0;
2710 _ckvmssts(lib$find_file_end(&dd->context));
2713 /* The increment is in readdir(). */
2714 for (dd->count = 0; dd->count < count; )
2717 dd->vms_wantversions = vms_wantversions;
2719 } /* end of seekdir() */
2722 /* VMS subprocess management
2724 * my_vfork() - just a vfork(), after setting a flag to record that
2725 * the current script is trying a Unix-style fork/exec.
2727 * vms_do_aexec() and vms_do_exec() are called in response to the
2728 * perl 'exec' function. If this follows a vfork call, then they
2729 * call out the the regular perl routines in doio.c which do an
2730 * execvp (for those who really want to try this under VMS).
2731 * Otherwise, they do exactly what the perl docs say exec should
2732 * do - terminate the current script and invoke a new command
2733 * (See below for notes on command syntax.)
2735 * do_aspawn() and do_spawn() implement the VMS side of the perl
2736 * 'system' function.
2738 * Note on command arguments to perl 'exec' and 'system': When handled
2739 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2740 * are concatenated to form a DCL command string. If the first arg
2741 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2742 * the the command string is hrnded off to DCL directly. Otherwise,
2743 * the first token of the command is taken as the filespec of an image
2744 * to run. The filespec is expanded using a default type of '.EXE' and
2745 * the process defaults for device, directory, etc., and the resultant
2746 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2747 * the command string as parameters. This is perhaps a bit compicated,
2748 * but I hope it will form a happy medium between what VMS folks expect
2749 * from lib$spawn and what Unix folks expect from exec.
2752 static int vfork_called;
2754 /*{{{int my_vfork()*/
2764 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2772 if (VMScmd.dsc$a_pointer) {
2773 Safefree(VMScmd.dsc$a_pointer);
2774 VMScmd.dsc$w_length = 0;
2775 VMScmd.dsc$a_pointer = Nullch;
2780 setup_argstr(SV *really, SV **mark, SV **sp)
2783 char *junk, *tmps = Nullch;
2784 register size_t cmdlen = 0;
2790 tmps = SvPV(really,rlen);
2797 for (idx++; idx <= sp; idx++) {
2799 junk = SvPVx(*idx,rlen);
2800 cmdlen += rlen ? rlen + 1 : 0;
2803 New(401,Cmd,cmdlen+1,char);
2805 if (tmps && *tmps) {
2810 while (++mark <= sp) {
2813 strcat(Cmd,SvPVx(*mark,na));
2818 } /* end of setup_argstr() */
2821 static unsigned long int
2822 setup_cmddsc(char *cmd, int check_img)
2824 char resspec[NAM$C_MAXRSS+1];
2825 $DESCRIPTOR(defdsc,".EXE");
2826 $DESCRIPTOR(resdsc,resspec);
2827 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2828 unsigned long int cxt = 0, flags = 1, retsts;
2829 register char *s, *rest, *cp;
2830 register int isdcl = 0;
2833 while (*s && isspace(*s)) s++;
2835 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2836 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2837 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2838 if (*cp == ':' || *cp == '[' || *cp == '<') {
2846 if (isdcl) { /* It's a DCL command, just do it. */
2847 VMScmd.dsc$w_length = strlen(cmd);
2849 VMScmd.dsc$a_pointer = Cmd;
2850 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2852 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2854 else { /* assume first token is an image spec */
2856 while (*s && !isspace(*s)) s++;
2858 imgdsc.dsc$a_pointer = cmd;
2859 imgdsc.dsc$w_length = s - cmd;
2860 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2861 if (!(retsts & 1)) {
2862 /* just hand off status values likely to be due to user error */
2863 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2864 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2865 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2866 else { _ckvmssts(retsts); }
2869 _ckvmssts(lib$find_file_end(&cxt));
2871 while (*s && !isspace(*s)) s++;
2873 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2874 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2875 strcat(VMScmd.dsc$a_pointer,resspec);
2876 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2877 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2881 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2883 } /* end of setup_cmddsc() */
2886 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2888 vms_do_aexec(SV *really,SV **mark,SV **sp)
2892 if (vfork_called) { /* this follows a vfork - act Unixish */
2894 if (vfork_called < 0) {
2895 warn("Internal inconsistency in tracking vforks");
2898 else return do_aexec(really,mark,sp);
2900 /* no vfork - act VMSish */
2901 return vms_do_exec(setup_argstr(really,mark,sp));
2906 } /* end of vms_do_aexec() */
2909 /* {{{bool vms_do_exec(char *cmd) */
2911 vms_do_exec(char *cmd)
2914 if (vfork_called) { /* this follows a vfork - act Unixish */
2916 if (vfork_called < 0) {
2917 warn("Internal inconsistency in tracking vforks");
2920 else return do_exec(cmd);
2923 { /* no vfork - act VMSish */
2924 unsigned long int retsts;
2927 TAINT_PROPER("exec");
2928 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2929 retsts = lib$do_command(&VMScmd);
2932 set_vaxc_errno(retsts);
2934 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2940 } /* end of vms_do_exec() */
2943 unsigned long int do_spawn(char *);
2945 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
2947 do_aspawn(void *really,void **mark,void **sp)
2950 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
2953 } /* end of do_aspawn() */
2956 /* {{{unsigned long int do_spawn(char *cmd) */
2960 unsigned long int substs, hadcmd = 1;
2963 TAINT_PROPER("spawn");
2964 if (!cmd || !*cmd) {
2966 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2968 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2969 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2974 set_vaxc_errno(substs);
2976 warn("Can't spawn \"%s\": %s",
2977 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2982 } /* end of do_spawn() */
2986 * A simple fwrite replacement which outputs itmsz*nitm chars without
2987 * introducing record boundaries every itmsz chars.
2989 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2991 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2993 register char *cp, *end;
2995 end = (char *)src + itmsz * nitm;
2997 while ((char *)src <= end) {
2998 for (cp = src; cp <= end; cp++) if (!*cp) break;
2999 if (fputs(src,dest) == EOF) return EOF;
3001 if (fputc('\0',dest) == EOF) return EOF;
3007 } /* end of my_fwrite() */
3010 /*{{{ int my_flush(FILE *fp)*/
3015 if ((res = fflush(fp)) == 0) {
3016 #ifdef VMS_DO_SOCKETS
3018 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3020 res = fsync(fileno(fp));
3027 * Here are replacements for the following Unix routines in the VMS environment:
3028 * getpwuid Get information for a particular UIC or UID
3029 * getpwnam Get information for a named user
3030 * getpwent Get information for each user in the rights database
3031 * setpwent Reset search to the start of the rights database
3032 * endpwent Finish searching for users in the rights database
3034 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3035 * (defined in pwd.h), which contains the following fields:-
3037 * char *pw_name; Username (in lower case)
3038 * char *pw_passwd; Hashed password
3039 * unsigned int pw_uid; UIC
3040 * unsigned int pw_gid; UIC group number
3041 * char *pw_unixdir; Default device/directory (VMS-style)
3042 * char *pw_gecos; Owner name
3043 * char *pw_dir; Default device/directory (Unix-style)
3044 * char *pw_shell; Default CLI name (eg. DCL)
3046 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3048 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3049 * not the UIC member number (eg. what's returned by getuid()),
3050 * getpwuid() can accept either as input (if uid is specified, the caller's
3051 * UIC group is used), though it won't recognise gid=0.
3053 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3054 * information about other users in your group or in other groups, respectively.
3055 * If the required privilege is not available, then these routines fill only
3056 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3059 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3062 /* sizes of various UAF record fields */
3063 #define UAI$S_USERNAME 12
3064 #define UAI$S_IDENT 31
3065 #define UAI$S_OWNER 31
3066 #define UAI$S_DEFDEV 31
3067 #define UAI$S_DEFDIR 63
3068 #define UAI$S_DEFCLI 31
3071 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3072 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3073 (uic).uic$v_group != UIC$K_WILD_GROUP)
3075 static char __empty[]= "";
3076 static struct passwd __passwd_empty=
3077 {(char *) __empty, (char *) __empty, 0, 0,
3078 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3079 static int contxt= 0;
3080 static struct passwd __pwdcache;
3081 static char __pw_namecache[UAI$S_IDENT+1];
3084 * This routine does most of the work extracting the user information.
3086 static int fillpasswd (const char *name, struct passwd *pwd)
3089 unsigned char length;
3090 char pw_gecos[UAI$S_OWNER+1];
3092 static union uicdef uic;
3094 unsigned char length;
3095 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3098 unsigned char length;
3099 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3102 unsigned char length;
3103 char pw_shell[UAI$S_DEFCLI+1];
3105 static char pw_passwd[UAI$S_PWD+1];
3107 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3108 struct dsc$descriptor_s name_desc;
3109 unsigned long int sts;
3111 static struct itmlst_3 itmlst[]= {
3112 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3113 {sizeof(uic), UAI$_UIC, &uic, &luic},
3114 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3115 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3116 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3117 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3118 {0, 0, NULL, NULL}};
3120 name_desc.dsc$w_length= strlen(name);
3121 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3122 name_desc.dsc$b_class= DSC$K_CLASS_S;
3123 name_desc.dsc$a_pointer= (char *) name;
3125 /* Note that sys$getuai returns many fields as counted strings. */
3126 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3127 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3128 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3130 else { _ckvmssts(sts); }
3131 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3133 if ((int) owner.length < lowner) lowner= (int) owner.length;
3134 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3135 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3136 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3137 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3138 owner.pw_gecos[lowner]= '\0';
3139 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3140 defcli.pw_shell[ldefcli]= '\0';
3141 if (valid_uic(uic)) {
3142 pwd->pw_uid= uic.uic$l_uic;
3143 pwd->pw_gid= uic.uic$v_group;
3146 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3147 pwd->pw_passwd= pw_passwd;
3148 pwd->pw_gecos= owner.pw_gecos;
3149 pwd->pw_dir= defdev.pw_dir;
3150 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3151 pwd->pw_shell= defcli.pw_shell;
3152 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3154 ldir= strlen(pwd->pw_unixdir) - 1;
3155 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3158 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3159 __mystrtolower(pwd->pw_unixdir);
3164 * Get information for a named user.
3166 /*{{{struct passwd *getpwnam(char *name)*/
3167 struct passwd *my_getpwnam(char *name)
3169 struct dsc$descriptor_s name_desc;
3171 unsigned long int status, sts;
3173 __pwdcache = __passwd_empty;
3174 if (!fillpasswd(name, &__pwdcache)) {
3175 /* We still may be able to determine pw_uid and pw_gid */
3176 name_desc.dsc$w_length= strlen(name);
3177 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3178 name_desc.dsc$b_class= DSC$K_CLASS_S;
3179 name_desc.dsc$a_pointer= (char *) name;
3180 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3181 __pwdcache.pw_uid= uic.uic$l_uic;
3182 __pwdcache.pw_gid= uic.uic$v_group;
3185 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3186 set_vaxc_errno(sts);
3187 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3190 else { _ckvmssts(sts); }
3193 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3194 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3195 __pwdcache.pw_name= __pw_namecache;
3197 } /* end of my_getpwnam() */
3201 * Get information for a particular UIC or UID.
3202 * Called by my_getpwent with uid=-1 to list all users.
3204 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3205 struct passwd *my_getpwuid(Uid_t uid)
3207 const $DESCRIPTOR(name_desc,__pw_namecache);
3208 unsigned short lname;
3210 unsigned long int status;
3212 if (uid == (unsigned int) -1) {
3214 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3215 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3216 set_vaxc_errno(status);
3217 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3221 else { _ckvmssts(status); }
3222 } while (!valid_uic (uic));
3226 if (!uic.uic$v_group)
3227 uic.uic$v_group= PerlProc_getgid();
3229 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3230 else status = SS$_IVIDENT;
3231 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3232 status == RMS$_PRV) {
3233 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3236 else { _ckvmssts(status); }
3238 __pw_namecache[lname]= '\0';
3239 __mystrtolower(__pw_namecache);
3241 __pwdcache = __passwd_empty;
3242 __pwdcache.pw_name = __pw_namecache;
3244 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3245 The identifier's value is usually the UIC, but it doesn't have to be,
3246 so if we can, we let fillpasswd update this. */
3247 __pwdcache.pw_uid = uic.uic$l_uic;
3248 __pwdcache.pw_gid = uic.uic$v_group;
3250 fillpasswd(__pw_namecache, &__pwdcache);
3253 } /* end of my_getpwuid() */
3257 * Get information for next user.
3259 /*{{{struct passwd *my_getpwent()*/
3260 struct passwd *my_getpwent()
3262 return (my_getpwuid((unsigned int) -1));
3267 * Finish searching rights database for users.
3269 /*{{{void my_endpwent()*/
3273 _ckvmssts(sys$finish_rdb(&contxt));
3279 #ifdef HOMEGROWN_POSIX_SIGNALS
3280 /* Signal handling routines, pulled into the core from POSIX.xs.
3282 * We need these for threads, so they've been rolled into the core,
3283 * rather than left in POSIX.xs.
3285 * (DRS, Oct 23, 1997)
3288 /* sigset_t is atomic under VMS, so these routines are easy */
3289 /*{{{int my_sigemptyset(sigset_t *) */
3290 int my_sigemptyset(sigset_t *set) {
3291 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3297 /*{{{int my_sigfillset(sigset_t *)*/
3298 int my_sigfillset(sigset_t *set) {
3300 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3301 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3307 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3308 int my_sigaddset(sigset_t *set, int sig) {
3309 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3310 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3311 *set |= (1 << (sig - 1));
3317 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3318 int my_sigdelset(sigset_t *set, int sig) {
3319 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3320 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3321 *set &= ~(1 << (sig - 1));
3327 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3328 int my_sigismember(sigset_t *set, int sig) {
3329 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3330 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3331 *set & (1 << (sig - 1));
3336 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3337 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3340 /* If set and oset are both null, then things are badly wrong. Bail out. */
3341 if ((oset == NULL) && (set == NULL)) {
3342 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3346 /* If set's null, then we're just handling a fetch. */
3348 tempmask = sigblock(0);
3353 tempmask = sigsetmask(*set);
3356 tempmask = sigblock(*set);
3359 tempmask = sigblock(0);
3360 sigsetmask(*oset & ~tempmask);
3363 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3368 /* Did they pass us an oset? If so, stick our holding mask into it */
3375 #endif /* HOMEGROWN_POSIX_SIGNALS */
3378 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3379 * my_utime(), and flex_stat(), all of which operate on UTC unless
3380 * VMSISH_TIMES is true.
3382 /* method used to handle UTC conversions:
3383 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3385 static int gmtime_emulation_type;
3386 /* number of secs to add to UTC POSIX-style time to get local time */
3387 static long int utc_offset_secs;
3389 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3390 * in vmsish.h. #undef them here so we can call the CRTL routines
3397 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3398 # define RTL_USES_UTC 1
3401 static time_t toutc_dst(time_t loc) {
3404 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3405 loc -= utc_offset_secs;
3406 if (rsltmp->tm_isdst) loc -= 3600;
3409 #define _toutc(secs) ((secs) == -1 ? -1 : \
3410 ((gmtime_emulation_type || my_time(NULL)), \
3411 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3412 ((secs) - utc_offset_secs))))
3414 static time_t toloc_dst(time_t utc) {
3417 utc += utc_offset_secs;
3418 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3419 if (rsltmp->tm_isdst) utc += 3600;
3422 #define _toloc(secs) ((secs) == -1 ? -1 : \
3423 ((gmtime_emulation_type || my_time(NULL)), \
3424 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3425 ((secs) + utc_offset_secs))))
3428 /* my_time(), my_localtime(), my_gmtime()
3429 * By default traffic in UTC time values, using CRTL gmtime() or
3430 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3431 * Note: We need to use these functions even when the CRTL has working
3432 * UTC support, since they also handle C<use vmsish qw(times);>
3434 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3435 * Modified by Charles Bailey <bailey@genetics.upenn.edu>
3438 /*{{{time_t my_time(time_t *timep)*/
3439 time_t my_time(time_t *timep)
3445 if (gmtime_emulation_type == 0) {
3447 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3448 /* results of calls to gmtime() and localtime() */
3449 /* for same &base */
3451 gmtime_emulation_type++;
3452 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3455 gmtime_emulation_type++;
3456 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3457 gmtime_emulation_type++;
3458 warn("no UTC offset information; assuming local time is UTC");
3460 else { utc_offset_secs = atol(off); }
3462 else { /* We've got a working gmtime() */
3463 struct tm gmt, local;
3466 tm_p = localtime(&base);
3468 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3469 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3470 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3471 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3477 # ifdef RTL_USES_UTC
3478 if (VMSISH_TIME) when = _toloc(when);
3480 if (!VMSISH_TIME) when = _toutc(when);
3483 if (timep != NULL) *timep = when;
3486 } /* end of my_time() */
3490 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3492 my_gmtime(const time_t *timep)
3499 if (timep == NULL) {
3500 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3503 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3507 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
3509 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
3510 return gmtime(&when);
3512 /* CRTL localtime() wants local time as input, so does no tz correction */
3513 rsltmp = localtime(&when);
3514 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
3517 } /* end of my_gmtime() */
3521 /*{{{struct tm *my_localtime(const time_t *timep)*/
3523 my_localtime(const time_t *timep)
3529 if (timep == NULL) {
3530 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3533 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3534 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3537 # ifdef RTL_USES_UTC
3539 if (VMSISH_TIME) when = _toutc(when);
3541 /* CRTL localtime() wants UTC as input, does tz correction itself */
3542 return localtime(&when);
3545 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
3548 /* CRTL localtime() wants local time as input, so does no tz correction */
3549 rsltmp = localtime(&when);
3550 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
3553 } /* end of my_localtime() */
3556 /* Reset definitions for later calls */
3557 #define gmtime(t) my_gmtime(t)
3558 #define localtime(t) my_localtime(t)
3559 #define time(t) my_time(t)
3562 /* my_utime - update modification time of a file
3563 * calling sequence is identical to POSIX utime(), but under
3564 * VMS only the modification time is changed; ODS-2 does not
3565 * maintain access times. Restrictions differ from the POSIX
3566 * definition in that the time can be changed as long as the
3567 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3568 * no separate checks are made to insure that the caller is the
3569 * owner of the file or has special privs enabled.
3570 * Code here is based on Joe Meadows' FILE utility.
3573 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3574 * to VMS epoch (01-JAN-1858 00:00:00.00)
3575 * in 100 ns intervals.
3577 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3579 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3580 int my_utime(char *file, struct utimbuf *utimes)
3584 long int bintime[2], len = 2, lowbit, unixtime,
3585 secscale = 10000000; /* seconds --> 100 ns intervals */
3586 unsigned long int chan, iosb[2], retsts;
3587 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3588 struct FAB myfab = cc$rms_fab;
3589 struct NAM mynam = cc$rms_nam;
3590 #if defined (__DECC) && defined (__VAX)
3591 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3592 * at least through VMS V6.1, which causes a type-conversion warning.
3594 # pragma message save
3595 # pragma message disable cvtdiftypes
3597 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3598 struct fibdef myfib;
3599 #if defined (__DECC) && defined (__VAX)
3600 /* This should be right after the declaration of myatr, but due
3601 * to a bug in VAX DEC C, this takes effect a statement early.
3603 # pragma message restore
3605 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3606 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3607 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3609 if (file == NULL || *file == '\0') {
3611 set_vaxc_errno(LIB$_INVARG);
3614 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3616 if (utimes != NULL) {
3617 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3618 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3619 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3620 * as input, we force the sign bit to be clear by shifting unixtime right
3621 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3623 lowbit = (utimes->modtime & 1) ? secscale : 0;
3624 unixtime = (long int) utimes->modtime;
3626 /* If input was UTC; convert to local for sys svc */
3627 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
3629 unixtime >> 1; secscale << 1;
3630 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3631 if (!(retsts & 1)) {
3633 set_vaxc_errno(retsts);
3636 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3637 if (!(retsts & 1)) {
3639 set_vaxc_errno(retsts);
3644 /* Just get the current time in VMS format directly */
3645 retsts = sys$gettim(bintime);
3646 if (!(retsts & 1)) {
3648 set_vaxc_errno(retsts);
3653 myfab.fab$l_fna = vmsspec;
3654 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3655 myfab.fab$l_nam = &mynam;
3656 mynam.nam$l_esa = esa;
3657 mynam.nam$b_ess = (unsigned char) sizeof esa;
3658 mynam.nam$l_rsa = rsa;
3659 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3661 /* Look for the file to be affected, letting RMS parse the file
3662 * specification for us as well. I have set errno using only
3663 * values documented in the utime() man page for VMS POSIX.
3665 retsts = sys$parse(&myfab,0,0);
3666 if (!(retsts & 1)) {
3667 set_vaxc_errno(retsts);
3668 if (retsts == RMS$_PRV) set_errno(EACCES);
3669 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3670 else set_errno(EVMSERR);
3673 retsts = sys$search(&myfab,0,0);
3674 if (!(retsts & 1)) {
3675 set_vaxc_errno(retsts);
3676 if (retsts == RMS$_PRV) set_errno(EACCES);
3677 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3678 else set_errno(EVMSERR);
3682 devdsc.dsc$w_length = mynam.nam$b_dev;
3683 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3685 retsts = sys$assign(&devdsc,&chan,0,0);
3686 if (!(retsts & 1)) {
3687 set_vaxc_errno(retsts);
3688 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3689 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3690 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3691 else set_errno(EVMSERR);
3695 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3696 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3698 memset((void *) &myfib, 0, sizeof myfib);
3700 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3701 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3702 /* This prevents the revision time of the file being reset to the current
3703 * time as a result of our IO$_MODIFY $QIO. */
3704 myfib.fib$l_acctl = FIB$M_NORECORD;
3706 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3707 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3708 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3710 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3711 _ckvmssts(sys$dassgn(chan));
3712 if (retsts & 1) retsts = iosb[0];
3713 if (!(retsts & 1)) {
3714 set_vaxc_errno(retsts);
3715 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3716 else set_errno(EVMSERR);
3721 } /* end of my_utime() */
3725 * flex_stat, flex_fstat
3726 * basic stat, but gets it right when asked to stat
3727 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3730 /* encode_dev packs a VMS device name string into an integer to allow
3731 * simple comparisons. This can be used, for example, to check whether two
3732 * files are located on the same device, by comparing their encoded device
3733 * names. Even a string comparison would not do, because stat() reuses the
3734 * device name buffer for each call; so without encode_dev, it would be
3735 * necessary to save the buffer and use strcmp (this would mean a number of
3736 * changes to the standard Perl code, to say nothing of what a Perl script
3739 * The device lock id, if it exists, should be unique (unless perhaps compared
3740 * with lock ids transferred from other nodes). We have a lock id if the disk is
3741 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3742 * device names. Thus we use the lock id in preference, and only if that isn't
3743 * available, do we try to pack the device name into an integer (flagged by
3744 * the sign bit (LOCKID_MASK) being set).
3746 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3747 * name and its encoded form, but it seems very unlikely that we will find
3748 * two files on different disks that share the same encoded device names,
3749 * and even more remote that they will share the same file id (if the test
3750 * is to check for the same file).
3752 * A better method might be to use sys$device_scan on the first call, and to
3753 * search for the device, returning an index into the cached array.
3754 * The number returned would be more intelligable.
3755 * This is probably not worth it, and anyway would take quite a bit longer
3756 * on the first call.
3758 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3759 static mydev_t encode_dev (const char *dev)
3762 unsigned long int f;
3767 if (!dev || !dev[0]) return 0;
3771 struct dsc$descriptor_s dev_desc;
3772 unsigned long int status, lockid, item = DVI$_LOCKID;
3774 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3775 can try that first. */
3776 dev_desc.dsc$w_length = strlen (dev);
3777 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3778 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3779 dev_desc.dsc$a_pointer = (char *) dev;
3780 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3781 if (lockid) return (lockid & ~LOCKID_MASK);
3785 /* Otherwise we try to encode the device name */
3789 for (q = dev + strlen(dev); q--; q >= dev) {
3792 else if (isalpha (toupper (*q)))
3793 c= toupper (*q) - 'A' + (char)10;
3795 continue; /* Skip '$'s */
3797 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3799 enc += f * (unsigned long int) c;
3801 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3803 } /* end of encode_dev() */
3805 static char namecache[NAM$C_MAXRSS+1];
3808 is_null_device(name)
3811 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3812 The underscore prefix, controller letter, and unit number are
3813 independently optional; for our purposes, the colon punctuation
3814 is not. The colon can be trailed by optional directory and/or
3815 filename, but two consecutive colons indicates a nodename rather
3816 than a device. [pr] */
3817 if (*name == '_') ++name;
3818 if (tolower(*name++) != 'n') return 0;
3819 if (tolower(*name++) != 'l') return 0;
3820 if (tolower(*name) == 'a') ++name;
3821 if (*name == '0') ++name;
3822 return (*name++ == ':') && (*name != ':');
3825 /* Do the permissions allow some operation? Assumes statcache already set. */
3826 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3827 * subset of the applicable information.
3829 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3831 cando(I32 bit, I32 effective, Stat_t *statbufp)
3833 if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
3835 char fname[NAM$C_MAXRSS+1];
3836 unsigned long int retsts;
3837 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3838 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3840 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3841 device name on successive calls */
3842 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
3843 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
3844 namdsc.dsc$a_pointer = fname;
3845 namdsc.dsc$w_length = sizeof fname - 1;
3847 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
3848 &namdsc,&namdsc.dsc$w_length,0,0);
3850 fname[namdsc.dsc$w_length] = '\0';
3851 return cando_by_name(bit,effective,fname);
3853 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3854 warn("Can't get filespec - stale stat buffer?\n");
3858 return FALSE; /* Should never get to here */
3860 } /* end of cando() */
3864 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3866 cando_by_name(I32 bit, I32 effective, char *fname)
3868 static char usrname[L_cuserid];
3869 static struct dsc$descriptor_s usrdsc =
3870 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3871 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3872 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3873 unsigned short int retlen;
3874 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3875 union prvdef curprv;
3876 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3877 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3878 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3881 if (!fname || !*fname) return FALSE;
3882 /* Make sure we expand logical names, since sys$check_access doesn't */
3883 if (!strpbrk(fname,"/]>:")) {
3884 strcpy(fileified,fname);
3885 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3888 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3889 retlen = namdsc.dsc$w_length = strlen(vmsname);
3890 namdsc.dsc$a_pointer = vmsname;
3891 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3892 vmsname[retlen-1] == ':') {
3893 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3894 namdsc.dsc$w_length = strlen(fileified);
3895 namdsc.dsc$a_pointer = fileified;
3898 if (!usrdsc.dsc$w_length) {
3900 usrdsc.dsc$w_length = strlen(usrname);
3907 access = ARM$M_EXECUTE;
3912 access = ARM$M_READ;
3917 access = ARM$M_WRITE;
3922 access = ARM$M_DELETE;
3928 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3929 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3930 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
3931 retsts == RMS$_DIR || retsts == RMS$_DEV) {
3932 set_vaxc_errno(retsts);
3933 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3934 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
3935 else set_errno(ENOENT);
3938 if (retsts == SS$_NORMAL) {
3939 if (!privused) return TRUE;
3940 /* We can get access, but only by using privs. Do we have the
3941 necessary privs currently enabled? */
3942 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3943 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3944 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3945 !curprv.prv$v_bypass) return FALSE;
3946 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3947 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3948 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3953 return FALSE; /* Should never get here */
3955 } /* end of cando_by_name() */
3959 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
3961 flex_fstat(int fd, Stat_t *statbufp)
3964 if (!fstat(fd,(stat_t *) statbufp)) {
3965 if (statbufp == (Stat_t *) &statcache) *namecache == '\0';
3966 statbufp->st_dev = encode_dev(statbufp->st_devnam);
3967 # ifdef RTL_USES_UTC
3970 statbufp->st_mtime = _toloc(statbufp->st_mtime);
3971 statbufp->st_atime = _toloc(statbufp->st_atime);
3972 statbufp->st_ctime = _toloc(statbufp->st_ctime);
3977 if (!VMSISH_TIME) { /* Return UTC instead of local time */
3981 statbufp->st_mtime = _toutc(statbufp->st_mtime);
3982 statbufp->st_atime = _toutc(statbufp->st_atime);
3983 statbufp->st_ctime = _toutc(statbufp->st_ctime);
3990 } /* end of flex_fstat() */
3993 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
3995 flex_stat(char *fspec, Stat_t *statbufp)
3998 char fileified[NAM$C_MAXRSS+1];
4001 if (statbufp == (Stat_t *) &statcache)
4002 do_tovmsspec(fspec,namecache,0);
4003 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4004 memset(statbufp,0,sizeof *statbufp);
4005 statbufp->st_dev = encode_dev("_NLA0:");
4006 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4007 statbufp->st_uid = 0x00010001;
4008 statbufp->st_gid = 0x0001;
4009 time((time_t *)&statbufp->st_mtime);
4010 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4014 /* Try for a directory name first. If fspec contains a filename without
4015 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4016 * and sea:[wine.dark]water. exist, we prefer the directory here.
4017 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4018 * not sea:[wine.dark]., if the latter exists. If the intended target is
4019 * the file with null type, specify this by calling flex_stat() with
4020 * a '.' at the end of fspec.
4022 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4023 retval = stat(fileified,(stat_t *) statbufp);
4024 if (!retval && statbufp == (Stat_t *) &statcache)
4025 strcpy(namecache,fileified);
4027 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4029 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4030 # ifdef RTL_USES_UTC
4033 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4034 statbufp->st_atime = _toloc(statbufp->st_atime);
4035 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4040 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4044 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4045 statbufp->st_atime = _toutc(statbufp->st_atime);
4046 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4052 } /* end of flex_stat() */
4055 /* Insures that no carriage-control translation will be done on a file. */
4056 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
4058 my_binmode(FILE *fp, char iotype)
4060 char filespec[NAM$C_MAXRSS], *acmode;
4063 if (!fgetname(fp,filespec)) return NULL;
4064 if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
4066 case '<': case 'r': acmode = "rb"; break;
4068 /* use 'a' instead of 'w' to avoid creating new file;
4069 fsetpos below will take care of restoring file position */
4070 case 'a': acmode = "ab"; break;
4071 case '+': case '|': case 's': acmode = "rb+"; break;
4072 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
4074 warn("Unrecognized iotype %c in my_binmode",iotype);
4077 if (freopen(filespec,acmode,fp) == NULL) return NULL;
4078 if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
4080 } /* end of my_binmode() */
4084 /*{{{char *my_getlogin()*/
4085 /* VMS cuserid == Unix getlogin, except calling sequence */
4089 static char user[L_cuserid];
4090 return cuserid(user);
4095 /* rmscopy - copy a file using VMS RMS routines
4097 * Copies contents and attributes of spec_in to spec_out, except owner
4098 * and protection information. Name and type of spec_in are used as
4099 * defaults for spec_out. The third parameter specifies whether rmscopy()
4100 * should try to propagate timestamps from the input file to the output file.
4101 * If it is less than 0, no timestamps are preserved. If it is 0, then
4102 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4103 * propagated to the output file at creation iff the output file specification
4104 * did not contain an explicit name or type, and the revision date is always
4105 * updated at the end of the copy operation. If it is greater than 0, then
4106 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4107 * other than the revision date should be propagated, and bit 1 indicates
4108 * that the revision date should be propagated.
4110 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4112 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
4113 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4114 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4115 * as part of the Perl standard distribution under the terms of the
4116 * GNU General Public License or the Perl Artistic License. Copies
4117 * of each may be found in the Perl standard distribution.
4119 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4121 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4123 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4124 rsa[NAM$C_MAXRSS], ubf[32256];
4125 unsigned long int i, sts, sts2;
4126 struct FAB fab_in, fab_out;
4127 struct RAB rab_in, rab_out;
4129 struct XABDAT xabdat;
4130 struct XABFHC xabfhc;
4131 struct XABRDT xabrdt;
4132 struct XABSUM xabsum;
4134 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4135 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4136 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4140 fab_in = cc$rms_fab;
4141 fab_in.fab$l_fna = vmsin;
4142 fab_in.fab$b_fns = strlen(vmsin);
4143 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4144 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4145 fab_in.fab$l_fop = FAB$M_SQO;
4146 fab_in.fab$l_nam = &nam;
4147 fab_in.fab$l_xab = (void *) &xabdat;
4150 nam.nam$l_rsa = rsa;
4151 nam.nam$b_rss = sizeof(rsa);
4152 nam.nam$l_esa = esa;
4153 nam.nam$b_ess = sizeof (esa);
4154 nam.nam$b_esl = nam.nam$b_rsl = 0;
4156 xabdat = cc$rms_xabdat; /* To get creation date */
4157 xabdat.xab$l_nxt = (void *) &xabfhc;
4159 xabfhc = cc$rms_xabfhc; /* To get record length */
4160 xabfhc.xab$l_nxt = (void *) &xabsum;
4162 xabsum = cc$rms_xabsum; /* To get key and area information */
4164 if (!((sts = sys$open(&fab_in)) & 1)) {
4165 set_vaxc_errno(sts);
4169 set_errno(ENOENT); break;
4171 set_errno(ENODEV); break;
4173 set_errno(EINVAL); break;
4175 set_errno(EACCES); break;
4183 fab_out.fab$w_ifi = 0;
4184 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4185 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4186 fab_out.fab$l_fop = FAB$M_SQO;
4187 fab_out.fab$l_fna = vmsout;
4188 fab_out.fab$b_fns = strlen(vmsout);
4189 fab_out.fab$l_dna = nam.nam$l_name;
4190 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4192 if (preserve_dates == 0) { /* Act like DCL COPY */
4193 nam.nam$b_nop = NAM$M_SYNCHK;
4194 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4195 if (!((sts = sys$parse(&fab_out)) & 1)) {
4196 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4197 set_vaxc_errno(sts);
4200 fab_out.fab$l_xab = (void *) &xabdat;
4201 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4203 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4204 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4205 preserve_dates =0; /* bitmask from this point forward */
4207 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4208 if (!((sts = sys$create(&fab_out)) & 1)) {
4209 set_vaxc_errno(sts);
4212 set_errno(ENOENT); break;
4214 set_errno(ENODEV); break;
4216 set_errno(EINVAL); break;
4218 set_errno(EACCES); break;
4224 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4225 if (preserve_dates & 2) {
4226 /* sys$close() will process xabrdt, not xabdat */
4227 xabrdt = cc$rms_xabrdt;
4229 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4231 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4232 * is unsigned long[2], while DECC & VAXC use a struct */
4233 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4235 fab_out.fab$l_xab = (void *) &xabrdt;
4238 rab_in = cc$rms_rab;
4239 rab_in.rab$l_fab = &fab_in;
4240 rab_in.rab$l_rop = RAB$M_BIO;
4241 rab_in.rab$l_ubf = ubf;
4242 rab_in.rab$w_usz = sizeof ubf;
4243 if (!((sts = sys$connect(&rab_in)) & 1)) {
4244 sys$close(&fab_in); sys$close(&fab_out);
4245 set_errno(EVMSERR); set_vaxc_errno(sts);
4249 rab_out = cc$rms_rab;
4250 rab_out.rab$l_fab = &fab_out;
4251 rab_out.rab$l_rbf = ubf;
4252 if (!((sts = sys$connect(&rab_out)) & 1)) {
4253 sys$close(&fab_in); sys$close(&fab_out);
4254 set_errno(EVMSERR); set_vaxc_errno(sts);
4258 while ((sts = sys$read(&rab_in))) { /* always true */
4259 if (sts == RMS$_EOF) break;
4260 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4261 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4262 sys$close(&fab_in); sys$close(&fab_out);
4263 set_errno(EVMSERR); set_vaxc_errno(sts);
4268 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4269 sys$close(&fab_in); sys$close(&fab_out);
4270 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4272 set_errno(EVMSERR); set_vaxc_errno(sts);
4278 } /* end of rmscopy() */
4282 /*** The following glue provides 'hooks' to make some of the routines
4283 * from this file available from Perl. These routines are sufficiently
4284 * basic, and are required sufficiently early in the build process,
4285 * that's it's nice to have them available to miniperl as well as the
4286 * full Perl, so they're set up here instead of in an extension. The
4287 * Perl code which handles importation of these names into a given
4288 * package lives in [.VMS]Filespec.pm in @INC.
4292 rmsexpand_fromperl(CV *cv)
4295 char *fspec, *defspec = NULL, *rslt;
4297 if (!items || items > 2)
4298 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4299 fspec = SvPV(ST(0),na);
4300 if (!fspec || !*fspec) XSRETURN_UNDEF;
4301 if (items == 2) defspec = SvPV(ST(1),na);
4303 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4304 ST(0) = sv_newmortal();
4305 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4310 vmsify_fromperl(CV *cv)
4315 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4316 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
4317 ST(0) = sv_newmortal();
4318 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4323 unixify_fromperl(CV *cv)
4328 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4329 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
4330 ST(0) = sv_newmortal();
4331 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4336 fileify_fromperl(CV *cv)
4341 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4342 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
4343 ST(0) = sv_newmortal();
4344 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4349 pathify_fromperl(CV *cv)
4354 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4355 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
4356 ST(0) = sv_newmortal();
4357 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4362 vmspath_fromperl(CV *cv)
4367 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4368 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
4369 ST(0) = sv_newmortal();
4370 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4375 unixpath_fromperl(CV *cv)
4380 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4381 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
4382 ST(0) = sv_newmortal();
4383 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4388 candelete_fromperl(CV *cv)
4391 char fspec[NAM$C_MAXRSS+1], *fsp;
4395 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4397 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4398 if (SvTYPE(mysv) == SVt_PVGV) {
4399 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
4400 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4407 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
4408 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4414 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4419 rmscopy_fromperl(CV *cv)
4422 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4424 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4425 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4426 unsigned long int sts;
4430 if (items < 2 || items > 3)
4431 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4433 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4434 if (SvTYPE(mysv) == SVt_PVGV) {
4435 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
4436 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4443 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
4444 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4449 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4450 if (SvTYPE(mysv) == SVt_PVGV) {
4451 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
4452 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4459 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
4460 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4465 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4467 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4474 char* file = __FILE__;
4476 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4477 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4478 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4479 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4480 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4481 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4482 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4483 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4484 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);