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");
109 #if defined(USE_THREADS)
110 /* We jump through these hoops because we can be called at */
111 /* platform-specific initialization time, which is before anything is */
112 /* set up--we can't even do a plain dTHR since that relies on the */
113 /* interpreter structure to be initialized */
114 struct perl_thread *thr;
116 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
122 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
123 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
125 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
126 *cp2 = _toupper(*cp1);
127 if (cp1 - lnm > LNM$C_NAMLENGTH) {
128 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
132 lnmdsc.dsc$w_length = cp1 - lnm;
133 lnmdsc.dsc$a_pointer = uplnm;
134 secure = flags & PERL__TRNENV_SECURE;
135 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
136 if (!tabvec || !*tabvec) tabvec = env_tables;
138 for (curtab = 0; tabvec[curtab]; curtab++) {
139 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
140 if (!ivenv && !secure) {
145 warn("Can't read CRTL environ\n");
148 retsts = SS$_NOLOGNAM;
149 for (i = 0; environ[i]; i++) {
150 if ((eq = strchr(environ[i],'=')) &&
151 !strncmp(environ[i],uplnm,eq - environ[i])) {
153 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
154 if (!eqvlen) continue;
159 if (retsts != SS$_NOLOGNAM) break;
162 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
163 !str$case_blind_compare(&tmpdsc,&clisym)) {
164 if (!ivsym && !secure) {
165 unsigned short int deflen = LNM$C_NAMLENGTH;
166 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
167 /* dynamic dsc to accomodate possible long value */
168 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
169 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
172 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
174 /* Special hack--we might be called before the interpreter's */
175 /* fully initialized, in which case either thr or PL_curcop */
176 /* might be bogus. We have to check, since ckWARN needs them */
177 /* both to be valid if running threaded */
178 #if defined(USE_THREADS)
179 if (thr && PL_curcop) {
181 if (ckWARN(WARN_MISC)) {
182 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
184 #if defined(USE_THREADS)
186 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
191 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
193 _ckvmssts(lib$sfree1_dd(&eqvdsc));
194 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
195 if (retsts == LIB$_NOSUCHSYM) continue;
200 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
201 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
202 if (retsts == SS$_NOLOGNAM) continue;
206 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
207 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
208 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
209 retsts == SS$_NOLOGNAM) {
210 set_errno(EINVAL); set_vaxc_errno(retsts);
212 else _ckvmssts(retsts);
214 } /* end of vmstrnenv */
217 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
218 /* Define as a function so we can access statics. */
219 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
221 return vmstrnenv(lnm,eqv,idx,fildev,
222 #ifdef SECURE_INTERNAL_GETENV
223 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
232 * Note: Uses Perl temp to store result so char * can be returned to
233 * caller; this pointer will be invalidated at next Perl statement
235 * We define this as a function rather than a macro in terms of my_getenv_len()
236 * so that it'll work when PL_curinterp is undefined (and we therefore can't
239 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
241 my_getenv(const char *lnm, bool sys)
243 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
244 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
245 unsigned long int idx = 0;
249 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
250 /* Set up a temporary buffer for the return value; Perl will
251 * clean it up at the next statement transition */
252 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
253 if (!tmpsv) return NULL;
256 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
257 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
258 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
259 getcwd(eqv,LNM$C_NAMLENGTH);
263 if ((cp2 = strchr(lnm,';')) != NULL) {
265 uplnm[cp2-lnm] = '\0';
266 idx = strtoul(cp2+1,NULL,0);
269 if (vmstrnenv(lnm,eqv,idx,
271 #ifdef SECURE_INTERNAL_GETENV
272 sys ? PERL__TRNENV_SECURE : 0
280 } /* end of my_getenv() */
284 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
286 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
288 char *buf, *cp1, *cp2;
289 unsigned long idx = 0;
290 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
293 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
294 /* Set up a temporary buffer for the return value; Perl will
295 * clean it up at the next statement transition */
296 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
297 if (!tmpsv) return NULL;
300 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
301 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
302 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
303 getcwd(buf,LNM$C_NAMLENGTH);
308 if ((cp2 = strchr(lnm,';')) != NULL) {
311 idx = strtoul(cp2+1,NULL,0);
314 if ((*len = vmstrnenv(lnm,buf,idx,
316 #ifdef SECURE_INTERNAL_GETENV
317 sys ? PERL__TRNENV_SECURE : 0
327 } /* end of my_getenv_len() */
330 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
332 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
334 /*{{{ void prime_env_iter() */
337 /* Fill the %ENV associative array with all logical names we can
338 * find, in preparation for iterating over it.
342 static int primed = 0;
343 HV *seenhv = NULL, *envhv;
344 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
345 unsigned short int chan;
346 #ifndef CLI$M_TRUSTED
347 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
349 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
350 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
352 bool have_sym = FALSE, have_lnm = FALSE;
353 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
354 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
355 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
356 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
357 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
359 static perl_mutex primenv_mutex;
360 MUTEX_INIT(&primenv_mutex);
363 if (primed || !PL_envgv) return;
364 MUTEX_LOCK(&primenv_mutex);
365 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
366 envhv = GvHVn(PL_envgv);
367 /* Perform a dummy fetch as an lval to insure that the hash table is
368 * set up. Otherwise, the hv_store() will turn into a nullop. */
369 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
371 for (i = 0; env_tables[i]; i++) {
372 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
373 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
374 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
376 if (have_sym || have_lnm) {
377 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
378 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
379 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
380 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
383 for (i--; i >= 0; i--) {
384 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
387 for (j = 0; environ[j]; j++) {
388 if (!(start = strchr(environ[j],'='))) {
389 if (ckWARN(WARN_INTERNAL))
390 warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
394 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
400 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
401 !str$case_blind_compare(&tmpdsc,&clisym)) {
402 strcpy(cmd,"Show Symbol/Global *");
403 cmddsc.dsc$w_length = 20;
404 if (env_tables[i]->dsc$w_length == 12 &&
405 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
406 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
407 flags = defflags | CLI$M_NOLOGNAM;
410 strcpy(cmd,"Show Logical *");
411 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
412 strcat(cmd," /Table=");
413 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
414 cmddsc.dsc$w_length = strlen(cmd);
416 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
417 flags = defflags | CLI$M_NOCLISYM;
420 /* Create a new subprocess to execute each command, to exclude the
421 * remote possibility that someone could subvert a mbx or file used
422 * to write multiple commands to a single subprocess.
425 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
426 0,&riseandshine,0,0,&clidsc,&clitabdsc);
427 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
428 defflags &= ~CLI$M_TRUSTED;
429 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
431 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
432 if (seenhv) SvREFCNT_dec(seenhv);
435 char *cp1, *cp2, *key;
436 unsigned long int sts, iosb[2], retlen, keylen;
439 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
440 if (sts & 1) sts = iosb[0] & 0xffff;
441 if (sts == SS$_ENDOFFILE) {
443 while (substs == 0) { sys$hiber(); wakect++;}
444 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
449 retlen = iosb[0] >> 16;
450 if (!retlen) continue; /* blank line */
452 if (iosb[1] != subpid) {
454 croak("Unknown process %x sent message to prime_env_iter: %s",buf);
458 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
459 warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
461 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
462 if (*cp1 == '(' || /* Logical name table name */
463 *cp1 == '=' /* Next eqv of searchlist */) continue;
464 if (*cp1 == '"') cp1++;
465 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
466 key = cp1; keylen = cp2 - cp1;
467 if (keylen && hv_exists(seenhv,key,keylen)) continue;
468 while (*cp2 && *cp2 != '=') cp2++;
469 while (*cp2 && *cp2 != '"') cp2++;
470 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
471 if ((!keylen || (cp1 - cp2 <= 0)) && ckWARN(WARN_INTERNAL)) {
472 warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
475 /* Skip "" surrounding translation */
476 PERL_HASH(hash,key,keylen);
477 hv_store(envhv,key,keylen,newSVpv(cp2+1,cp1 - cp2 - 1),hash);
478 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
480 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
481 /* get the PPFs for this process, not the subprocess */
482 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
483 char eqv[LNM$C_NAMLENGTH+1];
485 for (i = 0; ppfs[i]; i++) {
486 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
487 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
492 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
493 if (buf) Safefree(buf);
494 if (seenhv) SvREFCNT_dec(seenhv);
495 MUTEX_UNLOCK(&primenv_mutex);
498 } /* end of prime_env_iter */
502 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
503 /* Define or delete an element in the same "environment" as
504 * vmstrnenv(). If an element is to be deleted, it's removed from
505 * the first place it's found. If it's to be set, it's set in the
506 * place designated by the first element of the table vector.
507 * Like setenv() returns 0 for success, non-zero on error.
510 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
512 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
513 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
514 unsigned long int retsts, usermode = PSL$C_USER;
515 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
516 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
517 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
518 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
519 $DESCRIPTOR(local,"_LOCAL");
521 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
522 *cp2 = _toupper(*cp1);
523 if (cp1 - lnm > LNM$C_NAMLENGTH) {
524 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
528 lnmdsc.dsc$w_length = cp1 - lnm;
529 if (!tabvec || !*tabvec) tabvec = env_tables;
531 if (!eqv) { /* we're deleting n element */
532 for (curtab = 0; tabvec[curtab]; curtab++) {
533 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
535 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
536 if ((cp1 = strchr(environ[i],'=')) &&
537 !strncmp(environ[i],lnm,cp1 - environ[i])) {
539 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
542 ivenv = 1; retsts = SS$_NOLOGNAM;
544 if (ckWARN(WARN_INTERNAL))
545 warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
546 ivenv = 1; retsts = SS$_NOSUCHPGM;
552 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
553 !str$case_blind_compare(&tmpdsc,&clisym)) {
554 unsigned int symtype;
555 if (tabvec[curtab]->dsc$w_length == 12 &&
556 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
557 !str$case_blind_compare(&tmpdsc,&local))
558 symtype = LIB$K_CLI_LOCAL_SYM;
559 else symtype = LIB$K_CLI_GLOBAL_SYM;
560 retsts = lib$delete_symbol(&lnmdsc,&symtype);
561 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
562 if (retsts == LIB$_NOSUCHSYM) continue;
566 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
567 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
568 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
569 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
570 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
574 else { /* we're defining a value */
575 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
577 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
579 if (ckWARN(WARN_INTERNAL))
580 warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
581 retsts = SS$_NOSUCHPGM;
585 eqvdsc.dsc$a_pointer = eqv;
586 eqvdsc.dsc$w_length = strlen(eqv);
587 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
588 !str$case_blind_compare(&tmpdsc,&clisym)) {
589 unsigned int symtype;
590 if (tabvec[0]->dsc$w_length == 12 &&
591 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
592 !str$case_blind_compare(&tmpdsc,&local))
593 symtype = LIB$K_CLI_LOCAL_SYM;
594 else symtype = LIB$K_CLI_GLOBAL_SYM;
595 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
598 if (!*eqv) eqvdsc.dsc$w_length = 1;
599 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
605 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
606 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
607 set_errno(EVMSERR); break;
608 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
609 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
610 set_errno(EINVAL); break;
617 set_vaxc_errno(retsts);
618 return (int) retsts || 44; /* retsts should never be 0, but just in case */
621 /* We reset error values on success because Perl does an hv_fetch()
622 * before each hv_store(), and if the thing we're setting didn't
623 * previously exist, we've got a leftover error message. (Of course,
624 * this fails in the face of
625 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
626 * in that the error reported in $! isn't spurious,
627 * but it's right more often than not.)
629 set_errno(0); set_vaxc_errno(retsts);
633 } /* end of vmssetenv() */
636 /*{{{ void my_setenv(char *lnm, char *eqv)*/
637 /* This has to be a function since there's a prototype for it in proto.h */
639 my_setenv(char *lnm,char *eqv)
641 if (lnm && *lnm && strlen(lnm) == 7) {
644 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
645 if (!strcmp(uplnm,"DEFAULT")) {
646 if (eqv && *eqv) chdir(eqv);
650 (void) vmssetenv(lnm,eqv,NULL);
656 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
657 /* my_crypt - VMS password hashing
658 * my_crypt() provides an interface compatible with the Unix crypt()
659 * C library function, and uses sys$hash_password() to perform VMS
660 * password hashing. The quadword hashed password value is returned
661 * as a NUL-terminated 8 character string. my_crypt() does not change
662 * the case of its string arguments; in order to match the behavior
663 * of LOGINOUT et al., alphabetic characters in both arguments must
664 * be upcased by the caller.
667 my_crypt(const char *textpasswd, const char *usrname)
669 # ifndef UAI$C_PREFERRED_ALGORITHM
670 # define UAI$C_PREFERRED_ALGORITHM 127
672 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
673 unsigned short int salt = 0;
674 unsigned long int sts;
676 unsigned short int dsc$w_length;
677 unsigned char dsc$b_type;
678 unsigned char dsc$b_class;
679 const char * dsc$a_pointer;
680 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
681 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
682 struct itmlst_3 uailst[3] = {
683 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
684 { sizeof salt, UAI$_SALT, &salt, 0},
685 { 0, 0, NULL, NULL}};
688 usrdsc.dsc$w_length = strlen(usrname);
689 usrdsc.dsc$a_pointer = usrname;
690 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
697 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
703 if (sts != RMS$_RNF) return NULL;
706 txtdsc.dsc$w_length = strlen(textpasswd);
707 txtdsc.dsc$a_pointer = textpasswd;
708 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
709 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
712 return (char *) hash;
714 } /* end of my_crypt() */
718 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
719 static char *do_fileify_dirspec(char *, char *, int);
720 static char *do_tovmsspec(char *, char *, int);
722 /*{{{int do_rmdir(char *name)*/
726 char dirfile[NAM$C_MAXRSS+1];
730 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
731 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
732 else retval = kill_file(dirfile);
735 } /* end of do_rmdir */
739 * Delete any file to which user has control access, regardless of whether
740 * delete access is explicitly allowed.
741 * Limitations: User must have write access to parent directory.
742 * Does not block signals or ASTs; if interrupted in midstream
743 * may leave file with an altered ACL.
746 /*{{{int kill_file(char *name)*/
748 kill_file(char *name)
750 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
751 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
752 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
753 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
755 unsigned char myace$b_length;
756 unsigned char myace$b_type;
757 unsigned short int myace$w_flags;
758 unsigned long int myace$l_access;
759 unsigned long int myace$l_ident;
760 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
761 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
762 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
764 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
765 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
766 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
767 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
768 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
769 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
771 /* Expand the input spec using RMS, since the CRTL remove() and
772 * system services won't do this by themselves, so we may miss
773 * a file "hiding" behind a logical name or search list. */
774 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
775 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
776 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
777 /* If not, can changing protections help? */
778 if (vaxc$errno != RMS$_PRV) return -1;
780 /* No, so we get our own UIC to use as a rights identifier,
781 * and the insert an ACE at the head of the ACL which allows us
782 * to delete the file.
784 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
785 fildsc.dsc$w_length = strlen(rspec);
786 fildsc.dsc$a_pointer = rspec;
788 newace.myace$l_ident = oldace.myace$l_ident;
789 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
794 case SS$_NOSUCHOBJECT:
795 set_errno(ENOENT); break;
797 set_errno(ENODEV); break;
799 case SS$_INVFILFOROP:
800 set_errno(EINVAL); break;
802 set_errno(EACCES); break;
806 set_vaxc_errno(aclsts);
809 /* Grab any existing ACEs with this identifier in case we fail */
810 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
811 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
812 || fndsts == SS$_NOMOREACE ) {
813 /* Add the new ACE . . . */
814 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
816 if ((rmsts = remove(name))) {
817 /* We blew it - dir with files in it, no write priv for
818 * parent directory, etc. Put things back the way they were. */
819 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
822 addlst[0].bufadr = &oldace;
823 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
830 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
831 /* We just deleted it, so of course it's not there. Some versions of
832 * VMS seem to return success on the unlock operation anyhow (after all
833 * the unlock is successful), but others don't.
835 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
836 if (aclsts & 1) aclsts = fndsts;
839 set_vaxc_errno(aclsts);
845 } /* end of kill_file() */
849 /*{{{int my_mkdir(char *,Mode_t)*/
851 my_mkdir(char *dir, Mode_t mode)
853 STRLEN dirlen = strlen(dir);
855 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
856 * null file name/type. However, it's commonplace under Unix,
857 * so we'll allow it for a gain in portability.
859 if (dir[dirlen-1] == '/') {
860 char *newdir = savepvn(dir,dirlen-1);
861 int ret = mkdir(newdir,mode);
865 else return mkdir(dir,mode);
866 } /* end of my_mkdir */
871 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
873 static unsigned long int mbxbufsiz;
874 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
878 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
879 * preprocessor consant BUFSIZ from stdio.h as the size of the
882 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
883 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
885 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
887 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
888 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
890 } /* end of create_mbx() */
892 /*{{{ my_popen and my_pclose*/
895 struct pipe_details *next;
896 PerlIO *fp; /* stdio file pointer to pipe mailbox */
897 int pid; /* PID of subprocess */
898 int mode; /* == 'r' if pipe open for reading */
899 int done; /* subprocess has completed */
900 unsigned long int completion; /* termination status of subprocess */
903 struct exit_control_block
905 struct exit_control_block *flink;
906 unsigned long int (*exit_routine)();
907 unsigned long int arg_count;
908 unsigned long int *status_address;
909 unsigned long int exit_status;
912 static struct pipe_details *open_pipes = NULL;
913 static $DESCRIPTOR(nl_desc, "NL:");
914 static int waitpid_asleep = 0;
916 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
917 * to a mbx; that's the caller's responsibility.
919 static unsigned long int
922 char devnam[NAM$C_MAXRSS+1], *cp;
923 unsigned long int chan, iosb[2], retsts, retsts2;
924 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
926 if (fgetname(fp,devnam,1)) {
927 /* It oughta be a mailbox, so fgetname should give just the device
928 * name, but just in case . . . */
929 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
930 devdsc.dsc$w_length = strlen(devnam);
931 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
932 retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
933 if (retsts & 1) retsts = iosb[0];
934 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
935 if (retsts & 1) retsts = retsts2;
939 else _ckvmssts(vaxc$errno); /* Should never happen */
940 return (unsigned long int) vaxc$errno;
943 static unsigned long int
946 struct pipe_details *info;
947 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
951 first we try sending an EOF...ignore if doesn't work, make sure we
958 if (info->mode != 'r' && !info->done) {
959 if (pipe_eof(info->fp) & 1) did_stuff = 1;
963 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
968 if (!info->done) { /* Tap them gently on the shoulder . . .*/
969 sts = sys$forcex(&info->pid,0,&abort);
970 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
975 if (did_stuff) sleep(1); /* wait for them to respond */
979 if (!info->done) { /* We tried to be nice . . . */
980 sts = sys$delprc(&info->pid,0);
981 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
982 info->done = 1; /* so my_pclose doesn't try to write EOF */
988 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
989 else if (!(sts & 1)) retsts = sts;
994 static struct exit_control_block pipe_exitblock =
995 {(struct exit_control_block *) 0,
996 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1000 popen_completion_ast(struct pipe_details *thispipe)
1002 thispipe->done = TRUE;
1003 if (waitpid_asleep) {
1010 safe_popen(char *cmd, char *mode)
1012 static int handler_set_up = FALSE;
1014 unsigned short int chan;
1015 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
1016 struct pipe_details *info;
1017 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1018 DSC$K_CLASS_S, mbxname},
1019 cmddsc = {0, DSC$K_DTYPE_T,
1023 cmddsc.dsc$w_length=strlen(cmd);
1024 cmddsc.dsc$a_pointer=cmd;
1025 if (cmddsc.dsc$w_length > 255) {
1026 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
1030 New(1301,info,1,struct pipe_details);
1032 /* create mailbox */
1033 create_mbx(&chan,&namdsc);
1035 /* open a FILE* onto it */
1036 info->fp = PerlIO_open(mbxname, mode);
1038 /* give up other channel onto it */
1039 _ckvmssts(sys$dassgn(chan));
1049 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1050 0 /* name */, &info->pid, &info->completion,
1051 0, popen_completion_ast,info,0,0,0));
1054 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1055 0 /* name */, &info->pid, &info->completion,
1056 0, popen_completion_ast,info,0,0,0));
1059 if (!handler_set_up) {
1060 _ckvmssts(sys$dclexh(&pipe_exitblock));
1061 handler_set_up = TRUE;
1063 info->next=open_pipes; /* prepend to list */
1066 PL_forkprocess = info->pid;
1068 } /* end of safe_popen */
1071 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1073 my_popen(char *cmd, char *mode)
1076 TAINT_PROPER("popen");
1077 PERL_FLUSHALL_FOR_CHILD;
1078 return safe_popen(cmd,mode);
1083 /*{{{ I32 my_pclose(FILE *fp)*/
1084 I32 my_pclose(FILE *fp)
1086 struct pipe_details *info, *last = NULL;
1087 unsigned long int retsts;
1089 for (info = open_pipes; info != NULL; last = info, info = info->next)
1090 if (info->fp == fp) break;
1092 if (info == NULL) { /* no such pipe open */
1093 set_errno(ECHILD); /* quoth POSIX */
1094 set_vaxc_errno(SS$_NONEXPR);
1098 /* If we were writing to a subprocess, insure that someone reading from
1099 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1100 * produce an EOF record in the mailbox. */
1101 if (info->mode != 'r' && !info->done) pipe_eof(info->fp);
1102 PerlIO_close(info->fp);
1104 if (info->done) retsts = info->completion;
1105 else waitpid(info->pid,(int *) &retsts,0);
1107 /* remove from list of open pipes */
1108 if (last) last->next = info->next;
1109 else open_pipes = info->next;
1114 } /* end of my_pclose() */
1116 /* sort-of waitpid; use only with popen() */
1117 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1119 my_waitpid(Pid_t pid, int *statusp, int flags)
1121 struct pipe_details *info;
1124 for (info = open_pipes; info != NULL; info = info->next)
1125 if (info->pid == pid) break;
1127 if (info != NULL) { /* we know about this child */
1128 while (!info->done) {
1133 *statusp = info->completion;
1136 else { /* we haven't heard of this child */
1137 $DESCRIPTOR(intdsc,"0 00:00:01");
1138 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1139 unsigned long int interval[2],sts;
1141 if (ckWARN(WARN_EXEC)) {
1142 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1143 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1144 if (ownerpid != mypid)
1145 warner(WARN_EXEC,"pid %x not a child",pid);
1148 _ckvmssts(sys$bintim(&intdsc,interval));
1149 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1150 _ckvmssts(sys$schdwk(0,0,interval,0));
1151 _ckvmssts(sys$hiber());
1155 /* There's no easy way to find the termination status a child we're
1156 * not aware of beforehand. If we're really interested in the future,
1157 * we can go looking for a termination mailbox, or chase after the
1158 * accounting record for the process.
1164 } /* end of waitpid() */
1169 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1171 my_gconvert(double val, int ndig, int trail, char *buf)
1173 static char __gcvtbuf[DBL_DIG+1];
1176 loc = buf ? buf : __gcvtbuf;
1178 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1180 sprintf(loc,"%.*g",ndig,val);
1186 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1187 return gcvt(val,ndig,loc);
1190 loc[0] = '0'; loc[1] = '\0';
1198 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1199 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1200 * to expand file specification. Allows for a single default file
1201 * specification and a simple mask of options. If outbuf is non-NULL,
1202 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1203 * the resultant file specification is placed. If outbuf is NULL, the
1204 * resultant file specification is placed into a static buffer.
1205 * The third argument, if non-NULL, is taken to be a default file
1206 * specification string. The fourth argument is unused at present.
1207 * rmesexpand() returns the address of the resultant string if
1208 * successful, and NULL on error.
1210 static char *do_tounixspec(char *, char *, int);
1213 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1215 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1216 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1217 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1218 struct FAB myfab = cc$rms_fab;
1219 struct NAM mynam = cc$rms_nam;
1221 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1223 if (!filespec || !*filespec) {
1224 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1228 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1229 else outbuf = __rmsexpand_retbuf;
1231 if ((isunix = (strchr(filespec,'/') != NULL))) {
1232 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1233 filespec = vmsfspec;
1236 myfab.fab$l_fna = filespec;
1237 myfab.fab$b_fns = strlen(filespec);
1238 myfab.fab$l_nam = &mynam;
1240 if (defspec && *defspec) {
1241 if (strchr(defspec,'/') != NULL) {
1242 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1245 myfab.fab$l_dna = defspec;
1246 myfab.fab$b_dns = strlen(defspec);
1249 mynam.nam$l_esa = esa;
1250 mynam.nam$b_ess = sizeof esa;
1251 mynam.nam$l_rsa = outbuf;
1252 mynam.nam$b_rss = NAM$C_MAXRSS;
1254 retsts = sys$parse(&myfab,0,0);
1255 if (!(retsts & 1)) {
1256 mynam.nam$b_nop |= NAM$M_SYNCHK;
1257 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1258 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1259 retsts = sys$parse(&myfab,0,0);
1260 if (retsts & 1) goto expanded;
1262 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1263 (void) sys$parse(&myfab,0,0); /* Free search context */
1264 if (out) Safefree(out);
1265 set_vaxc_errno(retsts);
1266 if (retsts == RMS$_PRV) set_errno(EACCES);
1267 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1268 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1269 else set_errno(EVMSERR);
1272 retsts = sys$search(&myfab,0,0);
1273 if (!(retsts & 1) && retsts != RMS$_FNF) {
1274 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1275 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1276 if (out) Safefree(out);
1277 set_vaxc_errno(retsts);
1278 if (retsts == RMS$_PRV) set_errno(EACCES);
1279 else set_errno(EVMSERR);
1283 /* If the input filespec contained any lowercase characters,
1284 * downcase the result for compatibility with Unix-minded code. */
1286 for (out = myfab.fab$l_fna; *out; out++)
1287 if (islower(*out)) { haslower = 1; break; }
1288 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1289 else { out = esa; speclen = mynam.nam$b_esl; }
1290 /* Trim off null fields added by $PARSE
1291 * If type > 1 char, must have been specified in original or default spec
1292 * (not true for version; $SEARCH may have added version of existing file).
1294 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1295 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1296 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1297 if (trimver || trimtype) {
1298 if (defspec && *defspec) {
1299 char defesa[NAM$C_MAXRSS];
1300 struct FAB deffab = cc$rms_fab;
1301 struct NAM defnam = cc$rms_nam;
1303 deffab.fab$l_nam = &defnam;
1304 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1305 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1306 defnam.nam$b_nop = NAM$M_SYNCHK;
1307 if (sys$parse(&deffab,0,0) & 1) {
1308 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1309 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1312 if (trimver) speclen = mynam.nam$l_ver - out;
1314 /* If we didn't already trim version, copy down */
1315 if (speclen > mynam.nam$l_ver - out)
1316 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1317 speclen - (mynam.nam$l_ver - out));
1318 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1321 /* If we just had a directory spec on input, $PARSE "helpfully"
1322 * adds an empty name and type for us */
1323 if (mynam.nam$l_name == mynam.nam$l_type &&
1324 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1325 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1326 speclen = mynam.nam$l_name - out;
1327 out[speclen] = '\0';
1328 if (haslower) __mystrtolower(out);
1330 /* Have we been working with an expanded, but not resultant, spec? */
1331 /* Also, convert back to Unix syntax if necessary. */
1332 if (!mynam.nam$b_rsl) {
1334 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1336 else strcpy(outbuf,esa);
1339 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1340 strcpy(outbuf,tmpfspec);
1342 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1343 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1344 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1348 /* External entry points */
1349 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1350 { return do_rmsexpand(spec,buf,0,def,opt); }
1351 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1352 { return do_rmsexpand(spec,buf,1,def,opt); }
1356 ** The following routines are provided to make life easier when
1357 ** converting among VMS-style and Unix-style directory specifications.
1358 ** All will take input specifications in either VMS or Unix syntax. On
1359 ** failure, all return NULL. If successful, the routines listed below
1360 ** return a pointer to a buffer containing the appropriately
1361 ** reformatted spec (and, therefore, subsequent calls to that routine
1362 ** will clobber the result), while the routines of the same names with
1363 ** a _ts suffix appended will return a pointer to a mallocd string
1364 ** containing the appropriately reformatted spec.
1365 ** In all cases, only explicit syntax is altered; no check is made that
1366 ** the resulting string is valid or that the directory in question
1369 ** fileify_dirspec() - convert a directory spec into the name of the
1370 ** directory file (i.e. what you can stat() to see if it's a dir).
1371 ** The style (VMS or Unix) of the result is the same as the style
1372 ** of the parameter passed in.
1373 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1374 ** what you prepend to a filename to indicate what directory it's in).
1375 ** The style (VMS or Unix) of the result is the same as the style
1376 ** of the parameter passed in.
1377 ** tounixpath() - convert a directory spec into a Unix-style path.
1378 ** tovmspath() - convert a directory spec into a VMS-style path.
1379 ** tounixspec() - convert any file spec into a Unix-style file spec.
1380 ** tovmsspec() - convert any file spec into a VMS-style spec.
1382 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1383 ** Permission is given to distribute this code as part of the Perl
1384 ** standard distribution under the terms of the GNU General Public
1385 ** License or the Perl Artistic License. Copies of each may be
1386 ** found in the Perl standard distribution.
1389 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1390 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1392 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1393 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1394 char *retspec, *cp1, *cp2, *lastdir;
1395 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1397 if (!dir || !*dir) {
1398 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1400 dirlen = strlen(dir);
1401 while (dir[dirlen-1] == '/') --dirlen;
1402 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1403 strcpy(trndir,"/sys$disk/000000");
1407 if (dirlen > NAM$C_MAXRSS) {
1408 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1410 if (!strpbrk(dir+1,"/]>:")) {
1411 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1412 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1414 dirlen = strlen(dir);
1417 strncpy(trndir,dir,dirlen);
1418 trndir[dirlen] = '\0';
1421 /* If we were handed a rooted logical name or spec, treat it like a
1422 * simple directory, so that
1423 * $ Define myroot dev:[dir.]
1424 * ... do_fileify_dirspec("myroot",buf,1) ...
1425 * does something useful.
1427 if (!strcmp(dir+dirlen-2,".]")) {
1428 dir[--dirlen] = '\0';
1429 dir[dirlen-1] = ']';
1432 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1433 /* If we've got an explicit filename, we can just shuffle the string. */
1434 if (*(cp1+1)) hasfilename = 1;
1435 /* Similarly, we can just back up a level if we've got multiple levels
1436 of explicit directories in a VMS spec which ends with directories. */
1438 for (cp2 = cp1; cp2 > dir; cp2--) {
1440 *cp2 = *cp1; *cp1 = '\0';
1444 if (*cp2 == '[' || *cp2 == '<') break;
1449 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1450 if (dir[0] == '.') {
1451 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1452 return do_fileify_dirspec("[]",buf,ts);
1453 else if (dir[1] == '.' &&
1454 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1455 return do_fileify_dirspec("[-]",buf,ts);
1457 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1458 dirlen -= 1; /* to last element */
1459 lastdir = strrchr(dir,'/');
1461 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1462 /* If we have "/." or "/..", VMSify it and let the VMS code
1463 * below expand it, rather than repeating the code to handle
1464 * relative components of a filespec here */
1466 if (*(cp1+2) == '.') cp1++;
1467 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1468 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1469 if (strchr(vmsdir,'/') != NULL) {
1470 /* If do_tovmsspec() returned it, it must have VMS syntax
1471 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1472 * the time to check this here only so we avoid a recursion
1473 * loop; otherwise, gigo.
1475 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1477 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1478 return do_tounixspec(trndir,buf,ts);
1481 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1482 lastdir = strrchr(dir,'/');
1484 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1485 /* Ditto for specs that end in an MFD -- let the VMS code
1486 * figure out whether it's a real device or a rooted logical. */
1487 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1488 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1489 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1490 return do_tounixspec(trndir,buf,ts);
1493 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1494 !(lastdir = cp1 = strrchr(dir,']')) &&
1495 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1496 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1498 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1499 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1500 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1501 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1502 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1503 (ver || *cp3)))))) {
1505 set_vaxc_errno(RMS$_DIR);
1511 /* If we lead off with a device or rooted logical, add the MFD
1512 if we're specifying a top-level directory. */
1513 if (lastdir && *dir == '/') {
1515 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1522 retlen = dirlen + (addmfd ? 13 : 6);
1523 if (buf) retspec = buf;
1524 else if (ts) New(1309,retspec,retlen+1,char);
1525 else retspec = __fileify_retbuf;
1527 dirlen = lastdir - dir;
1528 memcpy(retspec,dir,dirlen);
1529 strcpy(&retspec[dirlen],"/000000");
1530 strcpy(&retspec[dirlen+7],lastdir);
1533 memcpy(retspec,dir,dirlen);
1534 retspec[dirlen] = '\0';
1536 /* We've picked up everything up to the directory file name.
1537 Now just add the type and version, and we're set. */
1538 strcat(retspec,".dir;1");
1541 else { /* VMS-style directory spec */
1542 char esa[NAM$C_MAXRSS+1], term, *cp;
1543 unsigned long int sts, cmplen, haslower = 0;
1544 struct FAB dirfab = cc$rms_fab;
1545 struct NAM savnam, dirnam = cc$rms_nam;
1547 dirfab.fab$b_fns = strlen(dir);
1548 dirfab.fab$l_fna = dir;
1549 dirfab.fab$l_nam = &dirnam;
1550 dirfab.fab$l_dna = ".DIR;1";
1551 dirfab.fab$b_dns = 6;
1552 dirnam.nam$b_ess = NAM$C_MAXRSS;
1553 dirnam.nam$l_esa = esa;
1555 for (cp = dir; *cp; cp++)
1556 if (islower(*cp)) { haslower = 1; break; }
1557 if (!((sts = sys$parse(&dirfab))&1)) {
1558 if (dirfab.fab$l_sts == RMS$_DIR) {
1559 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1560 sts = sys$parse(&dirfab) & 1;
1564 set_vaxc_errno(dirfab.fab$l_sts);
1570 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1571 /* Yes; fake the fnb bits so we'll check type below */
1572 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1575 if (dirfab.fab$l_sts != RMS$_FNF) {
1577 set_vaxc_errno(dirfab.fab$l_sts);
1580 dirnam = savnam; /* No; just work with potential name */
1583 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1584 cp1 = strchr(esa,']');
1585 if (!cp1) cp1 = strchr(esa,'>');
1586 if (cp1) { /* Should always be true */
1587 dirnam.nam$b_esl -= cp1 - esa - 1;
1588 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1591 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1592 /* Yep; check version while we're at it, if it's there. */
1593 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1594 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1595 /* Something other than .DIR[;1]. Bzzt. */
1597 set_vaxc_errno(RMS$_DIR);
1601 esa[dirnam.nam$b_esl] = '\0';
1602 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1603 /* They provided at least the name; we added the type, if necessary, */
1604 if (buf) retspec = buf; /* in sys$parse() */
1605 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1606 else retspec = __fileify_retbuf;
1607 strcpy(retspec,esa);
1610 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1611 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1613 dirnam.nam$b_esl -= 9;
1615 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1616 if (cp1 == NULL) return NULL; /* should never happen */
1619 retlen = strlen(esa);
1620 if ((cp1 = strrchr(esa,'.')) != NULL) {
1621 /* There's more than one directory in the path. Just roll back. */
1623 if (buf) retspec = buf;
1624 else if (ts) New(1311,retspec,retlen+7,char);
1625 else retspec = __fileify_retbuf;
1626 strcpy(retspec,esa);
1629 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1630 /* Go back and expand rooted logical name */
1631 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1632 if (!(sys$parse(&dirfab) & 1)) {
1634 set_vaxc_errno(dirfab.fab$l_sts);
1637 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1638 if (buf) retspec = buf;
1639 else if (ts) New(1312,retspec,retlen+16,char);
1640 else retspec = __fileify_retbuf;
1641 cp1 = strstr(esa,"][");
1643 memcpy(retspec,esa,dirlen);
1644 if (!strncmp(cp1+2,"000000]",7)) {
1645 retspec[dirlen-1] = '\0';
1646 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1647 if (*cp1 == '.') *cp1 = ']';
1649 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1650 memcpy(cp1+1,"000000]",7);
1654 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1655 retspec[retlen] = '\0';
1656 /* Convert last '.' to ']' */
1657 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1658 if (*cp1 == '.') *cp1 = ']';
1660 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1661 memcpy(cp1+1,"000000]",7);
1665 else { /* This is a top-level dir. Add the MFD to the path. */
1666 if (buf) retspec = buf;
1667 else if (ts) New(1312,retspec,retlen+16,char);
1668 else retspec = __fileify_retbuf;
1671 while (*cp1 != ':') *(cp2++) = *(cp1++);
1672 strcpy(cp2,":[000000]");
1677 /* We've set up the string up through the filename. Add the
1678 type and version, and we're done. */
1679 strcat(retspec,".DIR;1");
1681 /* $PARSE may have upcased filespec, so convert output to lower
1682 * case if input contained any lowercase characters. */
1683 if (haslower) __mystrtolower(retspec);
1686 } /* end of do_fileify_dirspec() */
1688 /* External entry points */
1689 char *fileify_dirspec(char *dir, char *buf)
1690 { return do_fileify_dirspec(dir,buf,0); }
1691 char *fileify_dirspec_ts(char *dir, char *buf)
1692 { return do_fileify_dirspec(dir,buf,1); }
1694 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1695 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1697 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1698 unsigned long int retlen;
1699 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1701 if (!dir || !*dir) {
1702 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1705 if (*dir) strcpy(trndir,dir);
1706 else getcwd(trndir,sizeof trndir - 1);
1708 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1709 STRLEN trnlen = strlen(trndir);
1711 /* Trap simple rooted lnms, and return lnm:[000000] */
1712 if (!strcmp(trndir+trnlen-2,".]")) {
1713 if (buf) retpath = buf;
1714 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1715 else retpath = __pathify_retbuf;
1716 strcpy(retpath,dir);
1717 strcat(retpath,":[000000]");
1723 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1724 if (*dir == '.' && (*(dir+1) == '\0' ||
1725 (*(dir+1) == '.' && *(dir+2) == '\0')))
1726 retlen = 2 + (*(dir+1) != '\0');
1728 if ( !(cp1 = strrchr(dir,'/')) &&
1729 !(cp1 = strrchr(dir,']')) &&
1730 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1731 if ((cp2 = strchr(cp1,'.')) != NULL &&
1732 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1733 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1734 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1735 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
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);
1747 retlen = cp2 - dir + 1;
1749 else { /* No file type present. Treat the filename as a directory. */
1750 retlen = strlen(dir) + 1;
1753 if (buf) retpath = buf;
1754 else if (ts) New(1313,retpath,retlen+1,char);
1755 else retpath = __pathify_retbuf;
1756 strncpy(retpath,dir,retlen-1);
1757 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1758 retpath[retlen-1] = '/'; /* with '/', add it. */
1759 retpath[retlen] = '\0';
1761 else retpath[retlen-1] = '\0';
1763 else { /* VMS-style directory spec */
1764 char esa[NAM$C_MAXRSS+1], *cp;
1765 unsigned long int sts, cmplen, haslower;
1766 struct FAB dirfab = cc$rms_fab;
1767 struct NAM savnam, dirnam = cc$rms_nam;
1769 /* If we've got an explicit filename, we can just shuffle the string. */
1770 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1771 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1772 if ((cp2 = strchr(cp1,'.')) != NULL) {
1774 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1775 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1776 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1777 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1778 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1779 (ver || *cp3)))))) {
1781 set_vaxc_errno(RMS$_DIR);
1785 else { /* No file type, so just draw name into directory part */
1786 for (cp2 = cp1; *cp2; cp2++) ;
1789 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1791 /* We've now got a VMS 'path'; fall through */
1793 dirfab.fab$b_fns = strlen(dir);
1794 dirfab.fab$l_fna = dir;
1795 if (dir[dirfab.fab$b_fns-1] == ']' ||
1796 dir[dirfab.fab$b_fns-1] == '>' ||
1797 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1798 if (buf) retpath = buf;
1799 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1800 else retpath = __pathify_retbuf;
1801 strcpy(retpath,dir);
1804 dirfab.fab$l_dna = ".DIR;1";
1805 dirfab.fab$b_dns = 6;
1806 dirfab.fab$l_nam = &dirnam;
1807 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1808 dirnam.nam$l_esa = esa;
1810 for (cp = dir; *cp; cp++)
1811 if (islower(*cp)) { haslower = 1; break; }
1813 if (!(sts = (sys$parse(&dirfab)&1))) {
1814 if (dirfab.fab$l_sts == RMS$_DIR) {
1815 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1816 sts = sys$parse(&dirfab) & 1;
1820 set_vaxc_errno(dirfab.fab$l_sts);
1826 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1827 if (dirfab.fab$l_sts != RMS$_FNF) {
1829 set_vaxc_errno(dirfab.fab$l_sts);
1832 dirnam = savnam; /* No; just work with potential name */
1835 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1836 /* Yep; check version while we're at it, if it's there. */
1837 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1838 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1839 /* Something other than .DIR[;1]. Bzzt. */
1841 set_vaxc_errno(RMS$_DIR);
1845 /* OK, the type was fine. Now pull any file name into the
1847 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1849 cp1 = strrchr(esa,'>');
1850 *dirnam.nam$l_type = '>';
1853 *(dirnam.nam$l_type + 1) = '\0';
1854 retlen = dirnam.nam$l_type - esa + 2;
1855 if (buf) retpath = buf;
1856 else if (ts) New(1314,retpath,retlen,char);
1857 else retpath = __pathify_retbuf;
1858 strcpy(retpath,esa);
1859 /* $PARSE may have upcased filespec, so convert output to lower
1860 * case if input contained any lowercase characters. */
1861 if (haslower) __mystrtolower(retpath);
1865 } /* end of do_pathify_dirspec() */
1867 /* External entry points */
1868 char *pathify_dirspec(char *dir, char *buf)
1869 { return do_pathify_dirspec(dir,buf,0); }
1870 char *pathify_dirspec_ts(char *dir, char *buf)
1871 { return do_pathify_dirspec(dir,buf,1); }
1873 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1874 static char *do_tounixspec(char *spec, char *buf, int ts)
1876 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1877 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1878 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1880 if (spec == NULL) return NULL;
1881 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1882 if (buf) rslt = buf;
1884 retlen = strlen(spec);
1885 cp1 = strchr(spec,'[');
1886 if (!cp1) cp1 = strchr(spec,'<');
1888 for (cp1++; *cp1; cp1++) {
1889 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1890 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1891 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1894 New(1315,rslt,retlen+2+2*expand,char);
1896 else rslt = __tounixspec_retbuf;
1897 if (strchr(spec,'/') != NULL) {
1904 dirend = strrchr(spec,']');
1905 if (dirend == NULL) dirend = strrchr(spec,'>');
1906 if (dirend == NULL) dirend = strchr(spec,':');
1907 if (dirend == NULL) {
1911 if (*cp2 != '[' && *cp2 != '<') {
1914 else { /* the VMS spec begins with directories */
1916 if (*cp2 == ']' || *cp2 == '>') {
1917 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1920 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1921 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1922 if (ts) Safefree(rslt);
1927 while (*cp3 != ':' && *cp3) cp3++;
1929 if (strchr(cp3,']') != NULL) break;
1930 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1932 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1933 retlen = devlen + dirlen;
1934 Renew(rslt,retlen+1+2*expand,char);
1940 *(cp1++) = *(cp3++);
1941 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1945 else if ( *cp2 == '.') {
1946 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1947 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1953 for (; cp2 <= dirend; cp2++) {
1956 if (*(cp2+1) == '[') cp2++;
1958 else if (*cp2 == ']' || *cp2 == '>') {
1959 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1961 else if (*cp2 == '.') {
1963 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1964 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1965 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1966 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1967 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1969 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1970 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1974 else if (*cp2 == '-') {
1975 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1976 while (*cp2 == '-') {
1978 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1980 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1981 if (ts) Safefree(rslt); /* filespecs like */
1982 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
1986 else *(cp1++) = *cp2;
1988 else *(cp1++) = *cp2;
1990 while (*cp2) *(cp1++) = *(cp2++);
1995 } /* end of do_tounixspec() */
1997 /* External entry points */
1998 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
1999 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2001 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2002 static char *do_tovmsspec(char *path, char *buf, int ts) {
2003 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2004 char *rslt, *dirend;
2005 register char *cp1, *cp2;
2006 unsigned long int infront = 0, hasdir = 1;
2008 if (path == NULL) return NULL;
2009 if (buf) rslt = buf;
2010 else if (ts) New(1316,rslt,strlen(path)+9,char);
2011 else rslt = __tovmsspec_retbuf;
2012 if (strpbrk(path,"]:>") ||
2013 (dirend = strrchr(path,'/')) == NULL) {
2014 if (path[0] == '.') {
2015 if (path[1] == '\0') strcpy(rslt,"[]");
2016 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2017 else strcpy(rslt,path); /* probably garbage */
2019 else strcpy(rslt,path);
2022 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2023 if (!*(dirend+2)) dirend +=2;
2024 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2025 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2030 char trndev[NAM$C_MAXRSS+1];
2034 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2036 if (!buf & ts) Renew(rslt,18,char);
2037 strcpy(rslt,"sys$disk:[000000]");
2040 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2042 islnm = my_trnlnm(rslt,trndev,0);
2043 trnend = islnm ? strlen(trndev) - 1 : 0;
2044 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2045 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2046 /* If the first element of the path is a logical name, determine
2047 * whether it has to be translated so we can add more directories. */
2048 if (!islnm || rooted) {
2051 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2055 if (cp2 != dirend) {
2056 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2057 strcpy(rslt,trndev);
2058 cp1 = rslt + trnend;
2071 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2072 cp2 += 2; /* skip over "./" - it's redundant */
2073 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2075 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2076 *(cp1++) = '-'; /* "../" --> "-" */
2079 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2080 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2081 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2082 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2085 if (cp2 > dirend) cp2 = dirend;
2087 else *(cp1++) = '.';
2089 for (; cp2 < dirend; cp2++) {
2091 if (*(cp2-1) == '/') continue;
2092 if (*(cp1-1) != '.') *(cp1++) = '.';
2095 else if (!infront && *cp2 == '.') {
2096 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2097 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2098 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2099 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2100 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2101 else { /* back up over previous directory name */
2103 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2104 if (*(cp1-1) == '[') {
2105 memcpy(cp1,"000000.",7);
2110 if (cp2 == dirend) break;
2112 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2113 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2114 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2115 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2117 *(cp1++) = '.'; /* Simulate trailing '/' */
2118 cp2 += 2; /* for loop will incr this to == dirend */
2120 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2122 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2125 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2126 if (*cp2 == '.') *(cp1++) = '_';
2127 else *(cp1++) = *cp2;
2131 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2132 if (hasdir) *(cp1++) = ']';
2133 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2134 while (*cp2) *(cp1++) = *(cp2++);
2139 } /* end of do_tovmsspec() */
2141 /* External entry points */
2142 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2143 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2145 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2146 static char *do_tovmspath(char *path, char *buf, int ts) {
2147 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2149 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2151 if (path == NULL) return NULL;
2152 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2153 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2154 if (buf) return buf;
2156 vmslen = strlen(vmsified);
2157 New(1317,cp,vmslen+1,char);
2158 memcpy(cp,vmsified,vmslen);
2163 strcpy(__tovmspath_retbuf,vmsified);
2164 return __tovmspath_retbuf;
2167 } /* end of do_tovmspath() */
2169 /* External entry points */
2170 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2171 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2174 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2175 static char *do_tounixpath(char *path, char *buf, int ts) {
2176 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2178 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2180 if (path == NULL) return NULL;
2181 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2182 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2183 if (buf) return buf;
2185 unixlen = strlen(unixified);
2186 New(1317,cp,unixlen+1,char);
2187 memcpy(cp,unixified,unixlen);
2192 strcpy(__tounixpath_retbuf,unixified);
2193 return __tounixpath_retbuf;
2196 } /* end of do_tounixpath() */
2198 /* External entry points */
2199 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2200 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2203 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2205 *****************************************************************************
2207 * Copyright (C) 1989-1994 by *
2208 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2210 * Permission is hereby granted for the reproduction of this software, *
2211 * on condition that this copyright notice is included in the reproduction, *
2212 * and that such reproduction is not for purposes of profit or material *
2215 * 27-Aug-1994 Modified for inclusion in perl5 *
2216 * by Charles Bailey bailey@newman.upenn.edu *
2217 *****************************************************************************
2221 * getredirection() is intended to aid in porting C programs
2222 * to VMS (Vax-11 C). The native VMS environment does not support
2223 * '>' and '<' I/O redirection, or command line wild card expansion,
2224 * or a command line pipe mechanism using the '|' AND background
2225 * command execution '&'. All of these capabilities are provided to any
2226 * C program which calls this procedure as the first thing in the
2228 * The piping mechanism will probably work with almost any 'filter' type
2229 * of program. With suitable modification, it may useful for other
2230 * portability problems as well.
2232 * Author: Mark Pizzolato mark@infocomm.com
2236 struct list_item *next;
2240 static void add_item(struct list_item **head,
2241 struct list_item **tail,
2245 static void expand_wild_cards(char *item,
2246 struct list_item **head,
2247 struct list_item **tail,
2250 static int background_process(int argc, char **argv);
2252 static void pipe_and_fork(char **cmargv);
2254 /*{{{ void getredirection(int *ac, char ***av)*/
2256 getredirection(int *ac, char ***av)
2258 * Process vms redirection arg's. Exit if any error is seen.
2259 * If getredirection() processes an argument, it is erased
2260 * from the vector. getredirection() returns a new argc and argv value.
2261 * In the event that a background command is requested (by a trailing "&"),
2262 * this routine creates a background subprocess, and simply exits the program.
2264 * Warning: do not try to simplify the code for vms. The code
2265 * presupposes that getredirection() is called before any data is
2266 * read from stdin or written to stdout.
2268 * Normal usage is as follows:
2274 * getredirection(&argc, &argv);
2278 int argc = *ac; /* Argument Count */
2279 char **argv = *av; /* Argument Vector */
2280 char *ap; /* Argument pointer */
2281 int j; /* argv[] index */
2282 int item_count = 0; /* Count of Items in List */
2283 struct list_item *list_head = 0; /* First Item in List */
2284 struct list_item *list_tail; /* Last Item in List */
2285 char *in = NULL; /* Input File Name */
2286 char *out = NULL; /* Output File Name */
2287 char *outmode = "w"; /* Mode to Open Output File */
2288 char *err = NULL; /* Error File Name */
2289 char *errmode = "w"; /* Mode to Open Error File */
2290 int cmargc = 0; /* Piped Command Arg Count */
2291 char **cmargv = NULL;/* Piped Command Arg Vector */
2294 * First handle the case where the last thing on the line ends with
2295 * a '&'. This indicates the desire for the command to be run in a
2296 * subprocess, so we satisfy that desire.
2299 if (0 == strcmp("&", ap))
2300 exit(background_process(--argc, argv));
2301 if (*ap && '&' == ap[strlen(ap)-1])
2303 ap[strlen(ap)-1] = '\0';
2304 exit(background_process(argc, argv));
2307 * Now we handle the general redirection cases that involve '>', '>>',
2308 * '<', and pipes '|'.
2310 for (j = 0; j < argc; ++j)
2312 if (0 == strcmp("<", argv[j]))
2316 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2317 exit(LIB$_WRONUMARG);
2322 if ('<' == *(ap = argv[j]))
2327 if (0 == strcmp(">", ap))
2331 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2332 exit(LIB$_WRONUMARG);
2351 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2352 exit(LIB$_WRONUMARG);
2356 if (('2' == *ap) && ('>' == ap[1]))
2373 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2374 exit(LIB$_WRONUMARG);
2378 if (0 == strcmp("|", argv[j]))
2382 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2383 exit(LIB$_WRONUMARG);
2385 cmargc = argc-(j+1);
2386 cmargv = &argv[j+1];
2390 if ('|' == *(ap = argv[j]))
2398 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2401 * Allocate and fill in the new argument vector, Some Unix's terminate
2402 * the list with an extra null pointer.
2404 New(1302, argv, item_count+1, char *);
2406 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2407 argv[j] = list_head->value;
2413 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2414 exit(LIB$_INVARGORD);
2416 pipe_and_fork(cmargv);
2419 /* Check for input from a pipe (mailbox) */
2421 if (in == NULL && 1 == isapipe(0))
2423 char mbxname[L_tmpnam];
2425 long int dvi_item = DVI$_DEVBUFSIZ;
2426 $DESCRIPTOR(mbxnam, "");
2427 $DESCRIPTOR(mbxdevnam, "");
2429 /* Input from a pipe, reopen it in binary mode to disable */
2430 /* carriage control processing. */
2432 PerlIO_getname(stdin, mbxname);
2433 mbxnam.dsc$a_pointer = mbxname;
2434 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2435 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2436 mbxdevnam.dsc$a_pointer = mbxname;
2437 mbxdevnam.dsc$w_length = sizeof(mbxname);
2438 dvi_item = DVI$_DEVNAM;
2439 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2440 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2443 freopen(mbxname, "rb", stdin);
2446 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2450 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2452 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2455 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2457 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2462 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2464 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2468 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2473 #ifdef ARGPROC_DEBUG
2474 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2475 for (j = 0; j < *ac; ++j)
2476 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2478 /* Clear errors we may have hit expanding wildcards, so they don't
2479 show up in Perl's $! later */
2480 set_errno(0); set_vaxc_errno(1);
2481 } /* end of getredirection() */
2484 static void add_item(struct list_item **head,
2485 struct list_item **tail,
2491 New(1303,*head,1,struct list_item);
2495 New(1304,(*tail)->next,1,struct list_item);
2496 *tail = (*tail)->next;
2498 (*tail)->value = value;
2502 static void expand_wild_cards(char *item,
2503 struct list_item **head,
2504 struct list_item **tail,
2508 unsigned long int context = 0;
2514 char vmsspec[NAM$C_MAXRSS+1];
2515 $DESCRIPTOR(filespec, "");
2516 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2517 $DESCRIPTOR(resultspec, "");
2518 unsigned long int zero = 0, sts;
2520 for (cp = item; *cp; cp++) {
2521 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2522 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2524 if (!*cp || isspace(*cp))
2526 add_item(head, tail, item, count);
2529 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2530 resultspec.dsc$b_class = DSC$K_CLASS_D;
2531 resultspec.dsc$a_pointer = NULL;
2532 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2533 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2534 if (!isunix || !filespec.dsc$a_pointer)
2535 filespec.dsc$a_pointer = item;
2536 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2538 * Only return version specs, if the caller specified a version
2540 had_version = strchr(item, ';');
2542 * Only return device and directory specs, if the caller specifed either.
2544 had_device = strchr(item, ':');
2545 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2547 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2548 &defaultspec, 0, 0, &zero))))
2553 New(1305,string,resultspec.dsc$w_length+1,char);
2554 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2555 string[resultspec.dsc$w_length] = '\0';
2556 if (NULL == had_version)
2557 *((char *)strrchr(string, ';')) = '\0';
2558 if ((!had_directory) && (had_device == NULL))
2560 if (NULL == (devdir = strrchr(string, ']')))
2561 devdir = strrchr(string, '>');
2562 strcpy(string, devdir + 1);
2565 * Be consistent with what the C RTL has already done to the rest of
2566 * the argv items and lowercase all of these names.
2568 for (c = string; *c; ++c)
2571 if (isunix) trim_unixpath(string,item,1);
2572 add_item(head, tail, string, count);
2575 if (sts != RMS$_NMF)
2577 set_vaxc_errno(sts);
2583 set_errno(ENOENT); break;
2585 set_errno(ENODEV); break;
2588 set_errno(EINVAL); break;
2590 set_errno(EACCES); break;
2592 _ckvmssts_noperl(sts);
2596 add_item(head, tail, item, count);
2597 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2598 _ckvmssts_noperl(lib$find_file_end(&context));
2601 static int child_st[2];/* Event Flag set when child process completes */
2603 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2605 static unsigned long int exit_handler(int *status)
2609 if (0 == child_st[0])
2611 #ifdef ARGPROC_DEBUG
2612 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2614 fflush(stdout); /* Have to flush pipe for binary data to */
2615 /* terminate properly -- <tp@mccall.com> */
2616 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2617 sys$dassgn(child_chan);
2619 sys$synch(0, child_st);
2624 static void sig_child(int chan)
2626 #ifdef ARGPROC_DEBUG
2627 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2629 if (child_st[0] == 0)
2633 static struct exit_control_block exit_block =
2638 &exit_block.exit_status,
2642 static void pipe_and_fork(char **cmargv)
2645 $DESCRIPTOR(cmddsc, "");
2646 static char mbxname[64];
2647 $DESCRIPTOR(mbxdsc, mbxname);
2649 unsigned long int zero = 0, one = 1;
2651 strcpy(subcmd, cmargv[0]);
2652 for (j = 1; NULL != cmargv[j]; ++j)
2654 strcat(subcmd, " \"");
2655 strcat(subcmd, cmargv[j]);
2656 strcat(subcmd, "\"");
2658 cmddsc.dsc$a_pointer = subcmd;
2659 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2661 create_mbx(&child_chan,&mbxdsc);
2662 #ifdef ARGPROC_DEBUG
2663 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2664 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2666 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2667 0, &pid, child_st, &zero, sig_child,
2669 #ifdef ARGPROC_DEBUG
2670 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2672 sys$dclexh(&exit_block);
2673 if (NULL == freopen(mbxname, "wb", stdout))
2675 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2679 static int background_process(int argc, char **argv)
2681 char command[2048] = "$";
2682 $DESCRIPTOR(value, "");
2683 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2684 static $DESCRIPTOR(null, "NLA0:");
2685 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2687 $DESCRIPTOR(pidstr, "");
2689 unsigned long int flags = 17, one = 1, retsts;
2691 strcat(command, argv[0]);
2694 strcat(command, " \"");
2695 strcat(command, *(++argv));
2696 strcat(command, "\"");
2698 value.dsc$a_pointer = command;
2699 value.dsc$w_length = strlen(value.dsc$a_pointer);
2700 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2701 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2702 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2703 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2706 _ckvmssts_noperl(retsts);
2708 #ifdef ARGPROC_DEBUG
2709 PerlIO_printf(Perl_debug_log, "%s\n", command);
2711 sprintf(pidstring, "%08X", pid);
2712 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2713 pidstr.dsc$a_pointer = pidstring;
2714 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2715 lib$set_symbol(&pidsymbol, &pidstr);
2719 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2722 /* OS-specific initialization at image activation (not thread startup) */
2723 /* Older VAXC header files lack these constants */
2724 #ifndef JPI$_RIGHTS_SIZE
2725 # define JPI$_RIGHTS_SIZE 817
2727 #ifndef KGB$M_SUBSYSTEM
2728 # define KGB$M_SUBSYSTEM 0x8
2731 /*{{{void vms_image_init(int *, char ***)*/
2733 vms_image_init(int *argcp, char ***argvp)
2735 char eqv[LNM$C_NAMLENGTH+1] = "";
2736 unsigned int len, tabct = 8, tabidx = 0;
2737 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2738 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2739 unsigned short int dummy, rlen;
2740 struct dsc$descriptor_s **tabvec;
2741 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2742 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2743 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2746 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2748 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2749 if (iprv[i]) { /* Running image installed with privs? */
2750 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2755 /* Rights identifiers might trigger tainting as well. */
2756 if (!will_taint && (rlen || rsz)) {
2757 while (rlen < rsz) {
2758 /* We didn't get all the identifiers on the first pass. Allocate a
2759 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2760 * were needed to hold all identifiers at time of last call; we'll
2761 * allocate that many unsigned long ints), and go back and get 'em.
2763 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2764 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2765 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2766 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2769 mask = jpilist[1].bufadr;
2770 /* Check attribute flags for each identifier (2nd longword); protected
2771 * subsystem identifiers trigger tainting.
2773 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2774 if (mask[i] & KGB$M_SUBSYSTEM) {
2779 if (mask != rlst) Safefree(mask);
2781 /* We need to use this hack to tell Perl it should run with tainting,
2782 * since its tainting flag may be part of the PL_curinterp struct, which
2783 * hasn't been allocated when vms_image_init() is called.
2787 New(1320,newap,*argcp+2,char **);
2788 newap[0] = argvp[0];
2790 Copy(argvp[1],newap[2],*argcp-1,char **);
2791 /* We orphan the old argv, since we don't know where it's come from,
2792 * so we don't know how to free it.
2794 *argcp++; argvp = newap;
2796 else { /* Did user explicitly request tainting? */
2798 char *cp, **av = *argvp;
2799 for (i = 1; i < *argcp; i++) {
2800 if (*av[i] != '-') break;
2801 for (cp = av[i]+1; *cp; cp++) {
2802 if (*cp == 'T') { will_taint = 1; break; }
2803 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2804 strchr("DFIiMmx",*cp)) break;
2806 if (will_taint) break;
2811 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2813 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2814 else if (tabidx >= tabct) {
2816 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2818 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2819 tabvec[tabidx]->dsc$w_length = 0;
2820 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2821 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2822 tabvec[tabidx]->dsc$a_pointer = NULL;
2823 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2825 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2827 getredirection(argcp,argvp);
2828 #if defined(USE_THREADS) && defined(__DECC)
2830 # include <reentrancy.h>
2831 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2840 * Trim Unix-style prefix off filespec, so it looks like what a shell
2841 * glob expansion would return (i.e. from specified prefix on, not
2842 * full path). Note that returned filespec is Unix-style, regardless
2843 * of whether input filespec was VMS-style or Unix-style.
2845 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2846 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2847 * vector of options; at present, only bit 0 is used, and if set tells
2848 * trim unixpath to try the current default directory as a prefix when
2849 * presented with a possibly ambiguous ... wildcard.
2851 * Returns !=0 on success, with trimmed filespec replacing contents of
2852 * fspec, and 0 on failure, with contents of fpsec unchanged.
2854 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2856 trim_unixpath(char *fspec, char *wildspec, int opts)
2858 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2859 *template, *base, *end, *cp1, *cp2;
2860 register int tmplen, reslen = 0, dirs = 0;
2862 if (!wildspec || !fspec) return 0;
2863 if (strpbrk(wildspec,"]>:") != NULL) {
2864 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2865 else template = unixwild;
2867 else template = wildspec;
2868 if (strpbrk(fspec,"]>:") != NULL) {
2869 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2870 else base = unixified;
2871 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2872 * check to see that final result fits into (isn't longer than) fspec */
2873 reslen = strlen(fspec);
2877 /* No prefix or absolute path on wildcard, so nothing to remove */
2878 if (!*template || *template == '/') {
2879 if (base == fspec) return 1;
2880 tmplen = strlen(unixified);
2881 if (tmplen > reslen) return 0; /* not enough space */
2882 /* Copy unixified resultant, including trailing NUL */
2883 memmove(fspec,unixified,tmplen+1);
2887 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2888 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2889 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2890 for (cp1 = end ;cp1 >= base; cp1--)
2891 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2893 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2897 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2898 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2899 int ells = 1, totells, segdirs, match;
2900 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2901 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2903 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2905 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2906 if (ellipsis == template && opts & 1) {
2907 /* Template begins with an ellipsis. Since we can't tell how many
2908 * directory names at the front of the resultant to keep for an
2909 * arbitrary starting point, we arbitrarily choose the current
2910 * default directory as a starting point. If it's there as a prefix,
2911 * clip it off. If not, fall through and act as if the leading
2912 * ellipsis weren't there (i.e. return shortest possible path that
2913 * could match template).
2915 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2916 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2917 if (_tolower(*cp1) != _tolower(*cp2)) break;
2918 segdirs = dirs - totells; /* Min # of dirs we must have left */
2919 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2920 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2921 memcpy(fspec,cp2+1,end - cp2);
2925 /* First off, back up over constant elements at end of path */
2927 for (front = end ; front >= base; front--)
2928 if (*front == '/' && !dirs--) { front++; break; }
2930 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2931 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2932 if (cp1 != '\0') return 0; /* Path too long. */
2934 *cp2 = '\0'; /* Pick up with memcpy later */
2935 lcfront = lcres + (front - base);
2936 /* Now skip over each ellipsis and try to match the path in front of it. */
2938 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2939 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2940 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2941 if (cp1 < template) break; /* template started with an ellipsis */
2942 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2943 ellipsis = cp1; continue;
2945 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2947 for (segdirs = 0, cp2 = tpl;
2948 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2950 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2951 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2952 if (*cp2 == '/') segdirs++;
2954 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2955 /* Back up at least as many dirs as in template before matching */
2956 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2957 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2958 for (match = 0; cp1 > lcres;) {
2959 resdsc.dsc$a_pointer = cp1;
2960 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2962 if (match == 1) lcfront = cp1;
2964 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2966 if (!match) return 0; /* Can't find prefix ??? */
2967 if (match > 1 && opts & 1) {
2968 /* This ... wildcard could cover more than one set of dirs (i.e.
2969 * a set of similar dir names is repeated). If the template
2970 * contains more than 1 ..., upstream elements could resolve the
2971 * ambiguity, but it's not worth a full backtracking setup here.
2972 * As a quick heuristic, clip off the current default directory
2973 * if it's present to find the trimmed spec, else use the
2974 * shortest string that this ... could cover.
2976 char def[NAM$C_MAXRSS+1], *st;
2978 if (getcwd(def, sizeof def,0) == NULL) return 0;
2979 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2980 if (_tolower(*cp1) != _tolower(*cp2)) break;
2981 segdirs = dirs - totells; /* Min # of dirs we must have left */
2982 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
2983 if (*cp1 == '\0' && *cp2 == '/') {
2984 memcpy(fspec,cp2+1,end - cp2);
2987 /* Nope -- stick with lcfront from above and keep going. */
2990 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
2995 } /* end of trim_unixpath() */
3000 * VMS readdir() routines.
3001 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3003 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3004 * Minor modifications to original routines.
3007 /* Number of elements in vms_versions array */
3008 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3011 * Open a directory, return a handle for later use.
3013 /*{{{ DIR *opendir(char*name) */
3018 char dir[NAM$C_MAXRSS+1];
3021 if (do_tovmspath(name,dir,0) == NULL) {
3024 if (flex_stat(dir,&sb) == -1) return NULL;
3025 if (!S_ISDIR(sb.st_mode)) {
3026 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3029 if (!cando_by_name(S_IRUSR,0,dir)) {
3030 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3033 /* Get memory for the handle, and the pattern. */
3035 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3037 /* Fill in the fields; mainly playing with the descriptor. */
3038 (void)sprintf(dd->pattern, "%s*.*",dir);
3041 dd->vms_wantversions = 0;
3042 dd->pat.dsc$a_pointer = dd->pattern;
3043 dd->pat.dsc$w_length = strlen(dd->pattern);
3044 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3045 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3048 } /* end of opendir() */
3052 * Set the flag to indicate we want versions or not.
3054 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3056 vmsreaddirversions(DIR *dd, int flag)
3058 dd->vms_wantversions = flag;
3063 * Free up an opened directory.
3065 /*{{{ void closedir(DIR *dd)*/
3069 (void)lib$find_file_end(&dd->context);
3070 Safefree(dd->pattern);
3071 Safefree((char *)dd);
3076 * Collect all the version numbers for the current file.
3082 struct dsc$descriptor_s pat;
3083 struct dsc$descriptor_s res;
3085 char *p, *text, buff[sizeof dd->entry.d_name];
3087 unsigned long context, tmpsts;
3089 /* Convenient shorthand. */
3092 /* Add the version wildcard, ignoring the "*.*" put on before */
3093 i = strlen(dd->pattern);
3094 New(1308,text,i + e->d_namlen + 3,char);
3095 (void)strcpy(text, dd->pattern);
3096 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3098 /* Set up the pattern descriptor. */
3099 pat.dsc$a_pointer = text;
3100 pat.dsc$w_length = i + e->d_namlen - 1;
3101 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3102 pat.dsc$b_class = DSC$K_CLASS_S;
3104 /* Set up result descriptor. */
3105 res.dsc$a_pointer = buff;
3106 res.dsc$w_length = sizeof buff - 2;
3107 res.dsc$b_dtype = DSC$K_DTYPE_T;
3108 res.dsc$b_class = DSC$K_CLASS_S;
3110 /* Read files, collecting versions. */
3111 for (context = 0, e->vms_verscount = 0;
3112 e->vms_verscount < VERSIZE(e);
3113 e->vms_verscount++) {
3114 tmpsts = lib$find_file(&pat, &res, &context);
3115 if (tmpsts == RMS$_NMF || context == 0) break;
3117 buff[sizeof buff - 1] = '\0';
3118 if ((p = strchr(buff, ';')))
3119 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3121 e->vms_versions[e->vms_verscount] = -1;
3124 _ckvmssts(lib$find_file_end(&context));
3127 } /* end of collectversions() */
3130 * Read the next entry from the directory.
3132 /*{{{ struct dirent *readdir(DIR *dd)*/
3136 struct dsc$descriptor_s res;
3137 char *p, buff[sizeof dd->entry.d_name];
3138 unsigned long int tmpsts;
3140 /* Set up result descriptor, and get next file. */
3141 res.dsc$a_pointer = buff;
3142 res.dsc$w_length = sizeof buff - 2;
3143 res.dsc$b_dtype = DSC$K_DTYPE_T;
3144 res.dsc$b_class = DSC$K_CLASS_S;
3145 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3146 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3147 if (!(tmpsts & 1)) {
3148 set_vaxc_errno(tmpsts);
3151 set_errno(EACCES); break;
3153 set_errno(ENODEV); break;
3156 set_errno(ENOENT); break;
3163 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3164 buff[sizeof buff - 1] = '\0';
3165 for (p = buff; *p; p++) *p = _tolower(*p);
3166 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3169 /* Skip any directory component and just copy the name. */
3170 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3171 else (void)strcpy(dd->entry.d_name, buff);
3173 /* Clobber the version. */
3174 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3176 dd->entry.d_namlen = strlen(dd->entry.d_name);
3177 dd->entry.vms_verscount = 0;
3178 if (dd->vms_wantversions) collectversions(dd);
3181 } /* end of readdir() */
3185 * Return something that can be used in a seekdir later.
3187 /*{{{ long telldir(DIR *dd)*/
3196 * Return to a spot where we used to be. Brute force.
3198 /*{{{ void seekdir(DIR *dd,long count)*/
3200 seekdir(DIR *dd, long count)
3202 int vms_wantversions;
3204 /* If we haven't done anything yet... */
3208 /* Remember some state, and clear it. */
3209 vms_wantversions = dd->vms_wantversions;
3210 dd->vms_wantversions = 0;
3211 _ckvmssts(lib$find_file_end(&dd->context));
3214 /* The increment is in readdir(). */
3215 for (dd->count = 0; dd->count < count; )
3218 dd->vms_wantversions = vms_wantversions;
3220 } /* end of seekdir() */
3223 /* VMS subprocess management
3225 * my_vfork() - just a vfork(), after setting a flag to record that
3226 * the current script is trying a Unix-style fork/exec.
3228 * vms_do_aexec() and vms_do_exec() are called in response to the
3229 * perl 'exec' function. If this follows a vfork call, then they
3230 * call out the the regular perl routines in doio.c which do an
3231 * execvp (for those who really want to try this under VMS).
3232 * Otherwise, they do exactly what the perl docs say exec should
3233 * do - terminate the current script and invoke a new command
3234 * (See below for notes on command syntax.)
3236 * do_aspawn() and do_spawn() implement the VMS side of the perl
3237 * 'system' function.
3239 * Note on command arguments to perl 'exec' and 'system': When handled
3240 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3241 * are concatenated to form a DCL command string. If the first arg
3242 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3243 * the the command string is handed off to DCL directly. Otherwise,
3244 * the first token of the command is taken as the filespec of an image
3245 * to run. The filespec is expanded using a default type of '.EXE' and
3246 * the process defaults for device, directory, etc., and if found, the resultant
3247 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3248 * the command string as parameters. This is perhaps a bit complicated,
3249 * but I hope it will form a happy medium between what VMS folks expect
3250 * from lib$spawn and what Unix folks expect from exec.
3253 static int vfork_called;
3255 /*{{{int my_vfork()*/
3265 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3273 if (VMScmd.dsc$a_pointer) {
3274 Safefree(VMScmd.dsc$a_pointer);
3275 VMScmd.dsc$w_length = 0;
3276 VMScmd.dsc$a_pointer = Nullch;
3281 setup_argstr(SV *really, SV **mark, SV **sp)
3284 char *junk, *tmps = Nullch;
3285 register size_t cmdlen = 0;
3292 tmps = SvPV(really,rlen);
3299 for (idx++; idx <= sp; idx++) {
3301 junk = SvPVx(*idx,rlen);
3302 cmdlen += rlen ? rlen + 1 : 0;
3305 New(401,PL_Cmd,cmdlen+1,char);
3307 if (tmps && *tmps) {
3308 strcpy(PL_Cmd,tmps);
3311 else *PL_Cmd = '\0';
3312 while (++mark <= sp) {
3314 char *s = SvPVx(*mark,n_a);
3316 if (*PL_Cmd) strcat(PL_Cmd," ");
3322 } /* end of setup_argstr() */
3325 static unsigned long int
3326 setup_cmddsc(char *cmd, int check_img)
3328 char resspec[NAM$C_MAXRSS+1];
3329 $DESCRIPTOR(defdsc,".EXE");
3330 $DESCRIPTOR(resdsc,resspec);
3331 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3332 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3333 register char *s, *rest, *cp;
3334 register int isdcl = 0;
3337 while (*s && isspace(*s)) s++;
3339 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3340 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3341 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3342 if (*cp == ':' || *cp == '[' || *cp == '<') {
3352 while (*s && !isspace(*s)) s++;
3354 imgdsc.dsc$a_pointer = cmd;
3355 imgdsc.dsc$w_length = s - cmd;
3356 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3358 _ckvmssts(lib$find_file_end(&cxt));
3360 while (*s && !isspace(*s)) s++;
3362 if (cando_by_name(S_IXUSR,0,resspec)) {
3363 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3364 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3365 strcat(VMScmd.dsc$a_pointer,resspec);
3366 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3367 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3370 else retsts = RMS$_PRV;
3373 /* It's either a DCL command or we couldn't find a suitable image */
3374 VMScmd.dsc$w_length = strlen(cmd);
3375 if (cmd == PL_Cmd) {
3376 VMScmd.dsc$a_pointer = PL_Cmd;
3377 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3379 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3380 if (!(retsts & 1)) {
3381 /* just hand off status values likely to be due to user error */
3382 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3383 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3384 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3385 else { _ckvmssts(retsts); }
3388 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3390 } /* end of setup_cmddsc() */
3393 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3395 vms_do_aexec(SV *really,SV **mark,SV **sp)
3399 if (vfork_called) { /* this follows a vfork - act Unixish */
3401 if (vfork_called < 0) {
3402 warn("Internal inconsistency in tracking vforks");
3405 else return do_aexec(really,mark,sp);
3407 /* no vfork - act VMSish */
3408 return vms_do_exec(setup_argstr(really,mark,sp));
3413 } /* end of vms_do_aexec() */
3416 /* {{{bool vms_do_exec(char *cmd) */
3418 vms_do_exec(char *cmd)
3422 if (vfork_called) { /* this follows a vfork - act Unixish */
3424 if (vfork_called < 0) {
3425 warn("Internal inconsistency in tracking vforks");
3428 else return do_exec(cmd);
3431 { /* no vfork - act VMSish */
3432 unsigned long int retsts;
3435 TAINT_PROPER("exec");
3436 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3437 retsts = lib$do_command(&VMScmd);
3441 set_errno(ENOENT); break;
3442 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3443 set_errno(ENOTDIR); break;
3445 set_errno(EACCES); break;
3447 set_errno(EINVAL); break;
3449 set_errno(E2BIG); break;
3450 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3451 _ckvmssts(retsts); /* fall through */
3452 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3455 set_vaxc_errno(retsts);
3456 if (ckWARN(WARN_EXEC)) {
3457 warner(WARN_EXEC,"Can't exec \"%*s\": %s",
3458 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3465 } /* end of vms_do_exec() */
3468 unsigned long int do_spawn(char *);
3470 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3472 do_aspawn(void *really,void **mark,void **sp)
3475 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3478 } /* end of do_aspawn() */
3481 /* {{{unsigned long int do_spawn(char *cmd) */
3485 unsigned long int sts, substs, hadcmd = 1;
3489 TAINT_PROPER("spawn");
3490 if (!cmd || !*cmd) {
3492 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3494 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3495 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3501 set_errno(ENOENT); break;
3502 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3503 set_errno(ENOTDIR); break;
3505 set_errno(EACCES); break;
3507 set_errno(EINVAL); break;
3509 set_errno(E2BIG); break;
3510 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3511 _ckvmssts(sts); /* fall through */
3512 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3515 set_vaxc_errno(sts);
3516 if (ckWARN(WARN_EXEC)) {
3517 warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
3518 hadcmd ? VMScmd.dsc$w_length : 0,
3519 hadcmd ? VMScmd.dsc$a_pointer : "",
3526 } /* end of do_spawn() */
3530 * A simple fwrite replacement which outputs itmsz*nitm chars without
3531 * introducing record boundaries every itmsz chars.
3533 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3535 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3537 register char *cp, *end;
3539 end = (char *)src + itmsz * nitm;
3541 while ((char *)src <= end) {
3542 for (cp = src; cp <= end; cp++) if (!*cp) break;
3543 if (fputs(src,dest) == EOF) return EOF;
3545 if (fputc('\0',dest) == EOF) return EOF;
3551 } /* end of my_fwrite() */
3554 /*{{{ int my_flush(FILE *fp)*/
3559 if ((res = fflush(fp)) == 0) {
3560 #ifdef VMS_DO_SOCKETS
3562 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3564 res = fsync(fileno(fp));
3571 * Here are replacements for the following Unix routines in the VMS environment:
3572 * getpwuid Get information for a particular UIC or UID
3573 * getpwnam Get information for a named user
3574 * getpwent Get information for each user in the rights database
3575 * setpwent Reset search to the start of the rights database
3576 * endpwent Finish searching for users in the rights database
3578 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3579 * (defined in pwd.h), which contains the following fields:-
3581 * char *pw_name; Username (in lower case)
3582 * char *pw_passwd; Hashed password
3583 * unsigned int pw_uid; UIC
3584 * unsigned int pw_gid; UIC group number
3585 * char *pw_unixdir; Default device/directory (VMS-style)
3586 * char *pw_gecos; Owner name
3587 * char *pw_dir; Default device/directory (Unix-style)
3588 * char *pw_shell; Default CLI name (eg. DCL)
3590 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3592 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3593 * not the UIC member number (eg. what's returned by getuid()),
3594 * getpwuid() can accept either as input (if uid is specified, the caller's
3595 * UIC group is used), though it won't recognise gid=0.
3597 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3598 * information about other users in your group or in other groups, respectively.
3599 * If the required privilege is not available, then these routines fill only
3600 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3603 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3606 /* sizes of various UAF record fields */
3607 #define UAI$S_USERNAME 12
3608 #define UAI$S_IDENT 31
3609 #define UAI$S_OWNER 31
3610 #define UAI$S_DEFDEV 31
3611 #define UAI$S_DEFDIR 63
3612 #define UAI$S_DEFCLI 31
3615 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3616 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3617 (uic).uic$v_group != UIC$K_WILD_GROUP)
3619 static char __empty[]= "";
3620 static struct passwd __passwd_empty=
3621 {(char *) __empty, (char *) __empty, 0, 0,
3622 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3623 static int contxt= 0;
3624 static struct passwd __pwdcache;
3625 static char __pw_namecache[UAI$S_IDENT+1];
3628 * This routine does most of the work extracting the user information.
3630 static int fillpasswd (const char *name, struct passwd *pwd)
3633 unsigned char length;
3634 char pw_gecos[UAI$S_OWNER+1];
3636 static union uicdef uic;
3638 unsigned char length;
3639 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3642 unsigned char length;
3643 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3646 unsigned char length;
3647 char pw_shell[UAI$S_DEFCLI+1];
3649 static char pw_passwd[UAI$S_PWD+1];
3651 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3652 struct dsc$descriptor_s name_desc;
3653 unsigned long int sts;
3655 static struct itmlst_3 itmlst[]= {
3656 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3657 {sizeof(uic), UAI$_UIC, &uic, &luic},
3658 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3659 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3660 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3661 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3662 {0, 0, NULL, NULL}};
3664 name_desc.dsc$w_length= strlen(name);
3665 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3666 name_desc.dsc$b_class= DSC$K_CLASS_S;
3667 name_desc.dsc$a_pointer= (char *) name;
3669 /* Note that sys$getuai returns many fields as counted strings. */
3670 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3671 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3672 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3674 else { _ckvmssts(sts); }
3675 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3677 if ((int) owner.length < lowner) lowner= (int) owner.length;
3678 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3679 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3680 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3681 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3682 owner.pw_gecos[lowner]= '\0';
3683 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3684 defcli.pw_shell[ldefcli]= '\0';
3685 if (valid_uic(uic)) {
3686 pwd->pw_uid= uic.uic$l_uic;
3687 pwd->pw_gid= uic.uic$v_group;
3690 warn("getpwnam returned invalid UIC %#o for user \"%s\"");
3691 pwd->pw_passwd= pw_passwd;
3692 pwd->pw_gecos= owner.pw_gecos;
3693 pwd->pw_dir= defdev.pw_dir;
3694 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3695 pwd->pw_shell= defcli.pw_shell;
3696 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3698 ldir= strlen(pwd->pw_unixdir) - 1;
3699 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3702 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3703 __mystrtolower(pwd->pw_unixdir);
3708 * Get information for a named user.
3710 /*{{{struct passwd *getpwnam(char *name)*/
3711 struct passwd *my_getpwnam(char *name)
3713 struct dsc$descriptor_s name_desc;
3715 unsigned long int status, sts;
3717 __pwdcache = __passwd_empty;
3718 if (!fillpasswd(name, &__pwdcache)) {
3719 /* We still may be able to determine pw_uid and pw_gid */
3720 name_desc.dsc$w_length= strlen(name);
3721 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3722 name_desc.dsc$b_class= DSC$K_CLASS_S;
3723 name_desc.dsc$a_pointer= (char *) name;
3724 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3725 __pwdcache.pw_uid= uic.uic$l_uic;
3726 __pwdcache.pw_gid= uic.uic$v_group;
3729 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3730 set_vaxc_errno(sts);
3731 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3734 else { _ckvmssts(sts); }
3737 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3738 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3739 __pwdcache.pw_name= __pw_namecache;
3741 } /* end of my_getpwnam() */
3745 * Get information for a particular UIC or UID.
3746 * Called by my_getpwent with uid=-1 to list all users.
3748 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3749 struct passwd *my_getpwuid(Uid_t uid)
3751 const $DESCRIPTOR(name_desc,__pw_namecache);
3752 unsigned short lname;
3754 unsigned long int status;
3756 if (uid == (unsigned int) -1) {
3758 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3759 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3760 set_vaxc_errno(status);
3761 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3765 else { _ckvmssts(status); }
3766 } while (!valid_uic (uic));
3770 if (!uic.uic$v_group)
3771 uic.uic$v_group= PerlProc_getgid();
3773 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3774 else status = SS$_IVIDENT;
3775 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3776 status == RMS$_PRV) {
3777 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3780 else { _ckvmssts(status); }
3782 __pw_namecache[lname]= '\0';
3783 __mystrtolower(__pw_namecache);
3785 __pwdcache = __passwd_empty;
3786 __pwdcache.pw_name = __pw_namecache;
3788 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3789 The identifier's value is usually the UIC, but it doesn't have to be,
3790 so if we can, we let fillpasswd update this. */
3791 __pwdcache.pw_uid = uic.uic$l_uic;
3792 __pwdcache.pw_gid = uic.uic$v_group;
3794 fillpasswd(__pw_namecache, &__pwdcache);
3797 } /* end of my_getpwuid() */
3801 * Get information for next user.
3803 /*{{{struct passwd *my_getpwent()*/
3804 struct passwd *my_getpwent()
3806 return (my_getpwuid((unsigned int) -1));
3811 * Finish searching rights database for users.
3813 /*{{{void my_endpwent()*/
3817 _ckvmssts(sys$finish_rdb(&contxt));
3823 #ifdef HOMEGROWN_POSIX_SIGNALS
3824 /* Signal handling routines, pulled into the core from POSIX.xs.
3826 * We need these for threads, so they've been rolled into the core,
3827 * rather than left in POSIX.xs.
3829 * (DRS, Oct 23, 1997)
3832 /* sigset_t is atomic under VMS, so these routines are easy */
3833 /*{{{int my_sigemptyset(sigset_t *) */
3834 int my_sigemptyset(sigset_t *set) {
3835 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3841 /*{{{int my_sigfillset(sigset_t *)*/
3842 int my_sigfillset(sigset_t *set) {
3844 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3845 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3851 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3852 int my_sigaddset(sigset_t *set, int sig) {
3853 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3854 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3855 *set |= (1 << (sig - 1));
3861 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3862 int my_sigdelset(sigset_t *set, int sig) {
3863 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3864 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3865 *set &= ~(1 << (sig - 1));
3871 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3872 int my_sigismember(sigset_t *set, int sig) {
3873 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3874 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3875 *set & (1 << (sig - 1));
3880 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3881 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3884 /* If set and oset are both null, then things are badly wrong. Bail out. */
3885 if ((oset == NULL) && (set == NULL)) {
3886 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3890 /* If set's null, then we're just handling a fetch. */
3892 tempmask = sigblock(0);
3897 tempmask = sigsetmask(*set);
3900 tempmask = sigblock(*set);
3903 tempmask = sigblock(0);
3904 sigsetmask(*oset & ~tempmask);
3907 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3912 /* Did they pass us an oset? If so, stick our holding mask into it */
3919 #endif /* HOMEGROWN_POSIX_SIGNALS */
3922 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3923 * my_utime(), and flex_stat(), all of which operate on UTC unless
3924 * VMSISH_TIMES is true.
3926 /* method used to handle UTC conversions:
3927 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3929 static int gmtime_emulation_type;
3930 /* number of secs to add to UTC POSIX-style time to get local time */
3931 static long int utc_offset_secs;
3933 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3934 * in vmsish.h. #undef them here so we can call the CRTL routines
3941 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3942 # define RTL_USES_UTC 1
3945 static time_t toutc_dst(time_t loc) {
3948 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3949 loc -= utc_offset_secs;
3950 if (rsltmp->tm_isdst) loc -= 3600;
3953 #define _toutc(secs) ((secs) == -1 ? -1 : \
3954 ((gmtime_emulation_type || my_time(NULL)), \
3955 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3956 ((secs) - utc_offset_secs))))
3958 static time_t toloc_dst(time_t utc) {
3961 utc += utc_offset_secs;
3962 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3963 if (rsltmp->tm_isdst) utc += 3600;
3966 #define _toloc(secs) ((secs) == -1 ? -1 : \
3967 ((gmtime_emulation_type || my_time(NULL)), \
3968 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3969 ((secs) + utc_offset_secs))))
3972 /* my_time(), my_localtime(), my_gmtime()
3973 * By default traffic in UTC time values, using CRTL gmtime() or
3974 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3975 * Note: We need to use these functions even when the CRTL has working
3976 * UTC support, since they also handle C<use vmsish qw(times);>
3978 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
3979 * Modified by Charles Bailey <bailey@newman.upenn.edu>
3982 /*{{{time_t my_time(time_t *timep)*/
3983 time_t my_time(time_t *timep)
3989 if (gmtime_emulation_type == 0) {
3991 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
3992 /* results of calls to gmtime() and localtime() */
3993 /* for same &base */
3995 gmtime_emulation_type++;
3996 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
3997 char off[LNM$C_NAMLENGTH+1];;
3999 gmtime_emulation_type++;
4000 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4001 gmtime_emulation_type++;
4002 warn("no UTC offset information; assuming local time is UTC");
4004 else { utc_offset_secs = atol(off); }
4006 else { /* We've got a working gmtime() */
4007 struct tm gmt, local;
4010 tm_p = localtime(&base);
4012 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4013 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4014 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4015 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4021 # ifdef RTL_USES_UTC
4022 if (VMSISH_TIME) when = _toloc(when);
4024 if (!VMSISH_TIME) when = _toutc(when);
4027 if (timep != NULL) *timep = when;
4030 } /* end of my_time() */
4034 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4036 my_gmtime(const time_t *timep)
4043 if (timep == NULL) {
4044 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4047 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4051 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4053 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4054 return gmtime(&when);
4056 /* CRTL localtime() wants local time as input, so does no tz correction */
4057 rsltmp = localtime(&when);
4058 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4061 } /* end of my_gmtime() */
4065 /*{{{struct tm *my_localtime(const time_t *timep)*/
4067 my_localtime(const time_t *timep)
4073 if (timep == NULL) {
4074 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4077 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4078 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4081 # ifdef RTL_USES_UTC
4083 if (VMSISH_TIME) when = _toutc(when);
4085 /* CRTL localtime() wants UTC as input, does tz correction itself */
4086 return localtime(&when);
4089 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4092 /* CRTL localtime() wants local time as input, so does no tz correction */
4093 rsltmp = localtime(&when);
4094 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4097 } /* end of my_localtime() */
4100 /* Reset definitions for later calls */
4101 #define gmtime(t) my_gmtime(t)
4102 #define localtime(t) my_localtime(t)
4103 #define time(t) my_time(t)
4106 /* my_utime - update modification time of a file
4107 * calling sequence is identical to POSIX utime(), but under
4108 * VMS only the modification time is changed; ODS-2 does not
4109 * maintain access times. Restrictions differ from the POSIX
4110 * definition in that the time can be changed as long as the
4111 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4112 * no separate checks are made to insure that the caller is the
4113 * owner of the file or has special privs enabled.
4114 * Code here is based on Joe Meadows' FILE utility.
4117 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4118 * to VMS epoch (01-JAN-1858 00:00:00.00)
4119 * in 100 ns intervals.
4121 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4123 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4124 int my_utime(char *file, struct utimbuf *utimes)
4128 long int bintime[2], len = 2, lowbit, unixtime,
4129 secscale = 10000000; /* seconds --> 100 ns intervals */
4130 unsigned long int chan, iosb[2], retsts;
4131 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4132 struct FAB myfab = cc$rms_fab;
4133 struct NAM mynam = cc$rms_nam;
4134 #if defined (__DECC) && defined (__VAX)
4135 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4136 * at least through VMS V6.1, which causes a type-conversion warning.
4138 # pragma message save
4139 # pragma message disable cvtdiftypes
4141 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4142 struct fibdef myfib;
4143 #if defined (__DECC) && defined (__VAX)
4144 /* This should be right after the declaration of myatr, but due
4145 * to a bug in VAX DEC C, this takes effect a statement early.
4147 # pragma message restore
4149 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4150 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4151 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4153 if (file == NULL || *file == '\0') {
4155 set_vaxc_errno(LIB$_INVARG);
4158 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4160 if (utimes != NULL) {
4161 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4162 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4163 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4164 * as input, we force the sign bit to be clear by shifting unixtime right
4165 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4167 lowbit = (utimes->modtime & 1) ? secscale : 0;
4168 unixtime = (long int) utimes->modtime;
4170 /* If input was UTC; convert to local for sys svc */
4171 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4173 unixtime >> 1; secscale << 1;
4174 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4175 if (!(retsts & 1)) {
4177 set_vaxc_errno(retsts);
4180 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4181 if (!(retsts & 1)) {
4183 set_vaxc_errno(retsts);
4188 /* Just get the current time in VMS format directly */
4189 retsts = sys$gettim(bintime);
4190 if (!(retsts & 1)) {
4192 set_vaxc_errno(retsts);
4197 myfab.fab$l_fna = vmsspec;
4198 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4199 myfab.fab$l_nam = &mynam;
4200 mynam.nam$l_esa = esa;
4201 mynam.nam$b_ess = (unsigned char) sizeof esa;
4202 mynam.nam$l_rsa = rsa;
4203 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4205 /* Look for the file to be affected, letting RMS parse the file
4206 * specification for us as well. I have set errno using only
4207 * values documented in the utime() man page for VMS POSIX.
4209 retsts = sys$parse(&myfab,0,0);
4210 if (!(retsts & 1)) {
4211 set_vaxc_errno(retsts);
4212 if (retsts == RMS$_PRV) set_errno(EACCES);
4213 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4214 else set_errno(EVMSERR);
4217 retsts = sys$search(&myfab,0,0);
4218 if (!(retsts & 1)) {
4219 set_vaxc_errno(retsts);
4220 if (retsts == RMS$_PRV) set_errno(EACCES);
4221 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4222 else set_errno(EVMSERR);
4226 devdsc.dsc$w_length = mynam.nam$b_dev;
4227 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4229 retsts = sys$assign(&devdsc,&chan,0,0);
4230 if (!(retsts & 1)) {
4231 set_vaxc_errno(retsts);
4232 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4233 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4234 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4235 else set_errno(EVMSERR);
4239 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4240 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4242 memset((void *) &myfib, 0, sizeof myfib);
4244 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4245 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4246 /* This prevents the revision time of the file being reset to the current
4247 * time as a result of our IO$_MODIFY $QIO. */
4248 myfib.fib$l_acctl = FIB$M_NORECORD;
4250 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4251 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4252 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4254 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4255 _ckvmssts(sys$dassgn(chan));
4256 if (retsts & 1) retsts = iosb[0];
4257 if (!(retsts & 1)) {
4258 set_vaxc_errno(retsts);
4259 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4260 else set_errno(EVMSERR);
4265 } /* end of my_utime() */
4269 * flex_stat, flex_fstat
4270 * basic stat, but gets it right when asked to stat
4271 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4274 /* encode_dev packs a VMS device name string into an integer to allow
4275 * simple comparisons. This can be used, for example, to check whether two
4276 * files are located on the same device, by comparing their encoded device
4277 * names. Even a string comparison would not do, because stat() reuses the
4278 * device name buffer for each call; so without encode_dev, it would be
4279 * necessary to save the buffer and use strcmp (this would mean a number of
4280 * changes to the standard Perl code, to say nothing of what a Perl script
4283 * The device lock id, if it exists, should be unique (unless perhaps compared
4284 * with lock ids transferred from other nodes). We have a lock id if the disk is
4285 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4286 * device names. Thus we use the lock id in preference, and only if that isn't
4287 * available, do we try to pack the device name into an integer (flagged by
4288 * the sign bit (LOCKID_MASK) being set).
4290 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4291 * name and its encoded form, but it seems very unlikely that we will find
4292 * two files on different disks that share the same encoded device names,
4293 * and even more remote that they will share the same file id (if the test
4294 * is to check for the same file).
4296 * A better method might be to use sys$device_scan on the first call, and to
4297 * search for the device, returning an index into the cached array.
4298 * The number returned would be more intelligable.
4299 * This is probably not worth it, and anyway would take quite a bit longer
4300 * on the first call.
4302 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4303 static mydev_t encode_dev (const char *dev)
4306 unsigned long int f;
4311 if (!dev || !dev[0]) return 0;
4315 struct dsc$descriptor_s dev_desc;
4316 unsigned long int status, lockid, item = DVI$_LOCKID;
4318 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4319 can try that first. */
4320 dev_desc.dsc$w_length = strlen (dev);
4321 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4322 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4323 dev_desc.dsc$a_pointer = (char *) dev;
4324 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4325 if (lockid) return (lockid & ~LOCKID_MASK);
4329 /* Otherwise we try to encode the device name */
4333 for (q = dev + strlen(dev); q--; q >= dev) {
4336 else if (isalpha (toupper (*q)))
4337 c= toupper (*q) - 'A' + (char)10;
4339 continue; /* Skip '$'s */
4341 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4343 enc += f * (unsigned long int) c;
4345 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4347 } /* end of encode_dev() */
4349 static char namecache[NAM$C_MAXRSS+1];
4352 is_null_device(name)
4355 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4356 The underscore prefix, controller letter, and unit number are
4357 independently optional; for our purposes, the colon punctuation
4358 is not. The colon can be trailed by optional directory and/or
4359 filename, but two consecutive colons indicates a nodename rather
4360 than a device. [pr] */
4361 if (*name == '_') ++name;
4362 if (tolower(*name++) != 'n') return 0;
4363 if (tolower(*name++) != 'l') return 0;
4364 if (tolower(*name) == 'a') ++name;
4365 if (*name == '0') ++name;
4366 return (*name++ == ':') && (*name != ':');
4369 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4370 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4371 * subset of the applicable information.
4373 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
4375 cando(I32 bit, I32 effective, Stat_t *statbufp)
4378 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4380 char fname[NAM$C_MAXRSS+1];
4381 unsigned long int retsts;
4382 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4383 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4385 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4386 device name on successive calls */
4387 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4388 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4389 namdsc.dsc$a_pointer = fname;
4390 namdsc.dsc$w_length = sizeof fname - 1;
4392 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4393 &namdsc,&namdsc.dsc$w_length,0,0);
4395 fname[namdsc.dsc$w_length] = '\0';
4396 return cando_by_name(bit,effective,fname);
4398 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4399 warn("Can't get filespec - stale stat buffer?\n");
4403 return FALSE; /* Should never get to here */
4405 } /* end of cando() */
4409 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
4411 cando_by_name(I32 bit, I32 effective, char *fname)
4413 static char usrname[L_cuserid];
4414 static struct dsc$descriptor_s usrdsc =
4415 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4416 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4417 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4418 unsigned short int retlen;
4419 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4420 union prvdef curprv;
4421 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4422 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4423 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4426 if (!fname || !*fname) return FALSE;
4427 /* Make sure we expand logical names, since sys$check_access doesn't */
4428 if (!strpbrk(fname,"/]>:")) {
4429 strcpy(fileified,fname);
4430 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4433 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4434 retlen = namdsc.dsc$w_length = strlen(vmsname);
4435 namdsc.dsc$a_pointer = vmsname;
4436 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4437 vmsname[retlen-1] == ':') {
4438 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4439 namdsc.dsc$w_length = strlen(fileified);
4440 namdsc.dsc$a_pointer = fileified;
4443 if (!usrdsc.dsc$w_length) {
4445 usrdsc.dsc$w_length = strlen(usrname);
4452 access = ARM$M_EXECUTE;
4457 access = ARM$M_READ;
4462 access = ARM$M_WRITE;
4467 access = ARM$M_DELETE;
4473 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4474 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4475 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4476 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4477 set_vaxc_errno(retsts);
4478 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4479 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4480 else set_errno(ENOENT);
4483 if (retsts == SS$_NORMAL) {
4484 if (!privused) return TRUE;
4485 /* We can get access, but only by using privs. Do we have the
4486 necessary privs currently enabled? */
4487 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4488 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4489 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4490 !curprv.prv$v_bypass) return FALSE;
4491 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4492 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4493 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4496 if (retsts == SS$_ACCONFLICT) {
4501 return FALSE; /* Should never get here */
4503 } /* end of cando_by_name() */
4507 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4509 flex_fstat(int fd, Stat_t *statbufp)
4512 if (!fstat(fd,(stat_t *) statbufp)) {
4513 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4514 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4515 # ifdef RTL_USES_UTC
4518 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4519 statbufp->st_atime = _toloc(statbufp->st_atime);
4520 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4525 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4529 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4530 statbufp->st_atime = _toutc(statbufp->st_atime);
4531 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4538 } /* end of flex_fstat() */
4541 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4543 flex_stat(const char *fspec, Stat_t *statbufp)
4546 char fileified[NAM$C_MAXRSS+1];
4547 char temp_fspec[NAM$C_MAXRSS+300];
4550 strcpy(temp_fspec, fspec);
4551 if (statbufp == (Stat_t *) &PL_statcache)
4552 do_tovmsspec(temp_fspec,namecache,0);
4553 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4554 memset(statbufp,0,sizeof *statbufp);
4555 statbufp->st_dev = encode_dev("_NLA0:");
4556 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4557 statbufp->st_uid = 0x00010001;
4558 statbufp->st_gid = 0x0001;
4559 time((time_t *)&statbufp->st_mtime);
4560 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4564 /* Try for a directory name first. If fspec contains a filename without
4565 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4566 * and sea:[wine.dark]water. exist, we prefer the directory here.
4567 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4568 * not sea:[wine.dark]., if the latter exists. If the intended target is
4569 * the file with null type, specify this by calling flex_stat() with
4570 * a '.' at the end of fspec.
4572 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4573 retval = stat(fileified,(stat_t *) statbufp);
4574 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4575 strcpy(namecache,fileified);
4577 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4579 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4580 # ifdef RTL_USES_UTC
4583 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4584 statbufp->st_atime = _toloc(statbufp->st_atime);
4585 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4590 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4594 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4595 statbufp->st_atime = _toutc(statbufp->st_atime);
4596 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4602 } /* end of flex_stat() */
4606 /*{{{char *my_getlogin()*/
4607 /* VMS cuserid == Unix getlogin, except calling sequence */
4611 static char user[L_cuserid];
4612 return cuserid(user);
4617 /* rmscopy - copy a file using VMS RMS routines
4619 * Copies contents and attributes of spec_in to spec_out, except owner
4620 * and protection information. Name and type of spec_in are used as
4621 * defaults for spec_out. The third parameter specifies whether rmscopy()
4622 * should try to propagate timestamps from the input file to the output file.
4623 * If it is less than 0, no timestamps are preserved. If it is 0, then
4624 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4625 * propagated to the output file at creation iff the output file specification
4626 * did not contain an explicit name or type, and the revision date is always
4627 * updated at the end of the copy operation. If it is greater than 0, then
4628 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4629 * other than the revision date should be propagated, and bit 1 indicates
4630 * that the revision date should be propagated.
4632 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4634 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4635 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4636 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4637 * as part of the Perl standard distribution under the terms of the
4638 * GNU General Public License or the Perl Artistic License. Copies
4639 * of each may be found in the Perl standard distribution.
4641 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4643 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4645 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4646 rsa[NAM$C_MAXRSS], ubf[32256];
4647 unsigned long int i, sts, sts2;
4648 struct FAB fab_in, fab_out;
4649 struct RAB rab_in, rab_out;
4651 struct XABDAT xabdat;
4652 struct XABFHC xabfhc;
4653 struct XABRDT xabrdt;
4654 struct XABSUM xabsum;
4656 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4657 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4658 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4662 fab_in = cc$rms_fab;
4663 fab_in.fab$l_fna = vmsin;
4664 fab_in.fab$b_fns = strlen(vmsin);
4665 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4666 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4667 fab_in.fab$l_fop = FAB$M_SQO;
4668 fab_in.fab$l_nam = &nam;
4669 fab_in.fab$l_xab = (void *) &xabdat;
4672 nam.nam$l_rsa = rsa;
4673 nam.nam$b_rss = sizeof(rsa);
4674 nam.nam$l_esa = esa;
4675 nam.nam$b_ess = sizeof (esa);
4676 nam.nam$b_esl = nam.nam$b_rsl = 0;
4678 xabdat = cc$rms_xabdat; /* To get creation date */
4679 xabdat.xab$l_nxt = (void *) &xabfhc;
4681 xabfhc = cc$rms_xabfhc; /* To get record length */
4682 xabfhc.xab$l_nxt = (void *) &xabsum;
4684 xabsum = cc$rms_xabsum; /* To get key and area information */
4686 if (!((sts = sys$open(&fab_in)) & 1)) {
4687 set_vaxc_errno(sts);
4691 set_errno(ENOENT); break;
4693 set_errno(ENODEV); break;
4695 set_errno(EINVAL); break;
4697 set_errno(EACCES); break;
4705 fab_out.fab$w_ifi = 0;
4706 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4707 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4708 fab_out.fab$l_fop = FAB$M_SQO;
4709 fab_out.fab$l_fna = vmsout;
4710 fab_out.fab$b_fns = strlen(vmsout);
4711 fab_out.fab$l_dna = nam.nam$l_name;
4712 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4714 if (preserve_dates == 0) { /* Act like DCL COPY */
4715 nam.nam$b_nop = NAM$M_SYNCHK;
4716 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4717 if (!((sts = sys$parse(&fab_out)) & 1)) {
4718 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4719 set_vaxc_errno(sts);
4722 fab_out.fab$l_xab = (void *) &xabdat;
4723 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4725 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4726 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4727 preserve_dates =0; /* bitmask from this point forward */
4729 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4730 if (!((sts = sys$create(&fab_out)) & 1)) {
4731 set_vaxc_errno(sts);
4734 set_errno(ENOENT); break;
4736 set_errno(ENODEV); break;
4738 set_errno(EINVAL); break;
4740 set_errno(EACCES); break;
4746 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4747 if (preserve_dates & 2) {
4748 /* sys$close() will process xabrdt, not xabdat */
4749 xabrdt = cc$rms_xabrdt;
4751 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4753 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4754 * is unsigned long[2], while DECC & VAXC use a struct */
4755 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4757 fab_out.fab$l_xab = (void *) &xabrdt;
4760 rab_in = cc$rms_rab;
4761 rab_in.rab$l_fab = &fab_in;
4762 rab_in.rab$l_rop = RAB$M_BIO;
4763 rab_in.rab$l_ubf = ubf;
4764 rab_in.rab$w_usz = sizeof ubf;
4765 if (!((sts = sys$connect(&rab_in)) & 1)) {
4766 sys$close(&fab_in); sys$close(&fab_out);
4767 set_errno(EVMSERR); set_vaxc_errno(sts);
4771 rab_out = cc$rms_rab;
4772 rab_out.rab$l_fab = &fab_out;
4773 rab_out.rab$l_rbf = ubf;
4774 if (!((sts = sys$connect(&rab_out)) & 1)) {
4775 sys$close(&fab_in); sys$close(&fab_out);
4776 set_errno(EVMSERR); set_vaxc_errno(sts);
4780 while ((sts = sys$read(&rab_in))) { /* always true */
4781 if (sts == RMS$_EOF) break;
4782 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4783 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4784 sys$close(&fab_in); sys$close(&fab_out);
4785 set_errno(EVMSERR); set_vaxc_errno(sts);
4790 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4791 sys$close(&fab_in); sys$close(&fab_out);
4792 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4794 set_errno(EVMSERR); set_vaxc_errno(sts);
4800 } /* end of rmscopy() */
4804 /*** The following glue provides 'hooks' to make some of the routines
4805 * from this file available from Perl. These routines are sufficiently
4806 * basic, and are required sufficiently early in the build process,
4807 * that's it's nice to have them available to miniperl as well as the
4808 * full Perl, so they're set up here instead of in an extension. The
4809 * Perl code which handles importation of these names into a given
4810 * package lives in [.VMS]Filespec.pm in @INC.
4814 rmsexpand_fromperl(CV *cv)
4817 char *fspec, *defspec = NULL, *rslt;
4820 if (!items || items > 2)
4821 croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4822 fspec = SvPV(ST(0),n_a);
4823 if (!fspec || !*fspec) XSRETURN_UNDEF;
4824 if (items == 2) defspec = SvPV(ST(1),n_a);
4826 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4827 ST(0) = sv_newmortal();
4828 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4833 vmsify_fromperl(CV *cv)
4839 if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
4840 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4841 ST(0) = sv_newmortal();
4842 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4847 unixify_fromperl(CV *cv)
4853 if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
4854 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4855 ST(0) = sv_newmortal();
4856 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4861 fileify_fromperl(CV *cv)
4867 if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
4868 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4869 ST(0) = sv_newmortal();
4870 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4875 pathify_fromperl(CV *cv)
4881 if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
4882 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4883 ST(0) = sv_newmortal();
4884 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4889 vmspath_fromperl(CV *cv)
4895 if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
4896 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4897 ST(0) = sv_newmortal();
4898 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4903 unixpath_fromperl(CV *cv)
4909 if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
4910 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4911 ST(0) = sv_newmortal();
4912 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4917 candelete_fromperl(CV *cv)
4920 char fspec[NAM$C_MAXRSS+1], *fsp;
4925 if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
4927 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4928 if (SvTYPE(mysv) == SVt_PVGV) {
4929 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4930 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4937 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4938 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4944 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4949 rmscopy_fromperl(CV *cv)
4952 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4954 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4955 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4956 unsigned long int sts;
4961 if (items < 2 || items > 3)
4962 croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
4964 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4965 if (SvTYPE(mysv) == SVt_PVGV) {
4966 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4967 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4974 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
4975 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4980 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
4981 if (SvTYPE(mysv) == SVt_PVGV) {
4982 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
4983 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4990 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
4991 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4996 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
4998 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5005 char* file = __FILE__;
5007 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5008 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5009 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5010 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5011 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5012 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5013 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5014 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5015 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);