3 * VMS-specific routines for perl5
5 * Last revised: 21-Jun-1996 by Charles Bailey bailey@genetics.upenn.edu
14 #include <climsgdef.h>
23 #include <lib$routines.h>
40 /* gcc's header files don't #define direct access macros
41 * corresponding to VAXC's variant structs */
43 # define uic$v_format uic$r_uic_form.uic$v_format
44 # define uic$v_group uic$r_uic_form.uic$v_group
45 # define uic$v_member uic$r_uic_form.uic$v_member
46 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
47 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
48 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
49 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
54 unsigned short int buflen;
55 unsigned short int itmcode;
57 unsigned short int *retlen;
60 static char *__mystrtolower(char *str)
62 if (str) for (; *str; ++str) *str= tolower(*str);
67 my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
69 static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
70 unsigned short int eqvlen;
71 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
72 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
73 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
74 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
75 {LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
78 if (!eqv) eqv = __my_trnlnm_eqv;
79 lnmlst[1].bufadr = (void *)eqv;
80 lnmdsc.dsc$a_pointer = lnm;
81 lnmdsc.dsc$w_length = strlen(lnm);
82 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
83 if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) {
84 set_vaxc_errno(retsts); set_errno(EINVAL); return 0;
86 else if (retsts & 1) {
90 _ckvmssts(retsts); /* Must be an error */
91 return 0; /* Not reached, assuming _ckvmssts() bails out */
93 } /* end of my_trnlnm */
96 * Translate a logical name. Substitute for CRTL getenv() to avoid
97 * memory leak, and to keep my_getenv() and my_setenv() in the same
98 * domain (mostly - my_getenv() need not return a translation from
99 * the process logical name table)
101 * Note: Uses static buffer -- not thread-safe!
103 /*{{{ char *my_getenv(char *lnm)*/
107 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
108 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
109 unsigned long int idx = 0;
111 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
113 if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
114 getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
115 return __my_getenv_eqv;
118 if ((cp2 = strchr(uplnm,';')) != NULL) {
120 idx = strtoul(cp2+1,NULL,0);
122 if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
123 return __my_getenv_eqv;
126 unsigned long int retsts;
127 struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
128 valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
129 DSC$K_CLASS_S, __my_getenv_eqv};
130 symdsc.dsc$w_length = cp1 - lnm;
131 symdsc.dsc$a_pointer = uplnm;
132 retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
133 if (retsts == LIB$_INVSYMNAM) return Nullch;
134 if (retsts != LIB$_NOSUCHSYM) {
135 /* We want to return only logical names or CRTL Unix emulations */
136 if (retsts & 1) return Nullch;
139 /* Try for CRTL emulation of a Unix/POSIX name */
140 else return getenv(lnm);
145 } /* end of my_getenv() */
148 /*{{{ void my_setenv(char *lnm, char *eqv)*/
150 my_setenv(char *lnm,char *eqv)
151 /* Define a supervisor-mode logical name in the process table.
152 * In the future we'll add tables, attribs, and acmodes,
153 * probably through a different call.
156 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
157 unsigned long int retsts, usermode = PSL$C_USER;
158 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
159 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
160 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
162 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
163 lnmdsc.dsc$w_length = cp1 - lnm;
165 if (!eqv || !*eqv) { /* we're deleting a logical name */
166 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
167 if (retsts == SS$_IVLOGNAM) return;
168 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
170 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
171 if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
175 eqvdsc.dsc$w_length = strlen(eqv);
176 eqvdsc.dsc$a_pointer = eqv;
178 _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
181 } /* end of my_setenv() */
185 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
186 /* my_crypt - VMS password hashing
187 * my_crypt() provides an interface compatible with the Unix crypt()
188 * C library function, and uses sys$hash_password() to perform VMS
189 * password hashing. The quadword hashed password value is returned
190 * as a NUL-terminated 8 character string. my_crypt() does not change
191 * the case of its string arguments; in order to match the behavior
192 * of LOGINOUT et al., alphabetic characters in both arguments must
193 * be upcased by the caller.
196 my_crypt(const char *textpasswd, const char *usrname)
198 # ifndef UAI$C_PREFERRED_ALGORITHM
199 # define UAI$C_PREFERRED_ALGORITHM 127
201 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
202 unsigned short int salt = 0;
203 unsigned long int sts;
205 unsigned short int dsc$w_length;
206 unsigned char dsc$b_type;
207 unsigned char dsc$b_class;
208 const char * dsc$a_pointer;
209 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
210 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
211 struct itmlst_3 uailst[3] = {
212 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
213 { sizeof salt, UAI$_SALT, &salt, 0},
214 { 0, 0, NULL, NULL}};
217 usrdsc.dsc$w_length = strlen(usrname);
218 usrdsc.dsc$a_pointer = usrname;
219 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
226 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
232 if (sts != RMS$_RNF) return NULL;
235 txtdsc.dsc$w_length = strlen(textpasswd);
236 txtdsc.dsc$a_pointer = textpasswd;
237 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
238 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
241 return (char *) hash;
243 } /* end of my_crypt() */
247 static char *do_fileify_dirspec(char *, char *, int);
248 static char *do_tovmsspec(char *, char *, int);
250 /*{{{int do_rmdir(char *name)*/
254 char dirfile[NAM$C_MAXRSS+1];
258 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
259 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
260 else retval = kill_file(dirfile);
263 } /* end of do_rmdir */
267 * Delete any file to which user has control access, regardless of whether
268 * delete access is explicitly allowed.
269 * Limitations: User must have write access to parent directory.
270 * Does not block signals or ASTs; if interrupted in midstream
271 * may leave file with an altered ACL.
274 /*{{{int kill_file(char *name)*/
276 kill_file(char *name)
278 char vmsname[NAM$C_MAXRSS+1];
279 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
280 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
281 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
283 unsigned char myace$b_length;
284 unsigned char myace$b_type;
285 unsigned short int myace$w_flags;
286 unsigned long int myace$l_access;
287 unsigned long int myace$l_ident;
288 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
289 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
290 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
292 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
293 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
294 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
295 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
296 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
297 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
299 if (!remove(name)) return 0; /* Can we just get rid of it? */
301 /* No, so we get our own UIC to use as a rights identifier,
302 * and the insert an ACE at the head of the ACL which allows us
303 * to delete the file.
305 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
306 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
307 fildsc.dsc$w_length = strlen(vmsname);
308 fildsc.dsc$a_pointer = vmsname;
310 newace.myace$l_ident = oldace.myace$l_ident;
311 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
313 set_vaxc_errno(aclsts);
316 /* Grab any existing ACEs with this identifier in case we fail */
317 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
318 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
319 || fndsts == SS$_NOMOREACE ) {
320 /* Add the new ACE . . . */
321 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
323 if ((rmsts = remove(name))) {
324 /* We blew it - dir with files in it, no write priv for
325 * parent directory, etc. Put things back the way they were. */
326 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
329 addlst[0].bufadr = &oldace;
330 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
338 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
339 if (aclsts & 1) aclsts = fndsts;
343 set_vaxc_errno(aclsts);
349 } /* end of kill_file() */
352 /* my_utime - update modification time of a file
353 * calling sequence is identical to POSIX utime(), but under
354 * VMS only the modification time is changed; ODS-2 does not
355 * maintain access times. Restrictions differ from the POSIX
356 * definition in that the time can be changed as long as the
357 * caller has permission to execute the necessary IO$_MODIFY $QIO;
358 * no separate checks are made to insure that the caller is the
359 * owner of the file or has special privs enabled.
360 * Code here is based on Joe Meadows' FILE utility.
363 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
364 * to VMS epoch (01-JAN-1858 00:00:00.00)
365 * in 100 ns intervals.
367 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
369 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
370 int my_utime(char *file, struct utimbuf *utimes)
373 long int bintime[2], len = 2, lowbit, unixtime,
374 secscale = 10000000; /* seconds --> 100 ns intervals */
375 unsigned long int chan, iosb[2], retsts;
376 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
377 struct FAB myfab = cc$rms_fab;
378 struct NAM mynam = cc$rms_nam;
379 #if defined (__DECC) && defined (__VAX)
380 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
381 * at least through VMS V6.1, which causes a type-conversion warning.
383 # pragma message save
384 # pragma message disable cvtdiftypes
386 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
388 #if defined (__DECC) && defined (__VAX)
389 /* This should be right after the declaration of myatr, but due
390 * to a bug in VAX DEC C, this takes effect a statement early.
392 # pragma message restore
394 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
395 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
396 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
398 if (file == NULL || *file == '\0') {
400 set_vaxc_errno(LIB$_INVARG);
403 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
405 if (utimes != NULL) {
406 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
407 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
408 * Since time_t is unsigned long int, and lib$emul takes a signed long int
409 * as input, we force the sign bit to be clear by shifting unixtime right
410 * one bit, then multiplying by an extra factor of 2 in lib$emul().
412 lowbit = (utimes->modtime & 1) ? secscale : 0;
413 unixtime = (long int) utimes->modtime;
414 unixtime >> 1; secscale << 1;
415 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
418 set_vaxc_errno(retsts);
421 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
424 set_vaxc_errno(retsts);
429 /* Just get the current time in VMS format directly */
430 retsts = sys$gettim(bintime);
433 set_vaxc_errno(retsts);
438 myfab.fab$l_fna = vmsspec;
439 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
440 myfab.fab$l_nam = &mynam;
441 mynam.nam$l_esa = esa;
442 mynam.nam$b_ess = (unsigned char) sizeof esa;
443 mynam.nam$l_rsa = rsa;
444 mynam.nam$b_rss = (unsigned char) sizeof rsa;
446 /* Look for the file to be affected, letting RMS parse the file
447 * specification for us as well. I have set errno using only
448 * values documented in the utime() man page for VMS POSIX.
450 retsts = sys$parse(&myfab,0,0);
452 set_vaxc_errno(retsts);
453 if (retsts == RMS$_PRV) set_errno(EACCES);
454 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
455 else set_errno(EVMSERR);
458 retsts = sys$search(&myfab,0,0);
460 set_vaxc_errno(retsts);
461 if (retsts == RMS$_PRV) set_errno(EACCES);
462 else if (retsts == RMS$_FNF) set_errno(ENOENT);
463 else set_errno(EVMSERR);
467 devdsc.dsc$w_length = mynam.nam$b_dev;
468 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
470 retsts = sys$assign(&devdsc,&chan,0,0);
472 set_vaxc_errno(retsts);
473 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
474 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
475 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
476 else set_errno(EVMSERR);
480 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
481 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
483 memset((void *) &myfib, 0, sizeof myfib);
485 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
486 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
487 /* This prevents the revision time of the file being reset to the current
488 * time as a result of our IO$_MODIFY $QIO. */
489 myfib.fib$l_acctl = FIB$M_NORECORD;
491 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
492 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
493 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
495 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
496 _ckvmssts(sys$dassgn(chan));
497 if (retsts & 1) retsts = iosb[0];
499 set_vaxc_errno(retsts);
500 if (retsts == SS$_NOPRIV) set_errno(EACCES);
501 else set_errno(EVMSERR);
506 } /* end of my_utime() */
510 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
512 static unsigned long int mbxbufsiz;
513 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
517 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
518 * preprocessor consant BUFSIZ from stdio.h as the size of the
521 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
522 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
524 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
526 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
527 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
529 } /* end of create_mbx() */
531 /*{{{ my_popen and my_pclose*/
534 struct pipe_details *next;
535 FILE *fp; /* stdio file pointer to pipe mailbox */
536 int pid; /* PID of subprocess */
537 int mode; /* == 'r' if pipe open for reading */
538 int done; /* subprocess has completed */
539 unsigned long int completion; /* termination status of subprocess */
542 struct exit_control_block
544 struct exit_control_block *flink;
545 unsigned long int (*exit_routine)();
546 unsigned long int arg_count;
547 unsigned long int *status_address;
548 unsigned long int exit_status;
551 static struct pipe_details *open_pipes = NULL;
552 static $DESCRIPTOR(nl_desc, "NL:");
553 static int waitpid_asleep = 0;
555 static unsigned long int
558 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
560 while (open_pipes != NULL) {
561 if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
562 _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
565 if (!open_pipes->done) /* We tried to be nice . . . */
566 _ckvmssts(sys$delprc(&open_pipes->pid,0));
567 if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
572 static struct exit_control_block pipe_exitblock =
573 {(struct exit_control_block *) 0,
574 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
578 popen_completion_ast(struct pipe_details *thispipe)
580 thispipe->done = TRUE;
581 if (waitpid_asleep) {
587 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
589 my_popen(char *cmd, char *mode)
591 static int handler_set_up = FALSE;
593 unsigned short int chan;
594 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
595 struct pipe_details *info;
596 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
597 DSC$K_CLASS_S, mbxname},
598 cmddsc = {0, DSC$K_DTYPE_T,
602 cmddsc.dsc$w_length=strlen(cmd);
603 cmddsc.dsc$a_pointer=cmd;
604 if (cmddsc.dsc$w_length > 255) {
605 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
609 New(7001,info,1,struct pipe_details);
612 create_mbx(&chan,&namdsc);
614 /* open a FILE* onto it */
615 info->fp=fopen(mbxname, mode);
617 /* give up other channel onto it */
618 _ckvmssts(sys$dassgn(chan));
628 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
629 0 /* name */, &info->pid, &info->completion,
630 0, popen_completion_ast,info,0,0,0));
633 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
634 0 /* name */, &info->pid, &info->completion,
635 0, popen_completion_ast,info,0,0,0));
638 if (!handler_set_up) {
639 _ckvmssts(sys$dclexh(&pipe_exitblock));
640 handler_set_up = TRUE;
642 info->next=open_pipes; /* prepend to list */
645 forkprocess = info->pid;
650 /*{{{ I32 my_pclose(FILE *fp)*/
651 I32 my_pclose(FILE *fp)
653 struct pipe_details *info, *last = NULL;
654 unsigned long int retsts;
656 for (info = open_pipes; info != NULL; last = info, info = info->next)
657 if (info->fp == fp) break;
660 /* get here => no such pipe open */
661 croak("No such pipe open");
665 if (info->done) retsts = info->completion;
666 else waitpid(info->pid,(int *) &retsts,0);
668 /* remove from list of open pipes */
669 if (last) last->next = info->next;
670 else open_pipes = info->next;
675 } /* end of my_pclose() */
677 /* sort-of waitpid; use only with popen() */
678 /*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
680 waitpid(unsigned long int pid, int *statusp, int flags)
682 struct pipe_details *info;
684 for (info = open_pipes; info != NULL; info = info->next)
685 if (info->pid == pid) break;
687 if (info != NULL) { /* we know about this child */
688 while (!info->done) {
693 *statusp = info->completion;
696 else { /* we haven't heard of this child */
697 $DESCRIPTOR(intdsc,"0 00:00:01");
698 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
699 unsigned long int interval[2],sts;
702 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
703 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
704 if (ownerpid != mypid)
705 warn("pid %d not a child",pid);
708 _ckvmssts(sys$bintim(&intdsc,interval));
709 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
710 _ckvmssts(sys$schdwk(0,0,interval,0));
711 _ckvmssts(sys$hiber());
715 /* There's no easy way to find the termination status a child we're
716 * not aware of beforehand. If we're really interested in the future,
717 * we can go looking for a termination mailbox, or chase after the
718 * accounting record for the process.
724 } /* end of waitpid() */
729 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
731 my_gconvert(double val, int ndig, int trail, char *buf)
733 static char __gcvtbuf[DBL_DIG+1];
736 loc = buf ? buf : __gcvtbuf;
738 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
739 return gcvt(val,ndig,loc);
742 loc[0] = '0'; loc[1] = '\0';
750 ** The following routines are provided to make life easier when
751 ** converting among VMS-style and Unix-style directory specifications.
752 ** All will take input specifications in either VMS or Unix syntax. On
753 ** failure, all return NULL. If successful, the routines listed below
754 ** return a pointer to a buffer containing the appropriately
755 ** reformatted spec (and, therefore, subsequent calls to that routine
756 ** will clobber the result), while the routines of the same names with
757 ** a _ts suffix appended will return a pointer to a mallocd string
758 ** containing the appropriately reformatted spec.
759 ** In all cases, only explicit syntax is altered; no check is made that
760 ** the resulting string is valid or that the directory in question
763 ** fileify_dirspec() - convert a directory spec into the name of the
764 ** directory file (i.e. what you can stat() to see if it's a dir).
765 ** The style (VMS or Unix) of the result is the same as the style
766 ** of the parameter passed in.
767 ** pathify_dirspec() - convert a directory spec into a path (i.e.
768 ** what you prepend to a filename to indicate what directory it's in).
769 ** The style (VMS or Unix) of the result is the same as the style
770 ** of the parameter passed in.
771 ** tounixpath() - convert a directory spec into a Unix-style path.
772 ** tovmspath() - convert a directory spec into a VMS-style path.
773 ** tounixspec() - convert any file spec into a Unix-style file spec.
774 ** tovmsspec() - convert any file spec into a VMS-style spec.
776 ** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
777 ** Permission is given to distribute this code as part of the Perl
778 ** standard distribution under the terms of the GNU General Public
779 ** License or the Perl Artistic License. Copies of each may be
780 ** found in the Perl standard distribution.
783 static char *do_tounixspec(char *, char *, int);
785 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
786 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
788 static char __fileify_retbuf[NAM$C_MAXRSS+1];
789 unsigned long int dirlen, retlen, addmfd = 0;
790 char *retspec, *cp1, *cp2, *lastdir;
791 char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
794 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
796 dirlen = strlen(dir);
797 if (dir[dirlen-1] == '/') --dirlen;
800 set_vaxc_errno(RMS$_DIR);
803 if (!strpbrk(dir+1,"/]>:")) {
804 strcpy(trndir,*dir == '/' ? dir + 1: dir);
805 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
807 dirlen = strlen(dir);
810 strncpy(trndir,dir,dirlen);
811 trndir[dirlen] = '\0';
814 /* If we were handed a rooted logical name or spec, treat it like a
815 * simple directory, so that
816 * $ Define myroot dev:[dir.]
817 * ... do_fileify_dirspec("myroot",buf,1) ...
818 * does something useful.
820 if (!strcmp(dir+dirlen-2,".]")) {
821 dir[--dirlen] = '\0';
825 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
827 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
828 return do_fileify_dirspec("[]",buf,ts);
829 else if (dir[1] == '.' &&
830 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
831 return do_fileify_dirspec("[-]",buf,ts);
833 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
834 dirlen -= 1; /* to last element */
835 lastdir = strrchr(dir,'/');
837 else if ((cp1 = strstr(dir,"/.")) != NULL) {
838 /* If we have "/." or "/..", VMSify it and let the VMS code
839 * below expand it, rather than repeating the code to handle
840 * relative components of a filespec here */
842 if (*(cp1+2) == '.') cp1++;
843 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
844 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
845 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
846 return do_tounixspec(trndir,buf,ts);
849 } while ((cp1 = strstr(cp1,"/.")) != NULL);
852 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
853 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
854 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
855 toupper(*(cp2+2)) == 'I' &&
856 toupper(*(cp2+3)) == 'R') {
857 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
858 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
859 set_errno(ENOTDIR); /* Bzzt. */
860 set_vaxc_errno(RMS$_DIR);
866 else { /* There's a type, and it's not .dir. Bzzt. */
868 set_vaxc_errno(RMS$_DIR);
873 /* If we lead off with a device or rooted logical, add the MFD
874 if we're specifying a top-level directory. */
875 if (lastdir && *dir == '/') {
877 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
884 retlen = dirlen + (addmfd ? 13 : 6);
885 if (buf) retspec = buf;
886 else if (ts) New(7009,retspec,retlen+1,char);
887 else retspec = __fileify_retbuf;
889 dirlen = lastdir - dir;
890 memcpy(retspec,dir,dirlen);
891 strcpy(&retspec[dirlen],"/000000");
892 strcpy(&retspec[dirlen+7],lastdir);
895 memcpy(retspec,dir,dirlen);
896 retspec[dirlen] = '\0';
898 /* We've picked up everything up to the directory file name.
899 Now just add the type and version, and we're set. */
900 strcat(retspec,".dir;1");
903 else { /* VMS-style directory spec */
904 char esa[NAM$C_MAXRSS+1], term, *cp;
905 unsigned long int sts, cmplen, haslower = 0;
906 struct FAB dirfab = cc$rms_fab;
907 struct NAM savnam, dirnam = cc$rms_nam;
909 dirfab.fab$b_fns = strlen(dir);
910 dirfab.fab$l_fna = dir;
911 dirfab.fab$l_nam = &dirnam;
912 dirfab.fab$l_dna = ".DIR;1";
913 dirfab.fab$b_dns = 6;
914 dirnam.nam$b_ess = NAM$C_MAXRSS;
915 dirnam.nam$l_esa = esa;
917 for (cp = dir; *cp; cp++)
918 if (islower(*cp)) { haslower = 1; break; }
919 if (!((sts = sys$parse(&dirfab))&1)) {
920 if (dirfab.fab$l_sts == RMS$_DIR) {
921 dirnam.nam$b_nop |= NAM$M_SYNCHK;
922 sts = sys$parse(&dirfab) & 1;
926 set_vaxc_errno(dirfab.fab$l_sts);
932 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
933 /* Yes; fake the fnb bits so we'll check type below */
934 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
937 if (dirfab.fab$l_sts != RMS$_FNF) {
939 set_vaxc_errno(dirfab.fab$l_sts);
942 dirnam = savnam; /* No; just work with potential name */
945 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
946 cp1 = strchr(esa,']');
947 if (!cp1) cp1 = strchr(esa,'>');
948 if (cp1) { /* Should always be true */
949 dirnam.nam$b_esl -= cp1 - esa - 1;
950 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
953 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
954 /* Yep; check version while we're at it, if it's there. */
955 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
956 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
957 /* Something other than .DIR[;1]. Bzzt. */
959 set_vaxc_errno(RMS$_DIR);
963 esa[dirnam.nam$b_esl] = '\0';
964 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
965 /* They provided at least the name; we added the type, if necessary, */
966 if (buf) retspec = buf; /* in sys$parse() */
967 else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
968 else retspec = __fileify_retbuf;
972 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
973 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
975 dirnam.nam$b_esl -= 9;
977 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
978 if (cp1 == NULL) return NULL; /* should never happen */
981 retlen = strlen(esa);
982 if ((cp1 = strrchr(esa,'.')) != NULL) {
983 /* There's more than one directory in the path. Just roll back. */
985 if (buf) retspec = buf;
986 else if (ts) New(7011,retspec,retlen+7,char);
987 else retspec = __fileify_retbuf;
991 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
992 /* Go back and expand rooted logical name */
993 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
994 if (!(sys$parse(&dirfab) & 1)) {
996 set_vaxc_errno(dirfab.fab$l_sts);
999 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1000 if (buf) retspec = buf;
1001 else if (ts) New(7012,retspec,retlen+16,char);
1002 else retspec = __fileify_retbuf;
1003 cp1 = strstr(esa,"][");
1005 memcpy(retspec,esa,dirlen);
1006 if (!strncmp(cp1+2,"000000]",7)) {
1007 retspec[dirlen-1] = '\0';
1008 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1009 if (*cp1 == '.') *cp1 = ']';
1011 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1012 memcpy(cp1+1,"000000]",7);
1016 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1017 retspec[retlen] = '\0';
1018 /* Convert last '.' to ']' */
1019 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1020 if (*cp1 == '.') *cp1 = ']';
1022 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1023 memcpy(cp1+1,"000000]",7);
1027 else { /* This is a top-level dir. Add the MFD to the path. */
1028 if (buf) retspec = buf;
1029 else if (ts) New(7012,retspec,retlen+16,char);
1030 else retspec = __fileify_retbuf;
1033 while (*cp1 != ':') *(cp2++) = *(cp1++);
1034 strcpy(cp2,":[000000]");
1039 /* We've set up the string up through the filename. Add the
1040 type and version, and we're done. */
1041 strcat(retspec,".DIR;1");
1043 /* $PARSE may have upcased filespec, so convert output to lower
1044 * case if input contained any lowercase characters. */
1045 if (haslower) __mystrtolower(retspec);
1048 } /* end of do_fileify_dirspec() */
1050 /* External entry points */
1051 char *fileify_dirspec(char *dir, char *buf)
1052 { return do_fileify_dirspec(dir,buf,0); }
1053 char *fileify_dirspec_ts(char *dir, char *buf)
1054 { return do_fileify_dirspec(dir,buf,1); }
1056 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1057 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1059 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1060 unsigned long int retlen;
1061 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1063 if (!dir || !*dir) {
1064 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1067 if (*dir) strcpy(trndir,dir);
1068 else getcwd(trndir,sizeof trndir - 1);
1070 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1071 STRLEN trnlen = strlen(trndir);
1073 /* Trap simple rooted lnms, and return lnm:[000000] */
1074 if (!strcmp(trndir+trnlen-2,".]")) {
1075 if (buf) retpath = buf;
1076 else if (ts) New(7018,retpath,strlen(dir)+10,char);
1077 else retpath = __pathify_retbuf;
1078 strcpy(retpath,dir);
1079 strcat(retpath,":[000000]");
1085 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
1086 if (*dir == '.' && (*(dir+1) == '\0' ||
1087 (*(dir+1) == '.' && *(dir+2) == '\0')))
1088 retlen = 2 + (*(dir+1) != '\0');
1090 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
1091 if ((cp2 = strchr(cp1,'.')) && (*(cp2+1) != '.' && *(cp2+1) != '\0')) {
1092 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
1093 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
1094 toupper(*(cp2+3)) == 'R') {
1095 retlen = cp2 - dir + 1;
1097 else { /* Some other file type. Bzzt. */
1099 set_vaxc_errno(RMS$_DIR);
1103 else { /* No file type present. Treat the filename as a directory. */
1104 retlen = strlen(dir) + 1;
1107 if (buf) retpath = buf;
1108 else if (ts) New(7013,retpath,retlen+1,char);
1109 else retpath = __pathify_retbuf;
1110 strncpy(retpath,dir,retlen-1);
1111 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1112 retpath[retlen-1] = '/'; /* with '/', add it. */
1113 retpath[retlen] = '\0';
1115 else retpath[retlen-1] = '\0';
1117 else { /* VMS-style directory spec */
1118 char esa[NAM$C_MAXRSS+1], *cp;
1119 unsigned long int sts, cmplen, haslower;
1120 struct FAB dirfab = cc$rms_fab;
1121 struct NAM savnam, dirnam = cc$rms_nam;
1123 dirfab.fab$b_fns = strlen(dir);
1124 dirfab.fab$l_fna = dir;
1125 if (dir[dirfab.fab$b_fns-1] == ']' ||
1126 dir[dirfab.fab$b_fns-1] == '>' ||
1127 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1128 if (buf) retpath = buf;
1129 else if (ts) New(7014,retpath,strlen(dir)+1,char);
1130 else retpath = __pathify_retbuf;
1131 strcpy(retpath,dir);
1134 dirfab.fab$l_dna = ".DIR;1";
1135 dirfab.fab$b_dns = 6;
1136 dirfab.fab$l_nam = &dirnam;
1137 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1138 dirnam.nam$l_esa = esa;
1140 for (cp = dir; *cp; cp++)
1141 if (islower(*cp)) { haslower = 1; break; }
1143 if (!(sts = (sys$parse(&dirfab)&1))) {
1144 if (dirfab.fab$l_sts == RMS$_DIR) {
1145 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1146 sts = sys$parse(&dirfab) & 1;
1150 set_vaxc_errno(dirfab.fab$l_sts);
1156 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1157 if (dirfab.fab$l_sts != RMS$_FNF) {
1159 set_vaxc_errno(dirfab.fab$l_sts);
1162 dirnam = savnam; /* No; just work with potential name */
1165 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1166 /* Yep; check version while we're at it, if it's there. */
1167 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1168 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1169 /* Something other than .DIR[;1]. Bzzt. */
1171 set_vaxc_errno(RMS$_DIR);
1175 /* OK, the type was fine. Now pull any file name into the
1177 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1179 cp1 = strrchr(esa,'>');
1180 *dirnam.nam$l_type = '>';
1183 *(dirnam.nam$l_type + 1) = '\0';
1184 retlen = dirnam.nam$l_type - esa + 2;
1185 if (buf) retpath = buf;
1186 else if (ts) New(7014,retpath,retlen,char);
1187 else retpath = __pathify_retbuf;
1188 strcpy(retpath,esa);
1189 /* $PARSE may have upcased filespec, so convert output to lower
1190 * case if input contained any lowercase characters. */
1191 if (haslower) __mystrtolower(retpath);
1195 } /* end of do_pathify_dirspec() */
1197 /* External entry points */
1198 char *pathify_dirspec(char *dir, char *buf)
1199 { return do_pathify_dirspec(dir,buf,0); }
1200 char *pathify_dirspec_ts(char *dir, char *buf)
1201 { return do_pathify_dirspec(dir,buf,1); }
1203 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1204 static char *do_tounixspec(char *spec, char *buf, int ts)
1206 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1207 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1208 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
1210 if (spec == NULL) return NULL;
1211 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1212 if (buf) rslt = buf;
1214 retlen = strlen(spec);
1215 cp1 = strchr(spec,'[');
1216 if (!cp1) cp1 = strchr(spec,'<');
1218 for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
1220 New(7015,rslt,retlen+2+2*dashes,char);
1222 else rslt = __tounixspec_retbuf;
1223 if (strchr(spec,'/') != NULL) {
1230 dirend = strrchr(spec,']');
1231 if (dirend == NULL) dirend = strrchr(spec,'>');
1232 if (dirend == NULL) dirend = strchr(spec,':');
1233 if (dirend == NULL) {
1237 if (*cp2 != '[' && *cp2 != '<') {
1240 else { /* the VMS spec begins with directories */
1242 if (*cp2 == ']' || *cp2 == '>') {
1246 else if ( *cp2 != '.' && *cp2 != '-') {
1247 *(cp1++) = '/'; /* add the implied device into the Unix spec */
1248 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1249 if (ts) Safefree(rslt);
1254 while (*cp3 != ':' && *cp3) cp3++;
1256 if (strchr(cp3,']') != NULL) break;
1257 } while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
1259 while (*cp3) *(cp1++) = *(cp3++);
1262 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1263 int offset = cp1 - rslt;
1265 retlen = devlen + dirlen;
1266 Renew(rslt,retlen+1+2*dashes,char);
1267 cp1 = rslt + offset;
1270 else if (*cp2 == '.') cp2++;
1272 for (; cp2 <= dirend; cp2++) {
1275 if (*(cp2+1) == '[') cp2++;
1277 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
1278 else if (*cp2 == '.') {
1280 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1281 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1282 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1283 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1284 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1287 else if (*cp2 == '-') {
1288 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1289 while (*cp2 == '-') {
1291 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1293 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1294 if (ts) Safefree(rslt); /* filespecs like */
1295 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1299 else *(cp1++) = *cp2;
1301 else *(cp1++) = *cp2;
1303 while (*cp2) *(cp1++) = *(cp2++);
1308 } /* end of do_tounixspec() */
1310 /* External entry points */
1311 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1312 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1314 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1315 static char *do_tovmsspec(char *path, char *buf, int ts) {
1316 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1317 char *rslt, *dirend;
1318 register char *cp1, *cp2;
1319 unsigned long int infront = 0, hasdir = 1;
1321 if (path == NULL) return NULL;
1322 if (buf) rslt = buf;
1323 else if (ts) New(7016,rslt,strlen(path)+9,char);
1324 else rslt = __tovmsspec_retbuf;
1325 if (strpbrk(path,"]:>") ||
1326 (dirend = strrchr(path,'/')) == NULL) {
1327 if (path[0] == '.') {
1328 if (path[1] == '\0') strcpy(rslt,"[]");
1329 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1330 else strcpy(rslt,path); /* probably garbage */
1332 else strcpy(rslt,path);
1335 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
1336 if (!*(dirend+2)) dirend +=2;
1337 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1342 char trndev[NAM$C_MAXRSS+1];
1346 while (*(++cp2) == '/') ; /* Skip multiple /s */
1347 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
1349 islnm = my_trnlnm(rslt,trndev,0);
1350 trnend = islnm ? strlen(trndev) - 1 : 0;
1351 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
1352 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
1353 /* If the first element of the path is a logical name, determine
1354 * whether it has to be translated so we can add more directories. */
1355 if (!islnm || rooted) {
1358 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
1362 if (cp2 != dirend) {
1363 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
1364 strcpy(rslt,trndev);
1365 cp1 = rslt + trnend;
1378 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
1379 cp2 += 2; /* skip over "./" - it's redundant */
1380 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
1382 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1383 *(cp1++) = '-'; /* "../" --> "-" */
1386 if (cp2 > dirend) cp2 = dirend;
1388 else *(cp1++) = '.';
1390 for (; cp2 < dirend; cp2++) {
1392 if (*(cp2-1) == '/') continue;
1393 if (*(cp1-1) != '.') *(cp1++) = '.';
1396 else if (!infront && *cp2 == '.') {
1397 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
1398 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
1399 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
1400 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
1401 else if (*(cp1-2) == '[') *(cp1-1) = '-';
1402 else { /* back up over previous directory name */
1404 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
1405 if (*(cp1-1) == '[') {
1406 memcpy(cp1,"000000.",7);
1411 if (cp2 == dirend) break;
1413 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
1416 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
1417 if (*cp2 == '.') *(cp1++) = '_';
1418 else *(cp1++) = *cp2;
1422 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
1423 if (hasdir) *(cp1++) = ']';
1424 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
1425 while (*cp2) *(cp1++) = *(cp2++);
1430 } /* end of do_tovmsspec() */
1432 /* External entry points */
1433 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
1434 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
1436 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
1437 static char *do_tovmspath(char *path, char *buf, int ts) {
1438 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
1440 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
1442 if (path == NULL) return NULL;
1443 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1444 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
1445 if (buf) return buf;
1447 vmslen = strlen(vmsified);
1448 New(7017,cp,vmslen+1,char);
1449 memcpy(cp,vmsified,vmslen);
1454 strcpy(__tovmspath_retbuf,vmsified);
1455 return __tovmspath_retbuf;
1458 } /* end of do_tovmspath() */
1460 /* External entry points */
1461 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
1462 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
1465 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
1466 static char *do_tounixpath(char *path, char *buf, int ts) {
1467 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
1469 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
1471 if (path == NULL) return NULL;
1472 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
1473 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
1474 if (buf) return buf;
1476 unixlen = strlen(unixified);
1477 New(7017,cp,unixlen+1,char);
1478 memcpy(cp,unixified,unixlen);
1483 strcpy(__tounixpath_retbuf,unixified);
1484 return __tounixpath_retbuf;
1487 } /* end of do_tounixpath() */
1489 /* External entry points */
1490 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
1491 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
1494 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
1496 *****************************************************************************
1498 * Copyright (C) 1989-1994 by *
1499 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
1501 * Permission is hereby granted for the reproduction of this software, *
1502 * on condition that this copyright notice is included in the reproduction, *
1503 * and that such reproduction is not for purposes of profit or material *
1506 * 27-Aug-1994 Modified for inclusion in perl5 *
1507 * by Charles Bailey bailey@genetics.upenn.edu *
1508 *****************************************************************************
1512 * getredirection() is intended to aid in porting C programs
1513 * to VMS (Vax-11 C). The native VMS environment does not support
1514 * '>' and '<' I/O redirection, or command line wild card expansion,
1515 * or a command line pipe mechanism using the '|' AND background
1516 * command execution '&'. All of these capabilities are provided to any
1517 * C program which calls this procedure as the first thing in the
1519 * The piping mechanism will probably work with almost any 'filter' type
1520 * of program. With suitable modification, it may useful for other
1521 * portability problems as well.
1523 * Author: Mark Pizzolato mark@infocomm.com
1527 struct list_item *next;
1531 static void add_item(struct list_item **head,
1532 struct list_item **tail,
1536 static void expand_wild_cards(char *item,
1537 struct list_item **head,
1538 struct list_item **tail,
1541 static int background_process(int argc, char **argv);
1543 static void pipe_and_fork(char **cmargv);
1545 /*{{{ void getredirection(int *ac, char ***av)*/
1547 getredirection(int *ac, char ***av)
1549 * Process vms redirection arg's. Exit if any error is seen.
1550 * If getredirection() processes an argument, it is erased
1551 * from the vector. getredirection() returns a new argc and argv value.
1552 * In the event that a background command is requested (by a trailing "&"),
1553 * this routine creates a background subprocess, and simply exits the program.
1555 * Warning: do not try to simplify the code for vms. The code
1556 * presupposes that getredirection() is called before any data is
1557 * read from stdin or written to stdout.
1559 * Normal usage is as follows:
1565 * getredirection(&argc, &argv);
1569 int argc = *ac; /* Argument Count */
1570 char **argv = *av; /* Argument Vector */
1571 char *ap; /* Argument pointer */
1572 int j; /* argv[] index */
1573 int item_count = 0; /* Count of Items in List */
1574 struct list_item *list_head = 0; /* First Item in List */
1575 struct list_item *list_tail; /* Last Item in List */
1576 char *in = NULL; /* Input File Name */
1577 char *out = NULL; /* Output File Name */
1578 char *outmode = "w"; /* Mode to Open Output File */
1579 char *err = NULL; /* Error File Name */
1580 char *errmode = "w"; /* Mode to Open Error File */
1581 int cmargc = 0; /* Piped Command Arg Count */
1582 char **cmargv = NULL;/* Piped Command Arg Vector */
1585 * First handle the case where the last thing on the line ends with
1586 * a '&'. This indicates the desire for the command to be run in a
1587 * subprocess, so we satisfy that desire.
1590 if (0 == strcmp("&", ap))
1591 exit(background_process(--argc, argv));
1592 if (*ap && '&' == ap[strlen(ap)-1])
1594 ap[strlen(ap)-1] = '\0';
1595 exit(background_process(argc, argv));
1598 * Now we handle the general redirection cases that involve '>', '>>',
1599 * '<', and pipes '|'.
1601 for (j = 0; j < argc; ++j)
1603 if (0 == strcmp("<", argv[j]))
1607 fprintf(stderr,"No input file after < on command line");
1608 exit(LIB$_WRONUMARG);
1613 if ('<' == *(ap = argv[j]))
1618 if (0 == strcmp(">", ap))
1622 fprintf(stderr,"No output file after > on command line");
1623 exit(LIB$_WRONUMARG);
1642 fprintf(stderr,"No output file after > or >> on command line");
1643 exit(LIB$_WRONUMARG);
1647 if (('2' == *ap) && ('>' == ap[1]))
1664 fprintf(stderr,"No output file after 2> or 2>> on command line");
1665 exit(LIB$_WRONUMARG);
1669 if (0 == strcmp("|", argv[j]))
1673 fprintf(stderr,"No command into which to pipe on command line");
1674 exit(LIB$_WRONUMARG);
1676 cmargc = argc-(j+1);
1677 cmargv = &argv[j+1];
1681 if ('|' == *(ap = argv[j]))
1689 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1692 * Allocate and fill in the new argument vector, Some Unix's terminate
1693 * the list with an extra null pointer.
1695 New(7002, argv, item_count+1, char *);
1697 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1698 argv[j] = list_head->value;
1704 fprintf(stderr,"'|' and '>' may not both be specified on command line");
1705 exit(LIB$_INVARGORD);
1707 pipe_and_fork(cmargv);
1710 /* Check for input from a pipe (mailbox) */
1712 if (in == NULL && 1 == isapipe(0))
1714 char mbxname[L_tmpnam];
1716 long int dvi_item = DVI$_DEVBUFSIZ;
1717 $DESCRIPTOR(mbxnam, "");
1718 $DESCRIPTOR(mbxdevnam, "");
1720 /* Input from a pipe, reopen it in binary mode to disable */
1721 /* carriage control processing. */
1723 fgetname(stdin, mbxname,1);
1724 mbxnam.dsc$a_pointer = mbxname;
1725 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1726 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1727 mbxdevnam.dsc$a_pointer = mbxname;
1728 mbxdevnam.dsc$w_length = sizeof(mbxname);
1729 dvi_item = DVI$_DEVNAM;
1730 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1731 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1734 freopen(mbxname, "rb", stdin);
1737 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
1741 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1743 fprintf(stderr,"Can't open input file %s as stdin",in);
1746 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1748 fprintf(stderr,"Can't open output file %s as stdout",out);
1753 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
1755 fprintf(stderr,"Can't open error file %s as stderr",err);
1759 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
1764 #ifdef ARGPROC_DEBUG
1765 fprintf(stderr, "Arglist:\n");
1766 for (j = 0; j < *ac; ++j)
1767 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1769 } /* end of getredirection() */
1772 static void add_item(struct list_item **head,
1773 struct list_item **tail,
1779 New(7003,*head,1,struct list_item);
1783 New(7004,(*tail)->next,1,struct list_item);
1784 *tail = (*tail)->next;
1786 (*tail)->value = value;
1790 static void expand_wild_cards(char *item,
1791 struct list_item **head,
1792 struct list_item **tail,
1796 unsigned long int context = 0;
1802 char vmsspec[NAM$C_MAXRSS+1];
1803 $DESCRIPTOR(filespec, "");
1804 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
1805 $DESCRIPTOR(resultspec, "");
1806 unsigned long int zero = 0, sts;
1808 if (strcspn(item, "*%") == strlen(item))
1810 add_item(head, tail, item, count);
1813 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1814 resultspec.dsc$b_class = DSC$K_CLASS_D;
1815 resultspec.dsc$a_pointer = NULL;
1816 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
1817 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1818 if (!isunix || !filespec.dsc$a_pointer)
1819 filespec.dsc$a_pointer = item;
1820 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1822 * Only return version specs, if the caller specified a version
1824 had_version = strchr(item, ';');
1826 * Only return device and directory specs, if the caller specifed either.
1828 had_device = strchr(item, ':');
1829 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1831 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
1832 &defaultspec, 0, 0, &zero))))
1837 New(7005,string,resultspec.dsc$w_length+1,char);
1838 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1839 string[resultspec.dsc$w_length] = '\0';
1840 if (NULL == had_version)
1841 *((char *)strrchr(string, ';')) = '\0';
1842 if ((!had_directory) && (had_device == NULL))
1844 if (NULL == (devdir = strrchr(string, ']')))
1845 devdir = strrchr(string, '>');
1846 strcpy(string, devdir + 1);
1849 * Be consistent with what the C RTL has already done to the rest of
1850 * the argv items and lowercase all of these names.
1852 for (c = string; *c; ++c)
1855 if (isunix) trim_unixpath(string,item);
1856 add_item(head, tail, string, count);
1859 if (sts != RMS$_NMF)
1861 set_vaxc_errno(sts);
1866 set_errno(ENOENT); break;
1868 set_errno(ENODEV); break;
1870 set_errno(EINVAL); break;
1872 set_errno(EACCES); break;
1878 add_item(head, tail, item, count);
1879 _ckvmssts(lib$sfree1_dd(&resultspec));
1880 _ckvmssts(lib$find_file_end(&context));
1883 static int child_st[2];/* Event Flag set when child process completes */
1885 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
1887 static unsigned long int exit_handler(int *status)
1891 if (0 == child_st[0])
1893 #ifdef ARGPROC_DEBUG
1894 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1896 fflush(stdout); /* Have to flush pipe for binary data to */
1897 /* terminate properly -- <tp@mccall.com> */
1898 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1899 sys$dassgn(child_chan);
1901 sys$synch(0, child_st);
1906 static void sig_child(int chan)
1908 #ifdef ARGPROC_DEBUG
1909 fprintf(stderr, "Child Completion AST\n");
1911 if (child_st[0] == 0)
1915 static struct exit_control_block exit_block =
1920 &exit_block.exit_status,
1924 static void pipe_and_fork(char **cmargv)
1927 $DESCRIPTOR(cmddsc, "");
1928 static char mbxname[64];
1929 $DESCRIPTOR(mbxdsc, mbxname);
1931 unsigned long int zero = 0, one = 1;
1933 strcpy(subcmd, cmargv[0]);
1934 for (j = 1; NULL != cmargv[j]; ++j)
1936 strcat(subcmd, " \"");
1937 strcat(subcmd, cmargv[j]);
1938 strcat(subcmd, "\"");
1940 cmddsc.dsc$a_pointer = subcmd;
1941 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1943 create_mbx(&child_chan,&mbxdsc);
1944 #ifdef ARGPROC_DEBUG
1945 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1946 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1948 _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1949 0, &pid, child_st, &zero, sig_child,
1951 #ifdef ARGPROC_DEBUG
1952 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1954 sys$dclexh(&exit_block);
1955 if (NULL == freopen(mbxname, "wb", stdout))
1957 fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
1961 static int background_process(int argc, char **argv)
1963 char command[2048] = "$";
1964 $DESCRIPTOR(value, "");
1965 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1966 static $DESCRIPTOR(null, "NLA0:");
1967 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1969 $DESCRIPTOR(pidstr, "");
1971 unsigned long int flags = 17, one = 1, retsts;
1973 strcat(command, argv[0]);
1976 strcat(command, " \"");
1977 strcat(command, *(++argv));
1978 strcat(command, "\"");
1980 value.dsc$a_pointer = command;
1981 value.dsc$w_length = strlen(value.dsc$a_pointer);
1982 _ckvmssts(lib$set_symbol(&cmd, &value));
1983 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
1984 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
1985 _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
1990 #ifdef ARGPROC_DEBUG
1991 fprintf(stderr, "%s\n", command);
1993 sprintf(pidstring, "%08X", pid);
1994 fprintf(stderr, "%s\n", pidstring);
1995 pidstr.dsc$a_pointer = pidstring;
1996 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1997 lib$set_symbol(&pidsymbol, &pidstr);
2001 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2004 * Trim Unix-style prefix off filespec, so it looks like what a shell
2005 * glob expansion would return (i.e. from specified prefix on, not
2006 * full path). Note that returned filespec is Unix-style, regardless
2007 * of whether input filespec was VMS-style or Unix-style.
2009 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2010 * determine prefix (both may be in VMS or Unix syntax).
2012 * Returns !=0 on success, with trimmed filespec replacing contents of
2013 * fspec, and 0 on failure, with contents of fpsec unchanged.
2015 /*{{{int trim_unixpath(char *fspec, char *wildspec)*/
2017 trim_unixpath(char *fspec, char *wildspec)
2019 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2020 *template, *base, *cp1, *cp2;
2021 register int tmplen, reslen = 0;
2023 if (!wildspec || !fspec) return 0;
2024 if (strpbrk(wildspec,"]>:") != NULL) {
2025 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2026 else template = unixified;
2028 else template = wildspec;
2029 if (strpbrk(fspec,"]>:") != NULL) {
2030 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2031 else base = unixified;
2032 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2033 * check to see that final result fits into (isn't longer than) fspec */
2034 reslen = strlen(fspec);
2038 /* No prefix or absolute path on wildcard, so nothing to remove */
2039 if (!*template || *template == '/') {
2040 if (base == fspec) return 1;
2041 tmplen = strlen(unixified);
2042 if (tmplen > reslen) return 0; /* not enough space */
2043 /* Copy unixified resultant, including trailing NUL */
2044 memmove(fspec,unixified,tmplen+1);
2048 /* Find prefix to template consisting of path elements without wildcards */
2049 if ((cp1 = strpbrk(template,"*%?")) == NULL)
2050 for (cp1 = template; *cp1; cp1++) ;
2051 else while (cp1 > template && *cp1 != '/') cp1--;
2052 for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
2054 /* Wildcard was in first element, so we don't have a reliable string to
2055 * match against. Guess where to trim resultant filespec by counting
2056 * directory levels in the Unix template. (We could do this instead of
2057 * string matching in all cases, since Unix doesn't have a ... wildcard
2058 * that can expand into multiple levels of subdirectory, but we try for
2059 * the string match so our caller can interpret foo/.../bar.* as
2060 * [.foo...]bar.* if it wants, and only get burned if there was a
2061 * wildcard in the first word (in which case, caveat caller). */
2062 if (cp1 == template) {
2064 for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
2065 /* need to back one more '/' than in template, to pick up leading dirname */
2067 while (cp2 > base) {
2068 if (*cp2 == '/') subdirs--;
2069 if (!subdirs) break; /* quit without decrement when we hit last '/' */
2072 /* ran out of directories on resultant; allow for already trimmed
2073 * resultant, which hits start of string looking for leading '/' */
2074 if (subdirs && (cp2 != base || subdirs != 1)) return 0;
2075 /* Move past leading '/', if there is one */
2076 base = cp2 + (*cp2 == '/' ? 1 : 0);
2077 tmplen = strlen(base);
2078 if (reslen && tmplen > reslen) return 0; /* not enough space */
2079 memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
2082 /* We have a prefix string of complete directory names, so we
2083 * try to find it on the resultant filespec */
2085 tmplen = cp1 - template;
2086 if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
2087 if (reslen) { /* we converted to Unix syntax; copy result over */
2088 tmplen = cp2 - base;
2089 if (tmplen > reslen) return 0; /* not enough space */
2090 memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
2094 for ( ; cp2 - base > tmplen; base++) {
2095 if (*base != '/') continue;
2096 if (!memcmp(base + 1,template,tmplen)) break;
2099 if (cp2 - base == tmplen) return 0; /* Not there - not good */
2100 base++; /* Move past leading '/' */
2101 if (reslen && cp2 - base > reslen) return 0; /* not enough space */
2102 /* Copy down remaining portion of filespec, including trailing NUL */
2103 memmove(fspec,base,cp2 - base + 1);
2107 } /* end of trim_unixpath() */
2112 * VMS readdir() routines.
2113 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2114 * This code has no copyright.
2116 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
2117 * Minor modifications to original routines.
2120 /* Number of elements in vms_versions array */
2121 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2124 * Open a directory, return a handle for later use.
2126 /*{{{ DIR *opendir(char*name) */
2131 char dir[NAM$C_MAXRSS+1];
2133 /* Get memory for the handle, and the pattern. */
2135 if (do_tovmspath(name,dir,0) == NULL) {
2136 Safefree((char *)dd);
2139 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
2141 /* Fill in the fields; mainly playing with the descriptor. */
2142 (void)sprintf(dd->pattern, "%s*.*",dir);
2145 dd->vms_wantversions = 0;
2146 dd->pat.dsc$a_pointer = dd->pattern;
2147 dd->pat.dsc$w_length = strlen(dd->pattern);
2148 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
2149 dd->pat.dsc$b_class = DSC$K_CLASS_S;
2152 } /* end of opendir() */
2156 * Set the flag to indicate we want versions or not.
2158 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
2160 vmsreaddirversions(DIR *dd, int flag)
2162 dd->vms_wantversions = flag;
2167 * Free up an opened directory.
2169 /*{{{ void closedir(DIR *dd)*/
2173 (void)lib$find_file_end(&dd->context);
2174 Safefree(dd->pattern);
2175 Safefree((char *)dd);
2180 * Collect all the version numbers for the current file.
2186 struct dsc$descriptor_s pat;
2187 struct dsc$descriptor_s res;
2189 char *p, *text, buff[sizeof dd->entry.d_name];
2191 unsigned long context, tmpsts;
2193 /* Convenient shorthand. */
2196 /* Add the version wildcard, ignoring the "*.*" put on before */
2197 i = strlen(dd->pattern);
2198 New(7008,text,i + e->d_namlen + 3,char);
2199 (void)strcpy(text, dd->pattern);
2200 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
2202 /* Set up the pattern descriptor. */
2203 pat.dsc$a_pointer = text;
2204 pat.dsc$w_length = i + e->d_namlen - 1;
2205 pat.dsc$b_dtype = DSC$K_DTYPE_T;
2206 pat.dsc$b_class = DSC$K_CLASS_S;
2208 /* Set up result descriptor. */
2209 res.dsc$a_pointer = buff;
2210 res.dsc$w_length = sizeof buff - 2;
2211 res.dsc$b_dtype = DSC$K_DTYPE_T;
2212 res.dsc$b_class = DSC$K_CLASS_S;
2214 /* Read files, collecting versions. */
2215 for (context = 0, e->vms_verscount = 0;
2216 e->vms_verscount < VERSIZE(e);
2217 e->vms_verscount++) {
2218 tmpsts = lib$find_file(&pat, &res, &context);
2219 if (tmpsts == RMS$_NMF || context == 0) break;
2221 buff[sizeof buff - 1] = '\0';
2222 if ((p = strchr(buff, ';')))
2223 e->vms_versions[e->vms_verscount] = atoi(p + 1);
2225 e->vms_versions[e->vms_verscount] = -1;
2228 _ckvmssts(lib$find_file_end(&context));
2231 } /* end of collectversions() */
2234 * Read the next entry from the directory.
2236 /*{{{ struct dirent *readdir(DIR *dd)*/
2240 struct dsc$descriptor_s res;
2241 char *p, buff[sizeof dd->entry.d_name];
2242 unsigned long int tmpsts;
2244 /* Set up result descriptor, and get next file. */
2245 res.dsc$a_pointer = buff;
2246 res.dsc$w_length = sizeof buff - 2;
2247 res.dsc$b_dtype = DSC$K_DTYPE_T;
2248 res.dsc$b_class = DSC$K_CLASS_S;
2249 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
2250 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
2251 if (!(tmpsts & 1)) {
2252 set_vaxc_errno(tmpsts);
2255 set_errno(EACCES); break;
2257 set_errno(ENODEV); break;
2260 set_errno(ENOENT); break;
2267 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
2268 buff[sizeof buff - 1] = '\0';
2269 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
2272 /* Skip any directory component and just copy the name. */
2273 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
2274 else (void)strcpy(dd->entry.d_name, buff);
2276 /* Clobber the version. */
2277 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
2279 dd->entry.d_namlen = strlen(dd->entry.d_name);
2280 dd->entry.vms_verscount = 0;
2281 if (dd->vms_wantversions) collectversions(dd);
2284 } /* end of readdir() */
2288 * Return something that can be used in a seekdir later.
2290 /*{{{ long telldir(DIR *dd)*/
2299 * Return to a spot where we used to be. Brute force.
2301 /*{{{ void seekdir(DIR *dd,long count)*/
2303 seekdir(DIR *dd, long count)
2305 int vms_wantversions;
2307 /* If we haven't done anything yet... */
2311 /* Remember some state, and clear it. */
2312 vms_wantversions = dd->vms_wantversions;
2313 dd->vms_wantversions = 0;
2314 _ckvmssts(lib$find_file_end(&dd->context));
2317 /* The increment is in readdir(). */
2318 for (dd->count = 0; dd->count < count; )
2321 dd->vms_wantversions = vms_wantversions;
2323 } /* end of seekdir() */
2326 /* VMS subprocess management
2328 * my_vfork() - just a vfork(), after setting a flag to record that
2329 * the current script is trying a Unix-style fork/exec.
2331 * vms_do_aexec() and vms_do_exec() are called in response to the
2332 * perl 'exec' function. If this follows a vfork call, then they
2333 * call out the the regular perl routines in doio.c which do an
2334 * execvp (for those who really want to try this under VMS).
2335 * Otherwise, they do exactly what the perl docs say exec should
2336 * do - terminate the current script and invoke a new command
2337 * (See below for notes on command syntax.)
2339 * do_aspawn() and do_spawn() implement the VMS side of the perl
2340 * 'system' function.
2342 * Note on command arguments to perl 'exec' and 'system': When handled
2343 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
2344 * are concatenated to form a DCL command string. If the first arg
2345 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
2346 * the the command string is hrnded off to DCL directly. Otherwise,
2347 * the first token of the command is taken as the filespec of an image
2348 * to run. The filespec is expanded using a default type of '.EXE' and
2349 * the process defaults for device, directory, etc., and the resultant
2350 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
2351 * the command string as parameters. This is perhaps a bit compicated,
2352 * but I hope it will form a happy medium between what VMS folks expect
2353 * from lib$spawn and what Unix folks expect from exec.
2356 static int vfork_called;
2358 /*{{{int my_vfork()*/
2368 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
2376 if (VMScmd.dsc$a_pointer) {
2377 Safefree(VMScmd.dsc$a_pointer);
2378 VMScmd.dsc$w_length = 0;
2379 VMScmd.dsc$a_pointer = Nullch;
2384 setup_argstr(SV *really, SV **mark, SV **sp)
2386 char *junk, *tmps = Nullch;
2387 register size_t cmdlen = 0;
2393 tmps = SvPV(really,rlen);
2400 for (idx++; idx <= sp; idx++) {
2402 junk = SvPVx(*idx,rlen);
2403 cmdlen += rlen ? rlen + 1 : 0;
2406 New(401,Cmd,cmdlen+1,char);
2408 if (tmps && *tmps) {
2413 while (++mark <= sp) {
2416 strcat(Cmd,SvPVx(*mark,na));
2421 } /* end of setup_argstr() */
2424 static unsigned long int
2425 setup_cmddsc(char *cmd, int check_img)
2427 char resspec[NAM$C_MAXRSS+1];
2428 $DESCRIPTOR(defdsc,".EXE");
2429 $DESCRIPTOR(resdsc,resspec);
2430 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2431 unsigned long int cxt = 0, flags = 1, retsts;
2432 register char *s, *rest, *cp;
2433 register int isdcl = 0;
2436 while (*s && isspace(*s)) s++;
2438 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
2439 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
2440 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
2441 if (*cp == ':' || *cp == '[' || *cp == '<') {
2449 if (isdcl) { /* It's a DCL command, just do it. */
2450 VMScmd.dsc$w_length = strlen(cmd);
2452 VMScmd.dsc$a_pointer = Cmd;
2453 Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
2455 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
2457 else { /* assume first token is an image spec */
2459 while (*s && !isspace(*s)) s++;
2461 imgdsc.dsc$a_pointer = cmd;
2462 imgdsc.dsc$w_length = s - cmd;
2463 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
2464 if (!(retsts & 1)) {
2465 /* just hand off status values likely to be due to user error */
2466 if (retsts == RMS$_FNF || retsts == RMS$_DNF ||
2467 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2468 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2469 else { _ckvmssts(retsts); }
2472 _ckvmssts(lib$find_file_end(&cxt));
2474 while (*s && !isspace(*s)) s++;
2476 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
2477 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
2478 strcat(VMScmd.dsc$a_pointer,resspec);
2479 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
2480 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
2484 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
2486 } /* end of setup_cmddsc() */
2489 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
2491 vms_do_aexec(SV *really,SV **mark,SV **sp)
2494 if (vfork_called) { /* this follows a vfork - act Unixish */
2496 if (vfork_called < 0) {
2497 warn("Internal inconsistency in tracking vforks");
2500 else return do_aexec(really,mark,sp);
2502 /* no vfork - act VMSish */
2503 return vms_do_exec(setup_argstr(really,mark,sp));
2508 } /* end of vms_do_aexec() */
2511 /* {{{bool vms_do_exec(char *cmd) */
2513 vms_do_exec(char *cmd)
2516 if (vfork_called) { /* this follows a vfork - act Unixish */
2518 if (vfork_called < 0) {
2519 warn("Internal inconsistency in tracking vforks");
2522 else return do_exec(cmd);
2525 { /* no vfork - act VMSish */
2526 unsigned long int retsts;
2528 if ((retsts = setup_cmddsc(cmd,1)) & 1)
2529 retsts = lib$do_command(&VMScmd);
2532 set_vaxc_errno(retsts);
2534 warn("Can't exec \"%s\": %s", VMScmd.dsc$a_pointer, Strerror(errno));
2540 } /* end of vms_do_exec() */
2543 unsigned long int do_spawn(char *);
2545 /* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2547 do_aspawn(SV *really,SV **mark,SV **sp)
2549 if (sp > mark) return do_spawn(setup_argstr(really,mark,sp));
2552 } /* end of do_aspawn() */
2555 /* {{{unsigned long int do_spawn(char *cmd) */
2559 unsigned long int substs, hadcmd = 1;
2561 if (!cmd || !*cmd) {
2563 _ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
2565 else if ((substs = setup_cmddsc(cmd,0)) & 1) {
2566 _ckvmssts(lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0));
2571 set_vaxc_errno(substs);
2573 warn("Can't spawn \"%s\": %s",
2574 hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
2579 } /* end of do_spawn() */
2583 * A simple fwrite replacement which outputs itmsz*nitm chars without
2584 * introducing record boundaries every itmsz chars.
2586 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2588 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2590 register char *cp, *end;
2592 end = (char *)src + itmsz * nitm;
2594 while ((char *)src <= end) {
2595 for (cp = src; cp <= end; cp++) if (!*cp) break;
2596 if (fputs(src,dest) == EOF) return EOF;
2598 if (fputc('\0',dest) == EOF) return EOF;
2604 } /* end of my_fwrite() */
2608 * Here are replacements for the following Unix routines in the VMS environment:
2609 * getpwuid Get information for a particular UIC or UID
2610 * getpwnam Get information for a named user
2611 * getpwent Get information for each user in the rights database
2612 * setpwent Reset search to the start of the rights database
2613 * endpwent Finish searching for users in the rights database
2615 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
2616 * (defined in pwd.h), which contains the following fields:-
2618 * char *pw_name; Username (in lower case)
2619 * char *pw_passwd; Hashed password
2620 * unsigned int pw_uid; UIC
2621 * unsigned int pw_gid; UIC group number
2622 * char *pw_unixdir; Default device/directory (VMS-style)
2623 * char *pw_gecos; Owner name
2624 * char *pw_dir; Default device/directory (Unix-style)
2625 * char *pw_shell; Default CLI name (eg. DCL)
2627 * If the specified user does not exist, getpwuid and getpwnam return NULL.
2629 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
2630 * not the UIC member number (eg. what's returned by getuid()),
2631 * getpwuid() can accept either as input (if uid is specified, the caller's
2632 * UIC group is used), though it won't recognise gid=0.
2634 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
2635 * information about other users in your group or in other groups, respectively.
2636 * If the required privilege is not available, then these routines fill only
2637 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
2640 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
2643 /* sizes of various UAF record fields */
2644 #define UAI$S_USERNAME 12
2645 #define UAI$S_IDENT 31
2646 #define UAI$S_OWNER 31
2647 #define UAI$S_DEFDEV 31
2648 #define UAI$S_DEFDIR 63
2649 #define UAI$S_DEFCLI 31
2652 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
2653 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
2654 (uic).uic$v_group != UIC$K_WILD_GROUP)
2656 static char __empty[]= "";
2657 static struct passwd __passwd_empty=
2658 {(char *) __empty, (char *) __empty, 0, 0,
2659 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
2660 static int contxt= 0;
2661 static struct passwd __pwdcache;
2662 static char __pw_namecache[UAI$S_IDENT+1];
2665 * This routine does most of the work extracting the user information.
2667 static int fillpasswd (const char *name, struct passwd *pwd)
2670 unsigned char length;
2671 char pw_gecos[UAI$S_OWNER+1];
2673 static union uicdef uic;
2675 unsigned char length;
2676 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
2679 unsigned char length;
2680 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
2683 unsigned char length;
2684 char pw_shell[UAI$S_DEFCLI+1];
2686 static char pw_passwd[UAI$S_PWD+1];
2688 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
2689 struct dsc$descriptor_s name_desc;
2690 unsigned long int sts;
2692 static struct itmlst_3 itmlst[]= {
2693 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
2694 {sizeof(uic), UAI$_UIC, &uic, &luic},
2695 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
2696 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
2697 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
2698 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
2699 {0, 0, NULL, NULL}};
2701 name_desc.dsc$w_length= strlen(name);
2702 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2703 name_desc.dsc$b_class= DSC$K_CLASS_S;
2704 name_desc.dsc$a_pointer= (char *) name;
2706 /* Note that sys$getuai returns many fields as counted strings. */
2707 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
2708 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
2709 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
2711 else { _ckvmssts(sts); }
2712 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
2714 if ((int) owner.length < lowner) lowner= (int) owner.length;
2715 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
2716 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
2717 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
2718 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
2719 owner.pw_gecos[lowner]= '\0';
2720 defdev.pw_dir[ldefdev+ldefdir]= '\0';
2721 defcli.pw_shell[ldefcli]= '\0';
2722 if (valid_uic(uic)) {
2723 pwd->pw_uid= uic.uic$l_uic;
2724 pwd->pw_gid= uic.uic$v_group;
2727 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
2728 pwd->pw_passwd= pw_passwd;
2729 pwd->pw_gecos= owner.pw_gecos;
2730 pwd->pw_dir= defdev.pw_dir;
2731 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
2732 pwd->pw_shell= defcli.pw_shell;
2733 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
2735 ldir= strlen(pwd->pw_unixdir) - 1;
2736 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
2739 strcpy(pwd->pw_unixdir, pwd->pw_dir);
2740 __mystrtolower(pwd->pw_unixdir);
2745 * Get information for a named user.
2747 /*{{{struct passwd *getpwnam(char *name)*/
2748 struct passwd *my_getpwnam(char *name)
2750 struct dsc$descriptor_s name_desc;
2752 unsigned long int status, stat;
2754 __pwdcache = __passwd_empty;
2755 if (!fillpasswd(name, &__pwdcache)) {
2756 /* We still may be able to determine pw_uid and pw_gid */
2757 name_desc.dsc$w_length= strlen(name);
2758 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
2759 name_desc.dsc$b_class= DSC$K_CLASS_S;
2760 name_desc.dsc$a_pointer= (char *) name;
2761 if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
2762 __pwdcache.pw_uid= uic.uic$l_uic;
2763 __pwdcache.pw_gid= uic.uic$v_group;
2766 if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
2767 set_vaxc_errno(stat);
2768 set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
2771 else { _ckvmssts(stat); }
2774 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
2775 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
2776 __pwdcache.pw_name= __pw_namecache;
2778 } /* end of my_getpwnam() */
2782 * Get information for a particular UIC or UID.
2783 * Called by my_getpwent with uid=-1 to list all users.
2785 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
2786 struct passwd *my_getpwuid(Uid_t uid)
2788 const $DESCRIPTOR(name_desc,__pw_namecache);
2789 unsigned short lname;
2791 unsigned long int status;
2793 if (uid == (unsigned int) -1) {
2795 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
2796 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
2797 set_vaxc_errno(status);
2798 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2802 else { _ckvmssts(status); }
2803 } while (!valid_uic (uic));
2807 if (!uic.uic$v_group)
2808 uic.uic$v_group= getgid();
2810 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
2811 else status = SS$_IVIDENT;
2812 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
2813 status == RMS$_PRV) {
2814 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
2817 else { _ckvmssts(status); }
2819 __pw_namecache[lname]= '\0';
2820 __mystrtolower(__pw_namecache);
2822 __pwdcache = __passwd_empty;
2823 __pwdcache.pw_name = __pw_namecache;
2825 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
2826 The identifier's value is usually the UIC, but it doesn't have to be,
2827 so if we can, we let fillpasswd update this. */
2828 __pwdcache.pw_uid = uic.uic$l_uic;
2829 __pwdcache.pw_gid = uic.uic$v_group;
2831 fillpasswd(__pw_namecache, &__pwdcache);
2834 } /* end of my_getpwuid() */
2838 * Get information for next user.
2840 /*{{{struct passwd *my_getpwent()*/
2841 struct passwd *my_getpwent()
2843 return (my_getpwuid((unsigned int) -1));
2848 * Finish searching rights database for users.
2850 /*{{{void my_endpwent()*/
2854 _ckvmssts(sys$finish_rdb(&contxt));
2862 * If the CRTL has a real gmtime(), use it, else look for the logical
2863 * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
2864 * VMS >= 6.0. Can be manually defined under earlier versions of VMS
2865 * to translate to the number of seconds which must be added to UTC
2866 * to get to the local time of the system.
2867 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
2870 /*{{{struct tm *my_gmtime(const time_t *time)*/
2871 /* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
2872 * so we can call the CRTL's routine to see if it works.
2876 my_gmtime(const time_t *time)
2878 static int gmtime_emulation_type;
2879 static time_t utc_offset_secs;
2883 if (gmtime_emulation_type == 0) {
2884 gmtime_emulation_type++;
2886 if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
2887 gmtime_emulation_type++;
2888 if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
2889 gmtime_emulation_type++;
2891 utc_offset_secs = (time_t) atol(p);
2895 switch (gmtime_emulation_type) {
2897 return gmtime(time);
2899 when = *time - utc_offset_secs;
2900 return localtime(&when);
2902 warn("gmtime not supported on this system");
2905 } /* end of my_gmtime() */
2906 /* Reset definition for later calls */
2907 #define gmtime(t) my_gmtime(t)
2912 * flex_stat, flex_fstat
2913 * basic stat, but gets it right when asked to stat
2914 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
2917 /* encode_dev packs a VMS device name string into an integer to allow
2918 * simple comparisons. This can be used, for example, to check whether two
2919 * files are located on the same device, by comparing their encoded device
2920 * names. Even a string comparison would not do, because stat() reuses the
2921 * device name buffer for each call; so without encode_dev, it would be
2922 * necessary to save the buffer and use strcmp (this would mean a number of
2923 * changes to the standard Perl code, to say nothing of what a Perl script
2926 * The device lock id, if it exists, should be unique (unless perhaps compared
2927 * with lock ids transferred from other nodes). We have a lock id if the disk is
2928 * mounted cluster-wide, which is when we tend to get long (host-qualified)
2929 * device names. Thus we use the lock id in preference, and only if that isn't
2930 * available, do we try to pack the device name into an integer (flagged by
2931 * the sign bit (LOCKID_MASK) being set).
2933 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
2934 * name and its encoded form, but it seems very unlikely that we will find
2935 * two files on different disks that share the same encoded device names,
2936 * and even more remote that they will share the same file id (if the test
2937 * is to check for the same file).
2939 * A better method might be to use sys$device_scan on the first call, and to
2940 * search for the device, returning an index into the cached array.
2941 * The number returned would be more intelligable.
2942 * This is probably not worth it, and anyway would take quite a bit longer
2943 * on the first call.
2945 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
2946 static dev_t encode_dev (const char *dev)
2949 unsigned long int f;
2954 if (!dev || !dev[0]) return 0;
2958 struct dsc$descriptor_s dev_desc;
2959 unsigned long int status, lockid, item = DVI$_LOCKID;
2961 /* For cluster-mounted disks, the disk lock identifier is unique, so we
2962 can try that first. */
2963 dev_desc.dsc$w_length = strlen (dev);
2964 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
2965 dev_desc.dsc$b_class = DSC$K_CLASS_S;
2966 dev_desc.dsc$a_pointer = (char *) dev;
2967 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
2968 if (lockid) return (lockid & ~LOCKID_MASK);
2972 /* Otherwise we try to encode the device name */
2976 for (q = dev + strlen(dev); q--; q >= dev) {
2979 else if (isalpha (toupper (*q)))
2980 c= toupper (*q) - 'A' + (char)10;
2982 continue; /* Skip '$'s */
2984 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
2986 enc += f * (unsigned long int) c;
2988 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
2990 } /* end of encode_dev() */
2992 static char namecache[NAM$C_MAXRSS+1];
2995 is_null_device(name)
2998 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
2999 The underscore prefix, controller letter, and unit number are
3000 independently optional; for our purposes, the colon punctuation
3001 is not. The colon can be trailed by optional directory and/or
3002 filename, but two consecutive colons indicates a nodename rather
3003 than a device. [pr] */
3004 if (*name == '_') ++name;
3005 if (tolower(*name++) != 'n') return 0;
3006 if (tolower(*name++) != 'l') return 0;
3007 if (tolower(*name) == 'a') ++name;
3008 if (*name == '0') ++name;
3009 return (*name++ == ':') && (*name != ':');
3012 /* Do the permissions allow some operation? Assumes statcache already set. */
3013 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
3014 * subset of the applicable information.
3016 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
3018 cando(I32 bit, I32 effective, struct stat *statbufp)
3020 if (statbufp == &statcache)
3021 return cando_by_name(bit,effective,namecache);
3023 char fname[NAM$C_MAXRSS+1];
3024 unsigned long int retsts;
3025 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3026 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3028 /* If the struct mystat is stale, we're OOL; stat() overwrites the
3029 device name on successive calls */
3030 devdsc.dsc$a_pointer = statbufp->st_devnam;
3031 devdsc.dsc$w_length = strlen(statbufp->st_devnam);
3032 namdsc.dsc$a_pointer = fname;
3033 namdsc.dsc$w_length = sizeof fname - 1;
3035 retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
3036 &namdsc.dsc$w_length,0,0);
3038 fname[namdsc.dsc$w_length] = '\0';
3039 return cando_by_name(bit,effective,fname);
3041 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
3042 warn("Can't get filespec - stale stat buffer?\n");
3046 return FALSE; /* Should never get to here */
3048 } /* end of cando() */
3052 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
3054 cando_by_name(I32 bit, I32 effective, char *fname)
3056 static char usrname[L_cuserid];
3057 static struct dsc$descriptor_s usrdsc =
3058 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
3059 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
3060 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
3061 unsigned short int retlen;
3062 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3063 union prvdef curprv;
3064 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
3065 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
3066 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
3069 if (!fname || !*fname) return FALSE;
3070 /* Make sure we expand logical names, since sys$check_access doesn't */
3071 if (!strpbrk(fname,"/]>:")) {
3072 strcpy(fileified,fname);
3073 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
3076 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
3077 retlen = namdsc.dsc$w_length = strlen(vmsname);
3078 namdsc.dsc$a_pointer = vmsname;
3079 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
3080 vmsname[retlen-1] == ':') {
3081 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
3082 namdsc.dsc$w_length = strlen(fileified);
3083 namdsc.dsc$a_pointer = fileified;
3086 if (!usrdsc.dsc$w_length) {
3088 usrdsc.dsc$w_length = strlen(usrname);
3095 access = ARM$M_EXECUTE;
3100 access = ARM$M_READ;
3105 access = ARM$M_WRITE;
3110 access = ARM$M_DELETE;
3116 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
3117 #ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
3118 # define SS$_NOSUCHOBJECT 2696
3120 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
3121 retsts == RMS$_FNF || retsts == RMS$_DIR ||
3122 retsts == RMS$_DEV) {
3123 set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts);
3126 if (retsts == SS$_NORMAL) {
3127 if (!privused) return TRUE;
3128 /* We can get access, but only by using privs. Do we have the
3129 necessary privs currently enabled? */
3130 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
3131 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
3132 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
3133 !curprv.prv$v_bypass) return FALSE;
3134 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
3135 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
3136 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
3141 return FALSE; /* Should never get here */
3143 } /* end of cando_by_name() */
3147 /*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
3149 flex_fstat(int fd, struct stat *statbuf)
3151 char fspec[NAM$C_MAXRSS+1];
3153 if (!getname(fd,fspec,1)) return -1;
3154 return flex_stat(fspec,statbuf);
3156 } /* end of flex_fstat() */
3159 /*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
3160 /* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
3161 * 'struct stat' elsewhere in Perl would use our struct. We go back
3162 * to the system version here, since we're actually calling their
3167 flex_stat(char *fspec, struct mystat *statbufp)
3169 char fileified[NAM$C_MAXRSS+1];
3170 int retval,myretval;
3171 struct mystat tmpbuf;
3174 if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
3175 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
3176 memset(statbufp,0,sizeof *statbufp);
3177 statbufp->st_dev = encode_dev("_NLA0:");
3178 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
3179 statbufp->st_uid = 0x00010001;
3180 statbufp->st_gid = 0x0001;
3181 time((time_t *)&statbufp->st_mtime);
3182 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
3186 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
3188 myretval = stat(fileified,(stat_t *) &tmpbuf);
3190 retval = stat(fspec,(stat_t *) statbufp);
3196 else if (!retval) { /* Dir with same name. Substitute it. */
3197 statbufp->st_mode &= ~S_IFDIR;
3198 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
3199 strcpy(namecache,fileified);
3202 if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
3205 } /* end of flex_stat() */
3206 /* Reset definition for later calls */
3210 /*{{{char *my_getlogin()*/
3211 /* VMS cuserid == Unix getlogin, except calling sequence */
3215 static char user[L_cuserid];
3216 return cuserid(user);
3221 /* rmscopy - copy a file using VMS RMS routines
3223 * Copies contents and attributes of spec_in to spec_out, except owner
3224 * and protection information. Name and type of spec_in are used as
3225 * defaults for spec_out. The third parameter specifies whether rmscopy()
3226 * should try to propagate timestamps from the input file to the output file.
3227 * If it is less than 0, no timestamps are preserved. If it is 0, then
3228 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
3229 * propagated to the output file at creation iff the output file specification
3230 * did not contain an explicit name or type, and the revision date is always
3231 * updated at the end of the copy operation. If it is greater than 0, then
3232 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
3233 * other than the revision date should be propagated, and bit 1 indicates
3234 * that the revision date should be propagated.
3236 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
3238 * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
3239 * Incorporates, with permission, some code from EZCOPY by Tim Adye
3240 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
3241 * as part of the Perl standard distribution under the terms of the
3242 * GNU General Public License or the Perl Artistic License. Copies
3243 * of each may be found in the Perl standard distribution.
3245 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
3247 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
3249 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
3250 rsa[NAM$C_MAXRSS], ubf[32256];
3251 unsigned long int i, sts, sts2;
3252 struct FAB fab_in, fab_out;
3253 struct RAB rab_in, rab_out;
3255 struct XABDAT xabdat;
3256 struct XABFHC xabfhc;
3257 struct XABRDT xabrdt;
3258 struct XABSUM xabsum;
3260 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
3261 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
3262 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3266 fab_in = cc$rms_fab;
3267 fab_in.fab$l_fna = vmsin;
3268 fab_in.fab$b_fns = strlen(vmsin);
3269 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
3270 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
3271 fab_in.fab$l_fop = FAB$M_SQO;
3272 fab_in.fab$l_nam = &nam;
3273 fab_in.fab$l_xab = (void *) &xabdat;
3276 nam.nam$l_rsa = rsa;
3277 nam.nam$b_rss = sizeof(rsa);
3278 nam.nam$l_esa = esa;
3279 nam.nam$b_ess = sizeof (esa);
3280 nam.nam$b_esl = nam.nam$b_rsl = 0;
3282 xabdat = cc$rms_xabdat; /* To get creation date */
3283 xabdat.xab$l_nxt = (void *) &xabfhc;
3285 xabfhc = cc$rms_xabfhc; /* To get record length */
3286 xabfhc.xab$l_nxt = (void *) &xabsum;
3288 xabsum = cc$rms_xabsum; /* To get key and area information */
3290 if (!((sts = sys$open(&fab_in)) & 1)) {
3291 set_vaxc_errno(sts);
3295 set_errno(ENOENT); break;
3297 set_errno(ENODEV); break;
3299 set_errno(EINVAL); break;
3301 set_errno(EACCES); break;
3309 fab_out.fab$w_ifi = 0;
3310 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
3311 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
3312 fab_out.fab$l_fop = FAB$M_SQO;
3313 fab_out.fab$l_fna = vmsout;
3314 fab_out.fab$b_fns = strlen(vmsout);
3315 fab_out.fab$l_dna = nam.nam$l_name;
3316 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
3318 if (preserve_dates == 0) { /* Act like DCL COPY */
3319 nam.nam$b_nop = NAM$M_SYNCHK;
3320 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
3321 if (!((sts = sys$parse(&fab_out)) & 1)) {
3322 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
3323 set_vaxc_errno(sts);
3326 fab_out.fab$l_xab = (void *) &xabdat;
3327 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
3329 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
3330 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
3331 preserve_dates =0; /* bitmask from this point forward */
3333 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
3334 if (!((sts = sys$create(&fab_out)) & 1)) {
3335 set_vaxc_errno(sts);
3338 set_errno(ENOENT); break;
3340 set_errno(ENODEV); break;
3342 set_errno(EINVAL); break;
3344 set_errno(EACCES); break;
3350 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
3351 if (preserve_dates & 2) {
3352 /* sys$close() will process xabrdt, not xabdat */
3353 xabrdt = cc$rms_xabrdt;
3354 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
3355 fab_out.fab$l_xab = (void *) &xabrdt;
3358 rab_in = cc$rms_rab;
3359 rab_in.rab$l_fab = &fab_in;
3360 rab_in.rab$l_rop = RAB$M_BIO;
3361 rab_in.rab$l_ubf = ubf;
3362 rab_in.rab$w_usz = sizeof ubf;
3363 if (!((sts = sys$connect(&rab_in)) & 1)) {
3364 sys$close(&fab_in); sys$close(&fab_out);
3365 set_errno(EVMSERR); set_vaxc_errno(sts);
3369 rab_out = cc$rms_rab;
3370 rab_out.rab$l_fab = &fab_out;
3371 rab_out.rab$l_rbf = ubf;
3372 if (!((sts = sys$connect(&rab_out)) & 1)) {
3373 sys$close(&fab_in); sys$close(&fab_out);
3374 set_errno(EVMSERR); set_vaxc_errno(sts);
3378 while ((sts = sys$read(&rab_in))) { /* always true */
3379 if (sts == RMS$_EOF) break;
3380 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
3381 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
3382 sys$close(&fab_in); sys$close(&fab_out);
3383 set_errno(EVMSERR); set_vaxc_errno(sts);
3388 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
3389 sys$close(&fab_in); sys$close(&fab_out);
3390 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
3392 set_errno(EVMSERR); set_vaxc_errno(sts);
3398 } /* end of rmscopy() */
3402 /*** The following glue provides 'hooks' to make some of the routines
3403 * from this file available from Perl. These routines are sufficiently
3404 * basic, and are required sufficiently early in the build process,
3405 * that's it's nice to have them available to miniperl as well as the
3406 * full Perl, so they're set up here instead of in an extension. The
3407 * Perl code which handles importation of these names into a given
3408 * package lives in [.VMS]Filespec.pm in @INC.
3412 rmsexpand_fromperl(CV *cv)
3415 char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
3416 struct FAB myfab = cc$rms_fab;
3417 struct NAM mynam = cc$rms_nam;
3419 unsigned long int retsts, haslower = 0;
3421 myfab.fab$l_fna = SvPV(ST(0),speclen);
3422 myfab.fab$b_fns = speclen;
3423 myfab.fab$l_nam = &mynam;
3425 mynam.nam$l_esa = esa;
3426 mynam.nam$b_ess = sizeof esa;
3427 mynam.nam$l_rsa = rsa;
3428 mynam.nam$b_rss = sizeof rsa;
3430 retsts = sys$parse(&myfab,0,0);
3431 if (!(retsts & 1)) {
3432 set_vaxc_errno(retsts);
3433 if (retsts == RMS$_PRV) set_errno(EACCES);
3434 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3435 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3436 else set_errno(EVMSERR);
3439 retsts = sys$search(&myfab,0,0);
3440 if (!(retsts & 1) && retsts != RMS$_FNF) {
3441 set_vaxc_errno(retsts);
3442 if (retsts == RMS$_PRV) set_errno(EACCES);
3443 else set_errno(EVMSERR);
3446 /* If the input filespec contained any lowercase characters,
3447 * downcase the result for compatibility with Unix-minded code. */
3448 for (out = myfab.fab$l_fna; *out; out++)
3449 if (islower(*out)) { haslower = 1; break; }
3450 if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
3451 else { out = esa; speclen = mynam.nam$b_esl; }
3452 if (!(mynam.nam$l_fnb & NAM$M_EXP_VER))
3453 speclen = mynam.nam$l_type - out;
3454 out[speclen] = '\0';
3455 if (haslower) __mystrtolower(out);
3457 ST(0) = sv_2mortal(newSVpv(out, speclen));
3461 vmsify_fromperl(CV *cv)
3466 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
3467 vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
3468 ST(0) = sv_newmortal();
3469 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
3474 unixify_fromperl(CV *cv)
3479 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
3480 unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
3481 ST(0) = sv_newmortal();
3482 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
3487 fileify_fromperl(CV *cv)
3492 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
3493 fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
3494 ST(0) = sv_newmortal();
3495 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
3500 pathify_fromperl(CV *cv)
3505 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
3506 pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
3507 ST(0) = sv_newmortal();
3508 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
3513 vmspath_fromperl(CV *cv)
3518 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
3519 vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
3520 ST(0) = sv_newmortal();
3521 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
3526 unixpath_fromperl(CV *cv)
3531 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
3532 unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
3533 ST(0) = sv_newmortal();
3534 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
3539 candelete_fromperl(CV *cv)
3542 char fspec[NAM$C_MAXRSS+1], *fsp;
3546 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
3548 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3549 if (SvTYPE(mysv) == SVt_PVGV) {
3550 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) {
3551 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3558 if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) {
3559 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3565 ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
3570 rmscopy_fromperl(CV *cv)
3573 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
3575 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
3576 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3577 unsigned long int sts;
3581 if (items < 2 || items > 3)
3582 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
3584 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
3585 if (SvTYPE(mysv) == SVt_PVGV) {
3586 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) {
3587 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3594 if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) {
3595 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3600 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3601 if (SvTYPE(mysv) == SVt_PVGV) {
3602 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) {
3603 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3610 if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) {
3611 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3616 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
3618 ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
3625 char* file = __FILE__;
3627 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$");
3628 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
3629 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
3630 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
3631 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
3632 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
3633 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
3634 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
3635 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);