3 * VMS-specific routines for perl5
5 * Last revised: 20-Aug-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
71 #if defined(NEED_AN_H_ERRNO)
76 unsigned short int buflen;
77 unsigned short int itmcode;
79 unsigned short int *retlen;
82 static char *__mystrtolower(char *str)
84 if (str) for (; *str; ++str) *str= tolower(*str);
88 static struct dsc$descriptor_s fildevdsc =
89 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
90 static struct dsc$descriptor_s crtlenvdsc =
91 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
92 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
93 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
94 static struct dsc$descriptor_s **env_tables = defenv;
95 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
97 /* True if we shouldn't treat barewords as logicals during directory */
99 static int no_translate_barewords;
101 /* Temp for subprocess commands */
102 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
104 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
106 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
107 struct dsc$descriptor_s **tabvec, unsigned long int flags)
109 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
110 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
111 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
112 unsigned char acmode;
113 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
114 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
115 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
116 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
118 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
119 #if defined(USE_THREADS)
120 /* We jump through these hoops because we can be called at */
121 /* platform-specific initialization time, which is before anything is */
122 /* set up--we can't even do a plain dTHX since that relies on the */
123 /* interpreter structure to be initialized */
124 struct perl_thread *thr;
126 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
132 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
133 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
135 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
136 *cp2 = _toupper(*cp1);
137 if (cp1 - lnm > LNM$C_NAMLENGTH) {
138 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
142 lnmdsc.dsc$w_length = cp1 - lnm;
143 lnmdsc.dsc$a_pointer = uplnm;
144 uplnm[lnmdsc.dsc$w_length] = '\0';
145 secure = flags & PERL__TRNENV_SECURE;
146 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
147 if (!tabvec || !*tabvec) tabvec = env_tables;
149 for (curtab = 0; tabvec[curtab]; curtab++) {
150 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
151 if (!ivenv && !secure) {
156 Perl_warn(aTHX_ "Can't read CRTL environ\n");
159 retsts = SS$_NOLOGNAM;
160 for (i = 0; environ[i]; i++) {
161 if ((eq = strchr(environ[i],'=')) &&
162 !strncmp(environ[i],uplnm,eq - environ[i])) {
164 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
165 if (!eqvlen) continue;
170 if (retsts != SS$_NOLOGNAM) break;
173 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
174 !str$case_blind_compare(&tmpdsc,&clisym)) {
175 if (!ivsym && !secure) {
176 unsigned short int deflen = LNM$C_NAMLENGTH;
177 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
178 /* dynamic dsc to accomodate possible long value */
179 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
180 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
183 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
185 /* Special hack--we might be called before the interpreter's */
186 /* fully initialized, in which case either thr or PL_curcop */
187 /* might be bogus. We have to check, since ckWARN needs them */
188 /* both to be valid if running threaded */
189 #if defined(USE_THREADS)
190 if (thr && PL_curcop) {
192 if (ckWARN(WARN_MISC)) {
193 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
195 #if defined(USE_THREADS)
197 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
202 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
204 _ckvmssts(lib$sfree1_dd(&eqvdsc));
205 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
206 if (retsts == LIB$_NOSUCHSYM) continue;
211 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
212 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
213 if (retsts == SS$_NOLOGNAM) continue;
214 /* PPFs have a prefix */
217 *((int *)uplnm) == *((int *)"SYS$") &&
219 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
220 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
221 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
222 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
223 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
224 memcpy(eqv,eqv+4,eqvlen-4);
230 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
231 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
232 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
233 retsts == SS$_NOLOGNAM) {
234 set_errno(EINVAL); set_vaxc_errno(retsts);
236 else _ckvmssts(retsts);
238 } /* end of vmstrnenv */
241 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
242 /* Define as a function so we can access statics. */
243 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
245 return vmstrnenv(lnm,eqv,idx,fildev,
246 #ifdef SECURE_INTERNAL_GETENV
247 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
256 * Note: Uses Perl temp to store result so char * can be returned to
257 * caller; this pointer will be invalidated at next Perl statement
259 * We define this as a function rather than a macro in terms of my_getenv_len()
260 * so that it'll work when PL_curinterp is undefined (and we therefore can't
263 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
265 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
267 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
268 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
269 unsigned long int idx = 0;
273 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
274 /* Set up a temporary buffer for the return value; Perl will
275 * clean it up at the next statement transition */
276 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
277 if (!tmpsv) return NULL;
280 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
281 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
282 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
283 getcwd(eqv,LNM$C_NAMLENGTH);
287 if ((cp2 = strchr(lnm,';')) != NULL) {
289 uplnm[cp2-lnm] = '\0';
290 idx = strtoul(cp2+1,NULL,0);
293 /* Impose security constraints only if tainting */
294 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
295 if (vmstrnenv(lnm,eqv,idx,
297 #ifdef SECURE_INTERNAL_GETENV
298 sys ? PERL__TRNENV_SECURE : 0
306 } /* end of my_getenv() */
310 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
312 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
315 char *buf, *cp1, *cp2;
316 unsigned long idx = 0;
317 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
320 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
321 /* Set up a temporary buffer for the return value; Perl will
322 * clean it up at the next statement transition */
323 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
324 if (!tmpsv) return NULL;
327 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
328 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
329 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
330 getcwd(buf,LNM$C_NAMLENGTH);
335 if ((cp2 = strchr(lnm,';')) != NULL) {
338 idx = strtoul(cp2+1,NULL,0);
341 /* Impose security constraints only if tainting */
342 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
343 if ((*len = vmstrnenv(lnm,buf,idx,
345 #ifdef SECURE_INTERNAL_GETENV
346 sys ? PERL__TRNENV_SECURE : 0
356 } /* end of my_getenv_len() */
359 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
361 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
363 /*{{{ void prime_env_iter() */
366 /* Fill the %ENV associative array with all logical names we can
367 * find, in preparation for iterating over it.
371 static int primed = 0;
372 HV *seenhv = NULL, *envhv;
373 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
374 unsigned short int chan;
375 #ifndef CLI$M_TRUSTED
376 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
378 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
379 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
381 bool have_sym = FALSE, have_lnm = FALSE;
382 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
383 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
384 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
385 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
386 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
388 static perl_mutex primenv_mutex;
389 MUTEX_INIT(&primenv_mutex);
392 if (primed || !PL_envgv) return;
393 MUTEX_LOCK(&primenv_mutex);
394 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
395 envhv = GvHVn(PL_envgv);
396 /* Perform a dummy fetch as an lval to insure that the hash table is
397 * set up. Otherwise, the hv_store() will turn into a nullop. */
398 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
400 for (i = 0; env_tables[i]; i++) {
401 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
402 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
403 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
405 if (have_sym || have_lnm) {
406 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
407 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
408 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
409 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
412 for (i--; i >= 0; i--) {
413 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
416 for (j = 0; environ[j]; j++) {
417 if (!(start = strchr(environ[j],'='))) {
418 if (ckWARN(WARN_INTERNAL))
419 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
423 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
429 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
430 !str$case_blind_compare(&tmpdsc,&clisym)) {
431 strcpy(cmd,"Show Symbol/Global *");
432 cmddsc.dsc$w_length = 20;
433 if (env_tables[i]->dsc$w_length == 12 &&
434 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
435 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
436 flags = defflags | CLI$M_NOLOGNAM;
439 strcpy(cmd,"Show Logical *");
440 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
441 strcat(cmd," /Table=");
442 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
443 cmddsc.dsc$w_length = strlen(cmd);
445 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
446 flags = defflags | CLI$M_NOCLISYM;
449 /* Create a new subprocess to execute each command, to exclude the
450 * remote possibility that someone could subvert a mbx or file used
451 * to write multiple commands to a single subprocess.
454 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
455 0,&riseandshine,0,0,&clidsc,&clitabdsc);
456 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
457 defflags &= ~CLI$M_TRUSTED;
458 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
460 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
461 if (seenhv) SvREFCNT_dec(seenhv);
464 char *cp1, *cp2, *key;
465 unsigned long int sts, iosb[2], retlen, keylen;
468 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
469 if (sts & 1) sts = iosb[0] & 0xffff;
470 if (sts == SS$_ENDOFFILE) {
472 while (substs == 0) { sys$hiber(); wakect++;}
473 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
478 retlen = iosb[0] >> 16;
479 if (!retlen) continue; /* blank line */
481 if (iosb[1] != subpid) {
483 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
487 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
488 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
490 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
491 if (*cp1 == '(' || /* Logical name table name */
492 *cp1 == '=' /* Next eqv of searchlist */) continue;
493 if (*cp1 == '"') cp1++;
494 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
495 key = cp1; keylen = cp2 - cp1;
496 if (keylen && hv_exists(seenhv,key,keylen)) continue;
497 while (*cp2 && *cp2 != '=') cp2++;
498 while (*cp2 && *cp2 == '=') cp2++;
499 while (*cp2 && *cp2 == ' ') cp2++;
500 if (*cp2 == '"') { /* String translation; may embed "" */
501 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
502 cp2++; cp1--; /* Skip "" surrounding translation */
504 else { /* Numeric translation */
505 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
506 cp1--; /* stop on last non-space char */
508 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
509 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
512 PERL_HASH(hash,key,keylen);
513 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
514 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
516 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
517 /* get the PPFs for this process, not the subprocess */
518 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
519 char eqv[LNM$C_NAMLENGTH+1];
521 for (i = 0; ppfs[i]; i++) {
522 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
523 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
528 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
529 if (buf) Safefree(buf);
530 if (seenhv) SvREFCNT_dec(seenhv);
531 MUTEX_UNLOCK(&primenv_mutex);
534 } /* end of prime_env_iter */
538 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
539 /* Define or delete an element in the same "environment" as
540 * vmstrnenv(). If an element is to be deleted, it's removed from
541 * the first place it's found. If it's to be set, it's set in the
542 * place designated by the first element of the table vector.
543 * Like setenv() returns 0 for success, non-zero on error.
546 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
548 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
549 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
550 unsigned long int retsts, usermode = PSL$C_USER;
551 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
552 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
553 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
554 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
555 $DESCRIPTOR(local,"_LOCAL");
558 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
559 *cp2 = _toupper(*cp1);
560 if (cp1 - lnm > LNM$C_NAMLENGTH) {
561 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
565 lnmdsc.dsc$w_length = cp1 - lnm;
566 if (!tabvec || !*tabvec) tabvec = env_tables;
568 if (!eqv) { /* we're deleting n element */
569 for (curtab = 0; tabvec[curtab]; curtab++) {
570 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
572 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
573 if ((cp1 = strchr(environ[i],'=')) &&
574 !strncmp(environ[i],lnm,cp1 - environ[i])) {
576 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
579 ivenv = 1; retsts = SS$_NOLOGNAM;
581 if (ckWARN(WARN_INTERNAL))
582 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
583 ivenv = 1; retsts = SS$_NOSUCHPGM;
589 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
590 !str$case_blind_compare(&tmpdsc,&clisym)) {
591 unsigned int symtype;
592 if (tabvec[curtab]->dsc$w_length == 12 &&
593 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
594 !str$case_blind_compare(&tmpdsc,&local))
595 symtype = LIB$K_CLI_LOCAL_SYM;
596 else symtype = LIB$K_CLI_GLOBAL_SYM;
597 retsts = lib$delete_symbol(&lnmdsc,&symtype);
598 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
599 if (retsts == LIB$_NOSUCHSYM) continue;
603 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
604 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
605 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
606 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
607 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
611 else { /* we're defining a value */
612 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
614 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
616 if (ckWARN(WARN_INTERNAL))
617 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
618 retsts = SS$_NOSUCHPGM;
622 eqvdsc.dsc$a_pointer = eqv;
623 eqvdsc.dsc$w_length = strlen(eqv);
624 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
625 !str$case_blind_compare(&tmpdsc,&clisym)) {
626 unsigned int symtype;
627 if (tabvec[0]->dsc$w_length == 12 &&
628 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
629 !str$case_blind_compare(&tmpdsc,&local))
630 symtype = LIB$K_CLI_LOCAL_SYM;
631 else symtype = LIB$K_CLI_GLOBAL_SYM;
632 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
635 if (!*eqv) eqvdsc.dsc$w_length = 1;
636 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
637 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
638 if (ckWARN(WARN_MISC)) {
639 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
642 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
648 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
649 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
650 set_errno(EVMSERR); break;
651 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
652 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
653 set_errno(EINVAL); break;
660 set_vaxc_errno(retsts);
661 return (int) retsts || 44; /* retsts should never be 0, but just in case */
664 /* We reset error values on success because Perl does an hv_fetch()
665 * before each hv_store(), and if the thing we're setting didn't
666 * previously exist, we've got a leftover error message. (Of course,
667 * this fails in the face of
668 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
669 * in that the error reported in $! isn't spurious,
670 * but it's right more often than not.)
672 set_errno(0); set_vaxc_errno(retsts);
676 } /* end of vmssetenv() */
679 /*{{{ void my_setenv(char *lnm, char *eqv)*/
680 /* This has to be a function since there's a prototype for it in proto.h */
682 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
684 if (lnm && *lnm && strlen(lnm) == 7) {
687 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
688 if (!strcmp(uplnm,"DEFAULT")) {
689 if (eqv && *eqv) chdir(eqv);
693 (void) vmssetenv(lnm,eqv,NULL);
699 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
700 /* my_crypt - VMS password hashing
701 * my_crypt() provides an interface compatible with the Unix crypt()
702 * C library function, and uses sys$hash_password() to perform VMS
703 * password hashing. The quadword hashed password value is returned
704 * as a NUL-terminated 8 character string. my_crypt() does not change
705 * the case of its string arguments; in order to match the behavior
706 * of LOGINOUT et al., alphabetic characters in both arguments must
707 * be upcased by the caller.
710 my_crypt(const char *textpasswd, const char *usrname)
712 # ifndef UAI$C_PREFERRED_ALGORITHM
713 # define UAI$C_PREFERRED_ALGORITHM 127
715 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
716 unsigned short int salt = 0;
717 unsigned long int sts;
719 unsigned short int dsc$w_length;
720 unsigned char dsc$b_type;
721 unsigned char dsc$b_class;
722 const char * dsc$a_pointer;
723 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
724 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
725 struct itmlst_3 uailst[3] = {
726 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
727 { sizeof salt, UAI$_SALT, &salt, 0},
728 { 0, 0, NULL, NULL}};
731 usrdsc.dsc$w_length = strlen(usrname);
732 usrdsc.dsc$a_pointer = usrname;
733 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
740 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
746 if (sts != RMS$_RNF) return NULL;
749 txtdsc.dsc$w_length = strlen(textpasswd);
750 txtdsc.dsc$a_pointer = textpasswd;
751 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
752 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
755 return (char *) hash;
757 } /* end of my_crypt() */
761 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
762 static char *do_fileify_dirspec(char *, char *, int);
763 static char *do_tovmsspec(char *, char *, int);
765 /*{{{int do_rmdir(char *name)*/
769 char dirfile[NAM$C_MAXRSS+1];
773 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
774 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
775 else retval = kill_file(dirfile);
778 } /* end of do_rmdir */
782 * Delete any file to which user has control access, regardless of whether
783 * delete access is explicitly allowed.
784 * Limitations: User must have write access to parent directory.
785 * Does not block signals or ASTs; if interrupted in midstream
786 * may leave file with an altered ACL.
789 /*{{{int kill_file(char *name)*/
791 kill_file(char *name)
793 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
794 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
795 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
797 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
799 unsigned char myace$b_length;
800 unsigned char myace$b_type;
801 unsigned short int myace$w_flags;
802 unsigned long int myace$l_access;
803 unsigned long int myace$l_ident;
804 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
805 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
806 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
808 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
809 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
810 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
811 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
812 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
813 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
815 /* Expand the input spec using RMS, since the CRTL remove() and
816 * system services won't do this by themselves, so we may miss
817 * a file "hiding" behind a logical name or search list. */
818 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
819 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
820 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
821 /* If not, can changing protections help? */
822 if (vaxc$errno != RMS$_PRV) return -1;
824 /* No, so we get our own UIC to use as a rights identifier,
825 * and the insert an ACE at the head of the ACL which allows us
826 * to delete the file.
828 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
829 fildsc.dsc$w_length = strlen(rspec);
830 fildsc.dsc$a_pointer = rspec;
832 newace.myace$l_ident = oldace.myace$l_ident;
833 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
838 case SS$_NOSUCHOBJECT:
839 set_errno(ENOENT); break;
841 set_errno(ENODEV); break;
843 case SS$_INVFILFOROP:
844 set_errno(EINVAL); break;
846 set_errno(EACCES); break;
850 set_vaxc_errno(aclsts);
853 /* Grab any existing ACEs with this identifier in case we fail */
854 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
855 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
856 || fndsts == SS$_NOMOREACE ) {
857 /* Add the new ACE . . . */
858 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
860 if ((rmsts = remove(name))) {
861 /* We blew it - dir with files in it, no write priv for
862 * parent directory, etc. Put things back the way they were. */
863 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
866 addlst[0].bufadr = &oldace;
867 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
874 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
875 /* We just deleted it, so of course it's not there. Some versions of
876 * VMS seem to return success on the unlock operation anyhow (after all
877 * the unlock is successful), but others don't.
879 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
880 if (aclsts & 1) aclsts = fndsts;
883 set_vaxc_errno(aclsts);
889 } /* end of kill_file() */
893 /*{{{int my_mkdir(char *,Mode_t)*/
895 my_mkdir(char *dir, Mode_t mode)
897 STRLEN dirlen = strlen(dir);
900 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
901 * null file name/type. However, it's commonplace under Unix,
902 * so we'll allow it for a gain in portability.
904 if (dir[dirlen-1] == '/') {
905 char *newdir = savepvn(dir,dirlen-1);
906 int ret = mkdir(newdir,mode);
910 else return mkdir(dir,mode);
911 } /* end of my_mkdir */
916 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
918 static unsigned long int mbxbufsiz;
919 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
924 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
925 * preprocessor consant BUFSIZ from stdio.h as the size of the
928 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
929 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
931 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
933 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
934 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
936 } /* end of create_mbx() */
938 /*{{{ my_popen and my_pclose*/
941 struct pipe_details *next;
942 PerlIO *fp; /* stdio file pointer to pipe mailbox */
943 int pid; /* PID of subprocess */
944 int mode; /* == 'r' if pipe open for reading */
945 int done; /* subprocess has completed */
946 unsigned long int completion; /* termination status of subprocess */
949 struct exit_control_block
951 struct exit_control_block *flink;
952 unsigned long int (*exit_routine)();
953 unsigned long int arg_count;
954 unsigned long int *status_address;
955 unsigned long int exit_status;
958 static struct pipe_details *open_pipes = NULL;
959 static $DESCRIPTOR(nl_desc, "NL:");
960 static int waitpid_asleep = 0;
962 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
963 * to a mbx; that's the caller's responsibility.
965 static unsigned long int
966 pipe_eof(FILE *fp, int immediate)
968 char devnam[NAM$C_MAXRSS+1], *cp;
969 unsigned long int chan, iosb[2], retsts, retsts2;
970 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
973 if (fgetname(fp,devnam,1)) {
974 /* It oughta be a mailbox, so fgetname should give just the device
975 * name, but just in case . . . */
976 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
977 devdsc.dsc$w_length = strlen(devnam);
978 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
979 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
980 iosb,0,0,0,0,0,0,0,0);
981 if (retsts & 1) retsts = iosb[0];
982 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
983 if (retsts & 1) retsts = retsts2;
987 else _ckvmssts(vaxc$errno); /* Should never happen */
988 return (unsigned long int) vaxc$errno;
991 static unsigned long int
994 struct pipe_details *info;
995 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1000 first we try sending an EOF...ignore if doesn't work, make sure we
1008 _ckvmssts(sys$setast(0));
1009 need_eof = info->mode != 'r' && !info->done;
1010 _ckvmssts(sys$setast(1));
1012 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1016 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1021 _ckvmssts(sys$setast(0));
1022 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1023 sts = sys$forcex(&info->pid,0,&abort);
1024 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1027 _ckvmssts(sys$setast(1));
1030 if (did_stuff) sleep(1); /* wait for them to respond */
1034 _ckvmssts(sys$setast(0));
1035 if (!info->done) { /* We tried to be nice . . . */
1036 sts = sys$delprc(&info->pid,0);
1037 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1038 info->done = 1; /* so my_pclose doesn't try to write EOF */
1040 _ckvmssts(sys$setast(1));
1045 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1046 else if (!(sts & 1)) retsts = sts;
1051 static struct exit_control_block pipe_exitblock =
1052 {(struct exit_control_block *) 0,
1053 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1057 popen_completion_ast(struct pipe_details *thispipe)
1059 thispipe->done = TRUE;
1060 if (waitpid_asleep) {
1066 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1067 static void vms_execfree();
1070 safe_popen(char *cmd, char *mode)
1072 static int handler_set_up = FALSE;
1074 unsigned short int chan;
1075 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1077 struct pipe_details *info;
1078 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1079 DSC$K_CLASS_S, mbxname},
1080 cmddsc = {0, DSC$K_DTYPE_T,
1084 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1085 New(1301,info,1,struct pipe_details);
1087 /* create mailbox */
1088 create_mbx(&chan,&namdsc);
1090 /* open a FILE* onto it */
1091 info->fp = PerlIO_open(mbxname, mode);
1093 /* give up other channel onto it */
1094 _ckvmssts(sys$dassgn(chan));
1104 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1105 0 /* name */, &info->pid, &info->completion,
1106 0, popen_completion_ast,info,0,0,0));
1109 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1110 0 /* name */, &info->pid, &info->completion,
1111 0, popen_completion_ast,info,0,0,0));
1115 if (!handler_set_up) {
1116 _ckvmssts(sys$dclexh(&pipe_exitblock));
1117 handler_set_up = TRUE;
1119 info->next=open_pipes; /* prepend to list */
1122 PL_forkprocess = info->pid;
1124 } /* end of safe_popen */
1127 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1129 Perl_my_popen(pTHX_ char *cmd, char *mode)
1132 TAINT_PROPER("popen");
1133 PERL_FLUSHALL_FOR_CHILD;
1134 return safe_popen(cmd,mode);
1139 /*{{{ I32 my_pclose(FILE *fp)*/
1140 I32 Perl_my_pclose(pTHX_ FILE *fp)
1142 struct pipe_details *info, *last = NULL;
1143 unsigned long int retsts;
1146 for (info = open_pipes; info != NULL; last = info, info = info->next)
1147 if (info->fp == fp) break;
1149 if (info == NULL) { /* no such pipe open */
1150 set_errno(ECHILD); /* quoth POSIX */
1151 set_vaxc_errno(SS$_NONEXPR);
1155 /* If we were writing to a subprocess, insure that someone reading from
1156 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1157 * produce an EOF record in the mailbox. */
1158 _ckvmssts(sys$setast(0));
1159 need_eof = info->mode != 'r' && !info->done;
1160 _ckvmssts(sys$setast(1));
1161 if (need_eof) pipe_eof(info->fp,0);
1162 PerlIO_close(info->fp);
1164 if (info->done) retsts = info->completion;
1165 else waitpid(info->pid,(int *) &retsts,0);
1167 /* remove from list of open pipes */
1168 _ckvmssts(sys$setast(0));
1169 if (last) last->next = info->next;
1170 else open_pipes = info->next;
1171 _ckvmssts(sys$setast(1));
1176 } /* end of my_pclose() */
1178 /* sort-of waitpid; use only with popen() */
1179 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1181 my_waitpid(Pid_t pid, int *statusp, int flags)
1183 struct pipe_details *info;
1186 for (info = open_pipes; info != NULL; info = info->next)
1187 if (info->pid == pid) break;
1189 if (info != NULL) { /* we know about this child */
1190 while (!info->done) {
1195 *statusp = info->completion;
1198 else { /* we haven't heard of this child */
1199 $DESCRIPTOR(intdsc,"0 00:00:01");
1200 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1201 unsigned long int interval[2],sts;
1203 if (ckWARN(WARN_EXEC)) {
1204 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1205 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1206 if (ownerpid != mypid)
1207 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1210 _ckvmssts(sys$bintim(&intdsc,interval));
1211 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1212 _ckvmssts(sys$schdwk(0,0,interval,0));
1213 _ckvmssts(sys$hiber());
1217 /* There's no easy way to find the termination status a child we're
1218 * not aware of beforehand. If we're really interested in the future,
1219 * we can go looking for a termination mailbox, or chase after the
1220 * accounting record for the process.
1226 } /* end of waitpid() */
1231 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1233 my_gconvert(double val, int ndig, int trail, char *buf)
1235 static char __gcvtbuf[DBL_DIG+1];
1238 loc = buf ? buf : __gcvtbuf;
1240 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1242 sprintf(loc,"%.*g",ndig,val);
1248 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1249 return gcvt(val,ndig,loc);
1252 loc[0] = '0'; loc[1] = '\0';
1260 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1261 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1262 * to expand file specification. Allows for a single default file
1263 * specification and a simple mask of options. If outbuf is non-NULL,
1264 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1265 * the resultant file specification is placed. If outbuf is NULL, the
1266 * resultant file specification is placed into a static buffer.
1267 * The third argument, if non-NULL, is taken to be a default file
1268 * specification string. The fourth argument is unused at present.
1269 * rmesexpand() returns the address of the resultant string if
1270 * successful, and NULL on error.
1272 static char *do_tounixspec(char *, char *, int);
1275 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1277 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1278 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1279 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1280 struct FAB myfab = cc$rms_fab;
1281 struct NAM mynam = cc$rms_nam;
1283 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1285 if (!filespec || !*filespec) {
1286 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1290 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1291 else outbuf = __rmsexpand_retbuf;
1293 if ((isunix = (strchr(filespec,'/') != NULL))) {
1294 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1295 filespec = vmsfspec;
1298 myfab.fab$l_fna = filespec;
1299 myfab.fab$b_fns = strlen(filespec);
1300 myfab.fab$l_nam = &mynam;
1302 if (defspec && *defspec) {
1303 if (strchr(defspec,'/') != NULL) {
1304 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1307 myfab.fab$l_dna = defspec;
1308 myfab.fab$b_dns = strlen(defspec);
1311 mynam.nam$l_esa = esa;
1312 mynam.nam$b_ess = sizeof esa;
1313 mynam.nam$l_rsa = outbuf;
1314 mynam.nam$b_rss = NAM$C_MAXRSS;
1316 retsts = sys$parse(&myfab,0,0);
1317 if (!(retsts & 1)) {
1318 mynam.nam$b_nop |= NAM$M_SYNCHK;
1319 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1320 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1321 retsts = sys$parse(&myfab,0,0);
1322 if (retsts & 1) goto expanded;
1324 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1325 (void) sys$parse(&myfab,0,0); /* Free search context */
1326 if (out) Safefree(out);
1327 set_vaxc_errno(retsts);
1328 if (retsts == RMS$_PRV) set_errno(EACCES);
1329 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1330 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1331 else set_errno(EVMSERR);
1334 retsts = sys$search(&myfab,0,0);
1335 if (!(retsts & 1) && retsts != RMS$_FNF) {
1336 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1337 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1338 if (out) Safefree(out);
1339 set_vaxc_errno(retsts);
1340 if (retsts == RMS$_PRV) set_errno(EACCES);
1341 else set_errno(EVMSERR);
1345 /* If the input filespec contained any lowercase characters,
1346 * downcase the result for compatibility with Unix-minded code. */
1348 for (out = myfab.fab$l_fna; *out; out++)
1349 if (islower(*out)) { haslower = 1; break; }
1350 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1351 else { out = esa; speclen = mynam.nam$b_esl; }
1352 /* Trim off null fields added by $PARSE
1353 * If type > 1 char, must have been specified in original or default spec
1354 * (not true for version; $SEARCH may have added version of existing file).
1356 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1357 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1358 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1359 if (trimver || trimtype) {
1360 if (defspec && *defspec) {
1361 char defesa[NAM$C_MAXRSS];
1362 struct FAB deffab = cc$rms_fab;
1363 struct NAM defnam = cc$rms_nam;
1365 deffab.fab$l_nam = &defnam;
1366 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1367 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1368 defnam.nam$b_nop = NAM$M_SYNCHK;
1369 if (sys$parse(&deffab,0,0) & 1) {
1370 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1371 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1374 if (trimver) speclen = mynam.nam$l_ver - out;
1376 /* If we didn't already trim version, copy down */
1377 if (speclen > mynam.nam$l_ver - out)
1378 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1379 speclen - (mynam.nam$l_ver - out));
1380 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1383 /* If we just had a directory spec on input, $PARSE "helpfully"
1384 * adds an empty name and type for us */
1385 if (mynam.nam$l_name == mynam.nam$l_type &&
1386 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1387 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1388 speclen = mynam.nam$l_name - out;
1389 out[speclen] = '\0';
1390 if (haslower) __mystrtolower(out);
1392 /* Have we been working with an expanded, but not resultant, spec? */
1393 /* Also, convert back to Unix syntax if necessary. */
1394 if (!mynam.nam$b_rsl) {
1396 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1398 else strcpy(outbuf,esa);
1401 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1402 strcpy(outbuf,tmpfspec);
1404 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1405 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1406 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1410 /* External entry points */
1411 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1412 { return do_rmsexpand(spec,buf,0,def,opt); }
1413 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1414 { return do_rmsexpand(spec,buf,1,def,opt); }
1418 ** The following routines are provided to make life easier when
1419 ** converting among VMS-style and Unix-style directory specifications.
1420 ** All will take input specifications in either VMS or Unix syntax. On
1421 ** failure, all return NULL. If successful, the routines listed below
1422 ** return a pointer to a buffer containing the appropriately
1423 ** reformatted spec (and, therefore, subsequent calls to that routine
1424 ** will clobber the result), while the routines of the same names with
1425 ** a _ts suffix appended will return a pointer to a mallocd string
1426 ** containing the appropriately reformatted spec.
1427 ** In all cases, only explicit syntax is altered; no check is made that
1428 ** the resulting string is valid or that the directory in question
1431 ** fileify_dirspec() - convert a directory spec into the name of the
1432 ** directory file (i.e. what you can stat() to see if it's a dir).
1433 ** The style (VMS or Unix) of the result is the same as the style
1434 ** of the parameter passed in.
1435 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1436 ** what you prepend to a filename to indicate what directory it's in).
1437 ** The style (VMS or Unix) of the result is the same as the style
1438 ** of the parameter passed in.
1439 ** tounixpath() - convert a directory spec into a Unix-style path.
1440 ** tovmspath() - convert a directory spec into a VMS-style path.
1441 ** tounixspec() - convert any file spec into a Unix-style file spec.
1442 ** tovmsspec() - convert any file spec into a VMS-style spec.
1444 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1445 ** Permission is given to distribute this code as part of the Perl
1446 ** standard distribution under the terms of the GNU General Public
1447 ** License or the Perl Artistic License. Copies of each may be
1448 ** found in the Perl standard distribution.
1451 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1452 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1454 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1455 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1456 char *retspec, *cp1, *cp2, *lastdir;
1457 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1459 if (!dir || !*dir) {
1460 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1462 dirlen = strlen(dir);
1463 while (dir[dirlen-1] == '/') --dirlen;
1464 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1465 strcpy(trndir,"/sys$disk/000000");
1469 if (dirlen > NAM$C_MAXRSS) {
1470 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1472 if (!strpbrk(dir+1,"/]>:")) {
1473 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1474 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1476 dirlen = strlen(dir);
1479 strncpy(trndir,dir,dirlen);
1480 trndir[dirlen] = '\0';
1483 /* If we were handed a rooted logical name or spec, treat it like a
1484 * simple directory, so that
1485 * $ Define myroot dev:[dir.]
1486 * ... do_fileify_dirspec("myroot",buf,1) ...
1487 * does something useful.
1489 if (!strcmp(dir+dirlen-2,".]")) {
1490 dir[--dirlen] = '\0';
1491 dir[dirlen-1] = ']';
1494 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1495 /* If we've got an explicit filename, we can just shuffle the string. */
1496 if (*(cp1+1)) hasfilename = 1;
1497 /* Similarly, we can just back up a level if we've got multiple levels
1498 of explicit directories in a VMS spec which ends with directories. */
1500 for (cp2 = cp1; cp2 > dir; cp2--) {
1502 *cp2 = *cp1; *cp1 = '\0';
1506 if (*cp2 == '[' || *cp2 == '<') break;
1511 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1512 if (dir[0] == '.') {
1513 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1514 return do_fileify_dirspec("[]",buf,ts);
1515 else if (dir[1] == '.' &&
1516 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1517 return do_fileify_dirspec("[-]",buf,ts);
1519 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1520 dirlen -= 1; /* to last element */
1521 lastdir = strrchr(dir,'/');
1523 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1524 /* If we have "/." or "/..", VMSify it and let the VMS code
1525 * below expand it, rather than repeating the code to handle
1526 * relative components of a filespec here */
1528 if (*(cp1+2) == '.') cp1++;
1529 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1530 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1531 if (strchr(vmsdir,'/') != NULL) {
1532 /* If do_tovmsspec() returned it, it must have VMS syntax
1533 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1534 * the time to check this here only so we avoid a recursion
1535 * loop; otherwise, gigo.
1537 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1539 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1540 return do_tounixspec(trndir,buf,ts);
1543 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1544 lastdir = strrchr(dir,'/');
1546 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1547 /* Ditto for specs that end in an MFD -- let the VMS code
1548 * figure out whether it's a real device or a rooted logical. */
1549 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1550 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1551 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1552 return do_tounixspec(trndir,buf,ts);
1555 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1556 !(lastdir = cp1 = strrchr(dir,']')) &&
1557 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1558 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1560 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1561 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1562 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1563 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1564 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1565 (ver || *cp3)))))) {
1567 set_vaxc_errno(RMS$_DIR);
1573 /* If we lead off with a device or rooted logical, add the MFD
1574 if we're specifying a top-level directory. */
1575 if (lastdir && *dir == '/') {
1577 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1584 retlen = dirlen + (addmfd ? 13 : 6);
1585 if (buf) retspec = buf;
1586 else if (ts) New(1309,retspec,retlen+1,char);
1587 else retspec = __fileify_retbuf;
1589 dirlen = lastdir - dir;
1590 memcpy(retspec,dir,dirlen);
1591 strcpy(&retspec[dirlen],"/000000");
1592 strcpy(&retspec[dirlen+7],lastdir);
1595 memcpy(retspec,dir,dirlen);
1596 retspec[dirlen] = '\0';
1598 /* We've picked up everything up to the directory file name.
1599 Now just add the type and version, and we're set. */
1600 strcat(retspec,".dir;1");
1603 else { /* VMS-style directory spec */
1604 char esa[NAM$C_MAXRSS+1], term, *cp;
1605 unsigned long int sts, cmplen, haslower = 0;
1606 struct FAB dirfab = cc$rms_fab;
1607 struct NAM savnam, dirnam = cc$rms_nam;
1609 dirfab.fab$b_fns = strlen(dir);
1610 dirfab.fab$l_fna = dir;
1611 dirfab.fab$l_nam = &dirnam;
1612 dirfab.fab$l_dna = ".DIR;1";
1613 dirfab.fab$b_dns = 6;
1614 dirnam.nam$b_ess = NAM$C_MAXRSS;
1615 dirnam.nam$l_esa = esa;
1617 for (cp = dir; *cp; cp++)
1618 if (islower(*cp)) { haslower = 1; break; }
1619 if (!((sts = sys$parse(&dirfab))&1)) {
1620 if (dirfab.fab$l_sts == RMS$_DIR) {
1621 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1622 sts = sys$parse(&dirfab) & 1;
1626 set_vaxc_errno(dirfab.fab$l_sts);
1632 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1633 /* Yes; fake the fnb bits so we'll check type below */
1634 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1636 else { /* No; just work with potential name */
1637 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1639 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1640 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1641 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1646 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1647 cp1 = strchr(esa,']');
1648 if (!cp1) cp1 = strchr(esa,'>');
1649 if (cp1) { /* Should always be true */
1650 dirnam.nam$b_esl -= cp1 - esa - 1;
1651 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1654 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1655 /* Yep; check version while we're at it, if it's there. */
1656 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1657 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1658 /* Something other than .DIR[;1]. Bzzt. */
1659 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1660 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1662 set_vaxc_errno(RMS$_DIR);
1666 esa[dirnam.nam$b_esl] = '\0';
1667 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1668 /* They provided at least the name; we added the type, if necessary, */
1669 if (buf) retspec = buf; /* in sys$parse() */
1670 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1671 else retspec = __fileify_retbuf;
1672 strcpy(retspec,esa);
1673 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1674 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1677 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1678 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1680 dirnam.nam$b_esl -= 9;
1682 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1683 if (cp1 == NULL) { /* should never happen */
1684 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1685 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1690 retlen = strlen(esa);
1691 if ((cp1 = strrchr(esa,'.')) != NULL) {
1692 /* There's more than one directory in the path. Just roll back. */
1694 if (buf) retspec = buf;
1695 else if (ts) New(1311,retspec,retlen+7,char);
1696 else retspec = __fileify_retbuf;
1697 strcpy(retspec,esa);
1700 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1701 /* Go back and expand rooted logical name */
1702 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1703 if (!(sys$parse(&dirfab) & 1)) {
1704 dirnam.nam$l_rlf = NULL;
1705 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1707 set_vaxc_errno(dirfab.fab$l_sts);
1710 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1711 if (buf) retspec = buf;
1712 else if (ts) New(1312,retspec,retlen+16,char);
1713 else retspec = __fileify_retbuf;
1714 cp1 = strstr(esa,"][");
1716 memcpy(retspec,esa,dirlen);
1717 if (!strncmp(cp1+2,"000000]",7)) {
1718 retspec[dirlen-1] = '\0';
1719 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1720 if (*cp1 == '.') *cp1 = ']';
1722 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1723 memcpy(cp1+1,"000000]",7);
1727 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1728 retspec[retlen] = '\0';
1729 /* Convert last '.' to ']' */
1730 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1731 if (*cp1 == '.') *cp1 = ']';
1733 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1734 memcpy(cp1+1,"000000]",7);
1738 else { /* This is a top-level dir. Add the MFD to the path. */
1739 if (buf) retspec = buf;
1740 else if (ts) New(1312,retspec,retlen+16,char);
1741 else retspec = __fileify_retbuf;
1744 while (*cp1 != ':') *(cp2++) = *(cp1++);
1745 strcpy(cp2,":[000000]");
1750 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1751 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1752 /* We've set up the string up through the filename. Add the
1753 type and version, and we're done. */
1754 strcat(retspec,".DIR;1");
1756 /* $PARSE may have upcased filespec, so convert output to lower
1757 * case if input contained any lowercase characters. */
1758 if (haslower) __mystrtolower(retspec);
1761 } /* end of do_fileify_dirspec() */
1763 /* External entry points */
1764 char *fileify_dirspec(char *dir, char *buf)
1765 { return do_fileify_dirspec(dir,buf,0); }
1766 char *fileify_dirspec_ts(char *dir, char *buf)
1767 { return do_fileify_dirspec(dir,buf,1); }
1769 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1770 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1772 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1773 unsigned long int retlen;
1774 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1776 if (!dir || !*dir) {
1777 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1780 if (*dir) strcpy(trndir,dir);
1781 else getcwd(trndir,sizeof trndir - 1);
1783 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1784 && my_trnlnm(trndir,trndir,0)) {
1785 STRLEN trnlen = strlen(trndir);
1787 /* Trap simple rooted lnms, and return lnm:[000000] */
1788 if (!strcmp(trndir+trnlen-2,".]")) {
1789 if (buf) retpath = buf;
1790 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1791 else retpath = __pathify_retbuf;
1792 strcpy(retpath,dir);
1793 strcat(retpath,":[000000]");
1799 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1800 if (*dir == '.' && (*(dir+1) == '\0' ||
1801 (*(dir+1) == '.' && *(dir+2) == '\0')))
1802 retlen = 2 + (*(dir+1) != '\0');
1804 if ( !(cp1 = strrchr(dir,'/')) &&
1805 !(cp1 = strrchr(dir,']')) &&
1806 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1807 if ((cp2 = strchr(cp1,'.')) != NULL &&
1808 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1809 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1810 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1811 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1813 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1814 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1815 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1816 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1817 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1818 (ver || *cp3)))))) {
1820 set_vaxc_errno(RMS$_DIR);
1823 retlen = cp2 - dir + 1;
1825 else { /* No file type present. Treat the filename as a directory. */
1826 retlen = strlen(dir) + 1;
1829 if (buf) retpath = buf;
1830 else if (ts) New(1313,retpath,retlen+1,char);
1831 else retpath = __pathify_retbuf;
1832 strncpy(retpath,dir,retlen-1);
1833 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1834 retpath[retlen-1] = '/'; /* with '/', add it. */
1835 retpath[retlen] = '\0';
1837 else retpath[retlen-1] = '\0';
1839 else { /* VMS-style directory spec */
1840 char esa[NAM$C_MAXRSS+1], *cp;
1841 unsigned long int sts, cmplen, haslower;
1842 struct FAB dirfab = cc$rms_fab;
1843 struct NAM savnam, dirnam = cc$rms_nam;
1845 /* If we've got an explicit filename, we can just shuffle the string. */
1846 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1847 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1848 if ((cp2 = strchr(cp1,'.')) != NULL) {
1850 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1851 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1852 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1853 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1854 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1855 (ver || *cp3)))))) {
1857 set_vaxc_errno(RMS$_DIR);
1861 else { /* No file type, so just draw name into directory part */
1862 for (cp2 = cp1; *cp2; cp2++) ;
1865 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1867 /* We've now got a VMS 'path'; fall through */
1869 dirfab.fab$b_fns = strlen(dir);
1870 dirfab.fab$l_fna = dir;
1871 if (dir[dirfab.fab$b_fns-1] == ']' ||
1872 dir[dirfab.fab$b_fns-1] == '>' ||
1873 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1874 if (buf) retpath = buf;
1875 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1876 else retpath = __pathify_retbuf;
1877 strcpy(retpath,dir);
1880 dirfab.fab$l_dna = ".DIR;1";
1881 dirfab.fab$b_dns = 6;
1882 dirfab.fab$l_nam = &dirnam;
1883 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1884 dirnam.nam$l_esa = esa;
1886 for (cp = dir; *cp; cp++)
1887 if (islower(*cp)) { haslower = 1; break; }
1889 if (!(sts = (sys$parse(&dirfab)&1))) {
1890 if (dirfab.fab$l_sts == RMS$_DIR) {
1891 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1892 sts = sys$parse(&dirfab) & 1;
1896 set_vaxc_errno(dirfab.fab$l_sts);
1902 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1903 if (dirfab.fab$l_sts != RMS$_FNF) {
1904 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1905 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1907 set_vaxc_errno(dirfab.fab$l_sts);
1910 dirnam = savnam; /* No; just work with potential name */
1913 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1914 /* Yep; check version while we're at it, if it's there. */
1915 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1916 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1917 /* Something other than .DIR[;1]. Bzzt. */
1918 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1919 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1921 set_vaxc_errno(RMS$_DIR);
1925 /* OK, the type was fine. Now pull any file name into the
1927 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1929 cp1 = strrchr(esa,'>');
1930 *dirnam.nam$l_type = '>';
1933 *(dirnam.nam$l_type + 1) = '\0';
1934 retlen = dirnam.nam$l_type - esa + 2;
1935 if (buf) retpath = buf;
1936 else if (ts) New(1314,retpath,retlen,char);
1937 else retpath = __pathify_retbuf;
1938 strcpy(retpath,esa);
1939 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1940 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1941 /* $PARSE may have upcased filespec, so convert output to lower
1942 * case if input contained any lowercase characters. */
1943 if (haslower) __mystrtolower(retpath);
1947 } /* end of do_pathify_dirspec() */
1949 /* External entry points */
1950 char *pathify_dirspec(char *dir, char *buf)
1951 { return do_pathify_dirspec(dir,buf,0); }
1952 char *pathify_dirspec_ts(char *dir, char *buf)
1953 { return do_pathify_dirspec(dir,buf,1); }
1955 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1956 static char *do_tounixspec(char *spec, char *buf, int ts)
1958 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1959 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1960 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1962 if (spec == NULL) return NULL;
1963 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1964 if (buf) rslt = buf;
1966 retlen = strlen(spec);
1967 cp1 = strchr(spec,'[');
1968 if (!cp1) cp1 = strchr(spec,'<');
1970 for (cp1++; *cp1; cp1++) {
1971 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1972 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1973 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1976 New(1315,rslt,retlen+2+2*expand,char);
1978 else rslt = __tounixspec_retbuf;
1979 if (strchr(spec,'/') != NULL) {
1986 dirend = strrchr(spec,']');
1987 if (dirend == NULL) dirend = strrchr(spec,'>');
1988 if (dirend == NULL) dirend = strchr(spec,':');
1989 if (dirend == NULL) {
1993 if (*cp2 != '[' && *cp2 != '<') {
1996 else { /* the VMS spec begins with directories */
1998 if (*cp2 == ']' || *cp2 == '>') {
1999 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2002 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2003 if (getcwd(tmp,sizeof tmp,1) == NULL) {
2004 if (ts) Safefree(rslt);
2009 while (*cp3 != ':' && *cp3) cp3++;
2011 if (strchr(cp3,']') != NULL) break;
2012 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2014 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2015 retlen = devlen + dirlen;
2016 Renew(rslt,retlen+1+2*expand,char);
2022 *(cp1++) = *(cp3++);
2023 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2027 else if ( *cp2 == '.') {
2028 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2029 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2035 for (; cp2 <= dirend; cp2++) {
2038 if (*(cp2+1) == '[') cp2++;
2040 else if (*cp2 == ']' || *cp2 == '>') {
2041 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2043 else if (*cp2 == '.') {
2045 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2046 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2047 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2048 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2049 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2051 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2052 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2056 else if (*cp2 == '-') {
2057 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2058 while (*cp2 == '-') {
2060 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2062 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2063 if (ts) Safefree(rslt); /* filespecs like */
2064 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2068 else *(cp1++) = *cp2;
2070 else *(cp1++) = *cp2;
2072 while (*cp2) *(cp1++) = *(cp2++);
2077 } /* end of do_tounixspec() */
2079 /* External entry points */
2080 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2081 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2083 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2084 static char *do_tovmsspec(char *path, char *buf, int ts) {
2085 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2086 char *rslt, *dirend;
2087 register char *cp1, *cp2;
2088 unsigned long int infront = 0, hasdir = 1;
2090 if (path == NULL) return NULL;
2091 if (buf) rslt = buf;
2092 else if (ts) New(1316,rslt,strlen(path)+9,char);
2093 else rslt = __tovmsspec_retbuf;
2094 if (strpbrk(path,"]:>") ||
2095 (dirend = strrchr(path,'/')) == NULL) {
2096 if (path[0] == '.') {
2097 if (path[1] == '\0') strcpy(rslt,"[]");
2098 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2099 else strcpy(rslt,path); /* probably garbage */
2101 else strcpy(rslt,path);
2104 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2105 if (!*(dirend+2)) dirend +=2;
2106 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2107 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2112 char trndev[NAM$C_MAXRSS+1];
2116 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2118 if (!buf & ts) Renew(rslt,18,char);
2119 strcpy(rslt,"sys$disk:[000000]");
2122 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2124 islnm = my_trnlnm(rslt,trndev,0);
2125 trnend = islnm ? strlen(trndev) - 1 : 0;
2126 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2127 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2128 /* If the first element of the path is a logical name, determine
2129 * whether it has to be translated so we can add more directories. */
2130 if (!islnm || rooted) {
2133 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2137 if (cp2 != dirend) {
2138 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2139 strcpy(rslt,trndev);
2140 cp1 = rslt + trnend;
2153 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2154 cp2 += 2; /* skip over "./" - it's redundant */
2155 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2157 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2158 *(cp1++) = '-'; /* "../" --> "-" */
2161 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2162 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2163 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2164 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2167 if (cp2 > dirend) cp2 = dirend;
2169 else *(cp1++) = '.';
2171 for (; cp2 < dirend; cp2++) {
2173 if (*(cp2-1) == '/') continue;
2174 if (*(cp1-1) != '.') *(cp1++) = '.';
2177 else if (!infront && *cp2 == '.') {
2178 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2179 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2180 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2181 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2182 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2183 else { /* back up over previous directory name */
2185 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2186 if (*(cp1-1) == '[') {
2187 memcpy(cp1,"000000.",7);
2192 if (cp2 == dirend) break;
2194 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2195 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2196 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2197 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2199 *(cp1++) = '.'; /* Simulate trailing '/' */
2200 cp2 += 2; /* for loop will incr this to == dirend */
2202 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2204 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2207 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2208 if (*cp2 == '.') *(cp1++) = '_';
2209 else *(cp1++) = *cp2;
2213 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2214 if (hasdir) *(cp1++) = ']';
2215 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2216 while (*cp2) *(cp1++) = *(cp2++);
2221 } /* end of do_tovmsspec() */
2223 /* External entry points */
2224 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2225 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2227 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2228 static char *do_tovmspath(char *path, char *buf, int ts) {
2229 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2231 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2233 if (path == NULL) return NULL;
2234 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2235 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2236 if (buf) return buf;
2238 vmslen = strlen(vmsified);
2239 New(1317,cp,vmslen+1,char);
2240 memcpy(cp,vmsified,vmslen);
2245 strcpy(__tovmspath_retbuf,vmsified);
2246 return __tovmspath_retbuf;
2249 } /* end of do_tovmspath() */
2251 /* External entry points */
2252 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2253 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2256 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2257 static char *do_tounixpath(char *path, char *buf, int ts) {
2258 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2260 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2262 if (path == NULL) return NULL;
2263 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2264 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2265 if (buf) return buf;
2267 unixlen = strlen(unixified);
2268 New(1317,cp,unixlen+1,char);
2269 memcpy(cp,unixified,unixlen);
2274 strcpy(__tounixpath_retbuf,unixified);
2275 return __tounixpath_retbuf;
2278 } /* end of do_tounixpath() */
2280 /* External entry points */
2281 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2282 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2285 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2287 *****************************************************************************
2289 * Copyright (C) 1989-1994 by *
2290 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2292 * Permission is hereby granted for the reproduction of this software, *
2293 * on condition that this copyright notice is included in the reproduction, *
2294 * and that such reproduction is not for purposes of profit or material *
2297 * 27-Aug-1994 Modified for inclusion in perl5 *
2298 * by Charles Bailey bailey@newman.upenn.edu *
2299 *****************************************************************************
2303 * getredirection() is intended to aid in porting C programs
2304 * to VMS (Vax-11 C). The native VMS environment does not support
2305 * '>' and '<' I/O redirection, or command line wild card expansion,
2306 * or a command line pipe mechanism using the '|' AND background
2307 * command execution '&'. All of these capabilities are provided to any
2308 * C program which calls this procedure as the first thing in the
2310 * The piping mechanism will probably work with almost any 'filter' type
2311 * of program. With suitable modification, it may useful for other
2312 * portability problems as well.
2314 * Author: Mark Pizzolato mark@infocomm.com
2318 struct list_item *next;
2322 static void add_item(struct list_item **head,
2323 struct list_item **tail,
2327 static void expand_wild_cards(char *item,
2328 struct list_item **head,
2329 struct list_item **tail,
2332 static int background_process(int argc, char **argv);
2334 static void pipe_and_fork(char **cmargv);
2336 /*{{{ void getredirection(int *ac, char ***av)*/
2338 getredirection(int *ac, char ***av)
2340 * Process vms redirection arg's. Exit if any error is seen.
2341 * If getredirection() processes an argument, it is erased
2342 * from the vector. getredirection() returns a new argc and argv value.
2343 * In the event that a background command is requested (by a trailing "&"),
2344 * this routine creates a background subprocess, and simply exits the program.
2346 * Warning: do not try to simplify the code for vms. The code
2347 * presupposes that getredirection() is called before any data is
2348 * read from stdin or written to stdout.
2350 * Normal usage is as follows:
2356 * getredirection(&argc, &argv);
2360 int argc = *ac; /* Argument Count */
2361 char **argv = *av; /* Argument Vector */
2362 char *ap; /* Argument pointer */
2363 int j; /* argv[] index */
2364 int item_count = 0; /* Count of Items in List */
2365 struct list_item *list_head = 0; /* First Item in List */
2366 struct list_item *list_tail; /* Last Item in List */
2367 char *in = NULL; /* Input File Name */
2368 char *out = NULL; /* Output File Name */
2369 char *outmode = "w"; /* Mode to Open Output File */
2370 char *err = NULL; /* Error File Name */
2371 char *errmode = "w"; /* Mode to Open Error File */
2372 int cmargc = 0; /* Piped Command Arg Count */
2373 char **cmargv = NULL;/* Piped Command Arg Vector */
2376 * First handle the case where the last thing on the line ends with
2377 * a '&'. This indicates the desire for the command to be run in a
2378 * subprocess, so we satisfy that desire.
2381 if (0 == strcmp("&", ap))
2382 exit(background_process(--argc, argv));
2383 if (*ap && '&' == ap[strlen(ap)-1])
2385 ap[strlen(ap)-1] = '\0';
2386 exit(background_process(argc, argv));
2389 * Now we handle the general redirection cases that involve '>', '>>',
2390 * '<', and pipes '|'.
2392 for (j = 0; j < argc; ++j)
2394 if (0 == strcmp("<", argv[j]))
2398 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2399 exit(LIB$_WRONUMARG);
2404 if ('<' == *(ap = argv[j]))
2409 if (0 == strcmp(">", ap))
2413 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2414 exit(LIB$_WRONUMARG);
2433 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2434 exit(LIB$_WRONUMARG);
2438 if (('2' == *ap) && ('>' == ap[1]))
2455 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2456 exit(LIB$_WRONUMARG);
2460 if (0 == strcmp("|", argv[j]))
2464 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2465 exit(LIB$_WRONUMARG);
2467 cmargc = argc-(j+1);
2468 cmargv = &argv[j+1];
2472 if ('|' == *(ap = argv[j]))
2480 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2483 * Allocate and fill in the new argument vector, Some Unix's terminate
2484 * the list with an extra null pointer.
2486 New(1302, argv, item_count+1, char *);
2488 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2489 argv[j] = list_head->value;
2495 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2496 exit(LIB$_INVARGORD);
2498 pipe_and_fork(cmargv);
2501 /* Check for input from a pipe (mailbox) */
2503 if (in == NULL && 1 == isapipe(0))
2505 char mbxname[L_tmpnam];
2507 long int dvi_item = DVI$_DEVBUFSIZ;
2508 $DESCRIPTOR(mbxnam, "");
2509 $DESCRIPTOR(mbxdevnam, "");
2511 /* Input from a pipe, reopen it in binary mode to disable */
2512 /* carriage control processing. */
2514 PerlIO_getname(stdin, mbxname);
2515 mbxnam.dsc$a_pointer = mbxname;
2516 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2517 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2518 mbxdevnam.dsc$a_pointer = mbxname;
2519 mbxdevnam.dsc$w_length = sizeof(mbxname);
2520 dvi_item = DVI$_DEVNAM;
2521 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2522 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2525 freopen(mbxname, "rb", stdin);
2528 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2532 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2534 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2537 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2539 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2543 if (strcmp(err,"&1") == 0) {
2544 dup2(fileno(stdout), fileno(Perl_debug_log));
2547 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2549 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2553 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2559 #ifdef ARGPROC_DEBUG
2560 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2561 for (j = 0; j < *ac; ++j)
2562 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2564 /* Clear errors we may have hit expanding wildcards, so they don't
2565 show up in Perl's $! later */
2566 set_errno(0); set_vaxc_errno(1);
2567 } /* end of getredirection() */
2570 static void add_item(struct list_item **head,
2571 struct list_item **tail,
2577 New(1303,*head,1,struct list_item);
2581 New(1304,(*tail)->next,1,struct list_item);
2582 *tail = (*tail)->next;
2584 (*tail)->value = value;
2588 static void expand_wild_cards(char *item,
2589 struct list_item **head,
2590 struct list_item **tail,
2594 unsigned long int context = 0;
2600 char vmsspec[NAM$C_MAXRSS+1];
2601 $DESCRIPTOR(filespec, "");
2602 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2603 $DESCRIPTOR(resultspec, "");
2604 unsigned long int zero = 0, sts;
2606 for (cp = item; *cp; cp++) {
2607 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2608 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2610 if (!*cp || isspace(*cp))
2612 add_item(head, tail, item, count);
2615 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2616 resultspec.dsc$b_class = DSC$K_CLASS_D;
2617 resultspec.dsc$a_pointer = NULL;
2618 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2619 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2620 if (!isunix || !filespec.dsc$a_pointer)
2621 filespec.dsc$a_pointer = item;
2622 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2624 * Only return version specs, if the caller specified a version
2626 had_version = strchr(item, ';');
2628 * Only return device and directory specs, if the caller specifed either.
2630 had_device = strchr(item, ':');
2631 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2633 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2634 &defaultspec, 0, 0, &zero))))
2639 New(1305,string,resultspec.dsc$w_length+1,char);
2640 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2641 string[resultspec.dsc$w_length] = '\0';
2642 if (NULL == had_version)
2643 *((char *)strrchr(string, ';')) = '\0';
2644 if ((!had_directory) && (had_device == NULL))
2646 if (NULL == (devdir = strrchr(string, ']')))
2647 devdir = strrchr(string, '>');
2648 strcpy(string, devdir + 1);
2651 * Be consistent with what the C RTL has already done to the rest of
2652 * the argv items and lowercase all of these names.
2654 for (c = string; *c; ++c)
2657 if (isunix) trim_unixpath(string,item,1);
2658 add_item(head, tail, string, count);
2661 if (sts != RMS$_NMF)
2663 set_vaxc_errno(sts);
2669 set_errno(ENOENT); break;
2671 set_errno(ENODEV); break;
2674 set_errno(EINVAL); break;
2676 set_errno(EACCES); break;
2678 _ckvmssts_noperl(sts);
2682 add_item(head, tail, item, count);
2683 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2684 _ckvmssts_noperl(lib$find_file_end(&context));
2687 static int child_st[2];/* Event Flag set when child process completes */
2689 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2691 static unsigned long int exit_handler(int *status)
2695 if (0 == child_st[0])
2697 #ifdef ARGPROC_DEBUG
2698 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2700 fflush(stdout); /* Have to flush pipe for binary data to */
2701 /* terminate properly -- <tp@mccall.com> */
2702 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2703 sys$dassgn(child_chan);
2705 sys$synch(0, child_st);
2710 static void sig_child(int chan)
2712 #ifdef ARGPROC_DEBUG
2713 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2715 if (child_st[0] == 0)
2719 static struct exit_control_block exit_block =
2724 &exit_block.exit_status,
2728 static void pipe_and_fork(char **cmargv)
2731 $DESCRIPTOR(cmddsc, "");
2732 static char mbxname[64];
2733 $DESCRIPTOR(mbxdsc, mbxname);
2735 unsigned long int zero = 0, one = 1;
2737 strcpy(subcmd, cmargv[0]);
2738 for (j = 1; NULL != cmargv[j]; ++j)
2740 strcat(subcmd, " \"");
2741 strcat(subcmd, cmargv[j]);
2742 strcat(subcmd, "\"");
2744 cmddsc.dsc$a_pointer = subcmd;
2745 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2747 create_mbx(&child_chan,&mbxdsc);
2748 #ifdef ARGPROC_DEBUG
2749 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2750 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2752 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2753 0, &pid, child_st, &zero, sig_child,
2755 #ifdef ARGPROC_DEBUG
2756 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2758 sys$dclexh(&exit_block);
2759 if (NULL == freopen(mbxname, "wb", stdout))
2761 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2765 static int background_process(int argc, char **argv)
2767 char command[2048] = "$";
2768 $DESCRIPTOR(value, "");
2769 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2770 static $DESCRIPTOR(null, "NLA0:");
2771 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2773 $DESCRIPTOR(pidstr, "");
2775 unsigned long int flags = 17, one = 1, retsts;
2777 strcat(command, argv[0]);
2780 strcat(command, " \"");
2781 strcat(command, *(++argv));
2782 strcat(command, "\"");
2784 value.dsc$a_pointer = command;
2785 value.dsc$w_length = strlen(value.dsc$a_pointer);
2786 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2787 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2788 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2789 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2792 _ckvmssts_noperl(retsts);
2794 #ifdef ARGPROC_DEBUG
2795 PerlIO_printf(Perl_debug_log, "%s\n", command);
2797 sprintf(pidstring, "%08X", pid);
2798 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2799 pidstr.dsc$a_pointer = pidstring;
2800 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2801 lib$set_symbol(&pidsymbol, &pidstr);
2805 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2808 /* OS-specific initialization at image activation (not thread startup) */
2809 /* Older VAXC header files lack these constants */
2810 #ifndef JPI$_RIGHTS_SIZE
2811 # define JPI$_RIGHTS_SIZE 817
2813 #ifndef KGB$M_SUBSYSTEM
2814 # define KGB$M_SUBSYSTEM 0x8
2817 /*{{{void vms_image_init(int *, char ***)*/
2819 vms_image_init(int *argcp, char ***argvp)
2821 char eqv[LNM$C_NAMLENGTH+1] = "";
2822 unsigned int len, tabct = 8, tabidx = 0;
2823 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2824 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2825 unsigned short int dummy, rlen;
2826 struct dsc$descriptor_s **tabvec;
2828 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2829 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2830 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2833 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2835 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2836 if (iprv[i]) { /* Running image installed with privs? */
2837 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2842 /* Rights identifiers might trigger tainting as well. */
2843 if (!will_taint && (rlen || rsz)) {
2844 while (rlen < rsz) {
2845 /* We didn't get all the identifiers on the first pass. Allocate a
2846 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2847 * were needed to hold all identifiers at time of last call; we'll
2848 * allocate that many unsigned long ints), and go back and get 'em.
2850 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2851 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2852 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2853 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2856 mask = jpilist[1].bufadr;
2857 /* Check attribute flags for each identifier (2nd longword); protected
2858 * subsystem identifiers trigger tainting.
2860 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2861 if (mask[i] & KGB$M_SUBSYSTEM) {
2866 if (mask != rlst) Safefree(mask);
2868 /* We need to use this hack to tell Perl it should run with tainting,
2869 * since its tainting flag may be part of the PL_curinterp struct, which
2870 * hasn't been allocated when vms_image_init() is called.
2874 New(1320,newap,*argcp+2,char **);
2875 newap[0] = argvp[0];
2877 Copy(argvp[1],newap[2],*argcp-1,char **);
2878 /* We orphan the old argv, since we don't know where it's come from,
2879 * so we don't know how to free it.
2881 *argcp++; argvp = newap;
2883 else { /* Did user explicitly request tainting? */
2885 char *cp, **av = *argvp;
2886 for (i = 1; i < *argcp; i++) {
2887 if (*av[i] != '-') break;
2888 for (cp = av[i]+1; *cp; cp++) {
2889 if (*cp == 'T') { will_taint = 1; break; }
2890 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2891 strchr("DFIiMmx",*cp)) break;
2893 if (will_taint) break;
2898 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2900 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2901 else if (tabidx >= tabct) {
2903 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2905 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2906 tabvec[tabidx]->dsc$w_length = 0;
2907 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2908 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2909 tabvec[tabidx]->dsc$a_pointer = NULL;
2910 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2912 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2914 getredirection(argcp,argvp);
2915 #if defined(USE_THREADS) && defined(__DECC)
2917 # include <reentrancy.h>
2918 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2927 * Trim Unix-style prefix off filespec, so it looks like what a shell
2928 * glob expansion would return (i.e. from specified prefix on, not
2929 * full path). Note that returned filespec is Unix-style, regardless
2930 * of whether input filespec was VMS-style or Unix-style.
2932 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2933 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2934 * vector of options; at present, only bit 0 is used, and if set tells
2935 * trim unixpath to try the current default directory as a prefix when
2936 * presented with a possibly ambiguous ... wildcard.
2938 * Returns !=0 on success, with trimmed filespec replacing contents of
2939 * fspec, and 0 on failure, with contents of fpsec unchanged.
2941 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2943 trim_unixpath(char *fspec, char *wildspec, int opts)
2945 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2946 *template, *base, *end, *cp1, *cp2;
2947 register int tmplen, reslen = 0, dirs = 0;
2949 if (!wildspec || !fspec) return 0;
2950 if (strpbrk(wildspec,"]>:") != NULL) {
2951 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2952 else template = unixwild;
2954 else template = wildspec;
2955 if (strpbrk(fspec,"]>:") != NULL) {
2956 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2957 else base = unixified;
2958 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2959 * check to see that final result fits into (isn't longer than) fspec */
2960 reslen = strlen(fspec);
2964 /* No prefix or absolute path on wildcard, so nothing to remove */
2965 if (!*template || *template == '/') {
2966 if (base == fspec) return 1;
2967 tmplen = strlen(unixified);
2968 if (tmplen > reslen) return 0; /* not enough space */
2969 /* Copy unixified resultant, including trailing NUL */
2970 memmove(fspec,unixified,tmplen+1);
2974 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2975 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2976 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2977 for (cp1 = end ;cp1 >= base; cp1--)
2978 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2980 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2984 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2985 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2986 int ells = 1, totells, segdirs, match;
2987 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2988 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2990 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2992 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2993 if (ellipsis == template && opts & 1) {
2994 /* Template begins with an ellipsis. Since we can't tell how many
2995 * directory names at the front of the resultant to keep for an
2996 * arbitrary starting point, we arbitrarily choose the current
2997 * default directory as a starting point. If it's there as a prefix,
2998 * clip it off. If not, fall through and act as if the leading
2999 * ellipsis weren't there (i.e. return shortest possible path that
3000 * could match template).
3002 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3003 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3004 if (_tolower(*cp1) != _tolower(*cp2)) break;
3005 segdirs = dirs - totells; /* Min # of dirs we must have left */
3006 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3007 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3008 memcpy(fspec,cp2+1,end - cp2);
3012 /* First off, back up over constant elements at end of path */
3014 for (front = end ; front >= base; front--)
3015 if (*front == '/' && !dirs--) { front++; break; }
3017 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3018 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3019 if (cp1 != '\0') return 0; /* Path too long. */
3021 *cp2 = '\0'; /* Pick up with memcpy later */
3022 lcfront = lcres + (front - base);
3023 /* Now skip over each ellipsis and try to match the path in front of it. */
3025 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3026 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3027 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3028 if (cp1 < template) break; /* template started with an ellipsis */
3029 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3030 ellipsis = cp1; continue;
3032 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3034 for (segdirs = 0, cp2 = tpl;
3035 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3037 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3038 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3039 if (*cp2 == '/') segdirs++;
3041 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3042 /* Back up at least as many dirs as in template before matching */
3043 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3044 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3045 for (match = 0; cp1 > lcres;) {
3046 resdsc.dsc$a_pointer = cp1;
3047 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3049 if (match == 1) lcfront = cp1;
3051 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3053 if (!match) return 0; /* Can't find prefix ??? */
3054 if (match > 1 && opts & 1) {
3055 /* This ... wildcard could cover more than one set of dirs (i.e.
3056 * a set of similar dir names is repeated). If the template
3057 * contains more than 1 ..., upstream elements could resolve the
3058 * ambiguity, but it's not worth a full backtracking setup here.
3059 * As a quick heuristic, clip off the current default directory
3060 * if it's present to find the trimmed spec, else use the
3061 * shortest string that this ... could cover.
3063 char def[NAM$C_MAXRSS+1], *st;
3065 if (getcwd(def, sizeof def,0) == NULL) return 0;
3066 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3067 if (_tolower(*cp1) != _tolower(*cp2)) break;
3068 segdirs = dirs - totells; /* Min # of dirs we must have left */
3069 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3070 if (*cp1 == '\0' && *cp2 == '/') {
3071 memcpy(fspec,cp2+1,end - cp2);
3074 /* Nope -- stick with lcfront from above and keep going. */
3077 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3082 } /* end of trim_unixpath() */
3087 * VMS readdir() routines.
3088 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3090 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3091 * Minor modifications to original routines.
3094 /* Number of elements in vms_versions array */
3095 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3098 * Open a directory, return a handle for later use.
3100 /*{{{ DIR *opendir(char*name) */
3105 char dir[NAM$C_MAXRSS+1];
3108 if (do_tovmspath(name,dir,0) == NULL) {
3111 if (flex_stat(dir,&sb) == -1) return NULL;
3112 if (!S_ISDIR(sb.st_mode)) {
3113 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3116 if (!cando_by_name(S_IRUSR,0,dir)) {
3117 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3120 /* Get memory for the handle, and the pattern. */
3122 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3124 /* Fill in the fields; mainly playing with the descriptor. */
3125 (void)sprintf(dd->pattern, "%s*.*",dir);
3128 dd->vms_wantversions = 0;
3129 dd->pat.dsc$a_pointer = dd->pattern;
3130 dd->pat.dsc$w_length = strlen(dd->pattern);
3131 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3132 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3135 } /* end of opendir() */
3139 * Set the flag to indicate we want versions or not.
3141 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3143 vmsreaddirversions(DIR *dd, int flag)
3145 dd->vms_wantversions = flag;
3150 * Free up an opened directory.
3152 /*{{{ void closedir(DIR *dd)*/
3156 (void)lib$find_file_end(&dd->context);
3157 Safefree(dd->pattern);
3158 Safefree((char *)dd);
3163 * Collect all the version numbers for the current file.
3169 struct dsc$descriptor_s pat;
3170 struct dsc$descriptor_s res;
3172 char *p, *text, buff[sizeof dd->entry.d_name];
3174 unsigned long context, tmpsts;
3177 /* Convenient shorthand. */
3180 /* Add the version wildcard, ignoring the "*.*" put on before */
3181 i = strlen(dd->pattern);
3182 New(1308,text,i + e->d_namlen + 3,char);
3183 (void)strcpy(text, dd->pattern);
3184 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3186 /* Set up the pattern descriptor. */
3187 pat.dsc$a_pointer = text;
3188 pat.dsc$w_length = i + e->d_namlen - 1;
3189 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3190 pat.dsc$b_class = DSC$K_CLASS_S;
3192 /* Set up result descriptor. */
3193 res.dsc$a_pointer = buff;
3194 res.dsc$w_length = sizeof buff - 2;
3195 res.dsc$b_dtype = DSC$K_DTYPE_T;
3196 res.dsc$b_class = DSC$K_CLASS_S;
3198 /* Read files, collecting versions. */
3199 for (context = 0, e->vms_verscount = 0;
3200 e->vms_verscount < VERSIZE(e);
3201 e->vms_verscount++) {
3202 tmpsts = lib$find_file(&pat, &res, &context);
3203 if (tmpsts == RMS$_NMF || context == 0) break;
3205 buff[sizeof buff - 1] = '\0';
3206 if ((p = strchr(buff, ';')))
3207 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3209 e->vms_versions[e->vms_verscount] = -1;
3212 _ckvmssts(lib$find_file_end(&context));
3215 } /* end of collectversions() */
3218 * Read the next entry from the directory.
3220 /*{{{ struct dirent *readdir(DIR *dd)*/
3224 struct dsc$descriptor_s res;
3225 char *p, buff[sizeof dd->entry.d_name];
3226 unsigned long int tmpsts;
3228 /* Set up result descriptor, and get next file. */
3229 res.dsc$a_pointer = buff;
3230 res.dsc$w_length = sizeof buff - 2;
3231 res.dsc$b_dtype = DSC$K_DTYPE_T;
3232 res.dsc$b_class = DSC$K_CLASS_S;
3233 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3234 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3235 if (!(tmpsts & 1)) {
3236 set_vaxc_errno(tmpsts);
3239 set_errno(EACCES); break;
3241 set_errno(ENODEV); break;
3244 set_errno(ENOENT); break;
3251 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3252 buff[sizeof buff - 1] = '\0';
3253 for (p = buff; *p; p++) *p = _tolower(*p);
3254 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3257 /* Skip any directory component and just copy the name. */
3258 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3259 else (void)strcpy(dd->entry.d_name, buff);
3261 /* Clobber the version. */
3262 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3264 dd->entry.d_namlen = strlen(dd->entry.d_name);
3265 dd->entry.vms_verscount = 0;
3266 if (dd->vms_wantversions) collectversions(dd);
3269 } /* end of readdir() */
3273 * Return something that can be used in a seekdir later.
3275 /*{{{ long telldir(DIR *dd)*/
3284 * Return to a spot where we used to be. Brute force.
3286 /*{{{ void seekdir(DIR *dd,long count)*/
3288 seekdir(DIR *dd, long count)
3290 int vms_wantversions;
3293 /* If we haven't done anything yet... */
3297 /* Remember some state, and clear it. */
3298 vms_wantversions = dd->vms_wantversions;
3299 dd->vms_wantversions = 0;
3300 _ckvmssts(lib$find_file_end(&dd->context));
3303 /* The increment is in readdir(). */
3304 for (dd->count = 0; dd->count < count; )
3307 dd->vms_wantversions = vms_wantversions;
3309 } /* end of seekdir() */
3312 /* VMS subprocess management
3314 * my_vfork() - just a vfork(), after setting a flag to record that
3315 * the current script is trying a Unix-style fork/exec.
3317 * vms_do_aexec() and vms_do_exec() are called in response to the
3318 * perl 'exec' function. If this follows a vfork call, then they
3319 * call out the the regular perl routines in doio.c which do an
3320 * execvp (for those who really want to try this under VMS).
3321 * Otherwise, they do exactly what the perl docs say exec should
3322 * do - terminate the current script and invoke a new command
3323 * (See below for notes on command syntax.)
3325 * do_aspawn() and do_spawn() implement the VMS side of the perl
3326 * 'system' function.
3328 * Note on command arguments to perl 'exec' and 'system': When handled
3329 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3330 * are concatenated to form a DCL command string. If the first arg
3331 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3332 * the the command string is handed off to DCL directly. Otherwise,
3333 * the first token of the command is taken as the filespec of an image
3334 * to run. The filespec is expanded using a default type of '.EXE' and
3335 * the process defaults for device, directory, etc., and if found, the resultant
3336 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3337 * the command string as parameters. This is perhaps a bit complicated,
3338 * but I hope it will form a happy medium between what VMS folks expect
3339 * from lib$spawn and what Unix folks expect from exec.
3342 static int vfork_called;
3344 /*{{{int my_vfork()*/
3357 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3360 if (VMScmd.dsc$a_pointer) {
3361 Safefree(VMScmd.dsc$a_pointer);
3362 VMScmd.dsc$w_length = 0;
3363 VMScmd.dsc$a_pointer = Nullch;
3368 setup_argstr(SV *really, SV **mark, SV **sp)
3371 char *junk, *tmps = Nullch;
3372 register size_t cmdlen = 0;
3379 tmps = SvPV(really,rlen);
3386 for (idx++; idx <= sp; idx++) {
3388 junk = SvPVx(*idx,rlen);
3389 cmdlen += rlen ? rlen + 1 : 0;
3392 New(401,PL_Cmd,cmdlen+1,char);
3394 if (tmps && *tmps) {
3395 strcpy(PL_Cmd,tmps);
3398 else *PL_Cmd = '\0';
3399 while (++mark <= sp) {
3401 char *s = SvPVx(*mark,n_a);
3403 if (*PL_Cmd) strcat(PL_Cmd," ");
3409 } /* end of setup_argstr() */
3412 static unsigned long int
3413 setup_cmddsc(char *cmd, int check_img)
3415 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3416 $DESCRIPTOR(defdsc,".EXE");
3417 $DESCRIPTOR(defdsc2,".");
3418 $DESCRIPTOR(resdsc,resspec);
3419 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3420 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3421 register char *s, *rest, *cp, *wordbreak;
3426 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3429 while (*s && isspace(*s)) s++;
3431 if (*s == '@' || *s == '$') {
3432 vmsspec[0] = *s; rest = s + 1;
3433 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3435 else { cp = vmsspec; rest = s; }
3436 if (*rest == '.' || *rest == '/') {
3439 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3440 rest++, cp2++) *cp2 = *rest;
3442 if (do_tovmsspec(resspec,cp,0)) {
3445 for (cp2 = vmsspec + strlen(vmsspec);
3446 *rest && cp2 - vmsspec < sizeof vmsspec;
3447 rest++, cp2++) *cp2 = *rest;
3452 /* Intuit whether verb (first word of cmd) is a DCL command:
3453 * - if first nonspace char is '@', it's a DCL indirection
3455 * - if verb contains a filespec separator, it's not a DCL command
3456 * - if it doesn't, caller tells us whether to default to a DCL
3457 * command, or to a local image unless told it's DCL (by leading '$')
3459 if (*s == '@') isdcl = 1;
3461 register char *filespec = strpbrk(s,":<[.;");
3462 rest = wordbreak = strpbrk(s," \"\t/");
3463 if (!wordbreak) wordbreak = s + strlen(s);
3464 if (*s == '$') check_img = 0;
3465 if (filespec && (filespec < wordbreak)) isdcl = 0;
3466 else isdcl = !check_img;
3470 imgdsc.dsc$a_pointer = s;
3471 imgdsc.dsc$w_length = wordbreak - s;
3472 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3474 _ckvmssts(lib$find_file_end(&cxt));
3475 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3476 if (!(retsts & 1) && *s == '$') {
3477 _ckvmssts(lib$find_file_end(&cxt));
3478 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3479 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3481 _ckvmssts(lib$find_file_end(&cxt));
3482 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3486 _ckvmssts(lib$find_file_end(&cxt));
3491 while (*s && !isspace(*s)) s++;
3494 /* check that it's really not DCL with no file extension */
3495 fp = fopen(resspec,"r","ctx=bin,shr=get");
3497 char b[4] = {0,0,0,0};
3498 read(fileno(fp),b,4);
3499 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3502 if (check_img && isdcl) return RMS$_FNF;
3504 if (cando_by_name(S_IXUSR,0,resspec)) {
3505 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3507 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3509 strcpy(VMScmd.dsc$a_pointer,"@");
3511 strcat(VMScmd.dsc$a_pointer,resspec);
3512 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3513 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3516 else retsts = RMS$_PRV;
3519 /* It's either a DCL command or we couldn't find a suitable image */
3520 VMScmd.dsc$w_length = strlen(cmd);
3521 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3522 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3523 if (!(retsts & 1)) {
3524 /* just hand off status values likely to be due to user error */
3525 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3526 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3527 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3528 else { _ckvmssts(retsts); }
3531 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3533 } /* end of setup_cmddsc() */
3536 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3538 vms_do_aexec(SV *really,SV **mark,SV **sp)
3542 if (vfork_called) { /* this follows a vfork - act Unixish */
3544 if (vfork_called < 0) {
3545 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3548 else return do_aexec(really,mark,sp);
3550 /* no vfork - act VMSish */
3551 return vms_do_exec(setup_argstr(really,mark,sp));
3556 } /* end of vms_do_aexec() */
3559 /* {{{bool vms_do_exec(char *cmd) */
3561 vms_do_exec(char *cmd)
3565 if (vfork_called) { /* this follows a vfork - act Unixish */
3567 if (vfork_called < 0) {
3568 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3571 else return do_exec(cmd);
3574 { /* no vfork - act VMSish */
3575 unsigned long int retsts;
3578 TAINT_PROPER("exec");
3579 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3580 retsts = lib$do_command(&VMScmd);
3584 set_errno(ENOENT); break;
3585 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3586 set_errno(ENOTDIR); break;
3588 set_errno(EACCES); break;
3590 set_errno(EINVAL); break;
3592 set_errno(E2BIG); break;
3593 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3594 _ckvmssts(retsts); /* fall through */
3595 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3598 set_vaxc_errno(retsts);
3599 if (ckWARN(WARN_EXEC)) {
3600 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3601 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3608 } /* end of vms_do_exec() */
3611 unsigned long int do_spawn(char *);
3613 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3615 do_aspawn(void *really,void **mark,void **sp)
3618 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3621 } /* end of do_aspawn() */
3624 /* {{{unsigned long int do_spawn(char *cmd) */
3628 unsigned long int sts, substs, hadcmd = 1;
3632 TAINT_PROPER("spawn");
3633 if (!cmd || !*cmd) {
3635 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3637 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3638 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3644 set_errno(ENOENT); break;
3645 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3646 set_errno(ENOTDIR); break;
3648 set_errno(EACCES); break;
3650 set_errno(EINVAL); break;
3652 set_errno(E2BIG); break;
3653 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3654 _ckvmssts(sts); /* fall through */
3655 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3658 set_vaxc_errno(sts);
3659 if (ckWARN(WARN_EXEC)) {
3660 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3661 hadcmd ? VMScmd.dsc$w_length : 0,
3662 hadcmd ? VMScmd.dsc$a_pointer : "",
3669 } /* end of do_spawn() */
3673 * A simple fwrite replacement which outputs itmsz*nitm chars without
3674 * introducing record boundaries every itmsz chars.
3676 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3678 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3680 register char *cp, *end;
3682 end = (char *)src + itmsz * nitm;
3684 while ((char *)src <= end) {
3685 for (cp = src; cp <= end; cp++) if (!*cp) break;
3686 if (fputs(src,dest) == EOF) return EOF;
3688 if (fputc('\0',dest) == EOF) return EOF;
3694 } /* end of my_fwrite() */
3697 /*{{{ int my_flush(FILE *fp)*/
3702 if ((res = fflush(fp)) == 0 && fp) {
3703 #ifdef VMS_DO_SOCKETS
3705 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3707 res = fsync(fileno(fp));
3714 * Here are replacements for the following Unix routines in the VMS environment:
3715 * getpwuid Get information for a particular UIC or UID
3716 * getpwnam Get information for a named user
3717 * getpwent Get information for each user in the rights database
3718 * setpwent Reset search to the start of the rights database
3719 * endpwent Finish searching for users in the rights database
3721 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3722 * (defined in pwd.h), which contains the following fields:-
3724 * char *pw_name; Username (in lower case)
3725 * char *pw_passwd; Hashed password
3726 * unsigned int pw_uid; UIC
3727 * unsigned int pw_gid; UIC group number
3728 * char *pw_unixdir; Default device/directory (VMS-style)
3729 * char *pw_gecos; Owner name
3730 * char *pw_dir; Default device/directory (Unix-style)
3731 * char *pw_shell; Default CLI name (eg. DCL)
3733 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3735 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3736 * not the UIC member number (eg. what's returned by getuid()),
3737 * getpwuid() can accept either as input (if uid is specified, the caller's
3738 * UIC group is used), though it won't recognise gid=0.
3740 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3741 * information about other users in your group or in other groups, respectively.
3742 * If the required privilege is not available, then these routines fill only
3743 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3746 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3749 /* sizes of various UAF record fields */
3750 #define UAI$S_USERNAME 12
3751 #define UAI$S_IDENT 31
3752 #define UAI$S_OWNER 31
3753 #define UAI$S_DEFDEV 31
3754 #define UAI$S_DEFDIR 63
3755 #define UAI$S_DEFCLI 31
3758 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3759 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3760 (uic).uic$v_group != UIC$K_WILD_GROUP)
3762 static char __empty[]= "";
3763 static struct passwd __passwd_empty=
3764 {(char *) __empty, (char *) __empty, 0, 0,
3765 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3766 static int contxt= 0;
3767 static struct passwd __pwdcache;
3768 static char __pw_namecache[UAI$S_IDENT+1];
3771 * This routine does most of the work extracting the user information.
3773 static int fillpasswd (const char *name, struct passwd *pwd)
3777 unsigned char length;
3778 char pw_gecos[UAI$S_OWNER+1];
3780 static union uicdef uic;
3782 unsigned char length;
3783 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3786 unsigned char length;
3787 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3790 unsigned char length;
3791 char pw_shell[UAI$S_DEFCLI+1];
3793 static char pw_passwd[UAI$S_PWD+1];
3795 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3796 struct dsc$descriptor_s name_desc;
3797 unsigned long int sts;
3799 static struct itmlst_3 itmlst[]= {
3800 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3801 {sizeof(uic), UAI$_UIC, &uic, &luic},
3802 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3803 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3804 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3805 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3806 {0, 0, NULL, NULL}};
3808 name_desc.dsc$w_length= strlen(name);
3809 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3810 name_desc.dsc$b_class= DSC$K_CLASS_S;
3811 name_desc.dsc$a_pointer= (char *) name;
3813 /* Note that sys$getuai returns many fields as counted strings. */
3814 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3815 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3816 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3818 else { _ckvmssts(sts); }
3819 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3821 if ((int) owner.length < lowner) lowner= (int) owner.length;
3822 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3823 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3824 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3825 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3826 owner.pw_gecos[lowner]= '\0';
3827 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3828 defcli.pw_shell[ldefcli]= '\0';
3829 if (valid_uic(uic)) {
3830 pwd->pw_uid= uic.uic$l_uic;
3831 pwd->pw_gid= uic.uic$v_group;
3834 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3835 pwd->pw_passwd= pw_passwd;
3836 pwd->pw_gecos= owner.pw_gecos;
3837 pwd->pw_dir= defdev.pw_dir;
3838 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3839 pwd->pw_shell= defcli.pw_shell;
3840 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3842 ldir= strlen(pwd->pw_unixdir) - 1;
3843 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3846 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3847 __mystrtolower(pwd->pw_unixdir);
3852 * Get information for a named user.
3854 /*{{{struct passwd *getpwnam(char *name)*/
3855 struct passwd *my_getpwnam(char *name)
3857 struct dsc$descriptor_s name_desc;
3859 unsigned long int status, sts;
3862 __pwdcache = __passwd_empty;
3863 if (!fillpasswd(name, &__pwdcache)) {
3864 /* We still may be able to determine pw_uid and pw_gid */
3865 name_desc.dsc$w_length= strlen(name);
3866 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3867 name_desc.dsc$b_class= DSC$K_CLASS_S;
3868 name_desc.dsc$a_pointer= (char *) name;
3869 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3870 __pwdcache.pw_uid= uic.uic$l_uic;
3871 __pwdcache.pw_gid= uic.uic$v_group;
3874 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3875 set_vaxc_errno(sts);
3876 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3879 else { _ckvmssts(sts); }
3882 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3883 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3884 __pwdcache.pw_name= __pw_namecache;
3886 } /* end of my_getpwnam() */
3890 * Get information for a particular UIC or UID.
3891 * Called by my_getpwent with uid=-1 to list all users.
3893 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3894 struct passwd *my_getpwuid(Uid_t uid)
3896 const $DESCRIPTOR(name_desc,__pw_namecache);
3897 unsigned short lname;
3899 unsigned long int status;
3902 if (uid == (unsigned int) -1) {
3904 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3905 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3906 set_vaxc_errno(status);
3907 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3911 else { _ckvmssts(status); }
3912 } while (!valid_uic (uic));
3916 if (!uic.uic$v_group)
3917 uic.uic$v_group= PerlProc_getgid();
3919 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3920 else status = SS$_IVIDENT;
3921 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3922 status == RMS$_PRV) {
3923 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3926 else { _ckvmssts(status); }
3928 __pw_namecache[lname]= '\0';
3929 __mystrtolower(__pw_namecache);
3931 __pwdcache = __passwd_empty;
3932 __pwdcache.pw_name = __pw_namecache;
3934 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3935 The identifier's value is usually the UIC, but it doesn't have to be,
3936 so if we can, we let fillpasswd update this. */
3937 __pwdcache.pw_uid = uic.uic$l_uic;
3938 __pwdcache.pw_gid = uic.uic$v_group;
3940 fillpasswd(__pw_namecache, &__pwdcache);
3943 } /* end of my_getpwuid() */
3947 * Get information for next user.
3949 /*{{{struct passwd *my_getpwent()*/
3950 struct passwd *my_getpwent()
3952 return (my_getpwuid((unsigned int) -1));
3957 * Finish searching rights database for users.
3959 /*{{{void my_endpwent()*/
3964 _ckvmssts(sys$finish_rdb(&contxt));
3970 #ifdef HOMEGROWN_POSIX_SIGNALS
3971 /* Signal handling routines, pulled into the core from POSIX.xs.
3973 * We need these for threads, so they've been rolled into the core,
3974 * rather than left in POSIX.xs.
3976 * (DRS, Oct 23, 1997)
3979 /* sigset_t is atomic under VMS, so these routines are easy */
3980 /*{{{int my_sigemptyset(sigset_t *) */
3981 int my_sigemptyset(sigset_t *set) {
3982 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3988 /*{{{int my_sigfillset(sigset_t *)*/
3989 int my_sigfillset(sigset_t *set) {
3991 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3992 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3998 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3999 int my_sigaddset(sigset_t *set, int sig) {
4000 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4001 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4002 *set |= (1 << (sig - 1));
4008 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4009 int my_sigdelset(sigset_t *set, int sig) {
4010 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4011 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4012 *set &= ~(1 << (sig - 1));
4018 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4019 int my_sigismember(sigset_t *set, int sig) {
4020 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4021 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4022 *set & (1 << (sig - 1));
4027 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4028 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4031 /* If set and oset are both null, then things are badly wrong. Bail out. */
4032 if ((oset == NULL) && (set == NULL)) {
4033 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4037 /* If set's null, then we're just handling a fetch. */
4039 tempmask = sigblock(0);
4044 tempmask = sigsetmask(*set);
4047 tempmask = sigblock(*set);
4050 tempmask = sigblock(0);
4051 sigsetmask(*oset & ~tempmask);
4054 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4059 /* Did they pass us an oset? If so, stick our holding mask into it */
4066 #endif /* HOMEGROWN_POSIX_SIGNALS */
4069 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4070 * my_utime(), and flex_stat(), all of which operate on UTC unless
4071 * VMSISH_TIMES is true.
4073 /* method used to handle UTC conversions:
4074 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4076 static int gmtime_emulation_type;
4077 /* number of secs to add to UTC POSIX-style time to get local time */
4078 static long int utc_offset_secs;
4080 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4081 * in vmsish.h. #undef them here so we can call the CRTL routines
4088 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4089 # define RTL_USES_UTC 1
4093 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4094 * qualifier with the extern prefix pragma. This provisional
4095 * hack circumvents this prefix pragma problem in previous
4098 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4099 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4100 # pragma __extern_prefix save
4101 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4102 # define gmtime decc$__utctz_gmtime
4103 # define localtime decc$__utctz_localtime
4104 # define time decc$__utc_time
4105 # pragma __extern_prefix restore
4107 struct tm *gmtime(), *localtime();
4113 static time_t toutc_dst(time_t loc) {
4116 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4117 loc -= utc_offset_secs;
4118 if (rsltmp->tm_isdst) loc -= 3600;
4121 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4122 ((gmtime_emulation_type || my_time(NULL)), \
4123 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4124 ((secs) - utc_offset_secs))))
4126 static time_t toloc_dst(time_t utc) {
4129 utc += utc_offset_secs;
4130 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4131 if (rsltmp->tm_isdst) utc += 3600;
4134 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4135 ((gmtime_emulation_type || my_time(NULL)), \
4136 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4137 ((secs) + utc_offset_secs))))
4140 /* my_time(), my_localtime(), my_gmtime()
4141 * By default traffic in UTC time values, using CRTL gmtime() or
4142 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4143 * Note: We need to use these functions even when the CRTL has working
4144 * UTC support, since they also handle C<use vmsish qw(times);>
4146 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4147 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4150 /*{{{time_t my_time(time_t *timep)*/
4151 time_t my_time(time_t *timep)
4157 if (gmtime_emulation_type == 0) {
4159 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4160 /* results of calls to gmtime() and localtime() */
4161 /* for same &base */
4163 gmtime_emulation_type++;
4164 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4165 char off[LNM$C_NAMLENGTH+1];;
4167 gmtime_emulation_type++;
4168 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4169 gmtime_emulation_type++;
4170 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4172 else { utc_offset_secs = atol(off); }
4174 else { /* We've got a working gmtime() */
4175 struct tm gmt, local;
4178 tm_p = localtime(&base);
4180 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4181 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4182 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4183 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4189 # ifdef RTL_USES_UTC
4190 if (VMSISH_TIME) when = _toloc(when);
4192 if (!VMSISH_TIME) when = _toutc(when);
4195 if (timep != NULL) *timep = when;
4198 } /* end of my_time() */
4202 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4204 my_gmtime(const time_t *timep)
4211 if (timep == NULL) {
4212 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4215 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4219 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4221 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4222 return gmtime(&when);
4224 /* CRTL localtime() wants local time as input, so does no tz correction */
4225 rsltmp = localtime(&when);
4226 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4229 } /* end of my_gmtime() */
4233 /*{{{struct tm *my_localtime(const time_t *timep)*/
4235 my_localtime(const time_t *timep)
4241 if (timep == NULL) {
4242 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4245 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4246 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4249 # ifdef RTL_USES_UTC
4251 if (VMSISH_TIME) when = _toutc(when);
4253 /* CRTL localtime() wants UTC as input, does tz correction itself */
4254 return localtime(&when);
4257 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4260 /* CRTL localtime() wants local time as input, so does no tz correction */
4261 rsltmp = localtime(&when);
4262 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4265 } /* end of my_localtime() */
4268 /* Reset definitions for later calls */
4269 #define gmtime(t) my_gmtime(t)
4270 #define localtime(t) my_localtime(t)
4271 #define time(t) my_time(t)
4274 /* my_utime - update modification time of a file
4275 * calling sequence is identical to POSIX utime(), but under
4276 * VMS only the modification time is changed; ODS-2 does not
4277 * maintain access times. Restrictions differ from the POSIX
4278 * definition in that the time can be changed as long as the
4279 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4280 * no separate checks are made to insure that the caller is the
4281 * owner of the file or has special privs enabled.
4282 * Code here is based on Joe Meadows' FILE utility.
4285 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4286 * to VMS epoch (01-JAN-1858 00:00:00.00)
4287 * in 100 ns intervals.
4289 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4291 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4292 int my_utime(char *file, struct utimbuf *utimes)
4296 long int bintime[2], len = 2, lowbit, unixtime,
4297 secscale = 10000000; /* seconds --> 100 ns intervals */
4298 unsigned long int chan, iosb[2], retsts;
4299 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4300 struct FAB myfab = cc$rms_fab;
4301 struct NAM mynam = cc$rms_nam;
4302 #if defined (__DECC) && defined (__VAX)
4303 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4304 * at least through VMS V6.1, which causes a type-conversion warning.
4306 # pragma message save
4307 # pragma message disable cvtdiftypes
4309 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4310 struct fibdef myfib;
4311 #if defined (__DECC) && defined (__VAX)
4312 /* This should be right after the declaration of myatr, but due
4313 * to a bug in VAX DEC C, this takes effect a statement early.
4315 # pragma message restore
4317 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4318 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4319 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4321 if (file == NULL || *file == '\0') {
4323 set_vaxc_errno(LIB$_INVARG);
4326 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4328 if (utimes != NULL) {
4329 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4330 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4331 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4332 * as input, we force the sign bit to be clear by shifting unixtime right
4333 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4335 lowbit = (utimes->modtime & 1) ? secscale : 0;
4336 unixtime = (long int) utimes->modtime;
4338 /* If input was UTC; convert to local for sys svc */
4339 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4341 unixtime >>= 1; secscale <<= 1;
4342 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4343 if (!(retsts & 1)) {
4345 set_vaxc_errno(retsts);
4348 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4349 if (!(retsts & 1)) {
4351 set_vaxc_errno(retsts);
4356 /* Just get the current time in VMS format directly */
4357 retsts = sys$gettim(bintime);
4358 if (!(retsts & 1)) {
4360 set_vaxc_errno(retsts);
4365 myfab.fab$l_fna = vmsspec;
4366 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4367 myfab.fab$l_nam = &mynam;
4368 mynam.nam$l_esa = esa;
4369 mynam.nam$b_ess = (unsigned char) sizeof esa;
4370 mynam.nam$l_rsa = rsa;
4371 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4373 /* Look for the file to be affected, letting RMS parse the file
4374 * specification for us as well. I have set errno using only
4375 * values documented in the utime() man page for VMS POSIX.
4377 retsts = sys$parse(&myfab,0,0);
4378 if (!(retsts & 1)) {
4379 set_vaxc_errno(retsts);
4380 if (retsts == RMS$_PRV) set_errno(EACCES);
4381 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4382 else set_errno(EVMSERR);
4385 retsts = sys$search(&myfab,0,0);
4386 if (!(retsts & 1)) {
4387 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4388 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4389 set_vaxc_errno(retsts);
4390 if (retsts == RMS$_PRV) set_errno(EACCES);
4391 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4392 else set_errno(EVMSERR);
4396 devdsc.dsc$w_length = mynam.nam$b_dev;
4397 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4399 retsts = sys$assign(&devdsc,&chan,0,0);
4400 if (!(retsts & 1)) {
4401 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4402 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4403 set_vaxc_errno(retsts);
4404 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4405 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4406 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4407 else set_errno(EVMSERR);
4411 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4412 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4414 memset((void *) &myfib, 0, sizeof myfib);
4416 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4417 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4418 /* This prevents the revision time of the file being reset to the current
4419 * time as a result of our IO$_MODIFY $QIO. */
4420 myfib.fib$l_acctl = FIB$M_NORECORD;
4422 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4423 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4424 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4426 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4427 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4428 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4429 _ckvmssts(sys$dassgn(chan));
4430 if (retsts & 1) retsts = iosb[0];
4431 if (!(retsts & 1)) {
4432 set_vaxc_errno(retsts);
4433 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4434 else set_errno(EVMSERR);
4439 } /* end of my_utime() */
4443 * flex_stat, flex_fstat
4444 * basic stat, but gets it right when asked to stat
4445 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4448 /* encode_dev packs a VMS device name string into an integer to allow
4449 * simple comparisons. This can be used, for example, to check whether two
4450 * files are located on the same device, by comparing their encoded device
4451 * names. Even a string comparison would not do, because stat() reuses the
4452 * device name buffer for each call; so without encode_dev, it would be
4453 * necessary to save the buffer and use strcmp (this would mean a number of
4454 * changes to the standard Perl code, to say nothing of what a Perl script
4457 * The device lock id, if it exists, should be unique (unless perhaps compared
4458 * with lock ids transferred from other nodes). We have a lock id if the disk is
4459 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4460 * device names. Thus we use the lock id in preference, and only if that isn't
4461 * available, do we try to pack the device name into an integer (flagged by
4462 * the sign bit (LOCKID_MASK) being set).
4464 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4465 * name and its encoded form, but it seems very unlikely that we will find
4466 * two files on different disks that share the same encoded device names,
4467 * and even more remote that they will share the same file id (if the test
4468 * is to check for the same file).
4470 * A better method might be to use sys$device_scan on the first call, and to
4471 * search for the device, returning an index into the cached array.
4472 * The number returned would be more intelligable.
4473 * This is probably not worth it, and anyway would take quite a bit longer
4474 * on the first call.
4476 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4477 static mydev_t encode_dev (const char *dev)
4480 unsigned long int f;
4486 if (!dev || !dev[0]) return 0;
4490 struct dsc$descriptor_s dev_desc;
4491 unsigned long int status, lockid, item = DVI$_LOCKID;
4493 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4494 can try that first. */
4495 dev_desc.dsc$w_length = strlen (dev);
4496 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4497 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4498 dev_desc.dsc$a_pointer = (char *) dev;
4499 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4500 if (lockid) return (lockid & ~LOCKID_MASK);
4504 /* Otherwise we try to encode the device name */
4508 for (q = dev + strlen(dev); q--; q >= dev) {
4511 else if (isalpha (toupper (*q)))
4512 c= toupper (*q) - 'A' + (char)10;
4514 continue; /* Skip '$'s */
4516 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4518 enc += f * (unsigned long int) c;
4520 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4522 } /* end of encode_dev() */
4524 static char namecache[NAM$C_MAXRSS+1];
4527 is_null_device(name)
4531 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4532 The underscore prefix, controller letter, and unit number are
4533 independently optional; for our purposes, the colon punctuation
4534 is not. The colon can be trailed by optional directory and/or
4535 filename, but two consecutive colons indicates a nodename rather
4536 than a device. [pr] */
4537 if (*name == '_') ++name;
4538 if (tolower(*name++) != 'n') return 0;
4539 if (tolower(*name++) != 'l') return 0;
4540 if (tolower(*name) == 'a') ++name;
4541 if (*name == '0') ++name;
4542 return (*name++ == ':') && (*name != ':');
4545 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4546 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4547 * subset of the applicable information.
4550 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4552 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4554 char fname[NAM$C_MAXRSS+1];
4555 unsigned long int retsts;
4556 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4557 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4559 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4560 device name on successive calls */
4561 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4562 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4563 namdsc.dsc$a_pointer = fname;
4564 namdsc.dsc$w_length = sizeof fname - 1;
4566 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4567 &namdsc,&namdsc.dsc$w_length,0,0);
4569 fname[namdsc.dsc$w_length] = '\0';
4570 return cando_by_name(bit,effective,fname);
4572 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4573 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4577 return FALSE; /* Should never get to here */
4579 } /* end of cando() */
4583 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4585 cando_by_name(I32 bit, Uid_t effective, char *fname)
4587 static char usrname[L_cuserid];
4588 static struct dsc$descriptor_s usrdsc =
4589 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4590 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4591 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4592 unsigned short int retlen;
4594 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4595 union prvdef curprv;
4596 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4597 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4598 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4601 if (!fname || !*fname) return FALSE;
4602 /* Make sure we expand logical names, since sys$check_access doesn't */
4603 if (!strpbrk(fname,"/]>:")) {
4604 strcpy(fileified,fname);
4605 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4608 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4609 retlen = namdsc.dsc$w_length = strlen(vmsname);
4610 namdsc.dsc$a_pointer = vmsname;
4611 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4612 vmsname[retlen-1] == ':') {
4613 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4614 namdsc.dsc$w_length = strlen(fileified);
4615 namdsc.dsc$a_pointer = fileified;
4618 if (!usrdsc.dsc$w_length) {
4620 usrdsc.dsc$w_length = strlen(usrname);
4627 access = ARM$M_EXECUTE;
4632 access = ARM$M_READ;
4637 access = ARM$M_WRITE;
4642 access = ARM$M_DELETE;
4648 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4649 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4650 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4651 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4652 set_vaxc_errno(retsts);
4653 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4654 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4655 else set_errno(ENOENT);
4658 if (retsts == SS$_NORMAL) {
4659 if (!privused) return TRUE;
4660 /* We can get access, but only by using privs. Do we have the
4661 necessary privs currently enabled? */
4662 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4663 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4664 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4665 !curprv.prv$v_bypass) return FALSE;
4666 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4667 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4668 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4671 if (retsts == SS$_ACCONFLICT) {
4676 return FALSE; /* Should never get here */
4678 } /* end of cando_by_name() */
4682 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4684 flex_fstat(int fd, Stat_t *statbufp)
4687 if (!fstat(fd,(stat_t *) statbufp)) {
4688 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4689 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4690 # ifdef RTL_USES_UTC
4693 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4694 statbufp->st_atime = _toloc(statbufp->st_atime);
4695 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4700 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4704 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4705 statbufp->st_atime = _toutc(statbufp->st_atime);
4706 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4713 } /* end of flex_fstat() */
4716 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4718 flex_stat(const char *fspec, Stat_t *statbufp)
4721 char fileified[NAM$C_MAXRSS+1];
4722 char temp_fspec[NAM$C_MAXRSS+300];
4725 strcpy(temp_fspec, fspec);
4726 if (statbufp == (Stat_t *) &PL_statcache)
4727 do_tovmsspec(temp_fspec,namecache,0);
4728 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4729 memset(statbufp,0,sizeof *statbufp);
4730 statbufp->st_dev = encode_dev("_NLA0:");
4731 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4732 statbufp->st_uid = 0x00010001;
4733 statbufp->st_gid = 0x0001;
4734 time((time_t *)&statbufp->st_mtime);
4735 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4739 /* Try for a directory name first. If fspec contains a filename without
4740 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4741 * and sea:[wine.dark]water. exist, we prefer the directory here.
4742 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4743 * not sea:[wine.dark]., if the latter exists. If the intended target is
4744 * the file with null type, specify this by calling flex_stat() with
4745 * a '.' at the end of fspec.
4747 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4748 retval = stat(fileified,(stat_t *) statbufp);
4749 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4750 strcpy(namecache,fileified);
4752 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4754 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4755 # ifdef RTL_USES_UTC
4758 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4759 statbufp->st_atime = _toloc(statbufp->st_atime);
4760 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4765 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4769 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4770 statbufp->st_atime = _toutc(statbufp->st_atime);
4771 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4777 } /* end of flex_stat() */
4781 /*{{{char *my_getlogin()*/
4782 /* VMS cuserid == Unix getlogin, except calling sequence */
4786 static char user[L_cuserid];
4787 return cuserid(user);
4792 /* rmscopy - copy a file using VMS RMS routines
4794 * Copies contents and attributes of spec_in to spec_out, except owner
4795 * and protection information. Name and type of spec_in are used as
4796 * defaults for spec_out. The third parameter specifies whether rmscopy()
4797 * should try to propagate timestamps from the input file to the output file.
4798 * If it is less than 0, no timestamps are preserved. If it is 0, then
4799 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4800 * propagated to the output file at creation iff the output file specification
4801 * did not contain an explicit name or type, and the revision date is always
4802 * updated at the end of the copy operation. If it is greater than 0, then
4803 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4804 * other than the revision date should be propagated, and bit 1 indicates
4805 * that the revision date should be propagated.
4807 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4809 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4810 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4811 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4812 * as part of the Perl standard distribution under the terms of the
4813 * GNU General Public License or the Perl Artistic License. Copies
4814 * of each may be found in the Perl standard distribution.
4816 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4818 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4820 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4821 rsa[NAM$C_MAXRSS], ubf[32256];
4822 unsigned long int i, sts, sts2;
4823 struct FAB fab_in, fab_out;
4824 struct RAB rab_in, rab_out;
4826 struct XABDAT xabdat;
4827 struct XABFHC xabfhc;
4828 struct XABRDT xabrdt;
4829 struct XABSUM xabsum;
4831 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4832 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4833 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4837 fab_in = cc$rms_fab;
4838 fab_in.fab$l_fna = vmsin;
4839 fab_in.fab$b_fns = strlen(vmsin);
4840 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4841 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4842 fab_in.fab$l_fop = FAB$M_SQO;
4843 fab_in.fab$l_nam = &nam;
4844 fab_in.fab$l_xab = (void *) &xabdat;
4847 nam.nam$l_rsa = rsa;
4848 nam.nam$b_rss = sizeof(rsa);
4849 nam.nam$l_esa = esa;
4850 nam.nam$b_ess = sizeof (esa);
4851 nam.nam$b_esl = nam.nam$b_rsl = 0;
4853 xabdat = cc$rms_xabdat; /* To get creation date */
4854 xabdat.xab$l_nxt = (void *) &xabfhc;
4856 xabfhc = cc$rms_xabfhc; /* To get record length */
4857 xabfhc.xab$l_nxt = (void *) &xabsum;
4859 xabsum = cc$rms_xabsum; /* To get key and area information */
4861 if (!((sts = sys$open(&fab_in)) & 1)) {
4862 set_vaxc_errno(sts);
4866 set_errno(ENOENT); break;
4868 set_errno(ENODEV); break;
4870 set_errno(EINVAL); break;
4872 set_errno(EACCES); break;
4880 fab_out.fab$w_ifi = 0;
4881 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4882 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4883 fab_out.fab$l_fop = FAB$M_SQO;
4884 fab_out.fab$l_fna = vmsout;
4885 fab_out.fab$b_fns = strlen(vmsout);
4886 fab_out.fab$l_dna = nam.nam$l_name;
4887 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4889 if (preserve_dates == 0) { /* Act like DCL COPY */
4890 nam.nam$b_nop = NAM$M_SYNCHK;
4891 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4892 if (!((sts = sys$parse(&fab_out)) & 1)) {
4893 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4894 set_vaxc_errno(sts);
4897 fab_out.fab$l_xab = (void *) &xabdat;
4898 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4900 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4901 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4902 preserve_dates =0; /* bitmask from this point forward */
4904 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4905 if (!((sts = sys$create(&fab_out)) & 1)) {
4906 set_vaxc_errno(sts);
4909 set_errno(ENOENT); break;
4911 set_errno(ENODEV); break;
4913 set_errno(EINVAL); break;
4915 set_errno(EACCES); break;
4921 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4922 if (preserve_dates & 2) {
4923 /* sys$close() will process xabrdt, not xabdat */
4924 xabrdt = cc$rms_xabrdt;
4926 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4928 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4929 * is unsigned long[2], while DECC & VAXC use a struct */
4930 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4932 fab_out.fab$l_xab = (void *) &xabrdt;
4935 rab_in = cc$rms_rab;
4936 rab_in.rab$l_fab = &fab_in;
4937 rab_in.rab$l_rop = RAB$M_BIO;
4938 rab_in.rab$l_ubf = ubf;
4939 rab_in.rab$w_usz = sizeof ubf;
4940 if (!((sts = sys$connect(&rab_in)) & 1)) {
4941 sys$close(&fab_in); sys$close(&fab_out);
4942 set_errno(EVMSERR); set_vaxc_errno(sts);
4946 rab_out = cc$rms_rab;
4947 rab_out.rab$l_fab = &fab_out;
4948 rab_out.rab$l_rbf = ubf;
4949 if (!((sts = sys$connect(&rab_out)) & 1)) {
4950 sys$close(&fab_in); sys$close(&fab_out);
4951 set_errno(EVMSERR); set_vaxc_errno(sts);
4955 while ((sts = sys$read(&rab_in))) { /* always true */
4956 if (sts == RMS$_EOF) break;
4957 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4958 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4959 sys$close(&fab_in); sys$close(&fab_out);
4960 set_errno(EVMSERR); set_vaxc_errno(sts);
4965 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4966 sys$close(&fab_in); sys$close(&fab_out);
4967 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4969 set_errno(EVMSERR); set_vaxc_errno(sts);
4975 } /* end of rmscopy() */
4979 /*** The following glue provides 'hooks' to make some of the routines
4980 * from this file available from Perl. These routines are sufficiently
4981 * basic, and are required sufficiently early in the build process,
4982 * that's it's nice to have them available to miniperl as well as the
4983 * full Perl, so they're set up here instead of in an extension. The
4984 * Perl code which handles importation of these names into a given
4985 * package lives in [.VMS]Filespec.pm in @INC.
4989 rmsexpand_fromperl(pTHX_ CV *cv)
4992 char *fspec, *defspec = NULL, *rslt;
4995 if (!items || items > 2)
4996 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4997 fspec = SvPV(ST(0),n_a);
4998 if (!fspec || !*fspec) XSRETURN_UNDEF;
4999 if (items == 2) defspec = SvPV(ST(1),n_a);
5001 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5002 ST(0) = sv_newmortal();
5003 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5008 vmsify_fromperl(pTHX_ CV *cv)
5014 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5015 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5016 ST(0) = sv_newmortal();
5017 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5022 unixify_fromperl(pTHX_ CV *cv)
5028 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5029 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5030 ST(0) = sv_newmortal();
5031 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5036 fileify_fromperl(pTHX_ CV *cv)
5042 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5043 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5044 ST(0) = sv_newmortal();
5045 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5050 pathify_fromperl(pTHX_ CV *cv)
5056 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5057 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5058 ST(0) = sv_newmortal();
5059 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5064 vmspath_fromperl(pTHX_ CV *cv)
5070 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5071 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5072 ST(0) = sv_newmortal();
5073 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5078 unixpath_fromperl(pTHX_ CV *cv)
5084 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5085 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5086 ST(0) = sv_newmortal();
5087 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5092 candelete_fromperl(pTHX_ CV *cv)
5095 char fspec[NAM$C_MAXRSS+1], *fsp;
5100 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5102 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5103 if (SvTYPE(mysv) == SVt_PVGV) {
5104 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5105 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5112 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5113 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5119 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5124 rmscopy_fromperl(pTHX_ CV *cv)
5127 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5129 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5130 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5131 unsigned long int sts;
5136 if (items < 2 || items > 3)
5137 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5139 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5140 if (SvTYPE(mysv) == SVt_PVGV) {
5141 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5142 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5149 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5150 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5155 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5156 if (SvTYPE(mysv) == SVt_PVGV) {
5157 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5158 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5165 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5166 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5171 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5173 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5180 char* file = __FILE__;
5182 char temp_buff[512];
5183 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5184 no_translate_barewords = TRUE;
5186 no_translate_barewords = FALSE;
5189 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5190 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5191 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5192 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5193 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5194 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5195 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5196 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5197 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);