3 * VMS-specific routines for perl5
5 * Last revised: 27-Feb-1998 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
25 #include <lib$routines.h>
34 #include <str$routines.h>
39 /* Older versions of ssdef.h don't have these */
40 #ifndef SS$_INVFILFOROP
41 # define SS$_INVFILFOROP 3930
43 #ifndef SS$_NOSUCHOBJECT
44 # define SS$_NOSUCHOBJECT 2696
47 /* Don't replace system definitions of vfork, getenv, and stat,
48 * code below needs to get to the underlying CRTL routines. */
49 #define DONT_MASK_RTL_CALLS
54 /* gcc's header files don't #define direct access macros
55 * corresponding to VAXC's variant structs */
57 # define uic$v_format uic$r_uic_form.uic$v_format
58 # define uic$v_group uic$r_uic_form.uic$v_group
59 # define uic$v_member uic$r_uic_form.uic$v_member
60 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
61 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
62 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
63 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
68 unsigned short int buflen;
69 unsigned short int itmcode;
71 unsigned short int *retlen;
74 static char *__mystrtolower(char *str)
76 if (str) for (; *str; ++str) *str= tolower(*str);
81 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
83 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
84 unsigned short int eqvlen;
85 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
86 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
87 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
88 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
89 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
92 if (!lnm || idx > LNM$_MAX_INDEX) {
93 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
95 if (!eqv) eqv = __my_trnlnm_eqv;
96 lnmlst[1].bufadr = (void *)eqv;
97 lnmdsc.dsc$a_pointer = lnm;
98 lnmdsc.dsc$w_length = strlen(lnm);
99 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
100 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
101 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
103 else if (retsts & 1) {
107 _ckvmssts(retsts); /* Must be an error */
108 return 0; /* Not reached, assuming _ckvmssts() bails out */
110 } /* end of my_trnlnm */
113 * Translate a logical name. Substitute for CRTL getenv() to avoid
114 * memory leak, and to keep my_getenv() and my_setenv() in the same
115 * domain (mostly - my_getenv() need not return a translation from
116 * the process logical name table)
118 * Note: Uses Perl temp to store result so char * can be returned to
119 * caller; this pointer will be invalidated at next Perl statement
122 /*{{{ char *my_getenv(const char *lnm)*/
124 my_getenv(const char *lnm)
126 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
127 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
129 unsigned long int idx = 0;
133 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
134 /* Set up a temporary buffer for the return value; Perl will
135 * clean it up at the next statement transition */
136 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
137 if (!tmpsv) return NULL;
140 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
141 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
143 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
144 getcwd(eqv,LNM$C_NAMLENGTH);
148 if ((cp2 = strchr(uplnm,';')) != NULL) {
150 idx = strtoul(cp2+1,NULL,0);
152 trnsuccess = my_trnlnm(uplnm,eqv,idx);
153 /* If we had a translation index, we're only interested in lnms */
154 if (!trnsuccess && cp2 != NULL) return Nullch;
155 if (trnsuccess) return eqv;
157 unsigned long int retsts;
158 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
159 valdsc = {LNM$C_NAMLENGTH,DSC$K_DTYPE_T,
161 symdsc.dsc$w_length = cp1 - lnm;
162 symdsc.dsc$a_pointer = uplnm;
163 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
164 if (retsts == LIB$_INVSYMNAM) return Nullch;
165 if (retsts != LIB$_NOSUCHSYM) {
166 /* We want to return only logical names or CRTL Unix emulations */
167 if (retsts & 1) return Nullch;
170 /* Try for CRTL emulation of a Unix/POSIX name */
171 else return getenv(uplnm);
176 } /* end of my_getenv() */
179 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
181 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
183 /*{{{ void prime_env_iter() */
186 /* Fill the %ENV associative array with all logical names we can
187 * find, in preparation for iterating over it.
191 static int primed = 0;
192 HV *envhv = GvHVn(PL_envgv);
194 char eqv[LNM$C_NAMLENGTH+1],mbxnam[LNM$C_NAMLENGTH+1],*start,*end;
195 unsigned short int chan;
196 #ifndef CLI$M_TRUSTED
197 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
199 unsigned long int flags = CLI$M_NOWAIT | CLI$M_NOCLISYM | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
200 unsigned long int i, retsts, substs = 0, wakect = 0;
202 SV *oldrs, *linesv, *eqvsv;
203 $DESCRIPTOR(cmddsc,"Show Logical *"); $DESCRIPTOR(nldsc,"_NLA0:");
204 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(tabdsc,"DCLTABLES");
205 $DESCRIPTOR(mbxdsc,mbxnam);
207 static perl_mutex primenv_mutex;
208 MUTEX_INIT(&primenv_mutex);
212 MUTEX_LOCK(&primenv_mutex);
213 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
214 /* Perform a dummy fetch as an lval to insure that the hash table is
215 * set up. Otherwise, the hv_store() will turn into a nullop. */
216 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
217 /* Also, set up any "special" keys that the CRTL defines,
218 * either by itself or becasue we were called from a C program
219 * using exec[lv]e() */
220 for (i = 0; environ[i]; i++) {
221 if (!(start = strchr(environ[i],'='))) {
222 warn("Ill-formed CRTL environ value \"%s\"\n",environ[i]);
226 (void) hv_store(envhv,environ[i],start - environ[i] - 1,newSVpv(start,0),0);
230 /* Now, go get the logical names */
231 create_mbx(&chan,&mbxdsc);
232 if ((sholog = PerlIO_open(mbxnam,"r")) != Nullfp) {
233 if ((retsts = sys$dassgn(chan)) & 1) {
234 /* Be certain that subprocess is using the CLI and command tables we
235 * expect, and don't pass symbols through so that we insure that
236 * "Show Logical" can't be subverted.
239 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,0,&substs,
240 0,&riseandshine,0,0,&clidsc,&tabdsc);
241 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
242 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
245 if (sholog == Nullfp || !(retsts & 1)) {
246 if (sholog != Nullfp) PerlIO_close(sholog);
247 MUTEX_UNLOCK(&primenv_mutex);
248 _ckvmssts(sholog == Nullfp ? vaxc$errno : retsts);
250 /* We use Perl's sv_gets to read from the pipe, since PerlIO_open is
251 * tied to Perl's I/O layer, so it may not return a simple FILE * */
253 PL_rs = newSVpv("\n",1);
254 linesv = newSVpv("",0);
256 if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
257 PerlIO_close(sholog);
258 SvREFCNT_dec(linesv); SvREFCNT_dec(PL_rs); PL_rs = oldrs;
260 /* Wait for subprocess to clean up (we know subproc won't return 0) */
261 while (substs == 0) { sys$hiber(); wakect++;}
262 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
264 MUTEX_UNLOCK(&primenv_mutex);
267 while (*start != '"' && *start != '=' && *start) start++;
268 if (*start != '"') continue;
269 for (end = ++start; *end && *end != '"'; end++) ;
270 if (*end) *end = '\0';
272 if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
273 if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
275 warn("Ill-formed logical name |%s| in prime_env_iter",start);
278 else { MUTEX_UNLOCK(&primenv_mutex); _ckvmssts(vaxc$errno); }
281 eqvsv = newSVpv(eqv,eqvlen);
282 hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
285 } /* end of prime_env_iter */
289 /*{{{ void my_setenv(char *lnm, char *eqv)*/
291 my_setenv(char *lnm,char *eqv)
292 /* Define a supervisor-mode logical name in the process table.
293 * In the future we'll add tables, attribs, and acmodes,
294 * probably through a different call.
297 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
298 unsigned long int retsts, usermode = PSL$C_USER;
299 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
300 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
301 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
303 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
304 lnmdsc.dsc$w_length = cp1 - lnm;
306 if (!eqv || !*eqv) { /* we're deleting a logical name */
307 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
308 if (retsts == SS$_IVLOGNAM) return;
309 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
311 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
312 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
316 eqvdsc.dsc$w_length = strlen(eqv);
317 eqvdsc.dsc$a_pointer = eqv;
319 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
322 } /* end of my_setenv() */
326 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
327 /* my_crypt - VMS password hashing
328 * my_crypt() provides an interface compatible with the Unix crypt()
329 * C library function, and uses sys$hash_password() to perform VMS
330 * password hashing. The quadword hashed password value is returned
331 * as a NUL-terminated 8 character string. my_crypt() does not change
332 * the case of its string arguments; in order to match the behavior
333 * of LOGINOUT et al., alphabetic characters in both arguments must
334 * be upcased by the caller.
337 my_crypt(const char *textpasswd, const char *usrname)
339 # ifndef UAI$C_PREFERRED_ALGORITHM
340 # define UAI$C_PREFERRED_ALGORITHM 127
342 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
343 unsigned short int salt = 0;
344 unsigned long int sts;
346 unsigned short int dsc$w_length;
347 unsigned char dsc$b_type;
348 unsigned char dsc$b_class;
349 const char * dsc$a_pointer;
350 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
351 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
352 struct itmlst_3 uailst[3] = {
353 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
354 { sizeof salt, UAI$_SALT, &salt, 0},
355 { 0, 0, NULL, NULL}};
358 usrdsc.dsc$w_length = strlen(usrname);
359 usrdsc.dsc$a_pointer = usrname;
360 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
367 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
373 if (sts != RMS$_RNF) return NULL;
376 txtdsc.dsc$w_length = strlen(textpasswd);
377 txtdsc.dsc$a_pointer = textpasswd;
378 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
379 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
382 return (char *) hash;
384 } /* end of my_crypt() */
388 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
389 static char *do_fileify_dirspec(char *, char *, int);
390 static char *do_tovmsspec(char *, char *, int);
392 /*{{{int do_rmdir(char *name)*/
396 char dirfile[NAM$C_MAXRSS+1];
400 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
401 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
402 else retval = kill_file(dirfile);
405 } /* end of do_rmdir */
409 * Delete any file to which user has control access, regardless of whether
410 * delete access is explicitly allowed.
411 * Limitations: User must have write access to parent directory.
412 * Does not block signals or ASTs; if interrupted in midstream
413 * may leave file with an altered ACL.
416 /*{{{int kill_file(char *name)*/
418 kill_file(char *name)
420 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
421 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
422 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
423 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
425 unsigned char myace$b_length;
426 unsigned char myace$b_type;
427 unsigned short int myace$w_flags;
428 unsigned long int myace$l_access;
429 unsigned long int myace$l_ident;
430 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
431 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
432 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
434 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
435 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
436 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
437 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
438 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
439 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
441 /* Expand the input spec using RMS, since the CRTL remove() and
442 * system services won't do this by themselves, so we may miss
443 * a file "hiding" behind a logical name or search list. */
444 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
445 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
446 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
447 /* If not, can changing protections help? */
448 if (vaxc$errno != RMS$_PRV) return -1;
450 /* No, so we get our own UIC to use as a rights identifier,
451 * and the insert an ACE at the head of the ACL which allows us
452 * to delete the file.
454 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
455 fildsc.dsc$w_length = strlen(rspec);
456 fildsc.dsc$a_pointer = rspec;
458 newace.myace$l_ident = oldace.myace$l_ident;
459 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
464 case SS$_NOSUCHOBJECT:
465 set_errno(ENOENT); break;
467 set_errno(ENODEV); break;
469 case SS$_INVFILFOROP:
470 set_errno(EINVAL); break;
472 set_errno(EACCES); break;
476 set_vaxc_errno(aclsts);
479 /* Grab any existing ACEs with this identifier in case we fail */
480 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
481 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
482 || fndsts == SS$_NOMOREACE ) {
483 /* Add the new ACE . . . */
484 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
486 if ((rmsts = remove(name))) {
487 /* We blew it - dir with files in it, no write priv for
488 * parent directory, etc. Put things back the way they were. */
489 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
492 addlst[0].bufadr = &oldace;
493 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
500 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
501 /* We just deleted it, so of course it's not there. Some versions of
502 * VMS seem to return success on the unlock operation anyhow (after all
503 * the unlock is successful), but others don't.
505 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
506 if (aclsts & 1) aclsts = fndsts;
509 set_vaxc_errno(aclsts);
515 } /* end of kill_file() */
519 /*{{{int my_mkdir(char *,Mode_t)*/
521 my_mkdir(char *dir, Mode_t mode)
523 STRLEN dirlen = strlen(dir);
525 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
526 * null file name/type. However, it's commonplace under Unix,
527 * so we'll allow it for a gain in portability.
529 if (dir[dirlen-1] == '/') {
530 char *newdir = savepvn(dir,dirlen-1);
531 int ret = mkdir(newdir,mode);
535 else return mkdir(dir,mode);
536 } /* end of my_mkdir */
541 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
543 static unsigned long int mbxbufsiz;
544 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
548 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
549 * preprocessor consant BUFSIZ from stdio.h as the size of the
552 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
553 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
555 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
557 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
558 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
560 } /* end of create_mbx() */
562 /*{{{ my_popen and my_pclose*/
565 struct pipe_details *next;
566 PerlIO *fp; /* stdio file pointer to pipe mailbox */
567 int pid; /* PID of subprocess */
568 int mode; /* == 'r' if pipe open for reading */
569 int done; /* subprocess has completed */
570 unsigned long int completion; /* termination status of subprocess */
573 struct exit_control_block
575 struct exit_control_block *flink;
576 unsigned long int (*exit_routine)();
577 unsigned long int arg_count;
578 unsigned long int *status_address;
579 unsigned long int exit_status;
582 static struct pipe_details *open_pipes = NULL;
583 static $DESCRIPTOR(nl_desc, "NL:");
584 static int waitpid_asleep = 0;
586 static unsigned long int
589 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
592 while (open_pipes != NULL) {
593 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
594 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
597 if (!open_pipes->done) /* We tried to be nice . . . */
598 _ckvmssts(sys$delprc(&open_pipes->pid,0));
599 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
600 else if (!(sts & 1)) retsts = sts;
605 static struct exit_control_block pipe_exitblock =
606 {(struct exit_control_block *) 0,
607 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
611 popen_completion_ast(struct pipe_details *thispipe)
613 thispipe->done = TRUE;
614 if (waitpid_asleep) {
621 safe_popen(char *cmd, char *mode)
623 static int handler_set_up = FALSE;
625 unsigned short int chan;
626 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
627 struct pipe_details *info;
628 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
629 DSC$K_CLASS_S, mbxname},
630 cmddsc = {0, DSC$K_DTYPE_T,
634 cmddsc.dsc$w_length=strlen(cmd);
635 cmddsc.dsc$a_pointer=cmd;
636 if (cmddsc.dsc$w_length > 255) {
637 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
641 New(1301,info,1,struct pipe_details);
644 create_mbx(&chan,&namdsc);
646 /* open a FILE* onto it */
647 info->fp = PerlIO_open(mbxname, mode);
649 /* give up other channel onto it */
650 _ckvmssts(sys$dassgn(chan));
660 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
661 0 /* name */, &info->pid, &info->completion,
662 0, popen_completion_ast,info,0,0,0));
665 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
666 0 /* name */, &info->pid, &info->completion,
667 0, popen_completion_ast,info,0,0,0));
670 if (!handler_set_up) {
671 _ckvmssts(sys$dclexh(&pipe_exitblock));
672 handler_set_up = TRUE;
674 info->next=open_pipes; /* prepend to list */
677 PL_forkprocess = info->pid;
679 } /* end of safe_popen */
682 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
684 my_popen(char *cmd, char *mode)
687 TAINT_PROPER("popen");
688 return safe_popen(cmd,mode);
693 /*{{{ I32 my_pclose(FILE *fp)*/
694 I32 my_pclose(FILE *fp)
696 struct pipe_details *info, *last = NULL;
697 unsigned long int retsts;
699 for (info = open_pipes; info != NULL; last = info, info = info->next)
700 if (info->fp == fp) break;
702 if (info == NULL) { /* no such pipe open */
703 set_errno(ECHILD); /* quoth POSIX */
704 set_vaxc_errno(SS$_NONEXPR);
708 /* If we were writing to a subprocess, insure that someone reading from
709 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
710 * produce an EOF record in the mailbox. */
711 if (info->mode != 'r') {
712 char devnam[NAM$C_MAXRSS+1], *cp;
713 unsigned long int chan, iosb[2], retsts, retsts2;
714 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
716 if (fgetname(info->fp,devnam,1)) {
717 /* It oughta be a mailbox, so fgetname should give just the device
718 * name, but just in case . . . */
719 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
720 devdsc.dsc$w_length = strlen(devnam);
721 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
722 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
723 if (retsts & 1) retsts = iosb[0];
724 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
725 if (retsts & 1) retsts = retsts2;
728 else _ckvmssts(vaxc$errno); /* Should never happen */
730 PerlIO_close(info->fp);
732 if (info->done) retsts = info->completion;
733 else waitpid(info->pid,(int *) &retsts,0);
735 /* remove from list of open pipes */
736 if (last) last->next = info->next;
737 else open_pipes = info->next;
742 } /* end of my_pclose() */
744 /* sort-of waitpid; use only with popen() */
745 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
747 my_waitpid(Pid_t pid, int *statusp, int flags)
749 struct pipe_details *info;
751 for (info = open_pipes; info != NULL; info = info->next)
752 if (info->pid == pid) break;
754 if (info != NULL) { /* we know about this child */
755 while (!info->done) {
760 *statusp = info->completion;
763 else { /* we haven't heard of this child */
764 $DESCRIPTOR(intdsc,"0 00:00:01");
765 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
766 unsigned long int interval[2],sts;
769 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
770 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
771 if (ownerpid != mypid)
772 warn("pid %x not a child",pid);
775 _ckvmssts(sys$bintim(&intdsc,interval));
776 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
777 _ckvmssts(sys$schdwk(0,0,interval,0));
778 _ckvmssts(sys$hiber());
782 /* There's no easy way to find the termination status a child we're
783 * not aware of beforehand. If we're really interested in the future,
784 * we can go looking for a termination mailbox, or chase after the
785 * accounting record for the process.
791 } /* end of waitpid() */
796 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
798 my_gconvert(double val, int ndig, int trail, char *buf)
800 static char __gcvtbuf[DBL_DIG+1];
803 loc = buf ? buf : __gcvtbuf;
805 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
807 sprintf(loc,"%.*g",ndig,val);
813 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
814 return gcvt(val,ndig,loc);
817 loc[0] = '0'; loc[1] = '\0';
825 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
826 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
827 * to expand file specification. Allows for a single default file
828 * specification and a simple mask of options. If outbuf is non-NULL,
829 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
830 * the resultant file specification is placed. If outbuf is NULL, the
831 * resultant file specification is placed into a static buffer.
832 * The third argument, if non-NULL, is taken to be a default file
833 * specification string. The fourth argument is unused at present.
834 * rmesexpand() returns the address of the resultant string if
835 * successful, and NULL on error.
837 static char *do_tounixspec(char *, char *, int);
840 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
842 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
843 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
844 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
845 struct FAB myfab = cc$rms_fab;
846 struct NAM mynam = cc$rms_nam;
848 unsigned long int retsts, haslower = 0, isunix = 0;
850 if (!filespec || !*filespec) {
851 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
855 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
856 else outbuf = __rmsexpand_retbuf;
858 if ((isunix = (strchr(filespec,'/') != NULL))) {
859 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
863 myfab.fab$l_fna = filespec;
864 myfab.fab$b_fns = strlen(filespec);
865 myfab.fab$l_nam = &mynam;
867 if (defspec && *defspec) {
868 if (strchr(defspec,'/') != NULL) {
869 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
872 myfab.fab$l_dna = defspec;
873 myfab.fab$b_dns = strlen(defspec);
876 mynam.nam$l_esa = esa;
877 mynam.nam$b_ess = sizeof esa;
878 mynam.nam$l_rsa = outbuf;
879 mynam.nam$b_rss = NAM$C_MAXRSS;
881 retsts = sys$parse(&myfab,0,0);
883 mynam.nam$b_nop |= NAM$M_SYNCHK;
884 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
885 retsts == RMS$_DEV || retsts == RMS$_DEV) {
886 retsts = sys$parse(&myfab,0,0);
887 if (retsts & 1) goto expanded;
889 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
890 (void) sys$parse(&myfab,0,0); /* Free search context */
891 if (out) Safefree(out);
892 set_vaxc_errno(retsts);
893 if (retsts == RMS$_PRV) set_errno(EACCES);
894 else if (retsts == RMS$_DEV) set_errno(ENODEV);
895 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
896 else set_errno(EVMSERR);
899 retsts = sys$search(&myfab,0,0);
900 if (!(retsts & 1) && retsts != RMS$_FNF) {
901 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
902 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
903 if (out) Safefree(out);
904 set_vaxc_errno(retsts);
905 if (retsts == RMS$_PRV) set_errno(EACCES);
906 else set_errno(EVMSERR);
910 /* If the input filespec contained any lowercase characters,
911 * downcase the result for compatibility with Unix-minded code. */
913 for (out = myfab.fab$l_fna; *out; out++)
914 if (islower(*out)) { haslower = 1; break; }
915 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
916 else { out = esa; speclen = mynam.nam$b_esl; }
917 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
918 (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
919 speclen = mynam.nam$l_ver - out;
920 if (!(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
921 (!defspec || !*defspec || defspec[myfab.fab$b_dns-1] != '.' ||
922 defspec[myfab.fab$b_dns-2] == '.'))
923 speclen = mynam.nam$l_type - out;
924 /* If we just had a directory spec on input, $PARSE "helpfully"
925 * adds an empty name and type for us */
926 if (mynam.nam$l_name == mynam.nam$l_type &&
927 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
928 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
929 speclen = mynam.nam$l_name - out;
931 if (haslower) __mystrtolower(out);
933 /* Have we been working with an expanded, but not resultant, spec? */
934 /* Also, convert back to Unix syntax if necessary. */
935 if (!mynam.nam$b_rsl) {
937 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
939 else strcpy(outbuf,esa);
942 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
943 strcpy(outbuf,tmpfspec);
945 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
946 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
947 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
951 /* External entry points */
952 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
953 { return do_rmsexpand(spec,buf,0,def,opt); }
954 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
955 { return do_rmsexpand(spec,buf,1,def,opt); }
959 ** The following routines are provided to make life easier when
960 ** converting among VMS-style and Unix-style directory specifications.
961 ** All will take input specifications in either VMS or Unix syntax. On
962 ** failure, all return NULL. If successful, the routines listed below
963 ** return a pointer to a buffer containing the appropriately
964 ** reformatted spec (and, therefore, subsequent calls to that routine
965 ** will clobber the result), while the routines of the same names with
966 ** a _ts suffix appended will return a pointer to a mallocd string
967 ** containing the appropriately reformatted spec.
968 ** In all cases, only explicit syntax is altered; no check is made that
969 ** the resulting string is valid or that the directory in question
972 ** fileify_dirspec() - convert a directory spec into the name of the
973 ** directory file (i.e. what you can stat() to see if it's a dir).
974 ** The style (VMS or Unix) of the result is the same as the style
975 ** of the parameter passed in.
976 ** pathify_dirspec() - convert a directory spec into a path (i.e.
977 ** what you prepend to a filename to indicate what directory it's in).
978 ** The style (VMS or Unix) of the result is the same as the style
979 ** of the parameter passed in.
980 ** tounixpath() - convert a directory spec into a Unix-style path.
981 ** tovmspath() - convert a directory spec into a VMS-style path.
982 ** tounixspec() - convert any file spec into a Unix-style file spec.
983 ** tovmsspec() - convert any file spec into a VMS-style spec.
985 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
986 ** Permission is given to distribute this code as part of the Perl
987 ** standard distribution under the terms of the GNU General Public
988 ** License or the Perl Artistic License. Copies of each may be
989 ** found in the Perl standard distribution.
992 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
993 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
995 static char __fileify_retbuf[NAM$C_MAXRSS+1];
996 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
997 char *retspec, *cp1, *cp2, *lastdir;
998 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1000 if (!dir || !*dir) {
1001 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1003 dirlen = strlen(dir);
1004 while (dir[dirlen-1] == '/') --dirlen;
1005 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1006 strcpy(trndir,"/sys$disk/000000");
1010 if (dirlen > NAM$C_MAXRSS) {
1011 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1013 if (!strpbrk(dir+1,"/]>:")) {
1014 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1015 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1017 dirlen = strlen(dir);
1020 strncpy(trndir,dir,dirlen);
1021 trndir[dirlen] = '\0';
1024 /* If we were handed a rooted logical name or spec, treat it like a
1025 * simple directory, so that
1026 * $ Define myroot dev:[dir.]
1027 * ... do_fileify_dirspec("myroot",buf,1) ...
1028 * does something useful.
1030 if (!strcmp(dir+dirlen-2,".]")) {
1031 dir[--dirlen] = '\0';
1032 dir[dirlen-1] = ']';
1035 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1036 /* If we've got an explicit filename, we can just shuffle the string. */
1037 if (*(cp1+1)) hasfilename = 1;
1038 /* Similarly, we can just back up a level if we've got multiple levels
1039 of explicit directories in a VMS spec which ends with directories. */
1041 for (cp2 = cp1; cp2 > dir; cp2--) {
1043 *cp2 = *cp1; *cp1 = '\0';
1047 if (*cp2 == '[' || *cp2 == '<') break;
1052 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1053 if (dir[0] == '.') {
1054 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1055 return do_fileify_dirspec("[]",buf,ts);
1056 else if (dir[1] == '.' &&
1057 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1058 return do_fileify_dirspec("[-]",buf,ts);
1060 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1061 dirlen -= 1; /* to last element */
1062 lastdir = strrchr(dir,'/');
1064 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1065 /* If we have "/." or "/..", VMSify it and let the VMS code
1066 * below expand it, rather than repeating the code to handle
1067 * relative components of a filespec here */
1069 if (*(cp1+2) == '.') cp1++;
1070 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1071 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1072 if (strchr(vmsdir,'/') != NULL) {
1073 /* If do_tovmsspec() returned it, it must have VMS syntax
1074 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1075 * the time to check this here only so we avoid a recursion
1076 * loop; otherwise, gigo.
1078 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1080 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1081 return do_tounixspec(trndir,buf,ts);
1084 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1085 lastdir = strrchr(dir,'/');
1087 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1088 /* Ditto for specs that end in an MFD -- let the VMS code
1089 * figure out whether it's a real device or a rooted logical. */
1090 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1091 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1092 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1093 return do_tounixspec(trndir,buf,ts);
1096 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1097 !(lastdir = cp1 = strrchr(dir,']')) &&
1098 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1099 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1101 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1102 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1103 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1104 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1105 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1106 (ver || *cp3)))))) {
1108 set_vaxc_errno(RMS$_DIR);
1114 /* If we lead off with a device or rooted logical, add the MFD
1115 if we're specifying a top-level directory. */
1116 if (lastdir && *dir == '/') {
1118 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1125 retlen = dirlen + (addmfd ? 13 : 6);
1126 if (buf) retspec = buf;
1127 else if (ts) New(1309,retspec,retlen+1,char);
1128 else retspec = __fileify_retbuf;
1130 dirlen = lastdir - dir;
1131 memcpy(retspec,dir,dirlen);
1132 strcpy(&retspec[dirlen],"/000000");
1133 strcpy(&retspec[dirlen+7],lastdir);
1136 memcpy(retspec,dir,dirlen);
1137 retspec[dirlen] = '\0';
1139 /* We've picked up everything up to the directory file name.
1140 Now just add the type and version, and we're set. */
1141 strcat(retspec,".dir;1");
1144 else { /* VMS-style directory spec */
1145 char esa[NAM$C_MAXRSS+1], term, *cp;
1146 unsigned long int sts, cmplen, haslower = 0;
1147 struct FAB dirfab = cc$rms_fab;
1148 struct NAM savnam, dirnam = cc$rms_nam;
1150 dirfab.fab$b_fns = strlen(dir);
1151 dirfab.fab$l_fna = dir;
1152 dirfab.fab$l_nam = &dirnam;
1153 dirfab.fab$l_dna = ".DIR;1";
1154 dirfab.fab$b_dns = 6;
1155 dirnam.nam$b_ess = NAM$C_MAXRSS;
1156 dirnam.nam$l_esa = esa;
1158 for (cp = dir; *cp; cp++)
1159 if (islower(*cp)) { haslower = 1; break; }
1160 if (!((sts = sys$parse(&dirfab))&1)) {
1161 if (dirfab.fab$l_sts == RMS$_DIR) {
1162 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1163 sts = sys$parse(&dirfab) & 1;
1167 set_vaxc_errno(dirfab.fab$l_sts);
1173 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1174 /* Yes; fake the fnb bits so we'll check type below */
1175 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1178 if (dirfab.fab$l_sts != RMS$_FNF) {
1180 set_vaxc_errno(dirfab.fab$l_sts);
1183 dirnam = savnam; /* No; just work with potential name */
1186 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1187 cp1 = strchr(esa,']');
1188 if (!cp1) cp1 = strchr(esa,'>');
1189 if (cp1) { /* Should always be true */
1190 dirnam.nam$b_esl -= cp1 - esa - 1;
1191 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1194 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1195 /* Yep; check version while we're at it, if it's there. */
1196 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1197 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1198 /* Something other than .DIR[;1]. Bzzt. */
1200 set_vaxc_errno(RMS$_DIR);
1204 esa[dirnam.nam$b_esl] = '\0';
1205 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1206 /* They provided at least the name; we added the type, if necessary, */
1207 if (buf) retspec = buf; /* in sys$parse() */
1208 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1209 else retspec = __fileify_retbuf;
1210 strcpy(retspec,esa);
1213 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1214 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1216 dirnam.nam$b_esl -= 9;
1218 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1219 if (cp1 == NULL) return NULL; /* should never happen */
1222 retlen = strlen(esa);
1223 if ((cp1 = strrchr(esa,'.')) != NULL) {
1224 /* There's more than one directory in the path. Just roll back. */
1226 if (buf) retspec = buf;
1227 else if (ts) New(1311,retspec,retlen+7,char);
1228 else retspec = __fileify_retbuf;
1229 strcpy(retspec,esa);
1232 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1233 /* Go back and expand rooted logical name */
1234 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1235 if (!(sys$parse(&dirfab) & 1)) {
1237 set_vaxc_errno(dirfab.fab$l_sts);
1240 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1241 if (buf) retspec = buf;
1242 else if (ts) New(1312,retspec,retlen+16,char);
1243 else retspec = __fileify_retbuf;
1244 cp1 = strstr(esa,"][");
1246 memcpy(retspec,esa,dirlen);
1247 if (!strncmp(cp1+2,"000000]",7)) {
1248 retspec[dirlen-1] = '\0';
1249 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1250 if (*cp1 == '.') *cp1 = ']';
1252 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1253 memcpy(cp1+1,"000000]",7);
1257 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1258 retspec[retlen] = '\0';
1259 /* Convert last '.' to ']' */
1260 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1261 if (*cp1 == '.') *cp1 = ']';
1263 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1264 memcpy(cp1+1,"000000]",7);
1268 else { /* This is a top-level dir. Add the MFD to the path. */
1269 if (buf) retspec = buf;
1270 else if (ts) New(1312,retspec,retlen+16,char);
1271 else retspec = __fileify_retbuf;
1274 while (*cp1 != ':') *(cp2++) = *(cp1++);
1275 strcpy(cp2,":[000000]");
1280 /* We've set up the string up through the filename. Add the
1281 type and version, and we're done. */
1282 strcat(retspec,".DIR;1");
1284 /* $PARSE may have upcased filespec, so convert output to lower
1285 * case if input contained any lowercase characters. */
1286 if (haslower) __mystrtolower(retspec);
1289 } /* end of do_fileify_dirspec() */
1291 /* External entry points */
1292 char *fileify_dirspec(char *dir, char *buf)
1293 { return do_fileify_dirspec(dir,buf,0); }
1294 char *fileify_dirspec_ts(char *dir, char *buf)
1295 { return do_fileify_dirspec(dir,buf,1); }
1297 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1298 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1300 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1301 unsigned long int retlen;
1302 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1304 if (!dir || !*dir) {
1305 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1308 if (*dir) strcpy(trndir,dir);
1309 else getcwd(trndir,sizeof trndir - 1);
1311 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1312 STRLEN trnlen = strlen(trndir);
1314 /* Trap simple rooted lnms, and return lnm:[000000] */
1315 if (!strcmp(trndir+trnlen-2,".]")) {
1316 if (buf) retpath = buf;
1317 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1318 else retpath = __pathify_retbuf;
1319 strcpy(retpath,dir);
1320 strcat(retpath,":[000000]");
1326 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1327 if (*dir == '.' && (*(dir+1) == '\0' ||
1328 (*(dir+1) == '.' && *(dir+2) == '\0')))
1329 retlen = 2 + (*(dir+1) != '\0');
1331 if ( !(cp1 = strrchr(dir,'/')) &&
1332 !(cp1 = strrchr(dir,']')) &&
1333 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1334 if ((cp2 = strchr(cp1,'.')) != NULL &&
1335 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1336 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1337 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1338 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1340 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1341 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1342 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1343 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1344 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1345 (ver || *cp3)))))) {
1347 set_vaxc_errno(RMS$_DIR);
1350 retlen = cp2 - dir + 1;
1352 else { /* No file type present. Treat the filename as a directory. */
1353 retlen = strlen(dir) + 1;
1356 if (buf) retpath = buf;
1357 else if (ts) New(1313,retpath,retlen+1,char);
1358 else retpath = __pathify_retbuf;
1359 strncpy(retpath,dir,retlen-1);
1360 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1361 retpath[retlen-1] = '/'; /* with '/', add it. */
1362 retpath[retlen] = '\0';
1364 else retpath[retlen-1] = '\0';
1366 else { /* VMS-style directory spec */
1367 char esa[NAM$C_MAXRSS+1], *cp;
1368 unsigned long int sts, cmplen, haslower;
1369 struct FAB dirfab = cc$rms_fab;
1370 struct NAM savnam, dirnam = cc$rms_nam;
1372 /* If we've got an explicit filename, we can just shuffle the string. */
1373 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1374 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1375 if ((cp2 = strchr(cp1,'.')) != NULL) {
1377 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1378 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1379 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1380 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1381 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1382 (ver || *cp3)))))) {
1384 set_vaxc_errno(RMS$_DIR);
1388 else { /* No file type, so just draw name into directory part */
1389 for (cp2 = cp1; *cp2; cp2++) ;
1392 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1394 /* We've now got a VMS 'path'; fall through */
1396 dirfab.fab$b_fns = strlen(dir);
1397 dirfab.fab$l_fna = dir;
1398 if (dir[dirfab.fab$b_fns-1] == ']' ||
1399 dir[dirfab.fab$b_fns-1] == '>' ||
1400 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1401 if (buf) retpath = buf;
1402 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1403 else retpath = __pathify_retbuf;
1404 strcpy(retpath,dir);
1407 dirfab.fab$l_dna = ".DIR;1";
1408 dirfab.fab$b_dns = 6;
1409 dirfab.fab$l_nam = &dirnam;
1410 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1411 dirnam.nam$l_esa = esa;
1413 for (cp = dir; *cp; cp++)
1414 if (islower(*cp)) { haslower = 1; break; }
1416 if (!(sts = (sys$parse(&dirfab)&1))) {
1417 if (dirfab.fab$l_sts == RMS$_DIR) {
1418 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1419 sts = sys$parse(&dirfab) & 1;
1423 set_vaxc_errno(dirfab.fab$l_sts);
1429 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1430 if (dirfab.fab$l_sts != RMS$_FNF) {
1432 set_vaxc_errno(dirfab.fab$l_sts);
1435 dirnam = savnam; /* No; just work with potential name */
1438 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1439 /* Yep; check version while we're at it, if it's there. */
1440 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1441 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1442 /* Something other than .DIR[;1]. Bzzt. */
1444 set_vaxc_errno(RMS$_DIR);
1448 /* OK, the type was fine. Now pull any file name into the
1450 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1452 cp1 = strrchr(esa,'>');
1453 *dirnam.nam$l_type = '>';
1456 *(dirnam.nam$l_type + 1) = '\0';
1457 retlen = dirnam.nam$l_type - esa + 2;
1458 if (buf) retpath = buf;
1459 else if (ts) New(1314,retpath,retlen,char);
1460 else retpath = __pathify_retbuf;
1461 strcpy(retpath,esa);
1462 /* $PARSE may have upcased filespec, so convert output to lower
1463 * case if input contained any lowercase characters. */
1464 if (haslower) __mystrtolower(retpath);
1468 } /* end of do_pathify_dirspec() */
1470 /* External entry points */
1471 char *pathify_dirspec(char *dir, char *buf)
1472 { return do_pathify_dirspec(dir,buf,0); }
1473 char *pathify_dirspec_ts(char *dir, char *buf)
1474 { return do_pathify_dirspec(dir,buf,1); }
1476 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1477 static char *do_tounixspec(char *spec, char *buf, int ts)
1479 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1480 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1481 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1483 if (spec == NULL) return NULL;
1484 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1485 if (buf) rslt = buf;
1487 retlen = strlen(spec);
1488 cp1 = strchr(spec,'[');
1489 if (!cp1) cp1 = strchr(spec,'<');
1491 for (cp1++; *cp1; cp1++) {
1492 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1493 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1494 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1497 New(1315,rslt,retlen+2+2*expand,char);
1499 else rslt = __tounixspec_retbuf;
1500 if (strchr(spec,'/') != NULL) {
1507 dirend = strrchr(spec,']');
1508 if (dirend == NULL) dirend = strrchr(spec,'>');
1509 if (dirend == NULL) dirend = strchr(spec,':');
1510 if (dirend == NULL) {
1514 if (*cp2 != '[' && *cp2 != '<') {
1517 else { /* the VMS spec begins with directories */
1519 if (*cp2 == ']' || *cp2 == '>') {
1520 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1523 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1524 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1525 if (ts) Safefree(rslt);
1530 while (*cp3 != ':' && *cp3) cp3++;
1532 if (strchr(cp3,']') != NULL) break;
1533 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1535 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1536 retlen = devlen + dirlen;
1537 Renew(rslt,retlen+1+2*expand,char);
1543 *(cp1++) = *(cp3++);
1544 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1548 else if ( *cp2 == '.') {
1549 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1550 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1556 for (; cp2 <= dirend; cp2++) {
1559 if (*(cp2+1) == '[') cp2++;
1561 else if (*cp2 == ']' || *cp2 == '>') {
1562 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1564 else if (*cp2 == '.') {
1566 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1567 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1568 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1569 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1570 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1572 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1573 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1577 else if (*cp2 == '-') {
1578 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1579 while (*cp2 == '-') {
1581 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1583 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1584 if (ts) Safefree(rslt); /* filespecs like */
1585 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1589 else *(cp1++) = *cp2;
1591 else *(cp1++) = *cp2;
1593 while (*cp2) *(cp1++) = *(cp2++);
1598 } /* end of do_tounixspec() */
1600 /* External entry points */
1601 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1602 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1604 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1605 static char *do_tovmsspec(char *path, char *buf, int ts) {
1606 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1607 char *rslt, *dirend;
1608 register char *cp1, *cp2;
1609 unsigned long int infront = 0, hasdir = 1;
1611 if (path == NULL) return NULL;
1612 if (buf) rslt = buf;
1613 else if (ts) New(1316,rslt,strlen(path)+9,char);
1614 else rslt = __tovmsspec_retbuf;
1615 if (strpbrk(path,"]:>") ||
1616 (dirend = strrchr(path,'/')) == NULL) {
1617 if (path[0] == '.') {
1618 if (path[1] == '\0') strcpy(rslt,"[]");
1619 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1620 else strcpy(rslt,path); /* probably garbage */
1622 else strcpy(rslt,path);
1625 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1626 if (!*(dirend+2)) dirend +=2;
1627 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1628 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1633 char trndev[NAM$C_MAXRSS+1];
1637 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1639 if (!buf & ts) Renew(rslt,18,char);
1640 strcpy(rslt,"sys$disk:[000000]");
1643 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1645 islnm = my_trnlnm(rslt,trndev,0);
1646 trnend = islnm ? strlen(trndev) - 1 : 0;
1647 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1648 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1649 /* If the first element of the path is a logical name, determine
1650 * whether it has to be translated so we can add more directories. */
1651 if (!islnm || rooted) {
1654 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1658 if (cp2 != dirend) {
1659 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1660 strcpy(rslt,trndev);
1661 cp1 = rslt + trnend;
1674 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1675 cp2 += 2; /* skip over "./" - it's redundant */
1676 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1678 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1679 *(cp1++) = '-'; /* "../" --> "-" */
1682 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
1683 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
1684 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1685 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
1688 if (cp2 > dirend) cp2 = dirend;
1690 else *(cp1++) = '.';
1692 for (; cp2 < dirend; cp2++) {
1694 if (*(cp2-1) == '/') continue;
1695 if (*(cp1-1) != '.') *(cp1++) = '.';
1698 else if (!infront && *cp2 == '.') {
1699 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1700 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1701 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1702 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1703 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1704 else { /* back up over previous directory name */
1706 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1707 if (*(cp1-1) == '[') {
1708 memcpy(cp1,"000000.",7);
1713 if (cp2 == dirend) break;
1715 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
1716 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
1717 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
1718 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
1720 *(cp1++) = '.'; /* Simulate trailing '/' */
1721 cp2 += 2; /* for loop will incr this to == dirend */
1723 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
1725 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1728 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1729 if (*cp2 == '.') *(cp1++) = '_';
1730 else *(cp1++) = *cp2;
1734 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1735 if (hasdir) *(cp1++) = ']';
1736 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1737 while (*cp2) *(cp1++) = *(cp2++);
1742 } /* end of do_tovmsspec() */
1744 /* External entry points */
1745 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1746 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1748 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1749 static char *do_tovmspath(char *path, char *buf, int ts) {
1750 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1752 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1754 if (path == NULL) return NULL;
1755 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1756 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1757 if (buf) return buf;
1759 vmslen = strlen(vmsified);
1760 New(1317,cp,vmslen+1,char);
1761 memcpy(cp,vmsified,vmslen);
1766 strcpy(__tovmspath_retbuf,vmsified);
1767 return __tovmspath_retbuf;
1770 } /* end of do_tovmspath() */
1772 /* External entry points */
1773 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1774 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1777 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1778 static char *do_tounixpath(char *path, char *buf, int ts) {
1779 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1781 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1783 if (path == NULL) return NULL;
1784 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1785 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1786 if (buf) return buf;
1788 unixlen = strlen(unixified);
1789 New(1317,cp,unixlen+1,char);
1790 memcpy(cp,unixified,unixlen);
1795 strcpy(__tounixpath_retbuf,unixified);
1796 return __tounixpath_retbuf;
1799 } /* end of do_tounixpath() */
1801 /* External entry points */
1802 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1803 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1806 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1808 *****************************************************************************
1810 * Copyright (C) 1989-1994 by *
1811 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1813 * Permission is hereby granted for the reproduction of this software, *
1814 * on condition that this copyright notice is included in the reproduction, *
1815 * and that such reproduction is not for purposes of profit or material *
1818 * 27-Aug-1994 Modified for inclusion in perl5 *
1819 * by Charles Bailey bailey@newman.upenn.edu *
1820 *****************************************************************************
1824 * getredirection() is intended to aid in porting C programs
1825 * to VMS (Vax-11 C). The native VMS environment does not support
1826 * '>' and '<' I/O redirection, or command line wild card expansion,
1827 * or a command line pipe mechanism using the '|' AND background
1828 * command execution '&'. All of these capabilities are provided to any
1829 * C program which calls this procedure as the first thing in the
1831 * The piping mechanism will probably work with almost any 'filter' type
1832 * of program. With suitable modification, it may useful for other
1833 * portability problems as well.
1835 * Author: Mark Pizzolato mark@infocomm.com
1839 struct list_item *next;
1843 static void add_item(struct list_item **head,
1844 struct list_item **tail,
1848 static void expand_wild_cards(char *item,
1849 struct list_item **head,
1850 struct list_item **tail,
1853 static int background_process(int argc, char **argv);
1855 static void pipe_and_fork(char **cmargv);
1857 /*{{{ void getredirection(int *ac, char ***av)*/
1859 getredirection(int *ac, char ***av)
1861 * Process vms redirection arg's. Exit if any error is seen.
1862 * If getredirection() processes an argument, it is erased
1863 * from the vector. getredirection() returns a new argc and argv value.
1864 * In the event that a background command is requested (by a trailing "&"),
1865 * this routine creates a background subprocess, and simply exits the program.
1867 * Warning: do not try to simplify the code for vms. The code
1868 * presupposes that getredirection() is called before any data is
1869 * read from stdin or written to stdout.
1871 * Normal usage is as follows:
1877 * getredirection(&argc, &argv);
1881 int argc = *ac; /* Argument Count */
1882 char **argv = *av; /* Argument Vector */
1883 char *ap; /* Argument pointer */
1884 int j; /* argv[] index */
1885 int item_count = 0; /* Count of Items in List */
1886 struct list_item *list_head = 0; /* First Item in List */
1887 struct list_item *list_tail; /* Last Item in List */
1888 char *in = NULL; /* Input File Name */
1889 char *out = NULL; /* Output File Name */
1890 char *outmode = "w"; /* Mode to Open Output File */
1891 char *err = NULL; /* Error File Name */
1892 char *errmode = "w"; /* Mode to Open Error File */
1893 int cmargc = 0; /* Piped Command Arg Count */
1894 char **cmargv = NULL;/* Piped Command Arg Vector */
1897 * First handle the case where the last thing on the line ends with
1898 * a '&'. This indicates the desire for the command to be run in a
1899 * subprocess, so we satisfy that desire.
1902 if (0 == strcmp("&", ap))
1903 exit(background_process(--argc, argv));
1904 if (*ap && '&' == ap[strlen(ap)-1])
1906 ap[strlen(ap)-1] = '\0';
1907 exit(background_process(argc, argv));
1910 * Now we handle the general redirection cases that involve '>', '>>',
1911 * '<', and pipes '|'.
1913 for (j = 0; j < argc; ++j)
1915 if (0 == strcmp("<", argv[j]))
1919 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
1920 exit(LIB$_WRONUMARG);
1925 if ('<' == *(ap = argv[j]))
1930 if (0 == strcmp(">", ap))
1934 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
1935 exit(LIB$_WRONUMARG);
1954 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
1955 exit(LIB$_WRONUMARG);
1959 if (('2' == *ap) && ('>' == ap[1]))
1976 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
1977 exit(LIB$_WRONUMARG);
1981 if (0 == strcmp("|", argv[j]))
1985 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
1986 exit(LIB$_WRONUMARG);
1988 cmargc = argc-(j+1);
1989 cmargv = &argv[j+1];
1993 if ('|' == *(ap = argv[j]))
2001 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2004 * Allocate and fill in the new argument vector, Some Unix's terminate
2005 * the list with an extra null pointer.
2007 New(1302, argv, item_count+1, char *);
2009 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2010 argv[j] = list_head->value;
2016 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2017 exit(LIB$_INVARGORD);
2019 pipe_and_fork(cmargv);
2022 /* Check for input from a pipe (mailbox) */
2024 if (in == NULL && 1 == isapipe(0))
2026 char mbxname[L_tmpnam];
2028 long int dvi_item = DVI$_DEVBUFSIZ;
2029 $DESCRIPTOR(mbxnam, "");
2030 $DESCRIPTOR(mbxdevnam, "");
2032 /* Input from a pipe, reopen it in binary mode to disable */
2033 /* carriage control processing. */
2035 PerlIO_getname(stdin, mbxname);
2036 mbxnam.dsc$a_pointer = mbxname;
2037 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2038 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2039 mbxdevnam.dsc$a_pointer = mbxname;
2040 mbxdevnam.dsc$w_length = sizeof(mbxname);
2041 dvi_item = DVI$_DEVNAM;
2042 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2043 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2046 freopen(mbxname, "rb", stdin);
2049 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2053 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2055 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2058 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2060 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2065 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2067 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2071 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2076 #ifdef ARGPROC_DEBUG
2077 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2078 for (j = 0; j < *ac; ++j)
2079 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2081 /* Clear errors we may have hit expanding wildcards, so they don't
2082 show up in Perl's $! later */
2083 set_errno(0); set_vaxc_errno(1);
2084 } /* end of getredirection() */
2087 static void add_item(struct list_item **head,
2088 struct list_item **tail,
2094 New(1303,*head,1,struct list_item);
2098 New(1304,(*tail)->next,1,struct list_item);
2099 *tail = (*tail)->next;
2101 (*tail)->value = value;
2105 static void expand_wild_cards(char *item,
2106 struct list_item **head,
2107 struct list_item **tail,
2111 unsigned long int context = 0;
2117 char vmsspec[NAM$C_MAXRSS+1];
2118 $DESCRIPTOR(filespec, "");
2119 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2120 $DESCRIPTOR(resultspec, "");
2121 unsigned long int zero = 0, sts;
2123 if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
2125 add_item(head, tail, item, count);
2128 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2129 resultspec.dsc$b_class = DSC$K_CLASS_D;
2130 resultspec.dsc$a_pointer = NULL;
2131 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2132 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2133 if (!isunix || !filespec.dsc$a_pointer)
2134 filespec.dsc$a_pointer = item;
2135 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2137 * Only return version specs, if the caller specified a version
2139 had_version = strchr(item, ';');
2141 * Only return device and directory specs, if the caller specifed either.
2143 had_device = strchr(item, ':');
2144 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2146 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2147 &defaultspec, 0, 0, &zero))))
2152 New(1305,string,resultspec.dsc$w_length+1,char);
2153 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2154 string[resultspec.dsc$w_length] = '\0';
2155 if (NULL == had_version)
2156 *((char *)strrchr(string, ';')) = '\0';
2157 if ((!had_directory) && (had_device == NULL))
2159 if (NULL == (devdir = strrchr(string, ']')))
2160 devdir = strrchr(string, '>');
2161 strcpy(string, devdir + 1);
2164 * Be consistent with what the C RTL has already done to the rest of
2165 * the argv items and lowercase all of these names.
2167 for (c = string; *c; ++c)
2170 if (isunix) trim_unixpath(string,item,1);
2171 add_item(head, tail, string, count);
2174 if (sts != RMS$_NMF)
2176 set_vaxc_errno(sts);
2182 set_errno(ENOENT); break;
2184 set_errno(ENODEV); break;
2187 set_errno(EINVAL); break;
2189 set_errno(EACCES); break;
2191 _ckvmssts_noperl(sts);
2195 add_item(head, tail, item, count);
2196 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2197 _ckvmssts_noperl(lib$find_file_end(&context));
2200 static int child_st[2];/* Event Flag set when child process completes */
2202 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2204 static unsigned long int exit_handler(int *status)
2208 if (0 == child_st[0])
2210 #ifdef ARGPROC_DEBUG
2211 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2213 fflush(stdout); /* Have to flush pipe for binary data to */
2214 /* terminate properly -- <tp@mccall.com> */
2215 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2216 sys$dassgn(child_chan);
2218 sys$synch(0, child_st);
2223 static void sig_child(int chan)
2225 #ifdef ARGPROC_DEBUG
2226 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2228 if (child_st[0] == 0)
2232 static struct exit_control_block exit_block =
2237 &exit_block.exit_status,
2241 static void pipe_and_fork(char **cmargv)
2244 $DESCRIPTOR(cmddsc, "");
2245 static char mbxname[64];
2246 $DESCRIPTOR(mbxdsc, mbxname);
2248 unsigned long int zero = 0, one = 1;
2250 strcpy(subcmd, cmargv[0]);
2251 for (j = 1; NULL != cmargv[j]; ++j)
2253 strcat(subcmd, " \"");
2254 strcat(subcmd, cmargv[j]);
2255 strcat(subcmd, "\"");
2257 cmddsc.dsc$a_pointer = subcmd;
2258 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2260 create_mbx(&child_chan,&mbxdsc);
2261 #ifdef ARGPROC_DEBUG
2262 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2263 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2265 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2266 0, &pid, child_st, &zero, sig_child,
2268 #ifdef ARGPROC_DEBUG
2269 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2271 sys$dclexh(&exit_block);
2272 if (NULL == freopen(mbxname, "wb", stdout))
2274 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2278 static int background_process(int argc, char **argv)
2280 char command[2048] = "$";
2281 $DESCRIPTOR(value, "");
2282 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2283 static $DESCRIPTOR(null, "NLA0:");
2284 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2286 $DESCRIPTOR(pidstr, "");
2288 unsigned long int flags = 17, one = 1, retsts;
2290 strcat(command, argv[0]);
2293 strcat(command, " \"");
2294 strcat(command, *(++argv));
2295 strcat(command, "\"");
2297 value.dsc$a_pointer = command;
2298 value.dsc$w_length = strlen(value.dsc$a_pointer);
2299 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2300 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2301 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2302 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2305 _ckvmssts_noperl(retsts);
2307 #ifdef ARGPROC_DEBUG
2308 PerlIO_printf(Perl_debug_log, "%s\n", command);
2310 sprintf(pidstring, "%08X", pid);
2311 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2312 pidstr.dsc$a_pointer = pidstring;
2313 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2314 lib$set_symbol(&pidsymbol, &pidstr);
2318 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2321 /* OS-specific initialization at image activation (not thread startup) */
2322 /* Older VAXC header files lack these constants */
2323 #ifndef JPI$_RIGHTS_SIZE
2324 # define JPI$_RIGHTS_SIZE 817
2326 #ifndef KGB$M_SUBSYSTEM
2327 # define KGB$M_SUBSYSTEM 0x8
2330 /*{{{void vms_image_init(int *, char ***)*/
2332 vms_image_init(int *argcp, char ***argvp)
2334 unsigned long int *mask, iosb[2], i, rlst[128], rsz, add_taint = FALSE;
2335 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2336 unsigned short int dummy, rlen;
2337 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2338 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2339 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2342 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2344 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2345 if (iprv[i]) { /* Running image installed with privs? */
2346 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2351 /* Rights identifiers might trigger tainting as well. */
2352 if (!add_taint && (rlen || rsz)) {
2353 while (rlen < rsz) {
2354 /* We didn't get all the identifiers on the first pass. Allocate a
2355 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2356 * were needed to hold all identifiers at time of last call; we'll
2357 * allocate that many unsigned long ints), and go back and get 'em.
2359 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2360 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2361 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2362 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2365 mask = jpilist[1].bufadr;
2366 /* Check attribute flags for each identifier (2nd longword); protected
2367 * subsystem identifiers trigger tainting.
2369 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2370 if (mask[i] & KGB$M_SUBSYSTEM) {
2375 if (mask != rlst) Safefree(mask);
2377 /* We need to use this hack to tell Perl it should run with tainting,
2378 * since its tainting flag may be part of the PL_curinterp struct, which
2379 * hasn't been allocated when vms_image_init() is called.
2383 New(1320,newap,*argcp+2,char **);
2384 newap[0] = argvp[0];
2386 Copy(argvp[1],newap[2],*argcp-1,char **);
2387 /* We orphan the old argv, since we don't know where it's come from,
2388 * so we don't know how to free it.
2390 *argcp++; argvp = newap;
2392 getredirection(argcp,argvp);
2393 #if defined(USE_THREADS) && defined(__DECC)
2395 # include <reentrancy.h>
2396 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2405 * Trim Unix-style prefix off filespec, so it looks like what a shell
2406 * glob expansion would return (i.e. from specified prefix on, not
2407 * full path). Note that returned filespec is Unix-style, regardless
2408 * of whether input filespec was VMS-style or Unix-style.
2410 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2411 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2412 * vector of options; at present, only bit 0 is used, and if set tells
2413 * trim unixpath to try the current default directory as a prefix when
2414 * presented with a possibly ambiguous ... wildcard.
2416 * Returns !=0 on success, with trimmed filespec replacing contents of
2417 * fspec, and 0 on failure, with contents of fpsec unchanged.
2419 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2421 trim_unixpath(char *fspec, char *wildspec, int opts)
2423 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2424 *template, *base, *end, *cp1, *cp2;
2425 register int tmplen, reslen = 0, dirs = 0;
2427 if (!wildspec || !fspec) return 0;
2428 if (strpbrk(wildspec,"]>:") != NULL) {
2429 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2430 else template = unixwild;
2432 else template = wildspec;
2433 if (strpbrk(fspec,"]>:") != NULL) {
2434 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2435 else base = unixified;
2436 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2437 * check to see that final result fits into (isn't longer than) fspec */
2438 reslen = strlen(fspec);
2442 /* No prefix or absolute path on wildcard, so nothing to remove */
2443 if (!*template || *template == '/') {
2444 if (base == fspec) return 1;
2445 tmplen = strlen(unixified);
2446 if (tmplen > reslen) return 0; /* not enough space */
2447 /* Copy unixified resultant, including trailing NUL */
2448 memmove(fspec,unixified,tmplen+1);
2452 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2453 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2454 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2455 for (cp1 = end ;cp1 >= base; cp1--)
2456 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2458 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2462 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2463 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2464 int ells = 1, totells, segdirs, match;
2465 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2466 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2468 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2470 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2471 if (ellipsis == template && opts & 1) {
2472 /* Template begins with an ellipsis. Since we can't tell how many
2473 * directory names at the front of the resultant to keep for an
2474 * arbitrary starting point, we arbitrarily choose the current
2475 * default directory as a starting point. If it's there as a prefix,
2476 * clip it off. If not, fall through and act as if the leading
2477 * ellipsis weren't there (i.e. return shortest possible path that
2478 * could match template).
2480 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2481 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2482 if (_tolower(*cp1) != _tolower(*cp2)) break;
2483 segdirs = dirs - totells; /* Min # of dirs we must have left */
2484 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2485 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2486 memcpy(fspec,cp2+1,end - cp2);
2490 /* First off, back up over constant elements at end of path */
2492 for (front = end ; front >= base; front--)
2493 if (*front == '/' && !dirs--) { front++; break; }
2495 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2496 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2497 if (cp1 != '\0') return 0; /* Path too long. */
2499 *cp2 = '\0'; /* Pick up with memcpy later */
2500 lcfront = lcres + (front - base);
2501 /* Now skip over each ellipsis and try to match the path in front of it. */
2503 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2504 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2505 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2506 if (cp1 < template) break; /* template started with an ellipsis */
2507 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2508 ellipsis = cp1; continue;
2510 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2512 for (segdirs = 0, cp2 = tpl;
2513 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2515 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2516 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2517 if (*cp2 == '/') segdirs++;
2519 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2520 /* Back up at least as many dirs as in template before matching */
2521 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2522 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2523 for (match = 0; cp1 > lcres;) {
2524 resdsc.dsc$a_pointer = cp1;
2525 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2527 if (match == 1) lcfront = cp1;
2529 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2531 if (!match) return 0; /* Can't find prefix ??? */
2532 if (match > 1 && opts & 1) {
2533 /* This ... wildcard could cover more than one set of dirs (i.e.
2534 * a set of similar dir names is repeated). If the template
2535 * contains more than 1 ..., upstream elements could resolve the
2536 * ambiguity, but it's not worth a full backtracking setup here.
2537 * As a quick heuristic, clip off the current default directory
2538 * if it's present to find the trimmed spec, else use the
2539 * shortest string that this ... could cover.
2541 char def[NAM$C_MAXRSS+1], *st;
2543 if (getcwd(def, sizeof def,0) == NULL) return 0;
2544 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2545 if (_tolower(*cp1) != _tolower(*cp2)) break;
2546 segdirs = dirs - totells; /* Min # of dirs we must have left */
2547 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2548 if (*cp1 == '\0' && *cp2 == '/') {
2549 memcpy(fspec,cp2+1,end - cp2);
2552 /* Nope -- stick with lcfront from above and keep going. */
2555 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2560 } /* end of trim_unixpath() */
2565 * VMS readdir() routines.
2566 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2568 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
2569 * Minor modifications to original routines.
2572 /* Number of elements in vms_versions array */
2573 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2576 * Open a directory, return a handle for later use.
2578 /*{{{ DIR *opendir(char*name) */
2583 char dir[NAM$C_MAXRSS+1];
2586 if (do_tovmspath(name,dir,0) == NULL) {
2589 if (flex_stat(dir,&sb) == -1) return NULL;
2590 if (!S_ISDIR(sb.st_mode)) {
2591 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2594 if (!cando_by_name(S_IRUSR,0,dir)) {
2595 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2598 /* Get memory for the handle, and the pattern. */
2600 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2602 /* Fill in the fields; mainly playing with the descriptor. */
2603 (void)sprintf(dd->pattern, "%s*.*",dir);
2606 dd->vms_wantversions = 0;
2607 dd->pat.dsc$a_pointer = dd->pattern;
2608 dd->pat.dsc$w_length = strlen(dd->pattern);
2609 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2610 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2613 } /* end of opendir() */
2617 * Set the flag to indicate we want versions or not.
2619 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2621 vmsreaddirversions(DIR *dd, int flag)
2623 dd->vms_wantversions = flag;
2628 * Free up an opened directory.
2630 /*{{{ void closedir(DIR *dd)*/
2634 (void)lib$find_file_end(&dd->context);
2635 Safefree(dd->pattern);
2636 Safefree((char *)dd);
2641 * Collect all the version numbers for the current file.
2647 struct dsc$descriptor_s pat;
2648 struct dsc$descriptor_s res;
2650 char *p, *text, buff[sizeof dd->entry.d_name];
2652 unsigned long context, tmpsts;
2654 /* Convenient shorthand. */
2657 /* Add the version wildcard, ignoring the "*.*" put on before */
2658 i = strlen(dd->pattern);
2659 New(1308,text,i + e->d_namlen + 3,char);
2660 (void)strcpy(text, dd->pattern);
2661 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2663 /* Set up the pattern descriptor. */
2664 pat.dsc$a_pointer = text;
2665 pat.dsc$w_length = i + e->d_namlen - 1;
2666 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2667 pat.dsc$b_class = DSC$K_CLASS_S;
2669 /* Set up result descriptor. */
2670 res.dsc$a_pointer = buff;
2671 res.dsc$w_length = sizeof buff - 2;
2672 res.dsc$b_dtype = DSC$K_DTYPE_T;
2673 res.dsc$b_class = DSC$K_CLASS_S;
2675 /* Read files, collecting versions. */
2676 for (context = 0, e->vms_verscount = 0;
2677 e->vms_verscount < VERSIZE(e);
2678 e->vms_verscount++) {
2679 tmpsts = lib$find_file(&pat, &res, &context);
2680 if (tmpsts == RMS$_NMF || context == 0) break;
2682 buff[sizeof buff - 1] = '\0';
2683 if ((p = strchr(buff, ';')))
2684 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2686 e->vms_versions[e->vms_verscount] = -1;
2689 _ckvmssts(lib$find_file_end(&context));
2692 } /* end of collectversions() */
2695 * Read the next entry from the directory.
2697 /*{{{ struct dirent *readdir(DIR *dd)*/
2701 struct dsc$descriptor_s res;
2702 char *p, buff[sizeof dd->entry.d_name];
2703 unsigned long int tmpsts;
2705 /* Set up result descriptor, and get next file. */
2706 res.dsc$a_pointer = buff;
2707 res.dsc$w_length = sizeof buff - 2;
2708 res.dsc$b_dtype = DSC$K_DTYPE_T;
2709 res.dsc$b_class = DSC$K_CLASS_S;
2710 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2711 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2712 if (!(tmpsts & 1)) {
2713 set_vaxc_errno(tmpsts);
2716 set_errno(EACCES); break;
2718 set_errno(ENODEV); break;
2721 set_errno(ENOENT); break;
2728 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2729 buff[sizeof buff - 1] = '\0';
2730 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2733 /* Skip any directory component and just copy the name. */
2734 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2735 else (void)strcpy(dd->entry.d_name, buff);
2737 /* Clobber the version. */
2738 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2740 dd->entry.d_namlen = strlen(dd->entry.d_name);
2741 dd->entry.vms_verscount = 0;
2742 if (dd->vms_wantversions) collectversions(dd);
2745 } /* end of readdir() */
2749 * Return something that can be used in a seekdir later.
2751 /*{{{ long telldir(DIR *dd)*/
2760 * Return to a spot where we used to be. Brute force.
2762 /*{{{ void seekdir(DIR *dd,long count)*/
2764 seekdir(DIR *dd, long count)
2766 int vms_wantversions;
2768 /* If we haven't done anything yet... */
2772 /* Remember some state, and clear it. */
2773 vms_wantversions = dd->vms_wantversions;
2774 dd->vms_wantversions = 0;
2775 _ckvmssts(lib$find_file_end(&dd->context));
2778 /* The increment is in readdir(). */
2779 for (dd->count = 0; dd->count < count; )
2782 dd->vms_wantversions = vms_wantversions;
2784 } /* end of seekdir() */
2787 /* VMS subprocess management
2789 * my_vfork() - just a vfork(), after setting a flag to record that
2790 * the current script is trying a Unix-style fork/exec.
2792 * vms_do_aexec() and vms_do_exec() are called in response to the
2793 * perl 'exec' function. If this follows a vfork call, then they
2794 * call out the the regular perl routines in doio.c which do an
2795 * execvp (for those who really want to try this under VMS).
2796 * Otherwise, they do exactly what the perl docs say exec should
2797 * do - terminate the current script and invoke a new command
2798 * (See below for notes on command syntax.)
2800 * do_aspawn() and do_spawn() implement the VMS side of the perl
2801 * 'system' function.
2803 * Note on command arguments to perl 'exec' and 'system': When handled
2804 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2805 * are concatenated to form a DCL command string. If the first arg
2806 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2807 * the the command string is hrnded off to DCL directly. Otherwise,
2808 * the first token of the command is taken as the filespec of an image
2809 * to run. The filespec is expanded using a default type of '.EXE' and
2810 * the process defaults for device, directory, etc., and the resultant
2811 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2812 * the command string as parameters. This is perhaps a bit compicated,
2813 * but I hope it will form a happy medium between what VMS folks expect
2814 * from lib$spawn and what Unix folks expect from exec.
2817 static int vfork_called;
2819 /*{{{int my_vfork()*/
2829 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2837 if (VMScmd.dsc$a_pointer) {
2838 Safefree(VMScmd.dsc$a_pointer);
2839 VMScmd.dsc$w_length = 0;
2840 VMScmd.dsc$a_pointer = Nullch;
2845 setup_argstr(SV *really, SV **mark, SV **sp)
2848 char *junk, *tmps = Nullch;
2849 register size_t cmdlen = 0;
2856 tmps = SvPV(really,rlen);
2863 for (idx++; idx <= sp; idx++) {
2865 junk = SvPVx(*idx,rlen);
2866 cmdlen += rlen ? rlen + 1 : 0;
2869 New(401,PL_Cmd,cmdlen+1,char);
2871 if (tmps && *tmps) {
2872 strcpy(PL_Cmd,tmps);
2875 else *PL_Cmd = '\0';
2876 while (++mark <= sp) {
2879 strcat(PL_Cmd,SvPVx(*mark,n_a));
2884 } /* end of setup_argstr() */
2887 static unsigned long int
2888 setup_cmddsc(char *cmd, int check_img)
2890 char resspec[NAM$C_MAXRSS+1];
2891 $DESCRIPTOR(defdsc,".EXE");
2892 $DESCRIPTOR(resdsc,resspec);
2893 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2894 unsigned long int cxt = 0, flags = 1, retsts;
2895 register char *s, *rest, *cp;
2896 register int isdcl = 0;
2899 while (*s && isspace(*s)) s++;
2901 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2902 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2903 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2904 if (*cp == ':' || *cp == '[' || *cp == '<') {
2912 if (isdcl) { /* It's a DCL command, just do it. */
2913 VMScmd.dsc$w_length = strlen(cmd);
2914 if (cmd == PL_Cmd) {
2915 VMScmd.dsc$a_pointer = PL_Cmd;
2916 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2918 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2920 else { /* assume first token is an image spec */
2922 while (*s && !isspace(*s)) s++;
2924 imgdsc.dsc$a_pointer = cmd;
2925 imgdsc.dsc$w_length = s - cmd;
2926 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2927 if (!(retsts & 1)) {
2928 /* just hand off status values likely to be due to user error */
2929 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2930 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2931 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2932 else { _ckvmssts(retsts); }
2935 _ckvmssts(lib$find_file_end(&cxt));
2937 while (*s && !isspace(*s)) s++;
2939 if (!cando_by_name(S_IXUSR,0,resspec)) return RMS$_PRV;
2940 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2941 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2942 strcat(VMScmd.dsc$a_pointer,resspec);
2943 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2944 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2948 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2950 } /* end of setup_cmddsc() */
2953 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2955 vms_do_aexec(SV *really,SV **mark,SV **sp)
2959 if (vfork_called) { /* this follows a vfork - act Unixish */
2961 if (vfork_called < 0) {
2962 warn("Internal inconsistency in tracking vforks");
2965 else return do_aexec(really,mark,sp);
2967 /* no vfork - act VMSish */
2968 return vms_do_exec(setup_argstr(really,mark,sp));
2973 } /* end of vms_do_aexec() */
2976 /* {{{bool vms_do_exec(char *cmd) */
2978 vms_do_exec(char *cmd)
2981 if (vfork_called) { /* this follows a vfork - act Unixish */
2983 if (vfork_called < 0) {
2984 warn("Internal inconsistency in tracking vforks");
2987 else return do_exec(cmd);
2990 { /* no vfork - act VMSish */
2991 unsigned long int retsts;
2994 TAINT_PROPER("exec");
2995 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2996 retsts = lib$do_command(&VMScmd);
3000 set_errno(ENOENT); break;
3001 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3002 set_errno(ENOTDIR); break;
3004 set_errno(EACCES); break;
3006 set_errno(EINVAL); break;
3008 set_errno(E2BIG); break;
3009 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3010 _ckvmssts(retsts); /* fall through */
3011 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3014 set_vaxc_errno(retsts);
3016 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
3022 } /* end of vms_do_exec() */
3025 unsigned long int do_spawn(char *);
3027 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3029 do_aspawn(void *really,void **mark,void **sp)
3032 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3035 } /* end of do_aspawn() */
3038 /* {{{unsigned long int do_spawn(char *cmd) */
3042 unsigned long int sts, substs, hadcmd = 1;
3045 TAINT_PROPER("spawn");
3046 if (!cmd || !*cmd) {
3048 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3050 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3051 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3057 set_errno(ENOENT); break;
3058 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3059 set_errno(ENOTDIR); break;
3061 set_errno(EACCES); break;
3063 set_errno(EINVAL); break;
3065 set_errno(E2BIG); break;
3066 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3067 _ckvmssts(sts); /* fall through */
3068 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3071 set_vaxc_errno(sts);
3073 warn("Can't spawn \"%s\": %s",
3074 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
3079 } /* end of do_spawn() */
3083 * A simple fwrite replacement which outputs itmsz*nitm chars without
3084 * introducing record boundaries every itmsz chars.
3086 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3088 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3090 register char *cp, *end;
3092 end = (char *)src + itmsz * nitm;
3094 while ((char *)src <= end) {
3095 for (cp = src; cp <= end; cp++) if (!*cp) break;
3096 if (fputs(src,dest) == EOF) return EOF;
3098 if (fputc('\0',dest) == EOF) return EOF;
3104 } /* end of my_fwrite() */
3107 /*{{{ int my_flush(FILE *fp)*/
3112 if ((res = fflush(fp)) == 0) {
3113 #ifdef VMS_DO_SOCKETS
3115 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3117 res = fsync(fileno(fp));
3124 * Here are replacements for the following Unix routines in the VMS environment:
3125 * getpwuid Get information for a particular UIC or UID
3126 * getpwnam Get information for a named user
3127 * getpwent Get information for each user in the rights database
3128 * setpwent Reset search to the start of the rights database
3129 * endpwent Finish searching for users in the rights database
3131 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3132 * (defined in pwd.h), which contains the following fields:-
3134 * char *pw_name; Username (in lower case)
3135 * char *pw_passwd; Hashed password
3136 * unsigned int pw_uid; UIC
3137 * unsigned int pw_gid; UIC group number
3138 * char *pw_unixdir; Default device/directory (VMS-style)
3139 * char *pw_gecos; Owner name
3140 * char *pw_dir; Default device/directory (Unix-style)
3141 * char *pw_shell; Default CLI name (eg. DCL)
3143 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3145 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3146 * not the UIC member number (eg. what's returned by getuid()),
3147 * getpwuid() can accept either as input (if uid is specified, the caller's
3148 * UIC group is used), though it won't recognise gid=0.
3150 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3151 * information about other users in your group or in other groups, respectively.
3152 * If the required privilege is not available, then these routines fill only
3153 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3156 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3159 /* sizes of various UAF record fields */
3160 #define UAI$S_USERNAME 12
3161 #define UAI$S_IDENT 31
3162 #define UAI$S_OWNER 31
3163 #define UAI$S_DEFDEV 31
3164 #define UAI$S_DEFDIR 63
3165 #define UAI$S_DEFCLI 31
3168 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3169 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3170 (uic).uic$v_group != UIC$K_WILD_GROUP)
3172 static char __empty[]= "";
3173 static struct passwd __passwd_empty=
3174 {(char *) __empty, (char *) __empty, 0, 0,
3175 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3176 static int contxt= 0;
3177 static struct passwd __pwdcache;
3178 static char __pw_namecache[UAI$S_IDENT+1];
3181 * This routine does most of the work extracting the user information.
3183 static int fillpasswd (const char *name, struct passwd *pwd)
3186 unsigned char length;
3187 char pw_gecos[UAI$S_OWNER+1];
3189 static union uicdef uic;
3191 unsigned char length;
3192 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3195 unsigned char length;
3196 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3199 unsigned char length;
3200 char pw_shell[UAI$S_DEFCLI+1];
3202 static char pw_passwd[UAI$S_PWD+1];
3204 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3205 struct dsc$descriptor_s name_desc;
3206 unsigned long int sts;
3208 static struct itmlst_3 itmlst[]= {
3209 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3210 {sizeof(uic), UAI$_UIC, &uic, &luic},
3211 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3212 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3213 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3214 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3215 {0, 0, NULL, NULL}};
3217 name_desc.dsc$w_length= strlen(name);
3218 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3219 name_desc.dsc$b_class= DSC$K_CLASS_S;
3220 name_desc.dsc$a_pointer= (char *) name;
3222 /* Note that sys$getuai returns many fields as counted strings. */
3223 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3224 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3225 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3227 else { _ckvmssts(sts); }
3228 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3230 if ((int) owner.length < lowner) lowner= (int) owner.length;
3231 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3232 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3233 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3234 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3235 owner.pw_gecos[lowner]= '\0';
3236 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3237 defcli.pw_shell[ldefcli]= '\0';
3238 if (valid_uic(uic)) {
3239 pwd->pw_uid= uic.uic$l_uic;
3240 pwd->pw_gid= uic.uic$v_group;
3243 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3244 pwd->pw_passwd= pw_passwd;
3245 pwd->pw_gecos= owner.pw_gecos;
3246 pwd->pw_dir= defdev.pw_dir;
3247 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3248 pwd->pw_shell= defcli.pw_shell;
3249 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3251 ldir= strlen(pwd->pw_unixdir) - 1;
3252 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3255 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3256 __mystrtolower(pwd->pw_unixdir);
3261 * Get information for a named user.
3263 /*{{{struct passwd *getpwnam(char *name)*/
3264 struct passwd *my_getpwnam(char *name)
3266 struct dsc$descriptor_s name_desc;
3268 unsigned long int status, sts;
3270 __pwdcache = __passwd_empty;
3271 if (!fillpasswd(name, &__pwdcache)) {
3272 /* We still may be able to determine pw_uid and pw_gid */
3273 name_desc.dsc$w_length= strlen(name);
3274 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3275 name_desc.dsc$b_class= DSC$K_CLASS_S;
3276 name_desc.dsc$a_pointer= (char *) name;
3277 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3278 __pwdcache.pw_uid= uic.uic$l_uic;
3279 __pwdcache.pw_gid= uic.uic$v_group;
3282 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3283 set_vaxc_errno(sts);
3284 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3287 else { _ckvmssts(sts); }
3290 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3291 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3292 __pwdcache.pw_name= __pw_namecache;
3294 } /* end of my_getpwnam() */
3298 * Get information for a particular UIC or UID.
3299 * Called by my_getpwent with uid=-1 to list all users.
3301 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3302 struct passwd *my_getpwuid(Uid_t uid)
3304 const $DESCRIPTOR(name_desc,__pw_namecache);
3305 unsigned short lname;
3307 unsigned long int status;
3309 if (uid == (unsigned int) -1) {
3311 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3312 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3313 set_vaxc_errno(status);
3314 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3318 else { _ckvmssts(status); }
3319 } while (!valid_uic (uic));
3323 if (!uic.uic$v_group)
3324 uic.uic$v_group= PerlProc_getgid();
3326 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3327 else status = SS$_IVIDENT;
3328 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3329 status == RMS$_PRV) {
3330 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3333 else { _ckvmssts(status); }
3335 __pw_namecache[lname]= '\0';
3336 __mystrtolower(__pw_namecache);
3338 __pwdcache = __passwd_empty;
3339 __pwdcache.pw_name = __pw_namecache;
3341 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3342 The identifier's value is usually the UIC, but it doesn't have to be,
3343 so if we can, we let fillpasswd update this. */
3344 __pwdcache.pw_uid = uic.uic$l_uic;
3345 __pwdcache.pw_gid = uic.uic$v_group;
3347 fillpasswd(__pw_namecache, &__pwdcache);
3350 } /* end of my_getpwuid() */
3354 * Get information for next user.
3356 /*{{{struct passwd *my_getpwent()*/
3357 struct passwd *my_getpwent()
3359 return (my_getpwuid((unsigned int) -1));
3364 * Finish searching rights database for users.
3366 /*{{{void my_endpwent()*/
3370 _ckvmssts(sys$finish_rdb(&contxt));
3376 #ifdef HOMEGROWN_POSIX_SIGNALS
3377 /* Signal handling routines, pulled into the core from POSIX.xs.
3379 * We need these for threads, so they've been rolled into the core,
3380 * rather than left in POSIX.xs.
3382 * (DRS, Oct 23, 1997)
3385 /* sigset_t is atomic under VMS, so these routines are easy */
3386 /*{{{int my_sigemptyset(sigset_t *) */
3387 int my_sigemptyset(sigset_t *set) {
3388 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3394 /*{{{int my_sigfillset(sigset_t *)*/
3395 int my_sigfillset(sigset_t *set) {
3397 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3398 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3404 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3405 int my_sigaddset(sigset_t *set, int sig) {
3406 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3407 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3408 *set |= (1 << (sig - 1));
3414 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3415 int my_sigdelset(sigset_t *set, int sig) {
3416 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3417 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3418 *set &= ~(1 << (sig - 1));
3424 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3425 int my_sigismember(sigset_t *set, int sig) {
3426 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3427 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3428 *set & (1 << (sig - 1));
3433 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3434 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3437 /* If set and oset are both null, then things are badly wrong. Bail out. */
3438 if ((oset == NULL) && (set == NULL)) {
3439 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3443 /* If set's null, then we're just handling a fetch. */
3445 tempmask = sigblock(0);
3450 tempmask = sigsetmask(*set);
3453 tempmask = sigblock(*set);
3456 tempmask = sigblock(0);
3457 sigsetmask(*oset & ~tempmask);
3460 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3465 /* Did they pass us an oset? If so, stick our holding mask into it */
3472 #endif /* HOMEGROWN_POSIX_SIGNALS */
3475 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3476 * my_utime(), and flex_stat(), all of which operate on UTC unless
3477 * VMSISH_TIMES is true.
3479 /* method used to handle UTC conversions:
3480 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3482 static int gmtime_emulation_type;
3483 /* number of secs to add to UTC POSIX-style time to get local time */
3484 static long int utc_offset_secs;
3486 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3487 * in vmsish.h. #undef them here so we can call the CRTL routines
3494 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3495 # define RTL_USES_UTC 1
3498 static time_t toutc_dst(time_t loc) {
3501 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3502 loc -= utc_offset_secs;
3503 if (rsltmp->tm_isdst) loc -= 3600;
3506 #define _toutc(secs) ((secs) == -1 ? -1 : \
3507 ((gmtime_emulation_type || my_time(NULL)), \
3508 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3509 ((secs) - utc_offset_secs))))
3511 static time_t toloc_dst(time_t utc) {
3514 utc += utc_offset_secs;
3515 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3516 if (rsltmp->tm_isdst) utc += 3600;
3519 #define _toloc(secs) ((secs) == -1 ? -1 : \
3520 ((gmtime_emulation_type || my_time(NULL)), \
3521 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3522 ((secs) + utc_offset_secs))))
3525 /* my_time(), my_localtime(), my_gmtime()
3526 * By default traffic in UTC time values, using CRTL gmtime() or
3527 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3528 * Note: We need to use these functions even when the CRTL has working
3529 * UTC support, since they also handle C<use vmsish qw(times);>
3531 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3532 * Modified by Charles Bailey <bailey@newman.upenn.edu>
3535 /*{{{time_t my_time(time_t *timep)*/
3536 time_t my_time(time_t *timep)
3542 if (gmtime_emulation_type == 0) {
3544 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3545 /* results of calls to gmtime() and localtime() */
3546 /* for same &base */
3548 gmtime_emulation_type++;
3549 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3552 gmtime_emulation_type++;
3553 if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
3554 gmtime_emulation_type++;
3555 warn("no UTC offset information; assuming local time is UTC");
3557 else { utc_offset_secs = atol(off); }
3559 else { /* We've got a working gmtime() */
3560 struct tm gmt, local;
3563 tm_p = localtime(&base);
3565 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3566 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3567 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3568 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3574 # ifdef RTL_USES_UTC
3575 if (VMSISH_TIME) when = _toloc(when);
3577 if (!VMSISH_TIME) when = _toutc(when);
3580 if (timep != NULL) *timep = when;
3583 } /* end of my_time() */
3587 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3589 my_gmtime(const time_t *timep)
3596 if (timep == NULL) {
3597 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3600 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3604 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
3606 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
3607 return gmtime(&when);
3609 /* CRTL localtime() wants local time as input, so does no tz correction */
3610 rsltmp = localtime(&when);
3611 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
3614 } /* end of my_gmtime() */
3618 /*{{{struct tm *my_localtime(const time_t *timep)*/
3620 my_localtime(const time_t *timep)
3626 if (timep == NULL) {
3627 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3630 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
3631 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
3634 # ifdef RTL_USES_UTC
3636 if (VMSISH_TIME) when = _toutc(when);
3638 /* CRTL localtime() wants UTC as input, does tz correction itself */
3639 return localtime(&when);
3642 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
3645 /* CRTL localtime() wants local time as input, so does no tz correction */
3646 rsltmp = localtime(&when);
3647 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
3650 } /* end of my_localtime() */
3653 /* Reset definitions for later calls */
3654 #define gmtime(t) my_gmtime(t)
3655 #define localtime(t) my_localtime(t)
3656 #define time(t) my_time(t)
3659 /* my_utime - update modification time of a file
3660 * calling sequence is identical to POSIX utime(), but under
3661 * VMS only the modification time is changed; ODS-2 does not
3662 * maintain access times. Restrictions differ from the POSIX
3663 * definition in that the time can be changed as long as the
3664 * caller has permission to execute the necessary IO$_MODIFY $QIO;
3665 * no separate checks are made to insure that the caller is the
3666 * owner of the file or has special privs enabled.
3667 * Code here is based on Joe Meadows' FILE utility.
3670 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
3671 * to VMS epoch (01-JAN-1858 00:00:00.00)
3672 * in 100 ns intervals.
3674 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
3676 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
3677 int my_utime(char *file, struct utimbuf *utimes)
3681 long int bintime[2], len = 2, lowbit, unixtime,
3682 secscale = 10000000; /* seconds --> 100 ns intervals */
3683 unsigned long int chan, iosb[2], retsts;
3684 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
3685 struct FAB myfab = cc$rms_fab;
3686 struct NAM mynam = cc$rms_nam;
3687 #if defined (__DECC) && defined (__VAX)
3688 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
3689 * at least through VMS V6.1, which causes a type-conversion warning.
3691 # pragma message save
3692 # pragma message disable cvtdiftypes
3694 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
3695 struct fibdef myfib;
3696 #if defined (__DECC) && defined (__VAX)
3697 /* This should be right after the declaration of myatr, but due
3698 * to a bug in VAX DEC C, this takes effect a statement early.
3700 # pragma message restore
3702 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
3703 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
3704 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
3706 if (file == NULL || *file == '\0') {
3708 set_vaxc_errno(LIB$_INVARG);
3711 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
3713 if (utimes != NULL) {
3714 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
3715 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
3716 * Since time_t is unsigned long int, and lib$emul takes a signed long int
3717 * as input, we force the sign bit to be clear by shifting unixtime right
3718 * one bit, then multiplying by an extra factor of 2 in lib$emul().
3720 lowbit = (utimes->modtime & 1) ? secscale : 0;
3721 unixtime = (long int) utimes->modtime;
3723 /* If input was UTC; convert to local for sys svc */
3724 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
3726 unixtime >> 1; secscale << 1;
3727 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
3728 if (!(retsts & 1)) {
3730 set_vaxc_errno(retsts);
3733 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
3734 if (!(retsts & 1)) {
3736 set_vaxc_errno(retsts);
3741 /* Just get the current time in VMS format directly */
3742 retsts = sys$gettim(bintime);
3743 if (!(retsts & 1)) {
3745 set_vaxc_errno(retsts);
3750 myfab.fab$l_fna = vmsspec;
3751 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
3752 myfab.fab$l_nam = &mynam;
3753 mynam.nam$l_esa = esa;
3754 mynam.nam$b_ess = (unsigned char) sizeof esa;
3755 mynam.nam$l_rsa = rsa;
3756 mynam.nam$b_rss = (unsigned char) sizeof rsa;
3758 /* Look for the file to be affected, letting RMS parse the file
3759 * specification for us as well. I have set errno using only
3760 * values documented in the utime() man page for VMS POSIX.
3762 retsts = sys$parse(&myfab,0,0);
3763 if (!(retsts & 1)) {
3764 set_vaxc_errno(retsts);
3765 if (retsts == RMS$_PRV) set_errno(EACCES);
3766 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3767 else set_errno(EVMSERR);
3770 retsts = sys$search(&myfab,0,0);
3771 if (!(retsts & 1)) {
3772 set_vaxc_errno(retsts);
3773 if (retsts == RMS$_PRV) set_errno(EACCES);
3774 else if (retsts == RMS$_FNF) set_errno(ENOENT);
3775 else set_errno(EVMSERR);
3779 devdsc.dsc$w_length = mynam.nam$b_dev;
3780 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
3782 retsts = sys$assign(&devdsc,&chan,0,0);
3783 if (!(retsts & 1)) {
3784 set_vaxc_errno(retsts);
3785 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
3786 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
3787 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
3788 else set_errno(EVMSERR);
3792 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
3793 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
3795 memset((void *) &myfib, 0, sizeof myfib);
3797 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
3798 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
3799 /* This prevents the revision time of the file being reset to the current
3800 * time as a result of our IO$_MODIFY $QIO. */
3801 myfib.fib$l_acctl = FIB$M_NORECORD;
3803 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
3804 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
3805 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
3807 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
3808 _ckvmssts(sys$dassgn(chan));
3809 if (retsts & 1) retsts = iosb[0];
3810 if (!(retsts & 1)) {
3811 set_vaxc_errno(retsts);
3812 if (retsts == SS$_NOPRIV) set_errno(EACCES);
3813 else set_errno(EVMSERR);
3818 } /* end of my_utime() */
3822 * flex_stat, flex_fstat
3823 * basic stat, but gets it right when asked to stat
3824 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
3827 /* encode_dev packs a VMS device name string into an integer to allow
3828 * simple comparisons. This can be used, for example, to check whether two
3829 * files are located on the same device, by comparing their encoded device
3830 * names. Even a string comparison would not do, because stat() reuses the
3831 * device name buffer for each call; so without encode_dev, it would be
3832 * necessary to save the buffer and use strcmp (this would mean a number of
3833 * changes to the standard Perl code, to say nothing of what a Perl script
3836 * The device lock id, if it exists, should be unique (unless perhaps compared
3837 * with lock ids transferred from other nodes). We have a lock id if the disk is
3838 * mounted cluster-wide, which is when we tend to get long (host-qualified)
3839 * device names. Thus we use the lock id in preference, and only if that isn't
3840 * available, do we try to pack the device name into an integer (flagged by
3841 * the sign bit (LOCKID_MASK) being set).
3843 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
3844 * name and its encoded form, but it seems very unlikely that we will find
3845 * two files on different disks that share the same encoded device names,
3846 * and even more remote that they will share the same file id (if the test
3847 * is to check for the same file).
3849 * A better method might be to use sys$device_scan on the first call, and to
3850 * search for the device, returning an index into the cached array.
3851 * The number returned would be more intelligable.
3852 * This is probably not worth it, and anyway would take quite a bit longer
3853 * on the first call.
3855 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
3856 static mydev_t encode_dev (const char *dev)
3859 unsigned long int f;
3864 if (!dev || !dev[0]) return 0;
3868 struct dsc$descriptor_s dev_desc;
3869 unsigned long int status, lockid, item = DVI$_LOCKID;
3871 /* For cluster-mounted disks, the disk lock identifier is unique, so we
3872 can try that first. */
3873 dev_desc.dsc$w_length = strlen (dev);
3874 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
3875 dev_desc.dsc$b_class = DSC$K_CLASS_S;
3876 dev_desc.dsc$a_pointer = (char *) dev;
3877 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
3878 if (lockid) return (lockid & ~LOCKID_MASK);
3882 /* Otherwise we try to encode the device name */
3886 for (q = dev + strlen(dev); q--; q >= dev) {
3889 else if (isalpha (toupper (*q)))
3890 c= toupper (*q) - 'A' + (char)10;
3892 continue; /* Skip '$'s */
3894 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
3896 enc += f * (unsigned long int) c;
3898 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
3900 } /* end of encode_dev() */
3902 static char namecache[NAM$C_MAXRSS+1];
3905 is_null_device(name)
3908 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
3909 The underscore prefix, controller letter, and unit number are
3910 independently optional; for our purposes, the colon punctuation
3911 is not. The colon can be trailed by optional directory and/or
3912 filename, but two consecutive colons indicates a nodename rather
3913 than a device. [pr] */
3914 if (*name == '_') ++name;
3915 if (tolower(*name++) != 'n') return 0;
3916 if (tolower(*name++) != 'l') return 0;
3917 if (tolower(*name) == 'a') ++name;
3918 if (*name == '0') ++name;
3919 return (*name++ == ':') && (*name != ':');
3922 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
3923 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3924 * subset of the applicable information.
3926 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3928 cando(I32 bit, I32 effective, Stat_t *statbufp)
3931 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
3933 char fname[NAM$C_MAXRSS+1];
3934 unsigned long int retsts;
3935 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3936 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3938 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3939 device name on successive calls */
3940 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
3941 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
3942 namdsc.dsc$a_pointer = fname;
3943 namdsc.dsc$w_length = sizeof fname - 1;
3945 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
3946 &namdsc,&namdsc.dsc$w_length,0,0);
3948 fname[namdsc.dsc$w_length] = '\0';
3949 return cando_by_name(bit,effective,fname);
3951 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3952 warn("Can't get filespec - stale stat buffer?\n");
3956 return FALSE; /* Should never get to here */
3958 } /* end of cando() */
3962 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3964 cando_by_name(I32 bit, I32 effective, char *fname)
3966 static char usrname[L_cuserid];
3967 static struct dsc$descriptor_s usrdsc =
3968 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3969 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3970 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3971 unsigned short int retlen;
3972 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3973 union prvdef curprv;
3974 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3975 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3976 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3979 if (!fname || !*fname) return FALSE;
3980 /* Make sure we expand logical names, since sys$check_access doesn't */
3981 if (!strpbrk(fname,"/]>:")) {
3982 strcpy(fileified,fname);
3983 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3986 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3987 retlen = namdsc.dsc$w_length = strlen(vmsname);
3988 namdsc.dsc$a_pointer = vmsname;
3989 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3990 vmsname[retlen-1] == ':') {
3991 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3992 namdsc.dsc$w_length = strlen(fileified);
3993 namdsc.dsc$a_pointer = fileified;
3996 if (!usrdsc.dsc$w_length) {
3998 usrdsc.dsc$w_length = strlen(usrname);
4005 access = ARM$M_EXECUTE;
4010 access = ARM$M_READ;
4015 access = ARM$M_WRITE;
4020 access = ARM$M_DELETE;
4026 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4027 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4028 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4029 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4030 set_vaxc_errno(retsts);
4031 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4032 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4033 else set_errno(ENOENT);
4036 if (retsts == SS$_NORMAL) {
4037 if (!privused) return TRUE;
4038 /* We can get access, but only by using privs. Do we have the
4039 necessary privs currently enabled? */
4040 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4041 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4042 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4043 !curprv.prv$v_bypass) return FALSE;
4044 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4045 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4046 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4049 if (retsts == SS$_ACCONFLICT) {
4054 return FALSE; /* Should never get here */
4056 } /* end of cando_by_name() */
4060 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4062 flex_fstat(int fd, Stat_t *statbufp)
4065 if (!fstat(fd,(stat_t *) statbufp)) {
4066 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4067 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4068 # ifdef RTL_USES_UTC
4071 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4072 statbufp->st_atime = _toloc(statbufp->st_atime);
4073 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4078 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4082 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4083 statbufp->st_atime = _toutc(statbufp->st_atime);
4084 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4091 } /* end of flex_fstat() */
4094 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4096 flex_stat(char *fspec, Stat_t *statbufp)
4099 char fileified[NAM$C_MAXRSS+1];
4102 if (statbufp == (Stat_t *) &PL_statcache)
4103 do_tovmsspec(fspec,namecache,0);
4104 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4105 memset(statbufp,0,sizeof *statbufp);
4106 statbufp->st_dev = encode_dev("_NLA0:");
4107 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4108 statbufp->st_uid = 0x00010001;
4109 statbufp->st_gid = 0x0001;
4110 time((time_t *)&statbufp->st_mtime);
4111 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4115 /* Try for a directory name first. If fspec contains a filename without
4116 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4117 * and sea:[wine.dark]water. exist, we prefer the directory here.
4118 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4119 * not sea:[wine.dark]., if the latter exists. If the intended target is
4120 * the file with null type, specify this by calling flex_stat() with
4121 * a '.' at the end of fspec.
4123 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4124 retval = stat(fileified,(stat_t *) statbufp);
4125 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4126 strcpy(namecache,fileified);
4128 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4130 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4131 # ifdef RTL_USES_UTC
4134 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4135 statbufp->st_atime = _toloc(statbufp->st_atime);
4136 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4141 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4145 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4146 statbufp->st_atime = _toutc(statbufp->st_atime);
4147 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4153 } /* end of flex_stat() */
4156 /* Insures that no carriage-control translation will be done on a file. */
4157 /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
4159 my_binmode(FILE *fp, char iotype)
4161 char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
4162 int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
4165 if (!fgetname(fp,filespec,1)) return NULL;
4166 for (s = filespec; *s; s++) {
4167 if (*s == ':') colon = s;
4168 else if (*s == ']' || *s == '>') dirend = s;
4170 /* Looks like a tmpfile, which will go away if reopened */
4171 if (s == dirend + 3) return fp;
4172 /* If we've got a non-file-structured device, clip off the trailing
4173 * junk, and don't lose sleep if we can't get a stream position. */
4174 if (dirend == Nullch) *(colon+1) = '\0';
4175 if (iotype != '-'&& (ret = fgetpos(fp, &pos)) == -1 && dirend) return NULL;
4177 case '<': case 'r': acmode = "rb"; break;
4178 case '>': case 'w': case '|':
4179 /* use 'a' instead of 'w' to avoid creating new file;
4180 fsetpos below will take care of restoring file position */
4181 case 'a': acmode = "ab"; break;
4182 case '+': case 's': acmode = "rb+"; break;
4183 case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
4184 /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
4185 /* since we didn't really open them and can't really */
4187 case 0: return NULL; break;
4189 warn("Unrecognized iotype %x for %s in my_binmode",iotype, filespec);
4192 if (freopen(filespec,acmode,fp) == NULL) return NULL;
4193 if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) return NULL;
4194 if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
4196 } /* end of my_binmode() */
4200 /*{{{char *my_getlogin()*/
4201 /* VMS cuserid == Unix getlogin, except calling sequence */
4205 static char user[L_cuserid];
4206 return cuserid(user);
4211 /* rmscopy - copy a file using VMS RMS routines
4213 * Copies contents and attributes of spec_in to spec_out, except owner
4214 * and protection information. Name and type of spec_in are used as
4215 * defaults for spec_out. The third parameter specifies whether rmscopy()
4216 * should try to propagate timestamps from the input file to the output file.
4217 * If it is less than 0, no timestamps are preserved. If it is 0, then
4218 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4219 * propagated to the output file at creation iff the output file specification
4220 * did not contain an explicit name or type, and the revision date is always
4221 * updated at the end of the copy operation. If it is greater than 0, then
4222 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4223 * other than the revision date should be propagated, and bit 1 indicates
4224 * that the revision date should be propagated.
4226 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4228 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4229 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4230 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4231 * as part of the Perl standard distribution under the terms of the
4232 * GNU General Public License or the Perl Artistic License. Copies
4233 * of each may be found in the Perl standard distribution.
4235 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4237 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4239 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4240 rsa[NAM$C_MAXRSS], ubf[32256];
4241 unsigned long int i, sts, sts2;
4242 struct FAB fab_in, fab_out;
4243 struct RAB rab_in, rab_out;
4245 struct XABDAT xabdat;
4246 struct XABFHC xabfhc;
4247 struct XABRDT xabrdt;
4248 struct XABSUM xabsum;
4250 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4251 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4252 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4256 fab_in = cc$rms_fab;
4257 fab_in.fab$l_fna = vmsin;
4258 fab_in.fab$b_fns = strlen(vmsin);
4259 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4260 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4261 fab_in.fab$l_fop = FAB$M_SQO;
4262 fab_in.fab$l_nam = &nam;
4263 fab_in.fab$l_xab = (void *) &xabdat;
4266 nam.nam$l_rsa = rsa;
4267 nam.nam$b_rss = sizeof(rsa);
4268 nam.nam$l_esa = esa;
4269 nam.nam$b_ess = sizeof (esa);
4270 nam.nam$b_esl = nam.nam$b_rsl = 0;
4272 xabdat = cc$rms_xabdat; /* To get creation date */
4273 xabdat.xab$l_nxt = (void *) &xabfhc;
4275 xabfhc = cc$rms_xabfhc; /* To get record length */
4276 xabfhc.xab$l_nxt = (void *) &xabsum;
4278 xabsum = cc$rms_xabsum; /* To get key and area information */
4280 if (!((sts = sys$open(&fab_in)) & 1)) {
4281 set_vaxc_errno(sts);
4285 set_errno(ENOENT); break;
4287 set_errno(ENODEV); break;
4289 set_errno(EINVAL); break;
4291 set_errno(EACCES); break;
4299 fab_out.fab$w_ifi = 0;
4300 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4301 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4302 fab_out.fab$l_fop = FAB$M_SQO;
4303 fab_out.fab$l_fna = vmsout;
4304 fab_out.fab$b_fns = strlen(vmsout);
4305 fab_out.fab$l_dna = nam.nam$l_name;
4306 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4308 if (preserve_dates == 0) { /* Act like DCL COPY */
4309 nam.nam$b_nop = NAM$M_SYNCHK;
4310 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4311 if (!((sts = sys$parse(&fab_out)) & 1)) {
4312 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4313 set_vaxc_errno(sts);
4316 fab_out.fab$l_xab = (void *) &xabdat;
4317 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4319 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4320 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4321 preserve_dates =0; /* bitmask from this point forward */
4323 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4324 if (!((sts = sys$create(&fab_out)) & 1)) {
4325 set_vaxc_errno(sts);
4328 set_errno(ENOENT); break;
4330 set_errno(ENODEV); break;
4332 set_errno(EINVAL); break;
4334 set_errno(EACCES); break;
4340 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4341 if (preserve_dates & 2) {
4342 /* sys$close() will process xabrdt, not xabdat */
4343 xabrdt = cc$rms_xabrdt;
4345 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4347 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4348 * is unsigned long[2], while DECC & VAXC use a struct */
4349 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4351 fab_out.fab$l_xab = (void *) &xabrdt;
4354 rab_in = cc$rms_rab;
4355 rab_in.rab$l_fab = &fab_in;
4356 rab_in.rab$l_rop = RAB$M_BIO;
4357 rab_in.rab$l_ubf = ubf;
4358 rab_in.rab$w_usz = sizeof ubf;
4359 if (!((sts = sys$connect(&rab_in)) & 1)) {
4360 sys$close(&fab_in); sys$close(&fab_out);
4361 set_errno(EVMSERR); set_vaxc_errno(sts);
4365 rab_out = cc$rms_rab;
4366 rab_out.rab$l_fab = &fab_out;
4367 rab_out.rab$l_rbf = ubf;
4368 if (!((sts = sys$connect(&rab_out)) & 1)) {
4369 sys$close(&fab_in); sys$close(&fab_out);
4370 set_errno(EVMSERR); set_vaxc_errno(sts);
4374 while ((sts = sys$read(&rab_in))) { /* always true */
4375 if (sts == RMS$_EOF) break;
4376 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4377 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4378 sys$close(&fab_in); sys$close(&fab_out);
4379 set_errno(EVMSERR); set_vaxc_errno(sts);
4384 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4385 sys$close(&fab_in); sys$close(&fab_out);
4386 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4388 set_errno(EVMSERR); set_vaxc_errno(sts);
4394 } /* end of rmscopy() */
4398 /*** The following glue provides 'hooks' to make some of the routines
4399 * from this file available from Perl. These routines are sufficiently
4400 * basic, and are required sufficiently early in the build process,
4401 * that's it's nice to have them available to miniperl as well as the
4402 * full Perl, so they're set up here instead of in an extension. The
4403 * Perl code which handles importation of these names into a given
4404 * package lives in [.VMS]Filespec.pm in @INC.
4408 rmsexpand_fromperl(CV *cv)
4411 char *fspec, *defspec = NULL, *rslt;
4414 if (!items || items > 2)
4415 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4416 fspec = SvPV(ST(0),n_a);
4417 if (!fspec || !*fspec) XSRETURN_UNDEF;
4418 if (items == 2) defspec = SvPV(ST(1),n_a);
4420 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4421 ST(0) = sv_newmortal();
4422 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4427 vmsify_fromperl(CV *cv)
4433 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4434 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4435 ST(0) = sv_newmortal();
4436 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4441 unixify_fromperl(CV *cv)
4447 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4448 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4449 ST(0) = sv_newmortal();
4450 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4455 fileify_fromperl(CV *cv)
4461 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4462 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4463 ST(0) = sv_newmortal();
4464 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4469 pathify_fromperl(CV *cv)
4475 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4476 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4477 ST(0) = sv_newmortal();
4478 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4483 vmspath_fromperl(CV *cv)
4489 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4490 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4491 ST(0) = sv_newmortal();
4492 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4497 unixpath_fromperl(CV *cv)
4503 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4504 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4505 ST(0) = sv_newmortal();
4506 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4511 candelete_fromperl(CV *cv)
4514 char fspec[NAM$C_MAXRSS+1], *fsp;
4519 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4521 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4522 if (SvTYPE(mysv) == SVt_PVGV) {
4523 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4524 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4531 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4532 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4538 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4543 rmscopy_fromperl(CV *cv)
4546 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4548 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4549 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4550 unsigned long int sts;
4555 if (items < 2 || items > 3)
4556 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4558 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4559 if (SvTYPE(mysv) == SVt_PVGV) {
4560 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4561 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4568 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
4569 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4574 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4575 if (SvTYPE(mysv) == SVt_PVGV) {
4576 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
4577 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4584 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
4585 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4590 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4592 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4599 char* file = __FILE__;
4601 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4602 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4603 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4604 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4605 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4606 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4607 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4608 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4609 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
4611 #ifdef PRIME_ENV_AT_STARTUP