3 * VMS-specific routines for perl5
5 * Last revised: 24-Apr-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
24 #include <libclidef.h>
26 #include <lib$routines.h>
35 #include <str$routines.h>
40 /* Older versions of ssdef.h don't have these */
41 #ifndef SS$_INVFILFOROP
42 # define SS$_INVFILFOROP 3930
44 #ifndef SS$_NOSUCHOBJECT
45 # define SS$_NOSUCHOBJECT 2696
48 /* Don't replace system definitions of vfork, getenv, and stat,
49 * code below needs to get to the underlying CRTL routines. */
50 #define DONT_MASK_RTL_CALLS
54 /* Anticipating future expansion in lexical warnings . . . */
56 # define WARN_INTERNAL WARN_MISC
59 /* gcc's header files don't #define direct access macros
60 * corresponding to VAXC's variant structs */
62 # define uic$v_format uic$r_uic_form.uic$v_format
63 # define uic$v_group uic$r_uic_form.uic$v_group
64 # define uic$v_member uic$r_uic_form.uic$v_member
65 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
66 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
67 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
68 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
73 unsigned short int buflen;
74 unsigned short int itmcode;
76 unsigned short int *retlen;
79 static char *__mystrtolower(char *str)
81 if (str) for (; *str; ++str) *str= tolower(*str);
85 static struct dsc$descriptor_s fildevdsc =
86 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
87 static struct dsc$descriptor_s crtlenvdsc =
88 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
89 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
90 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
91 static struct dsc$descriptor_s **env_tables = defenv;
92 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
94 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
96 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
97 struct dsc$descriptor_s **tabvec, unsigned long int flags)
99 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
100 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
101 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
102 unsigned char acmode;
103 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
104 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
105 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
106 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
108 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
110 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
111 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
113 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
114 *cp2 = _toupper(*cp1);
115 if (cp1 - lnm > LNM$C_NAMLENGTH) {
116 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
120 lnmdsc.dsc$w_length = cp1 - lnm;
121 lnmdsc.dsc$a_pointer = uplnm;
122 secure = flags & PERL__TRNENV_SECURE;
123 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
124 if (!tabvec || !*tabvec) tabvec = env_tables;
126 for (curtab = 0; tabvec[curtab]; curtab++) {
127 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
128 if (!ivenv && !secure) {
133 warn("Can't read CRTL environ\n");
136 retsts = SS$_NOLOGNAM;
137 for (i = 0; environ[i]; i++) {
138 if ((eq = strchr(environ[i],'=')) &&
139 !strncmp(environ[i],uplnm,eq - environ[i])) {
141 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
142 if (!eqvlen) continue;
147 if (retsts != SS$_NOLOGNAM) break;
150 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
151 !str$case_blind_compare(&tmpdsc,&clisym)) {
152 if (!ivsym && !secure) {
153 unsigned short int deflen = LNM$C_NAMLENGTH;
154 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
155 /* dynamic dsc to accomodate possible long value */
156 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
157 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
160 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
162 if (ckWARN(WARN_MISC))
163 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
165 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
167 _ckvmssts(lib$sfree1_dd(&eqvdsc));
168 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
169 if (retsts == LIB$_NOSUCHSYM) continue;
174 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
175 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
176 if (retsts == SS$_NOLOGNAM) continue;
180 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
181 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
182 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
183 retsts == SS$_NOLOGNAM) {
184 set_errno(EINVAL); set_vaxc_errno(retsts);
186 else _ckvmssts(retsts);
188 } /* end of vmstrnenv */
192 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
193 /* Define as a function so we can access statics. */
194 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
196 return vmstrnenv(lnm,eqv,idx,fildev,
197 #ifdef SECURE_INTERNAL_GETENV
198 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
207 * Note: Uses Perl temp to store result so char * can be returned to
208 * caller; this pointer will be invalidated at next Perl statement
210 * We define this as a function rather than a macro in terms of my_getenv_len()
211 * so that it'll work when PL_curinterp is undefined (and we therefore can't
214 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
216 my_getenv(const char *lnm, bool sys)
218 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
219 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
220 unsigned long int idx = 0;
224 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
225 /* Set up a temporary buffer for the return value; Perl will
226 * clean it up at the next statement transition */
227 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
228 if (!tmpsv) return NULL;
231 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
232 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
233 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
234 getcwd(eqv,LNM$C_NAMLENGTH);
238 if ((cp2 = strchr(lnm,';')) != NULL) {
240 uplnm[cp2-lnm] = '\0';
241 idx = strtoul(cp2+1,NULL,0);
244 if (vmstrnenv(lnm,eqv,idx,
246 #ifdef SECURE_INTERNAL_GETENV
247 sys ? PERL__TRNENV_SECURE : 0
255 } /* end of my_getenv() */
259 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
261 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
263 char buf[LNM$C_NAMLENGTH+1], *cp1, *cp2;
264 unsigned long idx = 0;
266 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
267 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
268 getcwd(buf,LNM$C_NAMLENGTH);
273 if ((cp2 = strchr(lnm,';')) != NULL) {
276 idx = strtoul(cp2+1,NULL,0);
279 if ((*len = vmstrnenv(lnm,buf,idx,
281 #ifdef SECURE_INTERNAL_GETENV
282 sys ? PERL__TRNENV_SECURE : 0
291 } /* end of my_getenv_len() */
294 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
296 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
298 /*{{{ void prime_env_iter() */
301 /* Fill the %ENV associative array with all logical names we can
302 * find, in preparation for iterating over it.
306 static int primed = 0;
307 HV *seenhv = NULL, *envhv;
308 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
309 unsigned short int chan;
310 #ifndef CLI$M_TRUSTED
311 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
313 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
314 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
316 bool have_sym = FALSE, have_lnm = FALSE;
317 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
318 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
319 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
320 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
321 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
323 static perl_mutex primenv_mutex;
324 MUTEX_INIT(&primenv_mutex);
327 if (primed || !PL_envgv) return;
328 MUTEX_LOCK(&primenv_mutex);
329 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
330 envhv = GvHVn(PL_envgv);
331 /* Perform a dummy fetch as an lval to insure that the hash table is
332 * set up. Otherwise, the hv_store() will turn into a nullop. */
333 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
335 for (i = 0; env_tables[i]; i++) {
336 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
337 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
338 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
340 if (have_sym || have_lnm) {
341 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
342 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
343 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
344 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
347 for (i--; i >= 0; i--) {
348 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
351 for (j = 0; environ[j]; j++) {
352 if (!(start = strchr(environ[j],'='))) {
353 if (ckWARN(WARN_INTERNAL))
354 warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
358 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
364 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
365 !str$case_blind_compare(&tmpdsc,&clisym)) {
366 strcpy(cmd,"Show Symbol/Global *");
367 cmddsc.dsc$w_length = 20;
368 if (env_tables[i]->dsc$w_length == 12 &&
369 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
370 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
371 flags = defflags | CLI$M_NOLOGNAM;
374 strcpy(cmd,"Show Logical *");
375 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
376 strcat(cmd," /Table=");
377 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
378 cmddsc.dsc$w_length = strlen(cmd);
380 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
381 flags = defflags | CLI$M_NOCLISYM;
384 /* Create a new subprocess to execute each command, to exclude the
385 * remote possibility that someone could subvert a mbx or file used
386 * to write multiple commands to a single subprocess.
389 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
390 0,&riseandshine,0,0,&clidsc,&clitabdsc);
391 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
392 defflags &= ~CLI$M_TRUSTED;
393 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
395 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
396 if (seenhv) SvREFCNT_dec(seenhv);
399 char *cp1, *cp2, *key;
400 unsigned long int sts, iosb[2], retlen, keylen;
403 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
404 if (sts & 1) sts = iosb[0] & 0xffff;
405 if (sts == SS$_ENDOFFILE) {
407 while (substs == 0) { sys$hiber(); wakect++;}
408 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
413 retlen = iosb[0] >> 16;
414 if (!retlen) continue; /* blank line */
416 if (iosb[1] != subpid) {
418 croak("Unknown process %x sent message to prime_env_iter: %s",buf);
422 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
423 warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
425 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
426 if (*cp1 == '(' || /* Logical name table name */
427 *cp1 == '=' /* Next eqv of searchlist */) continue;
428 if (*cp1 == '"') cp1++;
429 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
430 key = cp1; keylen = cp2 - cp1;
431 if (keylen && hv_exists(seenhv,key,keylen)) continue;
432 while (*cp2 && *cp2 != '=') cp2++;
433 while (*cp2 && *cp2 != '"') cp2++;
434 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
435 if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) {
436 warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
439 /* Skip "" surrounding translation */
440 PERL_HASH(hash,key,keylen);
441 hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
442 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
444 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
445 /* get the PPFs for this process, not the subprocess */
446 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
447 char eqv[LNM$C_NAMLENGTH+1];
449 for (i = 0; ppfs[i]; i++) {
450 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
451 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
456 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
457 if (buf) Safefree(buf);
458 if (seenhv) SvREFCNT_dec(seenhv);
459 MUTEX_UNLOCK(&primenv_mutex);
462 } /* end of prime_env_iter */
466 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
467 /* Define or delete an element in the same "environment" as
468 * vmstrnenv(). If an element is to be deleted, it's removed from
469 * the first place it's found. If it's to be set, it's set in the
470 * place designated by the first element of the table vector.
471 * Like setenv() returns 0 for success, non-zero on error.
474 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
476 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
477 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
478 unsigned long int retsts, usermode = PSL$C_USER;
479 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
480 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
481 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
482 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
483 $DESCRIPTOR(local,"_LOCAL");
485 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
486 *cp2 = _toupper(*cp1);
487 if (cp1 - lnm > LNM$C_NAMLENGTH) {
488 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
492 lnmdsc.dsc$w_length = cp1 - lnm;
493 if (!tabvec || !*tabvec) tabvec = env_tables;
495 if (!eqv) { /* we're deleting n element */
496 for (curtab = 0; tabvec[curtab]; curtab++) {
497 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
499 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
500 if ((cp1 = strchr(environ[i],'=')) &&
501 !strncmp(environ[i],lnm,cp1 - environ[i])) {
503 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
506 ivenv = 1; retsts = SS$_NOLOGNAM;
508 if (ckWARN(WARN_INTERNAL))
509 warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
510 ivenv = 1; retsts = SS$_NOSUCHPGM;
516 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
517 !str$case_blind_compare(&tmpdsc,&clisym)) {
518 unsigned int symtype;
519 if (tabvec[curtab]->dsc$w_length == 12 &&
520 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
521 !str$case_blind_compare(&tmpdsc,&local))
522 symtype = LIB$K_CLI_LOCAL_SYM;
523 else symtype = LIB$K_CLI_GLOBAL_SYM;
524 retsts = lib$delete_symbol(&lnmdsc,&symtype);
525 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
526 if (retsts == LIB$_NOSUCHSYM) continue;
530 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
531 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
532 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
533 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
534 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
538 else { /* we're defining a value */
539 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
541 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
543 if (ckWARN(WARN_INTERNAL))
544 warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
545 retsts = SS$_NOSUCHPGM;
549 eqvdsc.dsc$a_pointer = eqv;
550 eqvdsc.dsc$w_length = strlen(eqv);
551 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
552 !str$case_blind_compare(&tmpdsc,&clisym)) {
553 unsigned int symtype;
554 if (tabvec[0]->dsc$w_length == 12 &&
555 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
556 !str$case_blind_compare(&tmpdsc,&local))
557 symtype = LIB$K_CLI_LOCAL_SYM;
558 else symtype = LIB$K_CLI_GLOBAL_SYM;
559 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
562 if (!*eqv) eqvdsc.dsc$w_length = 1;
563 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
569 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
570 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
571 set_errno(EVMSERR); break;
572 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
573 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
574 set_errno(EINVAL); break;
581 set_vaxc_errno(retsts);
582 return (int) retsts || 44; /* retsts should never be 0, but just in case */
585 /* We reset error values on success because Perl does an hv_fetch()
586 * before each hv_store(), and if the thing we're setting didn't
587 * previously exist, we've got a leftover error message. (Of course,
588 * this fails in the face of
589 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
590 * in that the error reported in $! isn't spurious,
591 * but it's right more often than not.)
593 set_errno(0); set_vaxc_errno(retsts);
597 } /* end of vmssetenv() */
600 /*{{{ void my_setenv(char *lnm, char *eqv)*/
601 /* This has to be a function since there's a prototype for it in proto.h */
603 my_setenv(char *lnm,char *eqv)
605 if (lnm && *lnm && strlen(lnm) == 7) {
608 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
609 if (!strcmp(uplnm,"DEFAULT")) {
610 if (eqv && *eqv) chdir(eqv);
614 (void) vmssetenv(lnm,eqv,NULL);
620 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
621 /* my_crypt - VMS password hashing
622 * my_crypt() provides an interface compatible with the Unix crypt()
623 * C library function, and uses sys$hash_password() to perform VMS
624 * password hashing. The quadword hashed password value is returned
625 * as a NUL-terminated 8 character string. my_crypt() does not change
626 * the case of its string arguments; in order to match the behavior
627 * of LOGINOUT et al., alphabetic characters in both arguments must
628 * be upcased by the caller.
631 my_crypt(const char *textpasswd, const char *usrname)
633 # ifndef UAI$C_PREFERRED_ALGORITHM
634 # define UAI$C_PREFERRED_ALGORITHM 127
636 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
637 unsigned short int salt = 0;
638 unsigned long int sts;
640 unsigned short int dsc$w_length;
641 unsigned char dsc$b_type;
642 unsigned char dsc$b_class;
643 const char * dsc$a_pointer;
644 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
645 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
646 struct itmlst_3 uailst[3] = {
647 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
648 { sizeof salt, UAI$_SALT, &salt, 0},
649 { 0, 0, NULL, NULL}};
652 usrdsc.dsc$w_length = strlen(usrname);
653 usrdsc.dsc$a_pointer = usrname;
654 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
661 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
667 if (sts != RMS$_RNF) return NULL;
670 txtdsc.dsc$w_length = strlen(textpasswd);
671 txtdsc.dsc$a_pointer = textpasswd;
672 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
673 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
676 return (char *) hash;
678 } /* end of my_crypt() */
682 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
683 static char *do_fileify_dirspec(char *, char *, int);
684 static char *do_tovmsspec(char *, char *, int);
686 /*{{{int do_rmdir(char *name)*/
690 char dirfile[NAM$C_MAXRSS+1];
694 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
695 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
696 else retval = kill_file(dirfile);
699 } /* end of do_rmdir */
703 * Delete any file to which user has control access, regardless of whether
704 * delete access is explicitly allowed.
705 * Limitations: User must have write access to parent directory.
706 * Does not block signals or ASTs; if interrupted in midstream
707 * may leave file with an altered ACL.
710 /*{{{int kill_file(char *name)*/
712 kill_file(char *name)
714 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
715 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
716 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
717 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
719 unsigned char myace$b_length;
720 unsigned char myace$b_type;
721 unsigned short int myace$w_flags;
722 unsigned long int myace$l_access;
723 unsigned long int myace$l_ident;
724 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
725 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
726 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
728 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
729 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
730 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
731 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
732 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
733 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
735 /* Expand the input spec using RMS, since the CRTL remove() and
736 * system services won't do this by themselves, so we may miss
737 * a file "hiding" behind a logical name or search list. */
738 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
739 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
740 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
741 /* If not, can changing protections help? */
742 if (vaxc$errno != RMS$_PRV) return -1;
744 /* No, so we get our own UIC to use as a rights identifier,
745 * and the insert an ACE at the head of the ACL which allows us
746 * to delete the file.
748 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
749 fildsc.dsc$w_length = strlen(rspec);
750 fildsc.dsc$a_pointer = rspec;
752 newace.myace$l_ident = oldace.myace$l_ident;
753 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
758 case SS$_NOSUCHOBJECT:
759 set_errno(ENOENT); break;
761 set_errno(ENODEV); break;
763 case SS$_INVFILFOROP:
764 set_errno(EINVAL); break;
766 set_errno(EACCES); break;
770 set_vaxc_errno(aclsts);
773 /* Grab any existing ACEs with this identifier in case we fail */
774 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
775 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
776 || fndsts == SS$_NOMOREACE ) {
777 /* Add the new ACE . . . */
778 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
780 if ((rmsts = remove(name))) {
781 /* We blew it - dir with files in it, no write priv for
782 * parent directory, etc. Put things back the way they were. */
783 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
786 addlst[0].bufadr = &oldace;
787 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
794 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
795 /* We just deleted it, so of course it's not there. Some versions of
796 * VMS seem to return success on the unlock operation anyhow (after all
797 * the unlock is successful), but others don't.
799 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
800 if (aclsts & 1) aclsts = fndsts;
803 set_vaxc_errno(aclsts);
809 } /* end of kill_file() */
813 /*{{{int my_mkdir(char *,Mode_t)*/
815 my_mkdir(char *dir, Mode_t mode)
817 STRLEN dirlen = strlen(dir);
819 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
820 * null file name/type. However, it's commonplace under Unix,
821 * so we'll allow it for a gain in portability.
823 if (dir[dirlen-1] == '/') {
824 char *newdir = savepvn(dir,dirlen-1);
825 int ret = mkdir(newdir,mode);
829 else return mkdir(dir,mode);
830 } /* end of my_mkdir */
835 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
837 static unsigned long int mbxbufsiz;
838 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
842 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
843 * preprocessor consant BUFSIZ from stdio.h as the size of the
846 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
847 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
849 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
851 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
852 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
854 } /* end of create_mbx() */
856 /*{{{ my_popen and my_pclose*/
859 struct pipe_details *next;
860 PerlIO *fp; /* stdio file pointer to pipe mailbox */
861 int pid; /* PID of subprocess */
862 int mode; /* == 'r' if pipe open for reading */
863 int done; /* subprocess has completed */
864 unsigned long int completion; /* termination status of subprocess */
867 struct exit_control_block
869 struct exit_control_block *flink;
870 unsigned long int (*exit_routine)();
871 unsigned long int arg_count;
872 unsigned long int *status_address;
873 unsigned long int exit_status;
876 static struct pipe_details *open_pipes = NULL;
877 static $DESCRIPTOR(nl_desc, "NL:");
878 static int waitpid_asleep = 0;
880 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
881 * to a mbx; that's the caller's responsibility.
883 static unsigned long int
886 char devnam[NAM$C_MAXRSS+1], *cp;
887 unsigned long int chan, iosb[2], retsts, retsts2;
888 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
890 if (fgetname(fp,devnam,1)) {
891 /* It oughta be a mailbox, so fgetname should give just the device
892 * name, but just in case . . . */
893 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
894 devdsc.dsc$w_length = strlen(devnam);
895 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
896 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
897 if (retsts & 1) retsts = iosb[0];
898 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
899 if (retsts & 1) retsts = retsts2;
903 else _ckvmssts(vaxc$errno); /* Should never happen */
904 return (unsigned long int) vaxc$errno;
907 static unsigned long int
910 struct pipe_details *info;
911 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
915 first we try sending an EOF...ignore if doesn't work, make sure we
922 if (info->mode != 'r' && !info->done) {
923 if (pipe_eof(info->fp) & 1) did_stuff = 1;
927 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
932 if (!info->done) { /* Tap them gently on the shoulder . . .*/
933 sts = sys$forcex(&info->pid,0,&abort);
934 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
939 if (did_stuff) sleep(1); /* wait for them to respond */
943 if (!info->done) { /* We tried to be nice . . . */
944 sts = sys$delprc(&info->pid,0);
945 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
946 info->done = 1; /* so my_pclose doesn't try to write EOF */
952 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
953 else if (!(sts & 1)) retsts = sts;
958 static struct exit_control_block pipe_exitblock =
959 {(struct exit_control_block *) 0,
960 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
964 popen_completion_ast(struct pipe_details *thispipe)
966 thispipe->done = TRUE;
967 if (waitpid_asleep) {
974 safe_popen(char *cmd, char *mode)
976 static int handler_set_up = FALSE;
978 unsigned short int chan;
979 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
980 struct pipe_details *info;
981 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
982 DSC$K_CLASS_S, mbxname},
983 cmddsc = {0, DSC$K_DTYPE_T,
987 cmddsc.dsc$w_length=strlen(cmd);
988 cmddsc.dsc$a_pointer=cmd;
989 if (cmddsc.dsc$w_length > 255) {
990 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
994 New(1301,info,1,struct pipe_details);
997 create_mbx(&chan,&namdsc);
999 /* open a FILE* onto it */
1000 info->fp = PerlIO_open(mbxname, mode);
1002 /* give up other channel onto it */
1003 _ckvmssts(sys$dassgn(chan));
1013 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1014 0 /* name */, &info->pid, &info->completion,
1015 0, popen_completion_ast,info,0,0,0));
1018 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1019 0 /* name */, &info->pid, &info->completion,
1020 0, popen_completion_ast,info,0,0,0));
1023 if (!handler_set_up) {
1024 _ckvmssts(sys$dclexh(&pipe_exitblock));
1025 handler_set_up = TRUE;
1027 info->next=open_pipes; /* prepend to list */
1030 PL_forkprocess = info->pid;
1032 } /* end of safe_popen */
1035 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1037 my_popen(char *cmd, char *mode)
1040 TAINT_PROPER("popen");
1041 PERL_FLUSHALL_FOR_CHILD;
1042 return safe_popen(cmd,mode);
1047 /*{{{ I32 my_pclose(FILE *fp)*/
1048 I32 my_pclose(FILE *fp)
1050 struct pipe_details *info, *last = NULL;
1051 unsigned long int retsts;
1053 for (info = open_pipes; info != NULL; last = info, info = info->next)
1054 if (info->fp == fp) break;
1056 if (info == NULL) { /* no such pipe open */
1057 set_errno(ECHILD); /* quoth POSIX */
1058 set_vaxc_errno(SS$_NONEXPR);
1062 /* If we were writing to a subprocess, insure that someone reading from
1063 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1064 * produce an EOF record in the mailbox. */
1065 if (info->mode != 'r' && !info->done) pipe_eof(info->fp);
1066 PerlIO_close(info->fp);
1068 if (info->done) retsts = info->completion;
1069 else waitpid(info->pid,(int *) &retsts,0);
1071 /* remove from list of open pipes */
1072 if (last) last->next = info->next;
1073 else open_pipes = info->next;
1078 } /* end of my_pclose() */
1080 /* sort-of waitpid; use only with popen() */
1081 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1083 my_waitpid(Pid_t pid, int *statusp, int flags)
1085 struct pipe_details *info;
1087 for (info = open_pipes; info != NULL; info = info->next)
1088 if (info->pid == pid) break;
1090 if (info != NULL) { /* we know about this child */
1091 while (!info->done) {
1096 *statusp = info->completion;
1099 else { /* we haven't heard of this child */
1100 $DESCRIPTOR(intdsc,"0 00:00:01");
1101 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1102 unsigned long int interval[2],sts;
1104 if (ckWARN(WARN_EXEC)) {
1105 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1106 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1107 if (ownerpid != mypid)
1108 warner(WARN_EXEC,"pid %x not a child",pid);
1111 _ckvmssts(sys$bintim(&intdsc,interval));
1112 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1113 _ckvmssts(sys$schdwk(0,0,interval,0));
1114 _ckvmssts(sys$hiber());
1118 /* There's no easy way to find the termination status a child we're
1119 * not aware of beforehand. If we're really interested in the future,
1120 * we can go looking for a termination mailbox, or chase after the
1121 * accounting record for the process.
1127 } /* end of waitpid() */
1132 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1134 my_gconvert(double val, int ndig, int trail, char *buf)
1136 static char __gcvtbuf[DBL_DIG+1];
1139 loc = buf ? buf : __gcvtbuf;
1141 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1143 sprintf(loc,"%.*g",ndig,val);
1149 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1150 return gcvt(val,ndig,loc);
1153 loc[0] = '0'; loc[1] = '\0';
1161 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1162 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1163 * to expand file specification. Allows for a single default file
1164 * specification and a simple mask of options. If outbuf is non-NULL,
1165 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1166 * the resultant file specification is placed. If outbuf is NULL, the
1167 * resultant file specification is placed into a static buffer.
1168 * The third argument, if non-NULL, is taken to be a default file
1169 * specification string. The fourth argument is unused at present.
1170 * rmesexpand() returns the address of the resultant string if
1171 * successful, and NULL on error.
1173 static char *do_tounixspec(char *, char *, int);
1176 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1178 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1179 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1180 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1181 struct FAB myfab = cc$rms_fab;
1182 struct NAM mynam = cc$rms_nam;
1184 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1186 if (!filespec || !*filespec) {
1187 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1191 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1192 else outbuf = __rmsexpand_retbuf;
1194 if ((isunix = (strchr(filespec,'/') != NULL))) {
1195 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1196 filespec = vmsfspec;
1199 myfab.fab$l_fna = filespec;
1200 myfab.fab$b_fns = strlen(filespec);
1201 myfab.fab$l_nam = &mynam;
1203 if (defspec && *defspec) {
1204 if (strchr(defspec,'/') != NULL) {
1205 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1208 myfab.fab$l_dna = defspec;
1209 myfab.fab$b_dns = strlen(defspec);
1212 mynam.nam$l_esa = esa;
1213 mynam.nam$b_ess = sizeof esa;
1214 mynam.nam$l_rsa = outbuf;
1215 mynam.nam$b_rss = NAM$C_MAXRSS;
1217 retsts = sys$parse(&myfab,0,0);
1218 if (!(retsts & 1)) {
1219 mynam.nam$b_nop |= NAM$M_SYNCHK;
1220 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1221 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1222 retsts = sys$parse(&myfab,0,0);
1223 if (retsts & 1) goto expanded;
1225 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1226 (void) sys$parse(&myfab,0,0); /* Free search context */
1227 if (out) Safefree(out);
1228 set_vaxc_errno(retsts);
1229 if (retsts == RMS$_PRV) set_errno(EACCES);
1230 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1231 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1232 else set_errno(EVMSERR);
1235 retsts = sys$search(&myfab,0,0);
1236 if (!(retsts & 1) && retsts != RMS$_FNF) {
1237 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1238 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1239 if (out) Safefree(out);
1240 set_vaxc_errno(retsts);
1241 if (retsts == RMS$_PRV) set_errno(EACCES);
1242 else set_errno(EVMSERR);
1246 /* If the input filespec contained any lowercase characters,
1247 * downcase the result for compatibility with Unix-minded code. */
1249 for (out = myfab.fab$l_fna; *out; out++)
1250 if (islower(*out)) { haslower = 1; break; }
1251 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1252 else { out = esa; speclen = mynam.nam$b_esl; }
1253 /* Trim off null fields added by $PARSE
1254 * If type > 1 char, must have been specified in original or default spec
1255 * (not true for version; $SEARCH may have added version of existing file).
1257 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1258 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1259 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1260 if (trimver || trimtype) {
1261 if (defspec && *defspec) {
1262 char defesa[NAM$C_MAXRSS];
1263 struct FAB deffab = cc$rms_fab;
1264 struct NAM defnam = cc$rms_nam;
1266 deffab.fab$l_nam = &defnam;
1267 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1268 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1269 defnam.nam$b_nop = NAM$M_SYNCHK;
1270 if (sys$parse(&deffab,0,0) & 1) {
1271 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1272 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1275 if (trimver) speclen = mynam.nam$l_ver - out;
1277 /* If we didn't already trim version, copy down */
1278 if (speclen > mynam.nam$l_ver - out)
1279 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1280 speclen - (mynam.nam$l_ver - out));
1281 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1284 /* If we just had a directory spec on input, $PARSE "helpfully"
1285 * adds an empty name and type for us */
1286 if (mynam.nam$l_name == mynam.nam$l_type &&
1287 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1288 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1289 speclen = mynam.nam$l_name - out;
1290 out[speclen] = '\0';
1291 if (haslower) __mystrtolower(out);
1293 /* Have we been working with an expanded, but not resultant, spec? */
1294 /* Also, convert back to Unix syntax if necessary. */
1295 if (!mynam.nam$b_rsl) {
1297 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1299 else strcpy(outbuf,esa);
1302 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1303 strcpy(outbuf,tmpfspec);
1305 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1306 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1307 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1311 /* External entry points */
1312 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1313 { return do_rmsexpand(spec,buf,0,def,opt); }
1314 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1315 { return do_rmsexpand(spec,buf,1,def,opt); }
1319 ** The following routines are provided to make life easier when
1320 ** converting among VMS-style and Unix-style directory specifications.
1321 ** All will take input specifications in either VMS or Unix syntax. On
1322 ** failure, all return NULL. If successful, the routines listed below
1323 ** return a pointer to a buffer containing the appropriately
1324 ** reformatted spec (and, therefore, subsequent calls to that routine
1325 ** will clobber the result), while the routines of the same names with
1326 ** a _ts suffix appended will return a pointer to a mallocd string
1327 ** containing the appropriately reformatted spec.
1328 ** In all cases, only explicit syntax is altered; no check is made that
1329 ** the resulting string is valid or that the directory in question
1332 ** fileify_dirspec() - convert a directory spec into the name of the
1333 ** directory file (i.e. what you can stat() to see if it's a dir).
1334 ** The style (VMS or Unix) of the result is the same as the style
1335 ** of the parameter passed in.
1336 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1337 ** what you prepend to a filename to indicate what directory it's in).
1338 ** The style (VMS or Unix) of the result is the same as the style
1339 ** of the parameter passed in.
1340 ** tounixpath() - convert a directory spec into a Unix-style path.
1341 ** tovmspath() - convert a directory spec into a VMS-style path.
1342 ** tounixspec() - convert any file spec into a Unix-style file spec.
1343 ** tovmsspec() - convert any file spec into a VMS-style spec.
1345 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1346 ** Permission is given to distribute this code as part of the Perl
1347 ** standard distribution under the terms of the GNU General Public
1348 ** License or the Perl Artistic License. Copies of each may be
1349 ** found in the Perl standard distribution.
1352 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1353 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1355 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1356 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1357 char *retspec, *cp1, *cp2, *lastdir;
1358 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1360 if (!dir || !*dir) {
1361 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1363 dirlen = strlen(dir);
1364 while (dir[dirlen-1] == '/') --dirlen;
1365 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1366 strcpy(trndir,"/sys$disk/000000");
1370 if (dirlen > NAM$C_MAXRSS) {
1371 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1373 if (!strpbrk(dir+1,"/]>:")) {
1374 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1375 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1377 dirlen = strlen(dir);
1380 strncpy(trndir,dir,dirlen);
1381 trndir[dirlen] = '\0';
1384 /* If we were handed a rooted logical name or spec, treat it like a
1385 * simple directory, so that
1386 * $ Define myroot dev:[dir.]
1387 * ... do_fileify_dirspec("myroot",buf,1) ...
1388 * does something useful.
1390 if (!strcmp(dir+dirlen-2,".]")) {
1391 dir[--dirlen] = '\0';
1392 dir[dirlen-1] = ']';
1395 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1396 /* If we've got an explicit filename, we can just shuffle the string. */
1397 if (*(cp1+1)) hasfilename = 1;
1398 /* Similarly, we can just back up a level if we've got multiple levels
1399 of explicit directories in a VMS spec which ends with directories. */
1401 for (cp2 = cp1; cp2 > dir; cp2--) {
1403 *cp2 = *cp1; *cp1 = '\0';
1407 if (*cp2 == '[' || *cp2 == '<') break;
1412 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1413 if (dir[0] == '.') {
1414 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1415 return do_fileify_dirspec("[]",buf,ts);
1416 else if (dir[1] == '.' &&
1417 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1418 return do_fileify_dirspec("[-]",buf,ts);
1420 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1421 dirlen -= 1; /* to last element */
1422 lastdir = strrchr(dir,'/');
1424 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1425 /* If we have "/." or "/..", VMSify it and let the VMS code
1426 * below expand it, rather than repeating the code to handle
1427 * relative components of a filespec here */
1429 if (*(cp1+2) == '.') cp1++;
1430 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1431 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1432 if (strchr(vmsdir,'/') != NULL) {
1433 /* If do_tovmsspec() returned it, it must have VMS syntax
1434 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1435 * the time to check this here only so we avoid a recursion
1436 * loop; otherwise, gigo.
1438 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1440 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1441 return do_tounixspec(trndir,buf,ts);
1444 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1445 lastdir = strrchr(dir,'/');
1447 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1448 /* Ditto for specs that end in an MFD -- let the VMS code
1449 * figure out whether it's a real device or a rooted logical. */
1450 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1451 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1452 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1453 return do_tounixspec(trndir,buf,ts);
1456 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1457 !(lastdir = cp1 = strrchr(dir,']')) &&
1458 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1459 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1461 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1462 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1463 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1464 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1465 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1466 (ver || *cp3)))))) {
1468 set_vaxc_errno(RMS$_DIR);
1474 /* If we lead off with a device or rooted logical, add the MFD
1475 if we're specifying a top-level directory. */
1476 if (lastdir && *dir == '/') {
1478 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1485 retlen = dirlen + (addmfd ? 13 : 6);
1486 if (buf) retspec = buf;
1487 else if (ts) New(1309,retspec,retlen+1,char);
1488 else retspec = __fileify_retbuf;
1490 dirlen = lastdir - dir;
1491 memcpy(retspec,dir,dirlen);
1492 strcpy(&retspec[dirlen],"/000000");
1493 strcpy(&retspec[dirlen+7],lastdir);
1496 memcpy(retspec,dir,dirlen);
1497 retspec[dirlen] = '\0';
1499 /* We've picked up everything up to the directory file name.
1500 Now just add the type and version, and we're set. */
1501 strcat(retspec,".dir;1");
1504 else { /* VMS-style directory spec */
1505 char esa[NAM$C_MAXRSS+1], term, *cp;
1506 unsigned long int sts, cmplen, haslower = 0;
1507 struct FAB dirfab = cc$rms_fab;
1508 struct NAM savnam, dirnam = cc$rms_nam;
1510 dirfab.fab$b_fns = strlen(dir);
1511 dirfab.fab$l_fna = dir;
1512 dirfab.fab$l_nam = &dirnam;
1513 dirfab.fab$l_dna = ".DIR;1";
1514 dirfab.fab$b_dns = 6;
1515 dirnam.nam$b_ess = NAM$C_MAXRSS;
1516 dirnam.nam$l_esa = esa;
1518 for (cp = dir; *cp; cp++)
1519 if (islower(*cp)) { haslower = 1; break; }
1520 if (!((sts = sys$parse(&dirfab))&1)) {
1521 if (dirfab.fab$l_sts == RMS$_DIR) {
1522 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1523 sts = sys$parse(&dirfab) & 1;
1527 set_vaxc_errno(dirfab.fab$l_sts);
1533 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1534 /* Yes; fake the fnb bits so we'll check type below */
1535 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1538 if (dirfab.fab$l_sts != RMS$_FNF) {
1540 set_vaxc_errno(dirfab.fab$l_sts);
1543 dirnam = savnam; /* No; just work with potential name */
1546 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1547 cp1 = strchr(esa,']');
1548 if (!cp1) cp1 = strchr(esa,'>');
1549 if (cp1) { /* Should always be true */
1550 dirnam.nam$b_esl -= cp1 - esa - 1;
1551 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1554 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1555 /* Yep; check version while we're at it, if it's there. */
1556 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1557 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1558 /* Something other than .DIR[;1]. Bzzt. */
1560 set_vaxc_errno(RMS$_DIR);
1564 esa[dirnam.nam$b_esl] = '\0';
1565 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1566 /* They provided at least the name; we added the type, if necessary, */
1567 if (buf) retspec = buf; /* in sys$parse() */
1568 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1569 else retspec = __fileify_retbuf;
1570 strcpy(retspec,esa);
1573 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1574 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1576 dirnam.nam$b_esl -= 9;
1578 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1579 if (cp1 == NULL) return NULL; /* should never happen */
1582 retlen = strlen(esa);
1583 if ((cp1 = strrchr(esa,'.')) != NULL) {
1584 /* There's more than one directory in the path. Just roll back. */
1586 if (buf) retspec = buf;
1587 else if (ts) New(1311,retspec,retlen+7,char);
1588 else retspec = __fileify_retbuf;
1589 strcpy(retspec,esa);
1592 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1593 /* Go back and expand rooted logical name */
1594 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1595 if (!(sys$parse(&dirfab) & 1)) {
1597 set_vaxc_errno(dirfab.fab$l_sts);
1600 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1601 if (buf) retspec = buf;
1602 else if (ts) New(1312,retspec,retlen+16,char);
1603 else retspec = __fileify_retbuf;
1604 cp1 = strstr(esa,"][");
1606 memcpy(retspec,esa,dirlen);
1607 if (!strncmp(cp1+2,"000000]",7)) {
1608 retspec[dirlen-1] = '\0';
1609 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1610 if (*cp1 == '.') *cp1 = ']';
1612 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1613 memcpy(cp1+1,"000000]",7);
1617 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1618 retspec[retlen] = '\0';
1619 /* Convert last '.' to ']' */
1620 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1621 if (*cp1 == '.') *cp1 = ']';
1623 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1624 memcpy(cp1+1,"000000]",7);
1628 else { /* This is a top-level dir. Add the MFD to the path. */
1629 if (buf) retspec = buf;
1630 else if (ts) New(1312,retspec,retlen+16,char);
1631 else retspec = __fileify_retbuf;
1634 while (*cp1 != ':') *(cp2++) = *(cp1++);
1635 strcpy(cp2,":[000000]");
1640 /* We've set up the string up through the filename. Add the
1641 type and version, and we're done. */
1642 strcat(retspec,".DIR;1");
1644 /* $PARSE may have upcased filespec, so convert output to lower
1645 * case if input contained any lowercase characters. */
1646 if (haslower) __mystrtolower(retspec);
1649 } /* end of do_fileify_dirspec() */
1651 /* External entry points */
1652 char *fileify_dirspec(char *dir, char *buf)
1653 { return do_fileify_dirspec(dir,buf,0); }
1654 char *fileify_dirspec_ts(char *dir, char *buf)
1655 { return do_fileify_dirspec(dir,buf,1); }
1657 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1658 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1660 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1661 unsigned long int retlen;
1662 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1664 if (!dir || !*dir) {
1665 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1668 if (*dir) strcpy(trndir,dir);
1669 else getcwd(trndir,sizeof trndir - 1);
1671 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1672 STRLEN trnlen = strlen(trndir);
1674 /* Trap simple rooted lnms, and return lnm:[000000] */
1675 if (!strcmp(trndir+trnlen-2,".]")) {
1676 if (buf) retpath = buf;
1677 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1678 else retpath = __pathify_retbuf;
1679 strcpy(retpath,dir);
1680 strcat(retpath,":[000000]");
1686 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1687 if (*dir == '.' && (*(dir+1) == '\0' ||
1688 (*(dir+1) == '.' && *(dir+2) == '\0')))
1689 retlen = 2 + (*(dir+1) != '\0');
1691 if ( !(cp1 = strrchr(dir,'/')) &&
1692 !(cp1 = strrchr(dir,']')) &&
1693 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1694 if ((cp2 = strchr(cp1,'.')) != NULL &&
1695 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1696 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1697 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1698 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1700 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1701 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1702 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1703 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1704 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1705 (ver || *cp3)))))) {
1707 set_vaxc_errno(RMS$_DIR);
1710 retlen = cp2 - dir + 1;
1712 else { /* No file type present. Treat the filename as a directory. */
1713 retlen = strlen(dir) + 1;
1716 if (buf) retpath = buf;
1717 else if (ts) New(1313,retpath,retlen+1,char);
1718 else retpath = __pathify_retbuf;
1719 strncpy(retpath,dir,retlen-1);
1720 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1721 retpath[retlen-1] = '/'; /* with '/', add it. */
1722 retpath[retlen] = '\0';
1724 else retpath[retlen-1] = '\0';
1726 else { /* VMS-style directory spec */
1727 char esa[NAM$C_MAXRSS+1], *cp;
1728 unsigned long int sts, cmplen, haslower;
1729 struct FAB dirfab = cc$rms_fab;
1730 struct NAM savnam, dirnam = cc$rms_nam;
1732 /* If we've got an explicit filename, we can just shuffle the string. */
1733 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1734 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1735 if ((cp2 = strchr(cp1,'.')) != NULL) {
1737 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1738 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1739 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1740 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1741 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1742 (ver || *cp3)))))) {
1744 set_vaxc_errno(RMS$_DIR);
1748 else { /* No file type, so just draw name into directory part */
1749 for (cp2 = cp1; *cp2; cp2++) ;
1752 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1754 /* We've now got a VMS 'path'; fall through */
1756 dirfab.fab$b_fns = strlen(dir);
1757 dirfab.fab$l_fna = dir;
1758 if (dir[dirfab.fab$b_fns-1] == ']' ||
1759 dir[dirfab.fab$b_fns-1] == '>' ||
1760 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1761 if (buf) retpath = buf;
1762 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1763 else retpath = __pathify_retbuf;
1764 strcpy(retpath,dir);
1767 dirfab.fab$l_dna = ".DIR;1";
1768 dirfab.fab$b_dns = 6;
1769 dirfab.fab$l_nam = &dirnam;
1770 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1771 dirnam.nam$l_esa = esa;
1773 for (cp = dir; *cp; cp++)
1774 if (islower(*cp)) { haslower = 1; break; }
1776 if (!(sts = (sys$parse(&dirfab)&1))) {
1777 if (dirfab.fab$l_sts == RMS$_DIR) {
1778 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1779 sts = sys$parse(&dirfab) & 1;
1783 set_vaxc_errno(dirfab.fab$l_sts);
1789 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1790 if (dirfab.fab$l_sts != RMS$_FNF) {
1792 set_vaxc_errno(dirfab.fab$l_sts);
1795 dirnam = savnam; /* No; just work with potential name */
1798 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1799 /* Yep; check version while we're at it, if it's there. */
1800 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1801 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1802 /* Something other than .DIR[;1]. Bzzt. */
1804 set_vaxc_errno(RMS$_DIR);
1808 /* OK, the type was fine. Now pull any file name into the
1810 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1812 cp1 = strrchr(esa,'>');
1813 *dirnam.nam$l_type = '>';
1816 *(dirnam.nam$l_type + 1) = '\0';
1817 retlen = dirnam.nam$l_type - esa + 2;
1818 if (buf) retpath = buf;
1819 else if (ts) New(1314,retpath,retlen,char);
1820 else retpath = __pathify_retbuf;
1821 strcpy(retpath,esa);
1822 /* $PARSE may have upcased filespec, so convert output to lower
1823 * case if input contained any lowercase characters. */
1824 if (haslower) __mystrtolower(retpath);
1828 } /* end of do_pathify_dirspec() */
1830 /* External entry points */
1831 char *pathify_dirspec(char *dir, char *buf)
1832 { return do_pathify_dirspec(dir,buf,0); }
1833 char *pathify_dirspec_ts(char *dir, char *buf)
1834 { return do_pathify_dirspec(dir,buf,1); }
1836 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1837 static char *do_tounixspec(char *spec, char *buf, int ts)
1839 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1840 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1841 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1843 if (spec == NULL) return NULL;
1844 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1845 if (buf) rslt = buf;
1847 retlen = strlen(spec);
1848 cp1 = strchr(spec,'[');
1849 if (!cp1) cp1 = strchr(spec,'<');
1851 for (cp1++; *cp1; cp1++) {
1852 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1853 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1854 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1857 New(1315,rslt,retlen+2+2*expand,char);
1859 else rslt = __tounixspec_retbuf;
1860 if (strchr(spec,'/') != NULL) {
1867 dirend = strrchr(spec,']');
1868 if (dirend == NULL) dirend = strrchr(spec,'>');
1869 if (dirend == NULL) dirend = strchr(spec,':');
1870 if (dirend == NULL) {
1874 if (*cp2 != '[' && *cp2 != '<') {
1877 else { /* the VMS spec begins with directories */
1879 if (*cp2 == ']' || *cp2 == '>') {
1880 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1883 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1884 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1885 if (ts) Safefree(rslt);
1890 while (*cp3 != ':' && *cp3) cp3++;
1892 if (strchr(cp3,']') != NULL) break;
1893 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1895 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1896 retlen = devlen + dirlen;
1897 Renew(rslt,retlen+1+2*expand,char);
1903 *(cp1++) = *(cp3++);
1904 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1908 else if ( *cp2 == '.') {
1909 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1910 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1916 for (; cp2 <= dirend; cp2++) {
1919 if (*(cp2+1) == '[') cp2++;
1921 else if (*cp2 == ']' || *cp2 == '>') {
1922 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1924 else if (*cp2 == '.') {
1926 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1927 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1928 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1929 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1930 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1932 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1933 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1937 else if (*cp2 == '-') {
1938 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1939 while (*cp2 == '-') {
1941 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1943 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1944 if (ts) Safefree(rslt); /* filespecs like */
1945 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1949 else *(cp1++) = *cp2;
1951 else *(cp1++) = *cp2;
1953 while (*cp2) *(cp1++) = *(cp2++);
1958 } /* end of do_tounixspec() */
1960 /* External entry points */
1961 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1962 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
1964 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
1965 static char *do_tovmsspec(char *path, char *buf, int ts) {
1966 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
1967 char *rslt, *dirend;
1968 register char *cp1, *cp2;
1969 unsigned long int infront = 0, hasdir = 1;
1971 if (path == NULL) return NULL;
1972 if (buf) rslt = buf;
1973 else if (ts) New(1316,rslt,strlen(path)+9,char);
1974 else rslt = __tovmsspec_retbuf;
1975 if (strpbrk(path,"]:>") ||
1976 (dirend = strrchr(path,'/')) == NULL) {
1977 if (path[0] == '.') {
1978 if (path[1] == '\0') strcpy(rslt,"[]");
1979 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
1980 else strcpy(rslt,path); /* probably garbage */
1982 else strcpy(rslt,path);
1985 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
1986 if (!*(dirend+2)) dirend +=2;
1987 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
1988 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
1993 char trndev[NAM$C_MAXRSS+1];
1997 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
1999 if (!buf & ts) Renew(rslt,18,char);
2000 strcpy(rslt,"sys$disk:[000000]");
2003 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2005 islnm = my_trnlnm(rslt,trndev,0);
2006 trnend = islnm ? strlen(trndev) - 1 : 0;
2007 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2008 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2009 /* If the first element of the path is a logical name, determine
2010 * whether it has to be translated so we can add more directories. */
2011 if (!islnm || rooted) {
2014 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2018 if (cp2 != dirend) {
2019 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2020 strcpy(rslt,trndev);
2021 cp1 = rslt + trnend;
2034 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2035 cp2 += 2; /* skip over "./" - it's redundant */
2036 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2038 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2039 *(cp1++) = '-'; /* "../" --> "-" */
2042 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2043 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2044 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2045 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2048 if (cp2 > dirend) cp2 = dirend;
2050 else *(cp1++) = '.';
2052 for (; cp2 < dirend; cp2++) {
2054 if (*(cp2-1) == '/') continue;
2055 if (*(cp1-1) != '.') *(cp1++) = '.';
2058 else if (!infront && *cp2 == '.') {
2059 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2060 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2061 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2062 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2063 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2064 else { /* back up over previous directory name */
2066 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2067 if (*(cp1-1) == '[') {
2068 memcpy(cp1,"000000.",7);
2073 if (cp2 == dirend) break;
2075 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2076 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2077 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2078 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2080 *(cp1++) = '.'; /* Simulate trailing '/' */
2081 cp2 += 2; /* for loop will incr this to == dirend */
2083 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2085 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2088 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2089 if (*cp2 == '.') *(cp1++) = '_';
2090 else *(cp1++) = *cp2;
2094 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2095 if (hasdir) *(cp1++) = ']';
2096 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2097 while (*cp2) *(cp1++) = *(cp2++);
2102 } /* end of do_tovmsspec() */
2104 /* External entry points */
2105 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2106 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2108 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2109 static char *do_tovmspath(char *path, char *buf, int ts) {
2110 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2112 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2114 if (path == NULL) return NULL;
2115 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2116 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2117 if (buf) return buf;
2119 vmslen = strlen(vmsified);
2120 New(1317,cp,vmslen+1,char);
2121 memcpy(cp,vmsified,vmslen);
2126 strcpy(__tovmspath_retbuf,vmsified);
2127 return __tovmspath_retbuf;
2130 } /* end of do_tovmspath() */
2132 /* External entry points */
2133 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2134 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2137 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2138 static char *do_tounixpath(char *path, char *buf, int ts) {
2139 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2141 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2143 if (path == NULL) return NULL;
2144 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2145 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2146 if (buf) return buf;
2148 unixlen = strlen(unixified);
2149 New(1317,cp,unixlen+1,char);
2150 memcpy(cp,unixified,unixlen);
2155 strcpy(__tounixpath_retbuf,unixified);
2156 return __tounixpath_retbuf;
2159 } /* end of do_tounixpath() */
2161 /* External entry points */
2162 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2163 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2166 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2168 *****************************************************************************
2170 * Copyright (C) 1989-1994 by *
2171 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2173 * Permission is hereby granted for the reproduction of this software, *
2174 * on condition that this copyright notice is included in the reproduction, *
2175 * and that such reproduction is not for purposes of profit or material *
2178 * 27-Aug-1994 Modified for inclusion in perl5 *
2179 * by Charles Bailey bailey@newman.upenn.edu *
2180 *****************************************************************************
2184 * getredirection() is intended to aid in porting C programs
2185 * to VMS (Vax-11 C). The native VMS environment does not support
2186 * '>' and '<' I/O redirection, or command line wild card expansion,
2187 * or a command line pipe mechanism using the '|' AND background
2188 * command execution '&'. All of these capabilities are provided to any
2189 * C program which calls this procedure as the first thing in the
2191 * The piping mechanism will probably work with almost any 'filter' type
2192 * of program. With suitable modification, it may useful for other
2193 * portability problems as well.
2195 * Author: Mark Pizzolato mark@infocomm.com
2199 struct list_item *next;
2203 static void add_item(struct list_item **head,
2204 struct list_item **tail,
2208 static void expand_wild_cards(char *item,
2209 struct list_item **head,
2210 struct list_item **tail,
2213 static int background_process(int argc, char **argv);
2215 static void pipe_and_fork(char **cmargv);
2217 /*{{{ void getredirection(int *ac, char ***av)*/
2219 getredirection(int *ac, char ***av)
2221 * Process vms redirection arg's. Exit if any error is seen.
2222 * If getredirection() processes an argument, it is erased
2223 * from the vector. getredirection() returns a new argc and argv value.
2224 * In the event that a background command is requested (by a trailing "&"),
2225 * this routine creates a background subprocess, and simply exits the program.
2227 * Warning: do not try to simplify the code for vms. The code
2228 * presupposes that getredirection() is called before any data is
2229 * read from stdin or written to stdout.
2231 * Normal usage is as follows:
2237 * getredirection(&argc, &argv);
2241 int argc = *ac; /* Argument Count */
2242 char **argv = *av; /* Argument Vector */
2243 char *ap; /* Argument pointer */
2244 int j; /* argv[] index */
2245 int item_count = 0; /* Count of Items in List */
2246 struct list_item *list_head = 0; /* First Item in List */
2247 struct list_item *list_tail; /* Last Item in List */
2248 char *in = NULL; /* Input File Name */
2249 char *out = NULL; /* Output File Name */
2250 char *outmode = "w"; /* Mode to Open Output File */
2251 char *err = NULL; /* Error File Name */
2252 char *errmode = "w"; /* Mode to Open Error File */
2253 int cmargc = 0; /* Piped Command Arg Count */
2254 char **cmargv = NULL;/* Piped Command Arg Vector */
2257 * First handle the case where the last thing on the line ends with
2258 * a '&'. This indicates the desire for the command to be run in a
2259 * subprocess, so we satisfy that desire.
2262 if (0 == strcmp("&", ap))
2263 exit(background_process(--argc, argv));
2264 if (*ap && '&' == ap[strlen(ap)-1])
2266 ap[strlen(ap)-1] = '\0';
2267 exit(background_process(argc, argv));
2270 * Now we handle the general redirection cases that involve '>', '>>',
2271 * '<', and pipes '|'.
2273 for (j = 0; j < argc; ++j)
2275 if (0 == strcmp("<", argv[j]))
2279 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2280 exit(LIB$_WRONUMARG);
2285 if ('<' == *(ap = argv[j]))
2290 if (0 == strcmp(">", ap))
2294 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2295 exit(LIB$_WRONUMARG);
2314 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2315 exit(LIB$_WRONUMARG);
2319 if (('2' == *ap) && ('>' == ap[1]))
2336 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2337 exit(LIB$_WRONUMARG);
2341 if (0 == strcmp("|", argv[j]))
2345 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2346 exit(LIB$_WRONUMARG);
2348 cmargc = argc-(j+1);
2349 cmargv = &argv[j+1];
2353 if ('|' == *(ap = argv[j]))
2361 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2364 * Allocate and fill in the new argument vector, Some Unix's terminate
2365 * the list with an extra null pointer.
2367 New(1302, argv, item_count+1, char *);
2369 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2370 argv[j] = list_head->value;
2376 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2377 exit(LIB$_INVARGORD);
2379 pipe_and_fork(cmargv);
2382 /* Check for input from a pipe (mailbox) */
2384 if (in == NULL && 1 == isapipe(0))
2386 char mbxname[L_tmpnam];
2388 long int dvi_item = DVI$_DEVBUFSIZ;
2389 $DESCRIPTOR(mbxnam, "");
2390 $DESCRIPTOR(mbxdevnam, "");
2392 /* Input from a pipe, reopen it in binary mode to disable */
2393 /* carriage control processing. */
2395 PerlIO_getname(stdin, mbxname);
2396 mbxnam.dsc$a_pointer = mbxname;
2397 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2398 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2399 mbxdevnam.dsc$a_pointer = mbxname;
2400 mbxdevnam.dsc$w_length = sizeof(mbxname);
2401 dvi_item = DVI$_DEVNAM;
2402 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2403 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2406 freopen(mbxname, "rb", stdin);
2409 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2413 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2415 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2418 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2420 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2425 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2427 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2431 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2436 #ifdef ARGPROC_DEBUG
2437 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2438 for (j = 0; j < *ac; ++j)
2439 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2441 /* Clear errors we may have hit expanding wildcards, so they don't
2442 show up in Perl's $! later */
2443 set_errno(0); set_vaxc_errno(1);
2444 } /* end of getredirection() */
2447 static void add_item(struct list_item **head,
2448 struct list_item **tail,
2454 New(1303,*head,1,struct list_item);
2458 New(1304,(*tail)->next,1,struct list_item);
2459 *tail = (*tail)->next;
2461 (*tail)->value = value;
2465 static void expand_wild_cards(char *item,
2466 struct list_item **head,
2467 struct list_item **tail,
2471 unsigned long int context = 0;
2477 char vmsspec[NAM$C_MAXRSS+1];
2478 $DESCRIPTOR(filespec, "");
2479 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2480 $DESCRIPTOR(resultspec, "");
2481 unsigned long int zero = 0, sts;
2483 for (cp = item; *cp; cp++) {
2484 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2485 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2487 if (!*cp || isspace(*cp))
2489 add_item(head, tail, item, count);
2492 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2493 resultspec.dsc$b_class = DSC$K_CLASS_D;
2494 resultspec.dsc$a_pointer = NULL;
2495 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2496 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2497 if (!isunix || !filespec.dsc$a_pointer)
2498 filespec.dsc$a_pointer = item;
2499 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2501 * Only return version specs, if the caller specified a version
2503 had_version = strchr(item, ';');
2505 * Only return device and directory specs, if the caller specifed either.
2507 had_device = strchr(item, ':');
2508 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2510 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2511 &defaultspec, 0, 0, &zero))))
2516 New(1305,string,resultspec.dsc$w_length+1,char);
2517 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2518 string[resultspec.dsc$w_length] = '\0';
2519 if (NULL == had_version)
2520 *((char *)strrchr(string, ';')) = '\0';
2521 if ((!had_directory) && (had_device == NULL))
2523 if (NULL == (devdir = strrchr(string, ']')))
2524 devdir = strrchr(string, '>');
2525 strcpy(string, devdir + 1);
2528 * Be consistent with what the C RTL has already done to the rest of
2529 * the argv items and lowercase all of these names.
2531 for (c = string; *c; ++c)
2534 if (isunix) trim_unixpath(string,item,1);
2535 add_item(head, tail, string, count);
2538 if (sts != RMS$_NMF)
2540 set_vaxc_errno(sts);
2546 set_errno(ENOENT); break;
2548 set_errno(ENODEV); break;
2551 set_errno(EINVAL); break;
2553 set_errno(EACCES); break;
2555 _ckvmssts_noperl(sts);
2559 add_item(head, tail, item, count);
2560 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2561 _ckvmssts_noperl(lib$find_file_end(&context));
2564 static int child_st[2];/* Event Flag set when child process completes */
2566 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2568 static unsigned long int exit_handler(int *status)
2572 if (0 == child_st[0])
2574 #ifdef ARGPROC_DEBUG
2575 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2577 fflush(stdout); /* Have to flush pipe for binary data to */
2578 /* terminate properly -- <tp@mccall.com> */
2579 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2580 sys$dassgn(child_chan);
2582 sys$synch(0, child_st);
2587 static void sig_child(int chan)
2589 #ifdef ARGPROC_DEBUG
2590 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2592 if (child_st[0] == 0)
2596 static struct exit_control_block exit_block =
2601 &exit_block.exit_status,
2605 static void pipe_and_fork(char **cmargv)
2608 $DESCRIPTOR(cmddsc, "");
2609 static char mbxname[64];
2610 $DESCRIPTOR(mbxdsc, mbxname);
2612 unsigned long int zero = 0, one = 1;
2614 strcpy(subcmd, cmargv[0]);
2615 for (j = 1; NULL != cmargv[j]; ++j)
2617 strcat(subcmd, " \"");
2618 strcat(subcmd, cmargv[j]);
2619 strcat(subcmd, "\"");
2621 cmddsc.dsc$a_pointer = subcmd;
2622 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2624 create_mbx(&child_chan,&mbxdsc);
2625 #ifdef ARGPROC_DEBUG
2626 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2627 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2629 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2630 0, &pid, child_st, &zero, sig_child,
2632 #ifdef ARGPROC_DEBUG
2633 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2635 sys$dclexh(&exit_block);
2636 if (NULL == freopen(mbxname, "wb", stdout))
2638 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2642 static int background_process(int argc, char **argv)
2644 char command[2048] = "$";
2645 $DESCRIPTOR(value, "");
2646 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2647 static $DESCRIPTOR(null, "NLA0:");
2648 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2650 $DESCRIPTOR(pidstr, "");
2652 unsigned long int flags = 17, one = 1, retsts;
2654 strcat(command, argv[0]);
2657 strcat(command, " \"");
2658 strcat(command, *(++argv));
2659 strcat(command, "\"");
2661 value.dsc$a_pointer = command;
2662 value.dsc$w_length = strlen(value.dsc$a_pointer);
2663 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2664 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2665 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2666 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2669 _ckvmssts_noperl(retsts);
2671 #ifdef ARGPROC_DEBUG
2672 PerlIO_printf(Perl_debug_log, "%s\n", command);
2674 sprintf(pidstring, "%08X", pid);
2675 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2676 pidstr.dsc$a_pointer = pidstring;
2677 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2678 lib$set_symbol(&pidsymbol, &pidstr);
2682 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2685 /* OS-specific initialization at image activation (not thread startup) */
2686 /* Older VAXC header files lack these constants */
2687 #ifndef JPI$_RIGHTS_SIZE
2688 # define JPI$_RIGHTS_SIZE 817
2690 #ifndef KGB$M_SUBSYSTEM
2691 # define KGB$M_SUBSYSTEM 0x8
2694 /*{{{void vms_image_init(int *, char ***)*/
2696 vms_image_init(int *argcp, char ***argvp)
2698 char eqv[LNM$C_NAMLENGTH+1] = "";
2699 unsigned int len, tabct = 8, tabidx = 0;
2700 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2701 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2702 unsigned short int dummy, rlen;
2703 struct dsc$descriptor_s **tabvec;
2704 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2705 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2706 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2709 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2711 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2712 if (iprv[i]) { /* Running image installed with privs? */
2713 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2718 /* Rights identifiers might trigger tainting as well. */
2719 if (!will_taint && (rlen || rsz)) {
2720 while (rlen < rsz) {
2721 /* We didn't get all the identifiers on the first pass. Allocate a
2722 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2723 * were needed to hold all identifiers at time of last call; we'll
2724 * allocate that many unsigned long ints), and go back and get 'em.
2726 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2727 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2728 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2729 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2732 mask = jpilist[1].bufadr;
2733 /* Check attribute flags for each identifier (2nd longword); protected
2734 * subsystem identifiers trigger tainting.
2736 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2737 if (mask[i] & KGB$M_SUBSYSTEM) {
2742 if (mask != rlst) Safefree(mask);
2744 /* We need to use this hack to tell Perl it should run with tainting,
2745 * since its tainting flag may be part of the PL_curinterp struct, which
2746 * hasn't been allocated when vms_image_init() is called.
2750 New(1320,newap,*argcp+2,char **);
2751 newap[0] = argvp[0];
2753 Copy(argvp[1],newap[2],*argcp-1,char **);
2754 /* We orphan the old argv, since we don't know where it's come from,
2755 * so we don't know how to free it.
2757 *argcp++; argvp = newap;
2759 else { /* Did user explicitly request tainting? */
2761 char *cp, **av = *argvp;
2762 for (i = 1; i < *argcp; i++) {
2763 if (*av[i] != '-') break;
2764 for (cp = av[i]+1; *cp; cp++) {
2765 if (*cp == 'T') { will_taint = 1; break; }
2766 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2767 strchr("DFIiMmx",*cp)) break;
2769 if (will_taint) break;
2774 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2776 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2777 else if (tabidx >= tabct) {
2779 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2781 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2782 tabvec[tabidx]->dsc$w_length = 0;
2783 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2784 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2785 tabvec[tabidx]->dsc$a_pointer = NULL;
2786 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2788 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2790 getredirection(argcp,argvp);
2791 #if defined(USE_THREADS) && defined(__DECC)
2793 # include <reentrancy.h>
2794 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2803 * Trim Unix-style prefix off filespec, so it looks like what a shell
2804 * glob expansion would return (i.e. from specified prefix on, not
2805 * full path). Note that returned filespec is Unix-style, regardless
2806 * of whether input filespec was VMS-style or Unix-style.
2808 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2809 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2810 * vector of options; at present, only bit 0 is used, and if set tells
2811 * trim unixpath to try the current default directory as a prefix when
2812 * presented with a possibly ambiguous ... wildcard.
2814 * Returns !=0 on success, with trimmed filespec replacing contents of
2815 * fspec, and 0 on failure, with contents of fpsec unchanged.
2817 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2819 trim_unixpath(char *fspec, char *wildspec, int opts)
2821 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2822 *template, *base, *end, *cp1, *cp2;
2823 register int tmplen, reslen = 0, dirs = 0;
2825 if (!wildspec || !fspec) return 0;
2826 if (strpbrk(wildspec,"]>:") != NULL) {
2827 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2828 else template = unixwild;
2830 else template = wildspec;
2831 if (strpbrk(fspec,"]>:") != NULL) {
2832 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2833 else base = unixified;
2834 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2835 * check to see that final result fits into (isn't longer than) fspec */
2836 reslen = strlen(fspec);
2840 /* No prefix or absolute path on wildcard, so nothing to remove */
2841 if (!*template || *template == '/') {
2842 if (base == fspec) return 1;
2843 tmplen = strlen(unixified);
2844 if (tmplen > reslen) return 0; /* not enough space */
2845 /* Copy unixified resultant, including trailing NUL */
2846 memmove(fspec,unixified,tmplen+1);
2850 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2851 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2852 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2853 for (cp1 = end ;cp1 >= base; cp1--)
2854 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2856 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2860 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2861 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2862 int ells = 1, totells, segdirs, match;
2863 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2864 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2866 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2868 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2869 if (ellipsis == template && opts & 1) {
2870 /* Template begins with an ellipsis. Since we can't tell how many
2871 * directory names at the front of the resultant to keep for an
2872 * arbitrary starting point, we arbitrarily choose the current
2873 * default directory as a starting point. If it's there as a prefix,
2874 * clip it off. If not, fall through and act as if the leading
2875 * ellipsis weren't there (i.e. return shortest possible path that
2876 * could match template).
2878 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2879 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2880 if (_tolower(*cp1) != _tolower(*cp2)) break;
2881 segdirs = dirs - totells; /* Min # of dirs we must have left */
2882 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2883 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2884 memcpy(fspec,cp2+1,end - cp2);
2888 /* First off, back up over constant elements at end of path */
2890 for (front = end ; front >= base; front--)
2891 if (*front == '/' && !dirs--) { front++; break; }
2893 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2894 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2895 if (cp1 != '\0') return 0; /* Path too long. */
2897 *cp2 = '\0'; /* Pick up with memcpy later */
2898 lcfront = lcres + (front - base);
2899 /* Now skip over each ellipsis and try to match the path in front of it. */
2901 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2902 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2903 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2904 if (cp1 < template) break; /* template started with an ellipsis */
2905 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2906 ellipsis = cp1; continue;
2908 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2910 for (segdirs = 0, cp2 = tpl;
2911 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2913 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2914 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2915 if (*cp2 == '/') segdirs++;
2917 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2918 /* Back up at least as many dirs as in template before matching */
2919 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2920 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2921 for (match = 0; cp1 > lcres;) {
2922 resdsc.dsc$a_pointer = cp1;
2923 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2925 if (match == 1) lcfront = cp1;
2927 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2929 if (!match) return 0; /* Can't find prefix ??? */
2930 if (match > 1 && opts & 1) {
2931 /* This ... wildcard could cover more than one set of dirs (i.e.
2932 * a set of similar dir names is repeated). If the template
2933 * contains more than 1 ..., upstream elements could resolve the
2934 * ambiguity, but it's not worth a full backtracking setup here.
2935 * As a quick heuristic, clip off the current default directory
2936 * if it's present to find the trimmed spec, else use the
2937 * shortest string that this ... could cover.
2939 char def[NAM$C_MAXRSS+1], *st;
2941 if (getcwd(def, sizeof def,0) == NULL) return 0;
2942 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2943 if (_tolower(*cp1) != _tolower(*cp2)) break;
2944 segdirs = dirs - totells; /* Min # of dirs we must have left */
2945 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2946 if (*cp1 == '\0' && *cp2 == '/') {
2947 memcpy(fspec,cp2+1,end - cp2);
2950 /* Nope -- stick with lcfront from above and keep going. */
2953 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2958 } /* end of trim_unixpath() */
2963 * VMS readdir() routines.
2964 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
2966 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
2967 * Minor modifications to original routines.
2970 /* Number of elements in vms_versions array */
2971 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
2974 * Open a directory, return a handle for later use.
2976 /*{{{ DIR *opendir(char*name) */
2981 char dir[NAM$C_MAXRSS+1];
2984 if (do_tovmspath(name,dir,0) == NULL) {
2987 if (flex_stat(dir,&sb) == -1) return NULL;
2988 if (!S_ISDIR(sb.st_mode)) {
2989 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
2992 if (!cando_by_name(S_IRUSR,0,dir)) {
2993 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
2996 /* Get memory for the handle, and the pattern. */
2998 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3000 /* Fill in the fields; mainly playing with the descriptor. */
3001 (void)sprintf(dd->pattern, "%s*.*",dir);
3004 dd->vms_wantversions = 0;
3005 dd->pat.dsc$a_pointer = dd->pattern;
3006 dd->pat.dsc$w_length = strlen(dd->pattern);
3007 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3008 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3011 } /* end of opendir() */
3015 * Set the flag to indicate we want versions or not.
3017 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3019 vmsreaddirversions(DIR *dd, int flag)
3021 dd->vms_wantversions = flag;
3026 * Free up an opened directory.
3028 /*{{{ void closedir(DIR *dd)*/
3032 (void)lib$find_file_end(&dd->context);
3033 Safefree(dd->pattern);
3034 Safefree((char *)dd);
3039 * Collect all the version numbers for the current file.
3045 struct dsc$descriptor_s pat;
3046 struct dsc$descriptor_s res;
3048 char *p, *text, buff[sizeof dd->entry.d_name];
3050 unsigned long context, tmpsts;
3052 /* Convenient shorthand. */
3055 /* Add the version wildcard, ignoring the "*.*" put on before */
3056 i = strlen(dd->pattern);
3057 New(1308,text,i + e->d_namlen + 3,char);
3058 (void)strcpy(text, dd->pattern);
3059 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3061 /* Set up the pattern descriptor. */
3062 pat.dsc$a_pointer = text;
3063 pat.dsc$w_length = i + e->d_namlen - 1;
3064 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3065 pat.dsc$b_class = DSC$K_CLASS_S;
3067 /* Set up result descriptor. */
3068 res.dsc$a_pointer = buff;
3069 res.dsc$w_length = sizeof buff - 2;
3070 res.dsc$b_dtype = DSC$K_DTYPE_T;
3071 res.dsc$b_class = DSC$K_CLASS_S;
3073 /* Read files, collecting versions. */
3074 for (context = 0, e->vms_verscount = 0;
3075 e->vms_verscount < VERSIZE(e);
3076 e->vms_verscount++) {
3077 tmpsts = lib$find_file(&pat, &res, &context);
3078 if (tmpsts == RMS$_NMF || context == 0) break;
3080 buff[sizeof buff - 1] = '\0';
3081 if ((p = strchr(buff, ';')))
3082 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3084 e->vms_versions[e->vms_verscount] = -1;
3087 _ckvmssts(lib$find_file_end(&context));
3090 } /* end of collectversions() */
3093 * Read the next entry from the directory.
3095 /*{{{ struct dirent *readdir(DIR *dd)*/
3099 struct dsc$descriptor_s res;
3100 char *p, buff[sizeof dd->entry.d_name];
3101 unsigned long int tmpsts;
3103 /* Set up result descriptor, and get next file. */
3104 res.dsc$a_pointer = buff;
3105 res.dsc$w_length = sizeof buff - 2;
3106 res.dsc$b_dtype = DSC$K_DTYPE_T;
3107 res.dsc$b_class = DSC$K_CLASS_S;
3108 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3109 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3110 if (!(tmpsts & 1)) {
3111 set_vaxc_errno(tmpsts);
3114 set_errno(EACCES); break;
3116 set_errno(ENODEV); break;
3119 set_errno(ENOENT); break;
3126 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3127 buff[sizeof buff - 1] = '\0';
3128 for (p = buff; *p; p++) *p = _tolower(*p);
3129 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3132 /* Skip any directory component and just copy the name. */
3133 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3134 else (void)strcpy(dd->entry.d_name, buff);
3136 /* Clobber the version. */
3137 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3139 dd->entry.d_namlen = strlen(dd->entry.d_name);
3140 dd->entry.vms_verscount = 0;
3141 if (dd->vms_wantversions) collectversions(dd);
3144 } /* end of readdir() */
3148 * Return something that can be used in a seekdir later.
3150 /*{{{ long telldir(DIR *dd)*/
3159 * Return to a spot where we used to be. Brute force.
3161 /*{{{ void seekdir(DIR *dd,long count)*/
3163 seekdir(DIR *dd, long count)
3165 int vms_wantversions;
3167 /* If we haven't done anything yet... */
3171 /* Remember some state, and clear it. */
3172 vms_wantversions = dd->vms_wantversions;
3173 dd->vms_wantversions = 0;
3174 _ckvmssts(lib$find_file_end(&dd->context));
3177 /* The increment is in readdir(). */
3178 for (dd->count = 0; dd->count < count; )
3181 dd->vms_wantversions = vms_wantversions;
3183 } /* end of seekdir() */
3186 /* VMS subprocess management
3188 * my_vfork() - just a vfork(), after setting a flag to record that
3189 * the current script is trying a Unix-style fork/exec.
3191 * vms_do_aexec() and vms_do_exec() are called in response to the
3192 * perl 'exec' function. If this follows a vfork call, then they
3193 * call out the the regular perl routines in doio.c which do an
3194 * execvp (for those who really want to try this under VMS).
3195 * Otherwise, they do exactly what the perl docs say exec should
3196 * do - terminate the current script and invoke a new command
3197 * (See below for notes on command syntax.)
3199 * do_aspawn() and do_spawn() implement the VMS side of the perl
3200 * 'system' function.
3202 * Note on command arguments to perl 'exec' and 'system': When handled
3203 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3204 * are concatenated to form a DCL command string. If the first arg
3205 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3206 * the the command string is handed off to DCL directly. Otherwise,
3207 * the first token of the command is taken as the filespec of an image
3208 * to run. The filespec is expanded using a default type of '.EXE' and
3209 * the process defaults for device, directory, etc., and if found, the resultant
3210 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3211 * the command string as parameters. This is perhaps a bit complicated,
3212 * but I hope it will form a happy medium between what VMS folks expect
3213 * from lib$spawn and what Unix folks expect from exec.
3216 static int vfork_called;
3218 /*{{{int my_vfork()*/
3228 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3236 if (VMScmd.dsc$a_pointer) {
3237 Safefree(VMScmd.dsc$a_pointer);
3238 VMScmd.dsc$w_length = 0;
3239 VMScmd.dsc$a_pointer = Nullch;
3244 setup_argstr(SV *really, SV **mark, SV **sp)
3247 char *junk, *tmps = Nullch;
3248 register size_t cmdlen = 0;
3255 tmps = SvPV(really,rlen);
3262 for (idx++; idx <= sp; idx++) {
3264 junk = SvPVx(*idx,rlen);
3265 cmdlen += rlen ? rlen + 1 : 0;
3268 New(401,PL_Cmd,cmdlen+1,char);
3270 if (tmps && *tmps) {
3271 strcpy(PL_Cmd,tmps);
3274 else *PL_Cmd = '\0';
3275 while (++mark <= sp) {
3277 char *s = SvPVx(*mark,n_a);
3279 if (*PL_Cmd) strcat(PL_Cmd," ");
3285 } /* end of setup_argstr() */
3288 static unsigned long int
3289 setup_cmddsc(char *cmd, int check_img)
3291 char resspec[NAM$C_MAXRSS+1];
3292 $DESCRIPTOR(defdsc,".EXE");
3293 $DESCRIPTOR(resdsc,resspec);
3294 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3295 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3296 register char *s, *rest, *cp;
3297 register int isdcl = 0;
3300 while (*s && isspace(*s)) s++;
3302 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3303 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3304 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3305 if (*cp == ':' || *cp == '[' || *cp == '<') {
3315 while (*s && !isspace(*s)) s++;
3317 imgdsc.dsc$a_pointer = cmd;
3318 imgdsc.dsc$w_length = s - cmd;
3319 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3321 _ckvmssts(lib$find_file_end(&cxt));
3323 while (*s && !isspace(*s)) s++;
3325 if (cando_by_name(S_IXUSR,0,resspec)) {
3326 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3327 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3328 strcat(VMScmd.dsc$a_pointer,resspec);
3329 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3330 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3333 else retsts = RMS$_PRV;
3336 /* It's either a DCL command or we couldn't find a suitable image */
3337 VMScmd.dsc$w_length = strlen(cmd);
3338 if (cmd == PL_Cmd) {
3339 VMScmd.dsc$a_pointer = PL_Cmd;
3340 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3342 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3343 if (!(retsts & 1)) {
3344 /* just hand off status values likely to be due to user error */
3345 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3346 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3347 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3348 else { _ckvmssts(retsts); }
3351 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3353 } /* end of setup_cmddsc() */
3356 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3358 vms_do_aexec(SV *really,SV **mark,SV **sp)
3362 if (vfork_called) { /* this follows a vfork - act Unixish */
3364 if (vfork_called < 0) {
3365 warn("Internal inconsistency in tracking vforks");
3368 else return do_aexec(really,mark,sp);
3370 /* no vfork - act VMSish */
3371 return vms_do_exec(setup_argstr(really,mark,sp));
3376 } /* end of vms_do_aexec() */
3379 /* {{{bool vms_do_exec(char *cmd) */
3381 vms_do_exec(char *cmd)
3384 if (vfork_called) { /* this follows a vfork - act Unixish */
3386 if (vfork_called < 0) {
3387 warn("Internal inconsistency in tracking vforks");
3390 else return do_exec(cmd);
3393 { /* no vfork - act VMSish */
3394 unsigned long int retsts;
3397 TAINT_PROPER("exec");
3398 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3399 retsts = lib$do_command(&VMScmd);
3403 set_errno(ENOENT); break;
3404 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3405 set_errno(ENOTDIR); break;
3407 set_errno(EACCES); break;
3409 set_errno(EINVAL); break;
3411 set_errno(E2BIG); break;
3412 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3413 _ckvmssts(retsts); /* fall through */
3414 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3417 set_vaxc_errno(retsts);
3418 if (ckWARN(WARN_EXEC)) {
3419 warner(WARN_EXEC,"Can't exec \"%*s\": %s",
3420 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3427 } /* end of vms_do_exec() */
3430 unsigned long int do_spawn(char *);
3432 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3434 do_aspawn(void *really,void **mark,void **sp)
3437 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3440 } /* end of do_aspawn() */
3443 /* {{{unsigned long int do_spawn(char *cmd) */
3447 unsigned long int sts, substs, hadcmd = 1;
3450 TAINT_PROPER("spawn");
3451 if (!cmd || !*cmd) {
3453 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3455 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3456 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3462 set_errno(ENOENT); break;
3463 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3464 set_errno(ENOTDIR); break;
3466 set_errno(EACCES); break;
3468 set_errno(EINVAL); break;
3470 set_errno(E2BIG); break;
3471 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3472 _ckvmssts(sts); /* fall through */
3473 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3476 set_vaxc_errno(sts);
3477 if (ckWARN(WARN_EXEC)) {
3478 warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
3479 hadcmd ? VMScmd.dsc$w_length : 0,
3480 hadcmd ? VMScmd.dsc$a_pointer : "",
3487 } /* end of do_spawn() */
3491 * A simple fwrite replacement which outputs itmsz*nitm chars without
3492 * introducing record boundaries every itmsz chars.
3494 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3496 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3498 register char *cp, *end;
3500 end = (char *)src + itmsz * nitm;
3502 while ((char *)src <= end) {
3503 for (cp = src; cp <= end; cp++) if (!*cp) break;
3504 if (fputs(src,dest) == EOF) return EOF;
3506 if (fputc('\0',dest) == EOF) return EOF;
3512 } /* end of my_fwrite() */
3515 /*{{{ int my_flush(FILE *fp)*/
3520 if ((res = fflush(fp)) == 0) {
3521 #ifdef VMS_DO_SOCKETS
3523 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3525 res = fsync(fileno(fp));
3532 * Here are replacements for the following Unix routines in the VMS environment:
3533 * getpwuid Get information for a particular UIC or UID
3534 * getpwnam Get information for a named user
3535 * getpwent Get information for each user in the rights database
3536 * setpwent Reset search to the start of the rights database
3537 * endpwent Finish searching for users in the rights database
3539 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3540 * (defined in pwd.h), which contains the following fields:-
3542 * char *pw_name; Username (in lower case)
3543 * char *pw_passwd; Hashed password
3544 * unsigned int pw_uid; UIC
3545 * unsigned int pw_gid; UIC group number
3546 * char *pw_unixdir; Default device/directory (VMS-style)
3547 * char *pw_gecos; Owner name
3548 * char *pw_dir; Default device/directory (Unix-style)
3549 * char *pw_shell; Default CLI name (eg. DCL)
3551 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3553 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3554 * not the UIC member number (eg. what's returned by getuid()),
3555 * getpwuid() can accept either as input (if uid is specified, the caller's
3556 * UIC group is used), though it won't recognise gid=0.
3558 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3559 * information about other users in your group or in other groups, respectively.
3560 * If the required privilege is not available, then these routines fill only
3561 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3564 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3567 /* sizes of various UAF record fields */
3568 #define UAI$S_USERNAME 12
3569 #define UAI$S_IDENT 31
3570 #define UAI$S_OWNER 31
3571 #define UAI$S_DEFDEV 31
3572 #define UAI$S_DEFDIR 63
3573 #define UAI$S_DEFCLI 31
3576 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3577 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3578 (uic).uic$v_group != UIC$K_WILD_GROUP)
3580 static char __empty[]= "";
3581 static struct passwd __passwd_empty=
3582 {(char *) __empty, (char *) __empty, 0, 0,
3583 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3584 static int contxt= 0;
3585 static struct passwd __pwdcache;
3586 static char __pw_namecache[UAI$S_IDENT+1];
3589 * This routine does most of the work extracting the user information.
3591 static int fillpasswd (const char *name, struct passwd *pwd)
3594 unsigned char length;
3595 char pw_gecos[UAI$S_OWNER+1];
3597 static union uicdef uic;
3599 unsigned char length;
3600 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3603 unsigned char length;
3604 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3607 unsigned char length;
3608 char pw_shell[UAI$S_DEFCLI+1];
3610 static char pw_passwd[UAI$S_PWD+1];
3612 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3613 struct dsc$descriptor_s name_desc;
3614 unsigned long int sts;
3616 static struct itmlst_3 itmlst[]= {
3617 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3618 {sizeof(uic), UAI$_UIC, &uic, &luic},
3619 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3620 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3621 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3622 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3623 {0, 0, NULL, NULL}};
3625 name_desc.dsc$w_length= strlen(name);
3626 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3627 name_desc.dsc$b_class= DSC$K_CLASS_S;
3628 name_desc.dsc$a_pointer= (char *) name;
3630 /* Note that sys$getuai returns many fields as counted strings. */
3631 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3632 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3633 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3635 else { _ckvmssts(sts); }
3636 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3638 if ((int) owner.length < lowner) lowner= (int) owner.length;
3639 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3640 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3641 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3642 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3643 owner.pw_gecos[lowner]= '\0';
3644 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3645 defcli.pw_shell[ldefcli]= '\0';
3646 if (valid_uic(uic)) {
3647 pwd->pw_uid= uic.uic$l_uic;
3648 pwd->pw_gid= uic.uic$v_group;
3651 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3652 pwd->pw_passwd= pw_passwd;
3653 pwd->pw_gecos= owner.pw_gecos;
3654 pwd->pw_dir= defdev.pw_dir;
3655 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3656 pwd->pw_shell= defcli.pw_shell;
3657 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3659 ldir= strlen(pwd->pw_unixdir) - 1;
3660 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3663 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3664 __mystrtolower(pwd->pw_unixdir);
3669 * Get information for a named user.
3671 /*{{{struct passwd *getpwnam(char *name)*/
3672 struct passwd *my_getpwnam(char *name)
3674 struct dsc$descriptor_s name_desc;
3676 unsigned long int status, sts;
3678 __pwdcache = __passwd_empty;
3679 if (!fillpasswd(name, &__pwdcache)) {
3680 /* We still may be able to determine pw_uid and pw_gid */
3681 name_desc.dsc$w_length= strlen(name);
3682 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3683 name_desc.dsc$b_class= DSC$K_CLASS_S;
3684 name_desc.dsc$a_pointer= (char *) name;
3685 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3686 __pwdcache.pw_uid= uic.uic$l_uic;
3687 __pwdcache.pw_gid= uic.uic$v_group;
3690 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3691 set_vaxc_errno(sts);
3692 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3695 else { _ckvmssts(sts); }
3698 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3699 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3700 __pwdcache.pw_name= __pw_namecache;
3702 } /* end of my_getpwnam() */
3706 * Get information for a particular UIC or UID.
3707 * Called by my_getpwent with uid=-1 to list all users.
3709 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3710 struct passwd *my_getpwuid(Uid_t uid)
3712 const $DESCRIPTOR(name_desc,__pw_namecache);
3713 unsigned short lname;
3715 unsigned long int status;
3717 if (uid == (unsigned int) -1) {
3719 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3720 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3721 set_vaxc_errno(status);
3722 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3726 else { _ckvmssts(status); }
3727 } while (!valid_uic (uic));
3731 if (!uic.uic$v_group)
3732 uic.uic$v_group= PerlProc_getgid();
3734 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3735 else status = SS$_IVIDENT;
3736 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3737 status == RMS$_PRV) {
3738 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3741 else { _ckvmssts(status); }
3743 __pw_namecache[lname]= '\0';
3744 __mystrtolower(__pw_namecache);
3746 __pwdcache = __passwd_empty;
3747 __pwdcache.pw_name = __pw_namecache;
3749 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3750 The identifier's value is usually the UIC, but it doesn't have to be,
3751 so if we can, we let fillpasswd update this. */
3752 __pwdcache.pw_uid = uic.uic$l_uic;
3753 __pwdcache.pw_gid = uic.uic$v_group;
3755 fillpasswd(__pw_namecache, &__pwdcache);
3758 } /* end of my_getpwuid() */
3762 * Get information for next user.
3764 /*{{{struct passwd *my_getpwent()*/
3765 struct passwd *my_getpwent()
3767 return (my_getpwuid((unsigned int) -1));
3772 * Finish searching rights database for users.
3774 /*{{{void my_endpwent()*/
3778 _ckvmssts(sys$finish_rdb(&contxt));
3784 #ifdef HOMEGROWN_POSIX_SIGNALS
3785 /* Signal handling routines, pulled into the core from POSIX.xs.
3787 * We need these for threads, so they've been rolled into the core,
3788 * rather than left in POSIX.xs.
3790 * (DRS, Oct 23, 1997)
3793 /* sigset_t is atomic under VMS, so these routines are easy */
3794 /*{{{int my_sigemptyset(sigset_t *) */
3795 int my_sigemptyset(sigset_t *set) {
3796 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3802 /*{{{int my_sigfillset(sigset_t *)*/
3803 int my_sigfillset(sigset_t *set) {
3805 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3806 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3812 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3813 int my_sigaddset(sigset_t *set, int sig) {
3814 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3815 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3816 *set |= (1 << (sig - 1));
3822 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3823 int my_sigdelset(sigset_t *set, int sig) {
3824 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3825 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3826 *set &= ~(1 << (sig - 1));
3832 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3833 int my_sigismember(sigset_t *set, int sig) {
3834 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3835 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3836 *set & (1 << (sig - 1));
3841 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3842 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3845 /* If set and oset are both null, then things are badly wrong. Bail out. */
3846 if ((oset == NULL) && (set == NULL)) {
3847 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3851 /* If set's null, then we're just handling a fetch. */
3853 tempmask = sigblock(0);
3858 tempmask = sigsetmask(*set);
3861 tempmask = sigblock(*set);
3864 tempmask = sigblock(0);
3865 sigsetmask(*oset & ~tempmask);
3868 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3873 /* Did they pass us an oset? If so, stick our holding mask into it */
3880 #endif /* HOMEGROWN_POSIX_SIGNALS */
3883 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3884 * my_utime(), and flex_stat(), all of which operate on UTC unless
3885 * VMSISH_TIMES is true.
3887 /* method used to handle UTC conversions:
3888 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3890 static int gmtime_emulation_type;
3891 /* number of secs to add to UTC POSIX-style time to get local time */
3892 static long int utc_offset_secs;
3894 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3895 * in vmsish.h. #undef them here so we can call the CRTL routines
3902 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3903 # define RTL_USES_UTC 1
3906 static time_t toutc_dst(time_t loc) {
3909 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3910 loc -= utc_offset_secs;
3911 if (rsltmp->tm_isdst) loc -= 3600;
3914 #define _toutc(secs) ((secs) == -1 ? -1 : \
3915 ((gmtime_emulation_type || my_time(NULL)), \
3916 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3917 ((secs) - utc_offset_secs))))
3919 static time_t toloc_dst(time_t utc) {
3922 utc += utc_offset_secs;
3923 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3924 if (rsltmp->tm_isdst) utc += 3600;
3927 #define _toloc(secs) ((secs) == -1 ? -1 : \
3928 ((gmtime_emulation_type || my_time(NULL)), \
3929 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3930 ((secs) + utc_offset_secs))))
3933 /* my_time(), my_localtime(), my_gmtime()
3934 * By default traffic in UTC time values, using CRTL gmtime() or
3935 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3936 * Note: We need to use these functions even when the CRTL has working
3937 * UTC support, since they also handle C<use vmsish qw(times);>
3939 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3940 * Modified by Charles Bailey <bailey@newman.upenn.edu>
3943 /*{{{time_t my_time(time_t *timep)*/
3944 time_t my_time(time_t *timep)
3950 if (gmtime_emulation_type == 0) {
3952 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3953 /* results of calls to gmtime() and localtime() */
3954 /* for same &base */
3956 gmtime_emulation_type++;
3957 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3958 char off[LNM$C_NAMLENGTH+1];;
3960 gmtime_emulation_type++;
3961 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
3962 gmtime_emulation_type++;
3963 warn("no UTC offset information; assuming local time is UTC");
3965 else { utc_offset_secs = atol(off); }
3967 else { /* We've got a working gmtime() */
3968 struct tm gmt, local;
3971 tm_p = localtime(&base);
3973 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
3974 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
3975 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
3976 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
3982 # ifdef RTL_USES_UTC
3983 if (VMSISH_TIME) when = _toloc(when);
3985 if (!VMSISH_TIME) when = _toutc(when);
3988 if (timep != NULL) *timep = when;
3991 } /* end of my_time() */
3995 /*{{{struct tm *my_gmtime(const time_t *timep)*/
3997 my_gmtime(const time_t *timep)
4004 if (timep == NULL) {
4005 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4008 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4012 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4014 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4015 return gmtime(&when);
4017 /* CRTL localtime() wants local time as input, so does no tz correction */
4018 rsltmp = localtime(&when);
4019 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4022 } /* end of my_gmtime() */
4026 /*{{{struct tm *my_localtime(const time_t *timep)*/
4028 my_localtime(const time_t *timep)
4034 if (timep == NULL) {
4035 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4038 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4039 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4042 # ifdef RTL_USES_UTC
4044 if (VMSISH_TIME) when = _toutc(when);
4046 /* CRTL localtime() wants UTC as input, does tz correction itself */
4047 return localtime(&when);
4050 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4053 /* CRTL localtime() wants local time as input, so does no tz correction */
4054 rsltmp = localtime(&when);
4055 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4058 } /* end of my_localtime() */
4061 /* Reset definitions for later calls */
4062 #define gmtime(t) my_gmtime(t)
4063 #define localtime(t) my_localtime(t)
4064 #define time(t) my_time(t)
4067 /* my_utime - update modification time of a file
4068 * calling sequence is identical to POSIX utime(), but under
4069 * VMS only the modification time is changed; ODS-2 does not
4070 * maintain access times. Restrictions differ from the POSIX
4071 * definition in that the time can be changed as long as the
4072 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4073 * no separate checks are made to insure that the caller is the
4074 * owner of the file or has special privs enabled.
4075 * Code here is based on Joe Meadows' FILE utility.
4078 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4079 * to VMS epoch (01-JAN-1858 00:00:00.00)
4080 * in 100 ns intervals.
4082 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4084 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4085 int my_utime(char *file, struct utimbuf *utimes)
4089 long int bintime[2], len = 2, lowbit, unixtime,
4090 secscale = 10000000; /* seconds --> 100 ns intervals */
4091 unsigned long int chan, iosb[2], retsts;
4092 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4093 struct FAB myfab = cc$rms_fab;
4094 struct NAM mynam = cc$rms_nam;
4095 #if defined (__DECC) && defined (__VAX)
4096 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4097 * at least through VMS V6.1, which causes a type-conversion warning.
4099 # pragma message save
4100 # pragma message disable cvtdiftypes
4102 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4103 struct fibdef myfib;
4104 #if defined (__DECC) && defined (__VAX)
4105 /* This should be right after the declaration of myatr, but due
4106 * to a bug in VAX DEC C, this takes effect a statement early.
4108 # pragma message restore
4110 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4111 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4112 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4114 if (file == NULL || *file == '\0') {
4116 set_vaxc_errno(LIB$_INVARG);
4119 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4121 if (utimes != NULL) {
4122 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4123 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4124 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4125 * as input, we force the sign bit to be clear by shifting unixtime right
4126 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4128 lowbit = (utimes->modtime & 1) ? secscale : 0;
4129 unixtime = (long int) utimes->modtime;
4131 /* If input was UTC; convert to local for sys svc */
4132 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4134 unixtime >> 1; secscale << 1;
4135 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4136 if (!(retsts & 1)) {
4138 set_vaxc_errno(retsts);
4141 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4142 if (!(retsts & 1)) {
4144 set_vaxc_errno(retsts);
4149 /* Just get the current time in VMS format directly */
4150 retsts = sys$gettim(bintime);
4151 if (!(retsts & 1)) {
4153 set_vaxc_errno(retsts);
4158 myfab.fab$l_fna = vmsspec;
4159 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4160 myfab.fab$l_nam = &mynam;
4161 mynam.nam$l_esa = esa;
4162 mynam.nam$b_ess = (unsigned char) sizeof esa;
4163 mynam.nam$l_rsa = rsa;
4164 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4166 /* Look for the file to be affected, letting RMS parse the file
4167 * specification for us as well. I have set errno using only
4168 * values documented in the utime() man page for VMS POSIX.
4170 retsts = sys$parse(&myfab,0,0);
4171 if (!(retsts & 1)) {
4172 set_vaxc_errno(retsts);
4173 if (retsts == RMS$_PRV) set_errno(EACCES);
4174 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4175 else set_errno(EVMSERR);
4178 retsts = sys$search(&myfab,0,0);
4179 if (!(retsts & 1)) {
4180 set_vaxc_errno(retsts);
4181 if (retsts == RMS$_PRV) set_errno(EACCES);
4182 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4183 else set_errno(EVMSERR);
4187 devdsc.dsc$w_length = mynam.nam$b_dev;
4188 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4190 retsts = sys$assign(&devdsc,&chan,0,0);
4191 if (!(retsts & 1)) {
4192 set_vaxc_errno(retsts);
4193 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4194 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4195 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4196 else set_errno(EVMSERR);
4200 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4201 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4203 memset((void *) &myfib, 0, sizeof myfib);
4205 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4206 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4207 /* This prevents the revision time of the file being reset to the current
4208 * time as a result of our IO$_MODIFY $QIO. */
4209 myfib.fib$l_acctl = FIB$M_NORECORD;
4211 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4212 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4213 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4215 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4216 _ckvmssts(sys$dassgn(chan));
4217 if (retsts & 1) retsts = iosb[0];
4218 if (!(retsts & 1)) {
4219 set_vaxc_errno(retsts);
4220 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4221 else set_errno(EVMSERR);
4226 } /* end of my_utime() */
4230 * flex_stat, flex_fstat
4231 * basic stat, but gets it right when asked to stat
4232 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4235 /* encode_dev packs a VMS device name string into an integer to allow
4236 * simple comparisons. This can be used, for example, to check whether two
4237 * files are located on the same device, by comparing their encoded device
4238 * names. Even a string comparison would not do, because stat() reuses the
4239 * device name buffer for each call; so without encode_dev, it would be
4240 * necessary to save the buffer and use strcmp (this would mean a number of
4241 * changes to the standard Perl code, to say nothing of what a Perl script
4244 * The device lock id, if it exists, should be unique (unless perhaps compared
4245 * with lock ids transferred from other nodes). We have a lock id if the disk is
4246 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4247 * device names. Thus we use the lock id in preference, and only if that isn't
4248 * available, do we try to pack the device name into an integer (flagged by
4249 * the sign bit (LOCKID_MASK) being set).
4251 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4252 * name and its encoded form, but it seems very unlikely that we will find
4253 * two files on different disks that share the same encoded device names,
4254 * and even more remote that they will share the same file id (if the test
4255 * is to check for the same file).
4257 * A better method might be to use sys$device_scan on the first call, and to
4258 * search for the device, returning an index into the cached array.
4259 * The number returned would be more intelligable.
4260 * This is probably not worth it, and anyway would take quite a bit longer
4261 * on the first call.
4263 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4264 static mydev_t encode_dev (const char *dev)
4267 unsigned long int f;
4272 if (!dev || !dev[0]) return 0;
4276 struct dsc$descriptor_s dev_desc;
4277 unsigned long int status, lockid, item = DVI$_LOCKID;
4279 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4280 can try that first. */
4281 dev_desc.dsc$w_length = strlen (dev);
4282 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4283 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4284 dev_desc.dsc$a_pointer = (char *) dev;
4285 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4286 if (lockid) return (lockid & ~LOCKID_MASK);
4290 /* Otherwise we try to encode the device name */
4294 for (q = dev + strlen(dev); q--; q >= dev) {
4297 else if (isalpha (toupper (*q)))
4298 c= toupper (*q) - 'A' + (char)10;
4300 continue; /* Skip '$'s */
4302 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4304 enc += f * (unsigned long int) c;
4306 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4308 } /* end of encode_dev() */
4310 static char namecache[NAM$C_MAXRSS+1];
4313 is_null_device(name)
4316 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4317 The underscore prefix, controller letter, and unit number are
4318 independently optional; for our purposes, the colon punctuation
4319 is not. The colon can be trailed by optional directory and/or
4320 filename, but two consecutive colons indicates a nodename rather
4321 than a device. [pr] */
4322 if (*name == '_') ++name;
4323 if (tolower(*name++) != 'n') return 0;
4324 if (tolower(*name++) != 'l') return 0;
4325 if (tolower(*name) == 'a') ++name;
4326 if (*name == '0') ++name;
4327 return (*name++ == ':') && (*name != ':');
4330 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4331 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4332 * subset of the applicable information.
4334 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
4336 cando(I32 bit, I32 effective, Stat_t *statbufp)
4339 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4341 char fname[NAM$C_MAXRSS+1];
4342 unsigned long int retsts;
4343 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4344 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4346 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4347 device name on successive calls */
4348 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4349 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4350 namdsc.dsc$a_pointer = fname;
4351 namdsc.dsc$w_length = sizeof fname - 1;
4353 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4354 &namdsc,&namdsc.dsc$w_length,0,0);
4356 fname[namdsc.dsc$w_length] = '\0';
4357 return cando_by_name(bit,effective,fname);
4359 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4360 warn("Can't get filespec - stale stat buffer?\n");
4364 return FALSE; /* Should never get to here */
4366 } /* end of cando() */
4370 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
4372 cando_by_name(I32 bit, I32 effective, char *fname)
4374 static char usrname[L_cuserid];
4375 static struct dsc$descriptor_s usrdsc =
4376 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4377 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4378 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4379 unsigned short int retlen;
4380 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4381 union prvdef curprv;
4382 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4383 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4384 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4387 if (!fname || !*fname) return FALSE;
4388 /* Make sure we expand logical names, since sys$check_access doesn't */
4389 if (!strpbrk(fname,"/]>:")) {
4390 strcpy(fileified,fname);
4391 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4394 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4395 retlen = namdsc.dsc$w_length = strlen(vmsname);
4396 namdsc.dsc$a_pointer = vmsname;
4397 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4398 vmsname[retlen-1] == ':') {
4399 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4400 namdsc.dsc$w_length = strlen(fileified);
4401 namdsc.dsc$a_pointer = fileified;
4404 if (!usrdsc.dsc$w_length) {
4406 usrdsc.dsc$w_length = strlen(usrname);
4413 access = ARM$M_EXECUTE;
4418 access = ARM$M_READ;
4423 access = ARM$M_WRITE;
4428 access = ARM$M_DELETE;
4434 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4435 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4436 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4437 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4438 set_vaxc_errno(retsts);
4439 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4440 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4441 else set_errno(ENOENT);
4444 if (retsts == SS$_NORMAL) {
4445 if (!privused) return TRUE;
4446 /* We can get access, but only by using privs. Do we have the
4447 necessary privs currently enabled? */
4448 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4449 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4450 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4451 !curprv.prv$v_bypass) return FALSE;
4452 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4453 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4454 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4457 if (retsts == SS$_ACCONFLICT) {
4462 return FALSE; /* Should never get here */
4464 } /* end of cando_by_name() */
4468 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4470 flex_fstat(int fd, Stat_t *statbufp)
4473 if (!fstat(fd,(stat_t *) statbufp)) {
4474 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4475 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4476 # ifdef RTL_USES_UTC
4479 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4480 statbufp->st_atime = _toloc(statbufp->st_atime);
4481 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4486 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4490 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4491 statbufp->st_atime = _toutc(statbufp->st_atime);
4492 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4499 } /* end of flex_fstat() */
4502 /*{{{ int flex_stat(char *fspec, Stat_t *statbufp)*/
4504 flex_stat(char *fspec, Stat_t *statbufp)
4507 char fileified[NAM$C_MAXRSS+1];
4510 if (statbufp == (Stat_t *) &PL_statcache)
4511 do_tovmsspec(fspec,namecache,0);
4512 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
4513 memset(statbufp,0,sizeof *statbufp);
4514 statbufp->st_dev = encode_dev("_NLA0:");
4515 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4516 statbufp->st_uid = 0x00010001;
4517 statbufp->st_gid = 0x0001;
4518 time((time_t *)&statbufp->st_mtime);
4519 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4523 /* Try for a directory name first. If fspec contains a filename without
4524 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4525 * and sea:[wine.dark]water. exist, we prefer the directory here.
4526 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4527 * not sea:[wine.dark]., if the latter exists. If the intended target is
4528 * the file with null type, specify this by calling flex_stat() with
4529 * a '.' at the end of fspec.
4531 if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
4532 retval = stat(fileified,(stat_t *) statbufp);
4533 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4534 strcpy(namecache,fileified);
4536 if (retval) retval = stat(fspec,(stat_t *) statbufp);
4538 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4539 # ifdef RTL_USES_UTC
4542 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4543 statbufp->st_atime = _toloc(statbufp->st_atime);
4544 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4549 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4553 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4554 statbufp->st_atime = _toutc(statbufp->st_atime);
4555 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4561 } /* end of flex_stat() */
4565 /*{{{char *my_getlogin()*/
4566 /* VMS cuserid == Unix getlogin, except calling sequence */
4570 static char user[L_cuserid];
4571 return cuserid(user);
4576 /* rmscopy - copy a file using VMS RMS routines
4578 * Copies contents and attributes of spec_in to spec_out, except owner
4579 * and protection information. Name and type of spec_in are used as
4580 * defaults for spec_out. The third parameter specifies whether rmscopy()
4581 * should try to propagate timestamps from the input file to the output file.
4582 * If it is less than 0, no timestamps are preserved. If it is 0, then
4583 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4584 * propagated to the output file at creation iff the output file specification
4585 * did not contain an explicit name or type, and the revision date is always
4586 * updated at the end of the copy operation. If it is greater than 0, then
4587 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4588 * other than the revision date should be propagated, and bit 1 indicates
4589 * that the revision date should be propagated.
4591 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4593 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4594 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4595 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4596 * as part of the Perl standard distribution under the terms of the
4597 * GNU General Public License or the Perl Artistic License. Copies
4598 * of each may be found in the Perl standard distribution.
4600 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4602 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4604 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4605 rsa[NAM$C_MAXRSS], ubf[32256];
4606 unsigned long int i, sts, sts2;
4607 struct FAB fab_in, fab_out;
4608 struct RAB rab_in, rab_out;
4610 struct XABDAT xabdat;
4611 struct XABFHC xabfhc;
4612 struct XABRDT xabrdt;
4613 struct XABSUM xabsum;
4615 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4616 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4617 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4621 fab_in = cc$rms_fab;
4622 fab_in.fab$l_fna = vmsin;
4623 fab_in.fab$b_fns = strlen(vmsin);
4624 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4625 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4626 fab_in.fab$l_fop = FAB$M_SQO;
4627 fab_in.fab$l_nam = &nam;
4628 fab_in.fab$l_xab = (void *) &xabdat;
4631 nam.nam$l_rsa = rsa;
4632 nam.nam$b_rss = sizeof(rsa);
4633 nam.nam$l_esa = esa;
4634 nam.nam$b_ess = sizeof (esa);
4635 nam.nam$b_esl = nam.nam$b_rsl = 0;
4637 xabdat = cc$rms_xabdat; /* To get creation date */
4638 xabdat.xab$l_nxt = (void *) &xabfhc;
4640 xabfhc = cc$rms_xabfhc; /* To get record length */
4641 xabfhc.xab$l_nxt = (void *) &xabsum;
4643 xabsum = cc$rms_xabsum; /* To get key and area information */
4645 if (!((sts = sys$open(&fab_in)) & 1)) {
4646 set_vaxc_errno(sts);
4650 set_errno(ENOENT); break;
4652 set_errno(ENODEV); break;
4654 set_errno(EINVAL); break;
4656 set_errno(EACCES); break;
4664 fab_out.fab$w_ifi = 0;
4665 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4666 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4667 fab_out.fab$l_fop = FAB$M_SQO;
4668 fab_out.fab$l_fna = vmsout;
4669 fab_out.fab$b_fns = strlen(vmsout);
4670 fab_out.fab$l_dna = nam.nam$l_name;
4671 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4673 if (preserve_dates == 0) { /* Act like DCL COPY */
4674 nam.nam$b_nop = NAM$M_SYNCHK;
4675 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4676 if (!((sts = sys$parse(&fab_out)) & 1)) {
4677 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4678 set_vaxc_errno(sts);
4681 fab_out.fab$l_xab = (void *) &xabdat;
4682 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4684 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4685 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4686 preserve_dates =0; /* bitmask from this point forward */
4688 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4689 if (!((sts = sys$create(&fab_out)) & 1)) {
4690 set_vaxc_errno(sts);
4693 set_errno(ENOENT); break;
4695 set_errno(ENODEV); break;
4697 set_errno(EINVAL); break;
4699 set_errno(EACCES); break;
4705 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4706 if (preserve_dates & 2) {
4707 /* sys$close() will process xabrdt, not xabdat */
4708 xabrdt = cc$rms_xabrdt;
4710 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4712 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4713 * is unsigned long[2], while DECC & VAXC use a struct */
4714 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4716 fab_out.fab$l_xab = (void *) &xabrdt;
4719 rab_in = cc$rms_rab;
4720 rab_in.rab$l_fab = &fab_in;
4721 rab_in.rab$l_rop = RAB$M_BIO;
4722 rab_in.rab$l_ubf = ubf;
4723 rab_in.rab$w_usz = sizeof ubf;
4724 if (!((sts = sys$connect(&rab_in)) & 1)) {
4725 sys$close(&fab_in); sys$close(&fab_out);
4726 set_errno(EVMSERR); set_vaxc_errno(sts);
4730 rab_out = cc$rms_rab;
4731 rab_out.rab$l_fab = &fab_out;
4732 rab_out.rab$l_rbf = ubf;
4733 if (!((sts = sys$connect(&rab_out)) & 1)) {
4734 sys$close(&fab_in); sys$close(&fab_out);
4735 set_errno(EVMSERR); set_vaxc_errno(sts);
4739 while ((sts = sys$read(&rab_in))) { /* always true */
4740 if (sts == RMS$_EOF) break;
4741 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4742 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4743 sys$close(&fab_in); sys$close(&fab_out);
4744 set_errno(EVMSERR); set_vaxc_errno(sts);
4749 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4750 sys$close(&fab_in); sys$close(&fab_out);
4751 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4753 set_errno(EVMSERR); set_vaxc_errno(sts);
4759 } /* end of rmscopy() */
4763 /*** The following glue provides 'hooks' to make some of the routines
4764 * from this file available from Perl. These routines are sufficiently
4765 * basic, and are required sufficiently early in the build process,
4766 * that's it's nice to have them available to miniperl as well as the
4767 * full Perl, so they're set up here instead of in an extension. The
4768 * Perl code which handles importation of these names into a given
4769 * package lives in [.VMS]Filespec.pm in @INC.
4773 rmsexpand_fromperl(CV *cv)
4776 char *fspec, *defspec = NULL, *rslt;
4779 if (!items || items > 2)
4780 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4781 fspec = SvPV(ST(0),n_a);
4782 if (!fspec || !*fspec) XSRETURN_UNDEF;
4783 if (items == 2) defspec = SvPV(ST(1),n_a);
4785 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4786 ST(0) = sv_newmortal();
4787 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4792 vmsify_fromperl(CV *cv)
4798 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4799 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4800 ST(0) = sv_newmortal();
4801 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4806 unixify_fromperl(CV *cv)
4812 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4813 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4814 ST(0) = sv_newmortal();
4815 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4820 fileify_fromperl(CV *cv)
4826 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4827 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4828 ST(0) = sv_newmortal();
4829 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4834 pathify_fromperl(CV *cv)
4840 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4841 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4842 ST(0) = sv_newmortal();
4843 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4848 vmspath_fromperl(CV *cv)
4854 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4855 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4856 ST(0) = sv_newmortal();
4857 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4862 unixpath_fromperl(CV *cv)
4868 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4869 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4870 ST(0) = sv_newmortal();
4871 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4876 candelete_fromperl(CV *cv)
4879 char fspec[NAM$C_MAXRSS+1], *fsp;
4884 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4886 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4887 if (SvTYPE(mysv) == SVt_PVGV) {
4888 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4889 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4896 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4897 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4903 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4908 rmscopy_fromperl(CV *cv)
4911 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4913 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4914 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4915 unsigned long int sts;
4920 if (items < 2 || items > 3)
4921 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4923 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4924 if (SvTYPE(mysv) == SVt_PVGV) {
4925 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4926 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4933 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
4934 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4939 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4940 if (SvTYPE(mysv) == SVt_PVGV) {
4941 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
4942 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4949 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
4950 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4955 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4957 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
4964 char* file = __FILE__;
4966 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
4967 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
4968 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
4969 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
4970 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
4971 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
4972 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
4973 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
4974 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);