1 /* VMS-specific routines for perl5
3 * Last revised: 09-Oct-1994
17 #include <lib$routines.h>
32 unsigned short int buflen;
33 unsigned short int itmcode;
35 unsigned long int retlen;
38 static unsigned long int sts;
40 #define _cksts(call) \
41 if (!(sts=(call))&1) { \
42 errno = EVMSERR; vaxc$errno = sts; \
43 croak("fatal error at %s, line %d",__FILE__,__LINE__); \
47 * Translate a logical name. Substitute for CRTL getenv() to avoid
48 * memory leak, and to keep my_getenv() and my_setenv() in the same
49 * domain (mostly - my_getenv() need not return a translation from
50 * the process logical name table)
52 * Note: Uses static buffer -- not thread-safe!
54 /*{{{ char *my_getenv(char *lnm)*/
58 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
59 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
60 unsigned short int eqvlen;
61 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
62 $DESCRIPTOR(sysdiskdsc,"SYS$DISK");
63 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
64 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
65 eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
66 DSC$K_CLASS_S, __my_getenv_eqv};
67 struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING,
68 __my_getenv_eqv, &eqvlen, 0, 0, 0, 0};
70 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
72 lnmdsc.dsc$w_length = cp1 - lnm;
73 if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) {
74 _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst));
75 eqvdsc.dsc$a_pointer += eqvlen;
76 eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1;
77 _cksts(sys$setddir(0,&eqvlen,&eqvdsc));
78 eqvdsc.dsc$a_pointer[eqvlen] = '\0';
79 return __my_getenv_eqv;
82 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
83 if (retsts != SS$_NOLOGNAM) {
85 __my_getenv_eqv[eqvlen] = '\0';
86 return __my_getenv_eqv;
91 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0);
92 if (retsts != LIB$_NOSUCHSYM) {
93 /* We want to return only logical names or CRTL Unix emulations */
94 if (retsts & 1) return Nullch;
97 else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
102 } /* end of my_getenv() */
105 /*{{{ void my_setenv(char *lnm, char *eqv)*/
107 my_setenv(char *lnm,char *eqv)
108 /* Define a supervisor-mode logical name in the process table.
109 * In the future we'll add tables, attribs, and acmodes,
110 * probably through a different call.
113 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
114 unsigned long int retsts, usermode = PSL$C_USER;
115 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
116 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
117 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
119 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
120 lnmdsc.dsc$w_length = cp1 - lnm;
122 if (!eqv || !*eqv) { /* we're deleting a logical name */
123 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
124 if (retsts != SS$_NOLOGNAM) _cksts(retsts);
126 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
127 if (retsts != SS$_NOLOGNAM) _cksts(retsts);
131 eqvdsc.dsc$w_length = strlen(eqv);
132 eqvdsc.dsc$a_pointer = eqv;
134 _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
137 } /* end of my_setenv() */
140 static char *do_fileify_dirspec(char *, char *, int);
141 static char *do_tovmsspec(char *, char *, int);
143 /*{{{int do_rmdir(char *name)*/
147 char dirfile[NAM$C_MAXRSS+1];
151 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
152 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
153 else retval = kill_file(dirfile);
156 } /* end of do_rmdir */
160 * Delete any file to which user has control access, regardless of whether
161 * delete access is explicitly allowed.
162 * Limitations: User must have write access to parent directory.
163 * Does not block signals or ASTs; if interrupted in midstream
164 * may leave file with an altered ACL.
167 /*{{{int kill_file(char *name)*/
169 kill_file(char *name)
171 char vmsname[NAM$C_MAXRSS+1];
172 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
173 unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1;
174 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
176 unsigned char ace$b_length;
177 unsigned char ace$b_type;
178 unsigned short int ace$w_flags;
179 unsigned long int ace$l_access;
180 unsigned long int ace$l_ident;
181 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
182 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
183 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
185 findlst[3] = {sizeof oldace, ACL$C_FNDACLENT, &oldace, 0,
186 sizeof oldace, ACL$C_READACE, &oldace, 0, 0, 0, 0, 0},
187 addlst[2] = {sizeof newace, ACL$C_ADDACLENT, &newace, 0, 0, 0, 0, 0},
188 dellst[2] = {sizeof newace, ACL$C_DELACLENT, &newace, 0, 0, 0, 0, 0},
189 lcklst[2] = {sizeof newace, ACL$C_WLOCK_ACL, &newace, 0, 0, 0, 0, 0},
190 ulklst[2] = {sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0, 0, 0, 0, 0};
192 if (!remove(name)) return 0; /* Can we just get rid of it? */
194 /* No, so we get our own UIC to use as a rights identifier,
195 * and the insert an ACE at the head of the ACL which allows us
196 * to delete the file.
198 _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0));
199 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
200 fildsc.dsc$w_length = strlen(vmsname);
201 fildsc.dsc$a_pointer = vmsname;
203 newace.ace$l_ident = oldace.ace$l_ident;
204 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
209 /* Grab any existing ACEs with this identifier in case we fail */
210 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
211 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY) {
212 /* Add the new ACE . . . */
213 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
215 if (rmsts = remove(name)) {
216 /* We blew it - dir with files in it, no write priv for
217 * parent directory, etc. Put things back the way they were. */
218 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
221 addlst[0].bufadr = &oldace;
222 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
230 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
231 if (aclsts & 1) aclsts = fndsts;
241 } /* end of kill_file() */
245 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
247 static unsigned long int mbxbufsiz;
248 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
252 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
253 * preprocessor consant BUFSIZ from stdio.h as the size of the
256 _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
257 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
259 _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
261 _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
262 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
264 } /* end of create_mbx() */
266 /*{{{ my_popen and my_pclose*/
269 struct pipe_details *next;
272 unsigned long int completion;
275 static struct pipe_details *open_pipes = NULL;
276 static $DESCRIPTOR(nl_desc, "NL:");
277 static int waitpid_asleep = 0;
280 popen_completion_ast(unsigned long int unused)
282 if (waitpid_asleep) {
288 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
290 my_popen(char *cmd, char *mode)
293 unsigned short int chan;
294 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
295 struct pipe_details *info;
296 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
297 DSC$K_CLASS_S, mbxname},
298 cmddsc = {0, DSC$K_DTYPE_T,
302 New(7001,info,1,struct pipe_details);
304 info->completion=0; /* I assume this will remain 0 until terminates */
307 create_mbx(&chan,&namdsc);
309 /* open a FILE* onto it */
310 info->fp=fopen(mbxname, mode);
312 /* give up other channel onto it */
313 _cksts(sys$dassgn(chan));
318 cmddsc.dsc$w_length=strlen(cmd);
319 cmddsc.dsc$a_pointer=cmd;
321 if (strcmp(mode,"r")==0) {
322 _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
323 0 /* name */, &info->pid, &info->completion,
324 0, popen_completion_ast,0,0,0,0));
327 _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */,
328 0 /* name */, &info->pid, &info->completion));
331 info->next=open_pipes; /* prepend to list */
338 /*{{{ I32 my_pclose(FILE *fp)*/
339 I32 my_pclose(FILE *fp)
341 struct pipe_details *info, *last = NULL;
342 unsigned long int abort = SS$_TIMEOUT, retsts;
344 for (info = open_pipes; info != NULL; last = info, info = info->next)
345 if (info->fp == fp) break;
348 /* get here => no such pipe open */
349 croak("my_pclose() - no such pipe open ???");
351 if (!info->completion) { /* Tap them gently on the shoulder . . .*/
352 _cksts(sys$forcex(&info->pid,0,&abort));
355 if (!info->completion) /* We tried to be nice . . . */
356 _cksts(sys$delprc(&info->pid));
359 /* remove from list of open pipes */
360 if (last) last->next = info->next;
361 else open_pipes = info->next;
362 retsts = info->completion;
366 } /* end of my_pclose() */
369 /* sort-of waitpid; use only with popen() */
370 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
372 waitpid(unsigned long int pid, int *statusp, int flags)
374 struct pipe_details *info;
375 unsigned long int abort = SS$_TIMEOUT;
377 for (info = open_pipes; info != NULL; info = info->next)
378 if (info->pid == pid) break;
380 if (info != NULL) { /* we know about this child */
381 while (!info->completion) {
386 *statusp = info->completion;
389 else { /* we haven't heard of this child */
390 $DESCRIPTOR(intdsc,"0 00:00:01");
391 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
392 unsigned long int interval[2];
394 _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
395 _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
396 if (ownerpid != mypid)
397 croak("pid %d not a child",pid);
399 _cksts(sys$bintim(&intdsc,interval));
400 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
401 _cksts(sys$schdwk(0,0,interval,0));
406 /* There's no easy way to find the termination status a child we're
407 * not aware of beforehand. If we're really interested in the future,
408 * we can go looking for a termination mailbox, or chase after the
409 * accounting record for the process.
415 } /* end of waitpid() */
421 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
423 my_gconvert(double val, int ndig, int trail, char *buf)
425 static char __gcvtbuf[DBL_DIG+1];
428 loc = buf ? buf : __gcvtbuf;
430 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
431 return gcvt(val,ndig,loc);
434 loc[0] = '0'; loc[1] = '\0';
442 ** The following routines are provided to make life easier when
443 ** converting among VMS-style and Unix-style directory specifications.
444 ** All will take input specifications in either VMS or Unix syntax. On
445 ** failure, all return NULL. If successful, the routines listed below
446 ** return a pointer to a static buffer containing the appropriately
447 ** reformatted spec (and, therefore, subsequent calls to that routine
448 ** will clobber the result), while the routines of the same names with
449 ** a _ts suffix appended will return a pointer to a mallocd string
450 ** containing the appropriately reformatted spec.
451 ** In all cases, only explicit syntax is altered; no check is made that
452 ** the resulting string is valid or that the directory in question
455 ** fileify_dirspec() - convert a directory spec into the name of the
456 ** directory file (i.e. what you can stat() to see if it's a dir).
457 ** The style (VMS or Unix) of the result is the same as the style
458 ** of the parameter passed in.
459 ** pathify_dirspec() - convert a directory spec into a path (i.e.
460 ** what you prepend to a filename to indicate what directory it's in).
461 ** The style (VMS or Unix) of the result is the same as the style
462 ** of the parameter passed in.
463 ** tounixpath() - convert a directory spec into a Unix-style path.
464 ** tovmspath() - convert a directory spec into a VMS-style path.
465 ** tounixspec() - convert any file spec into a Unix-style file spec.
466 ** tovmsspec() - convert any file spec into a VMS-style spec.
469 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
470 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
472 static char __fileify_retbuf[NAM$C_MAXRSS+1];
473 unsigned long int dirlen, retlen, addmfd = 0;
474 char *retspec, *cp1, *cp2, *lastdir;
476 if (dir == NULL) return NULL;
478 dirlen = strlen(dir);
479 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
480 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
481 dirlen -= 1; /* to last element */
482 lastdir = strrchr(dir,'/');
485 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
486 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
487 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
488 toupper(*(cp2+2)) == 'I' &&
489 toupper(*(cp2+3)) == 'R') {
490 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
491 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
492 errno = ENOTDIR; /* Bzzt. */
498 else { /* There's a type, and it's not .dir. Bzzt. */
503 /* If we lead off with a device or rooted logical, add the MFD
504 if we're specifying a top-level directory. */
505 if (lastdir && *dir == '/') {
507 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
514 retlen = dirlen + addmfd ? 13 : 6;
515 if (buf) retspec = buf;
516 else if (ts) New(7009,retspec,retlen+6,char);
517 else retspec = __fileify_retbuf;
519 dirlen = lastdir - dir;
520 memcpy(retspec,dir,dirlen);
521 strcpy(&retspec[dirlen],"/000000");
522 strcpy(&retspec[dirlen+7],lastdir);
525 memcpy(retspec,dir,dirlen);
526 retspec[dirlen] = '\0';
529 /* We've picked up everything up to the directory file name.
530 Now just add the type and version, and we're set. */
531 strcat(retspec,".dir;1");
534 else { /* VMS-style directory spec */
535 char esa[NAM$C_MAXRSS+1], term;
536 unsigned long int sts, cmplen;
537 struct FAB dirfab = cc$rms_fab;
538 struct NAM savnam, dirnam = cc$rms_nam;
540 dirfab.fab$b_fns = strlen(dir);
541 dirfab.fab$l_fna = dir;
542 dirfab.fab$l_nam = &dirnam;
543 dirnam.nam$b_ess = NAM$C_MAXRSS;
544 dirnam.nam$l_esa = esa;
545 dirnam.nam$b_nop = NAM$M_SYNCHK;
546 if (!(sys$parse(&dirfab)&1)) {
548 vaxc$errno = dirfab.fab$l_sts;
552 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
553 /* Yes; fake the fnb bits so we'll check type below */
554 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
557 if (dirfab.fab$l_sts != RMS$_FNF) {
559 vaxc$errno = dirfab.fab$l_sts;
562 dirnam = savnam; /* No; just work with potential name */
565 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
566 /* Yep; check version while we're at it, if it's there. */
567 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
568 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
569 /* Something other than .DIR[;1]. Bzzt. */
573 else { /* Ok, it was .DIR[;1]; copy over everything up to the */
574 retlen = dirnam.nam$l_type - esa; /* file name. */
575 if (buf) retspec = buf;
576 else if (ts) New(7010,retspec,retlen+6,char);
577 else retspec = __fileify_retbuf;
578 strncpy(retspec,esa,retlen);
579 retspec[retlen] = '\0';
583 /* They didn't explicitly specify the directory file. Ignore
584 any file names in the input, pull off the last element of the
585 directory path, and make it the file name. If you want to
586 pay attention to filenames without .dir in the input, just use
587 ".DIR;1" as a default filespec for the $PARSE */
588 esa[dirnam.nam$b_esl] = '\0';
589 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
590 if (cp1 == NULL) return NULL; /* should never happen */
593 retlen = strlen(esa);
594 if ((cp1 = strrchr(esa,'.')) != NULL) {
595 /* There's more than one directory in the path. Just roll back. */
597 if (buf) retspec = buf;
598 else if (ts) New(7011,retspec,retlen+6,char);
599 else retspec = __fileify_retbuf;
602 else { /* This is a top-level dir. Add the MFD to the path. */
603 if (buf) retspec = buf;
604 else if (ts) New(7012,retspec,retlen+14,char);
605 else retspec = __fileify_retbuf;
608 while (*cp1 != ':') *(cp2++) = *(cp1++);
609 strcpy(cp2,":[000000]");
614 /* Again, we've set up the string up through the filename. Add the
615 type and version, and we're done. */
616 strcat(retspec,".DIR;1");
619 } /* end of do_fileify_dirspec() */
621 /* External entry points */
622 char *fileify_dirspec(char *dir, char *buf)
623 { return do_fileify_dirspec(dir,buf,0); }
624 char *fileify_dirspec_ts(char *dir, char *buf)
625 { return do_fileify_dirspec(dir,buf,1); }
627 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
628 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
630 static char __pathify_retbuf[NAM$C_MAXRSS+1];
631 unsigned long int retlen;
632 char *retpath, *cp1, *cp2;
634 if (dir == NULL) return NULL;
636 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
637 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
638 if (cp2 = strchr(cp1,'.')) {
639 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
640 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
641 toupper(*(cp2+3)) == 'R') {
642 retlen = cp2 - dir + 1;
644 else { /* Some other file type. Bzzt. */
649 else { /* No file type present. Treat the filename as a directory. */
650 retlen = strlen(dir) + 1;
652 if (buf) retpath = buf;
653 else if (ts) New(7013,retpath,retlen,char);
654 else retpath = __pathify_retbuf;
655 strncpy(retpath,dir,retlen-1);
656 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
657 retpath[retlen-1] = '/'; /* with '/', add it. */
658 retpath[retlen] = '\0';
660 else retpath[retlen-1] = '\0';
662 else { /* VMS-style directory spec */
663 char esa[NAM$C_MAXRSS+1];
664 unsigned long int sts, cmplen;
665 struct FAB dirfab = cc$rms_fab;
666 struct NAM savnam, dirnam = cc$rms_nam;
668 dirfab.fab$b_fns = strlen(dir);
669 dirfab.fab$l_fna = dir;
670 dirfab.fab$l_nam = &dirnam;
671 dirnam.nam$b_ess = sizeof esa;
672 dirnam.nam$l_esa = esa;
673 dirnam.nam$b_nop = NAM$M_SYNCHK;
674 if (!(sys$parse(&dirfab)&1)) {
676 vaxc$errno = dirfab.fab$l_sts;
680 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
681 /* Yes; fake the fnb bits so we'll check type below */
682 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
685 if (dirfab.fab$l_sts != RMS$_FNF) {
687 vaxc$errno = dirfab.fab$l_sts;
690 dirnam = savnam; /* No; just work with potential name */
693 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
694 /* Yep; check version while we're at it, if it's there. */
695 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
696 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
697 /* Something other than .DIR[;1]. Bzzt. */
701 /* OK, the type was fine. Now pull any file name into the
703 if (cp1 = strrchr(esa,']')) *dirnam.nam$l_type = ']';
705 cp1 = strrchr(esa,'>');
706 *dirnam.nam$l_type = '>';
709 *(dirnam.nam$l_type + 1) = '\0';
710 retlen = dirnam.nam$l_type - esa + 2;
713 /* There wasn't a type on the input, so ignore any file names as
714 well. If you want to pay attention to filenames without .dir
715 in the input, just use ".DIR;1" as a default filespec for
716 the $PARSE and set retlen thus
717 retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl);
719 retlen = dirnam.nam$l_name - esa;
722 if (buf) retpath = buf;
723 else if (ts) New(7014,retpath,retlen,char);
724 else retpath = __pathify_retbuf;
729 } /* end of do_pathify_dirspec() */
731 /* External entry points */
732 char *pathify_dirspec(char *dir, char *buf)
733 { return do_pathify_dirspec(dir,buf,0); }
734 char *pathify_dirspec_ts(char *dir, char *buf)
735 { return do_pathify_dirspec(dir,buf,1); }
737 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
738 static char *do_tounixspec(char *spec, char *buf, int ts)
740 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
741 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
744 if (spec == NULL || *spec == '\0') return NULL;
746 else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
747 else rslt = __tounixspec_retbuf;
748 if (strchr(spec,'/') != NULL) {
755 dirend = strrchr(spec,']');
756 if (dirend == NULL) dirend = strrchr(spec,'>');
757 if (dirend == NULL) dirend = strchr(spec,':');
758 if (dirend == NULL) {
765 else { /* the VMS spec begins with directories */
768 while (*cp2 == '-') {
769 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
772 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
773 if (ts) Safefree(rslt); /* filespecs like */
774 errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
779 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
781 if (getcwd(tmp,sizeof tmp,1) == NULL) {
782 if (ts) Safefree(rslt);
787 while (*cp3 != ':' && *cp3) cp3++;
789 if (strchr(cp3,']') != NULL) break;
790 } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3));
792 while (*cp3) *(cp1++) = *(cp3++);
794 if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
795 if (ts) Safefree(rslt);
802 for (; cp2 <= dirend; cp2++) {
805 if (*(cp2+1) == '[') cp2++;
807 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
808 else if (*cp2 == '.') {
810 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
811 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
813 else if (*cp2 == '-') {
814 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
815 while (*cp2 == '-') {
817 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
819 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
820 if (ts) Safefree(rslt); /* filespecs like */
821 errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
826 else *(cp1++) = *cp2;
828 else *(cp1++) = *cp2;
830 while (*cp2) *(cp1++) = *(cp2++);
835 } /* end of do_tounixspec() */
837 /* External entry points */
838 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
839 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
841 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
842 static char *do_tovmsspec(char *path, char *buf, int ts) {
843 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
844 char *rslt, *dirend, *cp1, *cp2;
846 if (path == NULL || *path == '\0') return NULL;
848 else if (ts) New(7016,rslt,strlen(path)+1,char);
849 else rslt = __tovmsspec_retbuf;
850 if (strchr(path,']') != NULL || strchr(path,'>') != NULL ||
851 (dirend = strrchr(path,'/')) == NULL) {
858 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
867 for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2;
870 while (*cp2) *(cp1++) = *(cp2++);
875 } /* end of do_tovmsspec() */
877 /* External entry points */
878 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
879 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
881 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
882 static char *do_tovmspath(char *path, char *buf, int ts) {
883 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
885 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
887 if (path == NULL || *path == '\0') return NULL;
888 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
889 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
892 vmslen = strlen(vmsified);
893 New(7017,cp,vmslen,char);
894 memcpy(cp,vmsified,vmslen);
899 strcpy(__tovmspath_retbuf,vmsified);
900 return __tovmspath_retbuf;
903 } /* end of do_tovmspath() */
905 /* External entry points */
906 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
907 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
910 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
911 static char *do_tounixpath(char *path, char *buf, int ts) {
912 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
914 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
916 if (path == NULL || *path == '\0') return NULL;
917 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
918 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
921 unixlen = strlen(unixified);
922 New(7017,cp,unixlen,char);
923 memcpy(cp,unixified,unixlen);
928 strcpy(__tounixpath_retbuf,unixified);
929 return __tounixpath_retbuf;
932 } /* end of do_tounixpath() */
934 /* External entry points */
935 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
936 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
939 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
941 *****************************************************************************
943 * Copyright (C) 1989-1994 by *
944 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
946 * Permission is hereby granted for the reproduction of this software, *
947 * on condition that this copyright notice is included in the reproduction, *
948 * and that such reproduction is not for purposes of profit or material *
951 * 27-Aug-1994 Modified for inclusion in perl5 *
952 * by Charles Bailey bailey@genetics.upenn.edu *
953 *****************************************************************************
957 * getredirection() is intended to aid in porting C programs
958 * to VMS (Vax-11 C). The native VMS environment does not support
959 * '>' and '<' I/O redirection, or command line wild card expansion,
960 * or a command line pipe mechanism using the '|' AND background
961 * command execution '&'. All of these capabilities are provided to any
962 * C program which calls this procedure as the first thing in the
964 * The piping mechanism will probably work with almost any 'filter' type
965 * of program. With suitable modification, it may useful for other
966 * portability problems as well.
968 * Author: Mark Pizzolato mark@infocomm.com
972 struct list_item *next;
976 static void add_item(struct list_item **head,
977 struct list_item **tail,
981 static void expand_wild_cards(char *item,
982 struct list_item **head,
983 struct list_item **tail,
986 static int background_process(int argc, char **argv);
988 static void pipe_and_fork(char **cmargv);
990 /*{{{ void getredirection(int *ac, char ***av)*/
992 getredirection(int *ac, char ***av)
994 * Process vms redirection arg's. Exit if any error is seen.
995 * If getredirection() processes an argument, it is erased
996 * from the vector. getredirection() returns a new argc and argv value.
997 * In the event that a background command is requested (by a trailing "&"),
998 * this routine creates a background subprocess, and simply exits the program.
1000 * Warning: do not try to simplify the code for vms. The code
1001 * presupposes that getredirection() is called before any data is
1002 * read from stdin or written to stdout.
1004 * Normal usage is as follows:
1010 * getredirection(&argc, &argv);
1014 int argc = *ac; /* Argument Count */
1015 char **argv = *av; /* Argument Vector */
1016 char *ap; /* Argument pointer */
1017 int j; /* argv[] index */
1018 int item_count = 0; /* Count of Items in List */
1019 struct list_item *list_head = 0; /* First Item in List */
1020 struct list_item *list_tail; /* Last Item in List */
1021 char *in = NULL; /* Input File Name */
1022 char *out = NULL; /* Output File Name */
1023 char *outmode = "w"; /* Mode to Open Output File */
1024 char *err = NULL; /* Error File Name */
1025 char *errmode = "w"; /* Mode to Open Error File */
1026 int cmargc = 0; /* Piped Command Arg Count */
1027 char **cmargv = NULL;/* Piped Command Arg Vector */
1028 stat_t statbuf; /* fstat buffer */
1031 * First handle the case where the last thing on the line ends with
1032 * a '&'. This indicates the desire for the command to be run in a
1033 * subprocess, so we satisfy that desire.
1036 if (0 == strcmp("&", ap))
1037 exit(background_process(--argc, argv));
1038 if ('&' == ap[strlen(ap)-1])
1040 ap[strlen(ap)-1] = '\0';
1041 exit(background_process(argc, argv));
1044 * Now we handle the general redirection cases that involve '>', '>>',
1045 * '<', and pipes '|'.
1047 for (j = 0; j < argc; ++j)
1049 if (0 == strcmp("<", argv[j]))
1054 croak("No input file");
1059 if ('<' == *(ap = argv[j]))
1064 if (0 == strcmp(">", ap))
1069 croak("No input file");
1089 croak("No output file");
1093 if (('2' == *ap) && ('>' == ap[1]))
1111 croak("No error file");
1115 if (0 == strcmp("|", argv[j]))
1120 croak("No command into which to pipe");
1122 cmargc = argc-(j+1);
1123 cmargv = &argv[j+1];
1127 if ('|' == *(ap = argv[j]))
1135 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1138 * Allocate and fill in the new argument vector, Some Unix's terminate
1139 * the list with an extra null pointer.
1141 New(7002, argv, item_count+1, char *);
1143 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1144 argv[j] = list_head->value;
1151 croak("'|' and '>' may not both be specified on command line");
1153 pipe_and_fork(cmargv);
1156 /* Check for input from a pipe (mailbox) */
1158 if (1 == isapipe(0))
1160 char mbxname[L_tmpnam];
1162 long int dvi_item = DVI$_DEVBUFSIZ;
1163 $DESCRIPTOR(mbxnam, "");
1164 $DESCRIPTOR(mbxdevnam, "");
1166 /* Input from a pipe, reopen it in binary mode to disable */
1167 /* carriage control processing. */
1172 croak("'|' and '<' may not both be specified on command line");
1174 fgetname(stdin, mbxname);
1175 mbxnam.dsc$a_pointer = mbxname;
1176 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1177 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1178 mbxdevnam.dsc$a_pointer = mbxname;
1179 mbxdevnam.dsc$w_length = sizeof(mbxname);
1180 dvi_item = DVI$_DEVNAM;
1181 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1182 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1184 freopen(mbxname, "rb", stdin);
1187 croak("Error reopening pipe (name: %s) in binary mode",mbxname);
1190 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1192 croak("Can't open input file %s",in);
1194 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1196 croak("Can't open output file %s",out);
1198 if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2")))
1200 croak("Can't open error file %s",err);
1202 #ifdef ARGPROC_DEBUG
1203 fprintf(stderr, "Arglist:\n");
1204 for (j = 0; j < *ac; ++j)
1205 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1207 } /* end of getredirection() */
1210 static void add_item(struct list_item **head,
1211 struct list_item **tail,
1217 New(7003,*head,1,struct list_item);
1221 New(7004,(*tail)->next,1,struct list_item);
1222 *tail = (*tail)->next;
1224 (*tail)->value = value;
1228 static void expand_wild_cards(char *item,
1229 struct list_item **head,
1230 struct list_item **tail,
1242 char vmsspec[NAM$C_MAXRSS+1];
1243 $DESCRIPTOR(filespec, "");
1244 $DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;");
1245 $DESCRIPTOR(resultspec, "");
1246 unsigned long int zero = 0;
1248 if (strcspn(item, "*%") == strlen(item))
1250 add_item(head, tail, item, count);
1253 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1254 resultspec.dsc$b_class = DSC$K_CLASS_D;
1255 resultspec.dsc$a_pointer = NULL;
1256 if (isunix = strchr(item,'/'))
1257 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1258 if (!isunix || !filespec.dsc$a_pointer)
1259 filespec.dsc$a_pointer = item;
1260 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1262 * Only return version specs, if the caller specified a version
1264 had_version = strchr(item, ';');
1266 * Only return device and directory specs, if the caller specifed either.
1268 had_device = strchr(item, ':');
1269 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1271 while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1272 &defaultspec, 0, &status_value, &zero)))
1277 New(7005,string,resultspec.dsc$w_length+1,char);
1278 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1279 string[resultspec.dsc$w_length] = '\0';
1280 if (NULL == had_version)
1281 *((char *)strrchr(string, ';')) = '\0';
1282 if ((!had_directory) && (had_device == NULL))
1284 if (NULL == (devdir = strrchr(string, ']')))
1285 devdir = strrchr(string, '>');
1286 strcpy(string, devdir + 1);
1289 * Be consistent with what the C RTL has already done to the rest of
1290 * the argv items and lowercase all of these names.
1292 for (c = string; *c; ++c)
1295 if (isunix) trim_unixpath(item,string);
1296 add_item(head, tail, string, count);
1300 add_item(head, tail, item, count);
1301 lib$sfree1_dd(&resultspec);
1302 lib$find_file_end(&context);
1305 static int child_st[2];/* Event Flag set when child process completes */
1307 static short child_chan;/* I/O Channel for Pipe Mailbox */
1309 static exit_handler(int *status)
1313 if (0 == child_st[0])
1315 #ifdef ARGPROC_DEBUG
1316 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1318 fflush(stdout); /* Have to flush pipe for binary data to */
1319 /* terminate properly -- <tp@mccall.com> */
1320 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1321 sys$dassgn(child_chan);
1323 sys$synch(0, child_st);
1328 static void sig_child(int chan)
1330 #ifdef ARGPROC_DEBUG
1331 fprintf(stderr, "Child Completion AST\n");
1333 if (child_st[0] == 0)
1337 static struct exit_control_block
1339 struct exit_control_block *flink;
1340 int (*exit_routine)();
1342 int *status_address;
1349 &exit_block.exit_status,
1353 static void pipe_and_fork(char **cmargv)
1356 $DESCRIPTOR(cmddsc, "");
1357 static char mbxname[64];
1358 $DESCRIPTOR(mbxdsc, mbxname);
1362 short dvi_item = DVI$_DEVNAM;
1363 unsigned long int zero = 0, one = 1;
1365 strcpy(subcmd, cmargv[0]);
1366 for (j = 1; NULL != cmargv[j]; ++j)
1368 strcat(subcmd, " \"");
1369 strcat(subcmd, cmargv[j]);
1370 strcat(subcmd, "\"");
1372 cmddsc.dsc$a_pointer = subcmd;
1373 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1375 create_mbx(&child_chan,&mbxdsc);
1376 #ifdef ARGPROC_DEBUG
1377 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1378 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1380 if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1381 0, &pid, child_st, &zero, sig_child,
1385 croak("Can't spawn subprocess");
1387 #ifdef ARGPROC_DEBUG
1388 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1390 sys$dclexh(&exit_block);
1391 if (NULL == freopen(mbxname, "wb", stdout))
1393 croak("Can't open pipe mailbox for output");
1397 static int background_process(int argc, char **argv)
1399 char command[2048] = "$";
1400 $DESCRIPTOR(value, "");
1401 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1402 static $DESCRIPTOR(null, "NLA0:");
1403 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1405 $DESCRIPTOR(pidstr, "");
1407 unsigned long int flags = 17, one = 1;
1409 strcat(command, argv[0]);
1412 strcat(command, " \"");
1413 strcat(command, *(++argv));
1414 strcat(command, "\"");
1416 value.dsc$a_pointer = command;
1417 value.dsc$w_length = strlen(value.dsc$a_pointer);
1418 if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value))))
1421 croak("Can't create symbol for subprocess command");
1423 if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) &&
1424 (vaxc$errno != 0x38250))
1427 croak("Can't spawn subprocess");
1429 if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */
1430 if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid))))
1433 croak("Can't spawn subprocess");
1435 #ifdef ARGPROC_DEBUG
1436 fprintf(stderr, "%s\n", command);
1438 sprintf(pidstring, "%08X", pid);
1439 fprintf(stderr, "%s\n", pidstring);
1440 pidstr.dsc$a_pointer = pidstring;
1441 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1442 lib$set_symbol(&pidsymbol, &pidstr);
1446 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
1449 * flex_stat, flex_fstat
1450 * basic stat, but gets it right when asked to stat
1451 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
1454 static char namecache[NAM$C_MAXRSS+1];
1457 is_null_device(name)
1460 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
1461 The underscore prefix, controller letter, and unit number are
1462 independently optional; for our purposes, the colon punctuation
1463 is not. The colon can be trailed by optional directory and/or
1464 filename, but two consecutive colons indicates a nodename rather
1465 than a device. [pr] */
1466 if (*name == '_') ++name;
1467 if (tolower(*name++) != 'n') return 0;
1468 if (tolower(*name++) != 'l') return 0;
1469 if (tolower(*name) == 'a') ++name;
1470 if (*name == '0') ++name;
1471 return (*name++ == ':') && (*name != ':');
1474 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
1476 flex_fstat(int fd, struct stat *statbuf)
1478 char fspec[NAM$C_MAXRSS+1];
1480 if (!getname(fd,fspec)) return -1;
1481 return flex_stat(fspec,statbuf);
1483 } /* end of flex_fstat() */
1486 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
1487 flex_stat(char *fspec, struct stat *statbufp)
1489 char fileified[NAM$C_MAXRSS+1];
1490 int retval,myretval;
1494 if (statbufp == &statcache) strcpy(namecache,fspec);
1495 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
1496 memset(statbufp,0,sizeof *statbufp);
1497 statbufp->st_dev = "_NLA0:";
1498 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
1499 statbufp->st_uid = 0x00010001;
1500 statbufp->st_gid = 0x0001;
1501 time(&statbufp->st_mtime);
1502 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
1505 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
1507 myretval = stat(fileified,&tmpbuf);
1509 retval = stat(fspec,statbufp);
1515 else if (!retval) { /* Dir with same name. Substitute it. */
1516 statbufp->st_mode &= ~S_IFDIR;
1517 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
1518 strcpy(namecache,fileified);
1523 } /* end of flex_stat() */
1527 * Trim Unix-style prefix off filespec, so it looks like what a shell
1528 * glob expansion would return (i.e. from specified prefix on, not
1529 * full path). Note that returned filespec is Unix-style, regardless
1530 * of whether input filespec was VMS-style or Unix-style.
1532 * Returns !=0 on success, 0 on failure.
1534 /*{{{int trim_unixpath(char *template, char *fspec)*/
1536 trim_unixpath(char *template, char *fspec)
1538 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1539 register int tmplen;
1541 if (strpbrk(fspec,"]>:") != NULL) {
1542 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1543 else base = unixified;
1546 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
1548 /* Find prefix to template consisting of path elements without wildcards */
1549 if ((cp1 = strpbrk(template,"*%?")) == NULL)
1550 for (cp1 = template; *cp1; cp1++) ;
1551 else while (cp1 >= template && *cp1 != '/') cp1--;
1552 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
1553 tmplen = cp1 - template;
1555 /* Try to find template prefix on filespec */
1556 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
1557 for (; cp2 - base > tmplen; base++) {
1558 if (*base != '/') continue;
1559 if (!memcmp(base + 1,template,tmplen)) break;
1561 if (cp2 - base == tmplen) return 0; /* Not there - not good */
1562 base++; /* Move past leading '/' */
1563 /* Copy down remaining portion of filespec, including trailing NUL */
1564 memmove(fspec,base,cp2 - base + 1);
1567 } /* end of trim_unixpath() */
1570 /* Do the permissions allow some operation? Assumes statcache already set. */
1571 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
1572 * subset of the applicable information.
1574 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
1576 cando(I32 bit, I32 effective, struct stat *statbufp)
1578 unsigned long int objtyp = ACL$C_FILE, access, retsts;
1579 unsigned short int retlen;
1580 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache};
1581 static char usrname[L_cuserid];
1582 static struct dsc$descriptor_s usrdsc =
1583 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
1584 struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen,
1587 if (!usrdsc.dsc$w_length) {
1589 usrdsc.dsc$w_length = strlen(usrname);
1591 namdsc.dsc$w_length = strlen(namecache);
1596 access = ARM$M_EXECUTE;
1601 access = ARM$M_READ;
1606 access = ARM$M_READ;
1612 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
1613 if (retsts == SS$_NORMAL) return TRUE;
1614 if (retsts == SS$_NOPRIV) return FALSE;
1617 return FALSE; /* Should never get here */
1619 } /* end of cando() */
1623 * VMS readdir() routines.
1624 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1625 * This code has no copyright.
1627 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
1628 * Minor modifications to original routines.
1631 /* Number of elements in vms_versions array */
1632 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
1635 * Open a directory, return a handle for later use.
1637 /*{{{ DIR *opendir(char*name) */
1642 char dir[NAM$C_MAXRSS+1];
1644 /* Get memory for the handle, and the pattern. */
1646 if (do_tovmspath(name,dir,0) == NULL) {
1647 Safefree((char *)dd);
1650 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1652 /* Fill in the fields; mainly playing with the descriptor. */
1653 (void)sprintf(dd->pattern, "%s*.*",dir);
1656 dd->vms_wantversions = 0;
1657 dd->pat.dsc$a_pointer = dd->pattern;
1658 dd->pat.dsc$w_length = strlen(dd->pattern);
1659 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1660 dd->pat.dsc$b_class = DSC$K_CLASS_S;
1663 } /* end of opendir() */
1667 * Set the flag to indicate we want versions or not.
1669 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1671 vmsreaddirversions(DIR *dd, int flag)
1673 dd->vms_wantversions = flag;
1678 * Free up an opened directory.
1680 /*{{{ void closedir(DIR *dd)*/
1684 (void)lib$find_file_end(&dd->context);
1685 Safefree(dd->pattern);
1686 Safefree((char *)dd);
1691 * Collect all the version numbers for the current file.
1697 struct dsc$descriptor_s pat;
1698 struct dsc$descriptor_s res;
1700 char *p, *text, buff[sizeof dd->entry.d_name];
1702 unsigned long context, tmpsts;
1704 /* Convenient shorthand. */
1707 /* Add the version wildcard, ignoring the "*.*" put on before */
1708 i = strlen(dd->pattern);
1709 New(7008,text,i + e->d_namlen + 3,char);
1710 (void)strcpy(text, dd->pattern);
1711 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1713 /* Set up the pattern descriptor. */
1714 pat.dsc$a_pointer = text;
1715 pat.dsc$w_length = i + e->d_namlen - 1;
1716 pat.dsc$b_dtype = DSC$K_DTYPE_T;
1717 pat.dsc$b_class = DSC$K_CLASS_S;
1719 /* Set up result descriptor. */
1720 res.dsc$a_pointer = buff;
1721 res.dsc$w_length = sizeof buff - 2;
1722 res.dsc$b_dtype = DSC$K_DTYPE_T;
1723 res.dsc$b_class = DSC$K_CLASS_S;
1725 /* Read files, collecting versions. */
1726 for (context = 0, e->vms_verscount = 0;
1727 e->vms_verscount < VERSIZE(e);
1728 e->vms_verscount++) {
1729 tmpsts = lib$find_file(&pat, &res, &context);
1730 if (tmpsts == RMS$_NMF || context == 0) break;
1732 buff[sizeof buff - 1] = '\0';
1733 if (p = strchr(buff, ';'))
1734 e->vms_versions[e->vms_verscount] = atoi(p + 1);
1736 e->vms_versions[e->vms_verscount] = -1;
1739 _cksts(lib$find_file_end(&context));
1742 } /* end of collectversions() */
1745 * Read the next entry from the directory.
1747 /*{{{ struct dirent *readdir(DIR *dd)*/
1751 struct dsc$descriptor_s res;
1752 char *p, buff[sizeof dd->entry.d_name];
1754 unsigned long int tmpsts;
1756 /* Set up result descriptor, and get next file. */
1757 res.dsc$a_pointer = buff;
1758 res.dsc$w_length = sizeof buff - 2;
1759 res.dsc$b_dtype = DSC$K_DTYPE_T;
1760 res.dsc$b_class = DSC$K_CLASS_S;
1762 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
1763 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
1765 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
1766 buff[sizeof buff - 1] = '\0';
1767 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
1770 /* Skip any directory component and just copy the name. */
1771 if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1);
1772 else (void)strcpy(dd->entry.d_name, buff);
1774 /* Clobber the version. */
1775 if (p = strchr(dd->entry.d_name, ';')) *p = '\0';
1777 dd->entry.d_namlen = strlen(dd->entry.d_name);
1778 dd->entry.vms_verscount = 0;
1779 if (dd->vms_wantversions) collectversions(dd);
1782 } /* end of readdir() */
1786 * Return something that can be used in a seekdir later.
1788 /*{{{ long telldir(DIR *dd)*/
1797 * Return to a spot where we used to be. Brute force.
1799 /*{{{ void seekdir(DIR *dd,long count)*/
1801 seekdir(DIR *dd, long count)
1803 int vms_wantversions;
1804 unsigned long int tmpsts;
1806 /* If we haven't done anything yet... */
1810 /* Remember some state, and clear it. */
1811 vms_wantversions = dd->vms_wantversions;
1812 dd->vms_wantversions = 0;
1813 _cksts(lib$find_file_end(&dd->context));
1816 /* The increment is in readdir(). */
1817 for (dd->count = 0; dd->count < count; )
1820 dd->vms_wantversions = vms_wantversions;
1822 } /* end of seekdir() */
1825 /* VMS subprocess management
1827 * my_vfork() - just a vfork(), after setting a flag to record that
1828 * the current script is trying a Unix-style fork/exec.
1830 * vms_do_aexec() and vms_do_exec() are called in response to the
1831 * perl 'exec' function. If this follows a vfork call, then they
1832 * call out the the regular perl routines in doio.c which do an
1833 * execvp (for those who really want to try this under VMS).
1834 * Otherwise, they do exactly what the perl docs say exec should
1835 * do - terminate the current script and invoke a new command
1836 * (See below for notes on command syntax.)
1838 * do_aspawn() and do_spawn() implement the VMS side of the perl
1839 * 'system' function.
1841 * Note on command arguments to perl 'exec' and 'system': When handled
1842 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
1843 * are concatenated to form a DCL command string. If the first arg
1844 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
1845 * the the command string is hrnded off to DCL directly. Otherwise,
1846 * the first token of the command is taken as the filespec of an image
1847 * to run. The filespec is expanded using a default type of '.EXE' and
1848 * the process defaults for device, directory, etc., and the resultant
1849 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
1850 * the command string as parameters. This is perhaps a bit compicated,
1851 * but I hope it will form a happy medium between what VMS folks expect
1852 * from lib$spawn and what Unix folks expect from exec.
1855 static int vfork_called;
1857 /*{{{int my_vfork()*/
1867 setup_argstr(SV *really, SV **mark, SV **sp, char **argstr)
1870 register size_t cmdlen = 0;
1875 if (really && *(tmps = SvPV(really,rlen))) {
1880 for (idx++; idx <= sp; idx++) {
1882 junk = SvPVx(*idx,rlen);
1883 cmdlen += rlen ? rlen + 1 : 0;
1886 New(401,*argstr,cmdlen, char);
1889 strcpy(*argstr,tmps);
1892 else **argstr = '\0';
1893 while (++mark <= sp) {
1895 strcat(*argstr," ");
1896 strcat(*argstr,SvPVx(*mark,na));
1900 } /* end of setup_argstr() */
1902 static unsigned long int
1903 setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img)
1905 char resspec[NAM$C_MAXRSS+1];
1906 $DESCRIPTOR(defdsc,".EXE");
1907 $DESCRIPTOR(resdsc,resspec);
1908 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1909 unsigned long int cxt = 0, flags = 1, retsts;
1910 register char *s, *rest, *cp;
1911 register int isdcl = 0;
1914 while (*s && isspace(*s)) s++;
1916 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
1917 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
1918 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
1919 if (*cp == ':' || *cp == '[' || *cp == '<') {
1927 if (isdcl) { /* It's a DCL command, just do it. */
1928 cmddsc->dsc$a_pointer = cmd;
1929 cmddsc->dsc$w_length = strlen(cmd);
1931 else { /* assume first token is an image spec */
1933 while (*s && !isspace(*s)) s++;
1935 imgdsc.dsc$a_pointer = cmd;
1936 imgdsc.dsc$w_length = s - cmd;
1937 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
1938 if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
1941 _cksts(lib$find_file_end(&cxt));
1943 while (*s && !isspace(*s)) s++;
1945 New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char);
1946 strcpy(Cmd,"$ MCR ");
1947 strcat(Cmd,resspec);
1948 if (rest) strcat(Cmd,rest);
1949 cmddsc->dsc$a_pointer = Cmd;
1950 cmddsc->dsc$w_length = strlen(Cmd);
1955 } /* end of setup_cmddsc() */
1957 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
1959 vms_do_aexec(SV *really,SV **mark,SV **sp)
1963 if (vfork_called) { /* this follows a vfork - act Unixish */
1965 do_aexec(really,mark,sp);
1967 else { /* no vfork - act VMSish */
1968 setup_argstr(really,mark,sp,&Argv);
1969 return vms_do_exec(Argv);
1974 } /* end of vms_do_aexec() */
1977 /* {{{bool vms_do_exec(char *cmd) */
1979 vms_do_exec(char *cmd)
1982 if (vfork_called) { /* this follows a vfork - act Unixish */
1986 else { /* no vfork - act VMSish */
1987 struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1989 if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1)
1990 vaxc$errno = lib$do_command(&cmddsc);
1994 warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
2000 } /* end of vms_do_exec() */
2003 unsigned long int do_spawn(char *);
2005 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2007 do_aspawn(SV *really,SV **mark,SV **sp)
2011 setup_argstr(really,mark,sp,&Argv);
2012 return do_spawn(Argv);
2016 } /* end of do_aspawn() */
2019 /* {{{unsigned long int do_spawn(char *cmd) */
2023 struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2024 unsigned long int substs;
2026 if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1)
2027 _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0));
2030 vaxc$errno = substs;
2033 warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
2037 } /* end of do_spawn() */
2041 * A simple fwrite replacement which outputs itmsz*nitm chars without
2042 * introducing record boundaries every itmsz chars.
2044 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2046 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2048 register char *cp, *end;
2050 end = (char *)src + itmsz * nitm;
2052 while ((char *)src <= end) {
2053 for (cp = src; cp <= end; cp++) if (!*cp) break;
2054 if (fputs(src,dest) == EOF) return EOF;
2056 if (fputc('\0',dest) == EOF) return EOF;
2062 } /* end of my_fwrite() */
2065 #ifndef VMS_DO_SOCKETS
2066 /***** The following two routines are temporary, and should be removed,
2067 * along with the corresponding #defines in vmsish.h, when TCP/IP support
2068 * has been added to the VMS port of perl5. (The temporary hacks are
2069 * here now sho that pack can handle type N elements.)
2070 * - C. Bailey 16-Aug-1994
2073 /*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/
2075 tmp_shortflip(unsigned short int val)
2077 return val << 8 | val >> 8;
2081 /*{{{ unsigned long int tmp_longflip(unsigned long int val)*/
2083 tmp_longflip(unsigned long int val)
2085 unsigned long int scratch = val;
2086 unsigned char savbyte, *tmp;
2088 tmp = (unsigned char *) &scratch;
2089 savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte;
2090 savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte;