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 */
914 /*{{{int my_chdir(char *)*/
918 STRLEN dirlen = strlen(dir);
921 /* zero length string sometimes gives ACCVIO */
922 if (dirlen == 0) return -1;
924 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
926 * null file name/type. However, it's commonplace under Unix,
927 * so we'll allow it for a gain in portability.
929 if (dir[dirlen-1] == '/') {
930 char *newdir = savepvn(dir,dirlen-1);
931 int ret = chdir(newdir);
935 else return chdir(dir);
936 } /* end of my_chdir */
940 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
942 static unsigned long int mbxbufsiz;
943 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
948 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
949 * preprocessor consant BUFSIZ from stdio.h as the size of the
952 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
953 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
955 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
957 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
958 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
960 } /* end of create_mbx() */
962 /*{{{ my_popen and my_pclose*/
965 struct pipe_details *next;
966 PerlIO *fp; /* stdio file pointer to pipe mailbox */
967 int pid; /* PID of subprocess */
968 int mode; /* == 'r' if pipe open for reading */
969 int done; /* subprocess has completed */
970 unsigned long int completion; /* termination status of subprocess */
973 struct exit_control_block
975 struct exit_control_block *flink;
976 unsigned long int (*exit_routine)();
977 unsigned long int arg_count;
978 unsigned long int *status_address;
979 unsigned long int exit_status;
982 static struct pipe_details *open_pipes = NULL;
983 static $DESCRIPTOR(nl_desc, "NL:");
984 static int waitpid_asleep = 0;
986 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
987 * to a mbx; that's the caller's responsibility.
989 static unsigned long int
990 pipe_eof(FILE *fp, int immediate)
992 char devnam[NAM$C_MAXRSS+1], *cp;
993 unsigned long int chan, iosb[2], retsts, retsts2;
994 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
997 if (fgetname(fp,devnam,1)) {
998 /* It oughta be a mailbox, so fgetname should give just the device
999 * name, but just in case . . . */
1000 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
1001 devdsc.dsc$w_length = strlen(devnam);
1002 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
1003 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
1004 iosb,0,0,0,0,0,0,0,0);
1005 if (retsts & 1) retsts = iosb[0];
1006 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
1007 if (retsts & 1) retsts = retsts2;
1011 else _ckvmssts(vaxc$errno); /* Should never happen */
1012 return (unsigned long int) vaxc$errno;
1015 static unsigned long int
1018 struct pipe_details *info;
1019 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1024 first we try sending an EOF...ignore if doesn't work, make sure we
1032 _ckvmssts(sys$setast(0));
1033 need_eof = info->mode != 'r' && !info->done;
1034 _ckvmssts(sys$setast(1));
1036 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1040 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1045 _ckvmssts(sys$setast(0));
1046 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1047 sts = sys$forcex(&info->pid,0,&abort);
1048 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1051 _ckvmssts(sys$setast(1));
1054 if (did_stuff) sleep(1); /* wait for them to respond */
1058 _ckvmssts(sys$setast(0));
1059 if (!info->done) { /* We tried to be nice . . . */
1060 sts = sys$delprc(&info->pid,0);
1061 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1062 info->done = 1; /* so my_pclose doesn't try to write EOF */
1064 _ckvmssts(sys$setast(1));
1069 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1070 else if (!(sts & 1)) retsts = sts;
1075 static struct exit_control_block pipe_exitblock =
1076 {(struct exit_control_block *) 0,
1077 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1081 popen_completion_ast(struct pipe_details *thispipe)
1083 thispipe->done = TRUE;
1084 if (waitpid_asleep) {
1090 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1091 static void vms_execfree();
1094 safe_popen(char *cmd, char *mode)
1096 static int handler_set_up = FALSE;
1098 unsigned short int chan;
1099 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1101 struct pipe_details *info;
1102 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1103 DSC$K_CLASS_S, mbxname},
1104 cmddsc = {0, DSC$K_DTYPE_T,
1108 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1109 New(1301,info,1,struct pipe_details);
1111 /* create mailbox */
1112 create_mbx(&chan,&namdsc);
1114 /* open a FILE* onto it */
1115 info->fp = PerlIO_open(mbxname, mode);
1117 /* give up other channel onto it */
1118 _ckvmssts(sys$dassgn(chan));
1128 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1129 0 /* name */, &info->pid, &info->completion,
1130 0, popen_completion_ast,info,0,0,0));
1133 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1134 0 /* name */, &info->pid, &info->completion,
1135 0, popen_completion_ast,info,0,0,0));
1139 if (!handler_set_up) {
1140 _ckvmssts(sys$dclexh(&pipe_exitblock));
1141 handler_set_up = TRUE;
1143 info->next=open_pipes; /* prepend to list */
1146 PL_forkprocess = info->pid;
1148 } /* end of safe_popen */
1151 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1153 Perl_my_popen(pTHX_ char *cmd, char *mode)
1156 TAINT_PROPER("popen");
1157 PERL_FLUSHALL_FOR_CHILD;
1158 return safe_popen(cmd,mode);
1163 /*{{{ I32 my_pclose(FILE *fp)*/
1164 I32 Perl_my_pclose(pTHX_ FILE *fp)
1166 struct pipe_details *info, *last = NULL;
1167 unsigned long int retsts;
1170 for (info = open_pipes; info != NULL; last = info, info = info->next)
1171 if (info->fp == fp) break;
1173 if (info == NULL) { /* no such pipe open */
1174 set_errno(ECHILD); /* quoth POSIX */
1175 set_vaxc_errno(SS$_NONEXPR);
1179 /* If we were writing to a subprocess, insure that someone reading from
1180 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1181 * produce an EOF record in the mailbox. */
1182 _ckvmssts(sys$setast(0));
1183 need_eof = info->mode != 'r' && !info->done;
1184 _ckvmssts(sys$setast(1));
1185 if (need_eof) pipe_eof(info->fp,0);
1186 PerlIO_close(info->fp);
1188 if (info->done) retsts = info->completion;
1189 else waitpid(info->pid,(int *) &retsts,0);
1191 /* remove from list of open pipes */
1192 _ckvmssts(sys$setast(0));
1193 if (last) last->next = info->next;
1194 else open_pipes = info->next;
1195 _ckvmssts(sys$setast(1));
1200 } /* end of my_pclose() */
1202 /* sort-of waitpid; use only with popen() */
1203 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1205 my_waitpid(Pid_t pid, int *statusp, int flags)
1207 struct pipe_details *info;
1210 for (info = open_pipes; info != NULL; info = info->next)
1211 if (info->pid == pid) break;
1213 if (info != NULL) { /* we know about this child */
1214 while (!info->done) {
1219 *statusp = info->completion;
1222 else { /* we haven't heard of this child */
1223 $DESCRIPTOR(intdsc,"0 00:00:01");
1224 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1225 unsigned long int interval[2],sts;
1227 if (ckWARN(WARN_EXEC)) {
1228 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1229 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1230 if (ownerpid != mypid)
1231 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1234 _ckvmssts(sys$bintim(&intdsc,interval));
1235 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1236 _ckvmssts(sys$schdwk(0,0,interval,0));
1237 _ckvmssts(sys$hiber());
1241 /* There's no easy way to find the termination status a child we're
1242 * not aware of beforehand. If we're really interested in the future,
1243 * we can go looking for a termination mailbox, or chase after the
1244 * accounting record for the process.
1250 } /* end of waitpid() */
1255 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1257 my_gconvert(double val, int ndig, int trail, char *buf)
1259 static char __gcvtbuf[DBL_DIG+1];
1262 loc = buf ? buf : __gcvtbuf;
1264 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1266 sprintf(loc,"%.*g",ndig,val);
1272 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1273 return gcvt(val,ndig,loc);
1276 loc[0] = '0'; loc[1] = '\0';
1284 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1285 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1286 * to expand file specification. Allows for a single default file
1287 * specification and a simple mask of options. If outbuf is non-NULL,
1288 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1289 * the resultant file specification is placed. If outbuf is NULL, the
1290 * resultant file specification is placed into a static buffer.
1291 * The third argument, if non-NULL, is taken to be a default file
1292 * specification string. The fourth argument is unused at present.
1293 * rmesexpand() returns the address of the resultant string if
1294 * successful, and NULL on error.
1296 static char *do_tounixspec(char *, char *, int);
1299 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1301 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1302 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1303 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1304 struct FAB myfab = cc$rms_fab;
1305 struct NAM mynam = cc$rms_nam;
1307 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1309 if (!filespec || !*filespec) {
1310 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1314 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1315 else outbuf = __rmsexpand_retbuf;
1317 if ((isunix = (strchr(filespec,'/') != NULL))) {
1318 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1319 filespec = vmsfspec;
1322 myfab.fab$l_fna = filespec;
1323 myfab.fab$b_fns = strlen(filespec);
1324 myfab.fab$l_nam = &mynam;
1326 if (defspec && *defspec) {
1327 if (strchr(defspec,'/') != NULL) {
1328 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1331 myfab.fab$l_dna = defspec;
1332 myfab.fab$b_dns = strlen(defspec);
1335 mynam.nam$l_esa = esa;
1336 mynam.nam$b_ess = sizeof esa;
1337 mynam.nam$l_rsa = outbuf;
1338 mynam.nam$b_rss = NAM$C_MAXRSS;
1340 retsts = sys$parse(&myfab,0,0);
1341 if (!(retsts & 1)) {
1342 mynam.nam$b_nop |= NAM$M_SYNCHK;
1343 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1344 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1345 retsts = sys$parse(&myfab,0,0);
1346 if (retsts & 1) goto expanded;
1348 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1349 (void) sys$parse(&myfab,0,0); /* Free search context */
1350 if (out) Safefree(out);
1351 set_vaxc_errno(retsts);
1352 if (retsts == RMS$_PRV) set_errno(EACCES);
1353 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1354 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1355 else set_errno(EVMSERR);
1358 retsts = sys$search(&myfab,0,0);
1359 if (!(retsts & 1) && retsts != RMS$_FNF) {
1360 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1361 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1362 if (out) Safefree(out);
1363 set_vaxc_errno(retsts);
1364 if (retsts == RMS$_PRV) set_errno(EACCES);
1365 else set_errno(EVMSERR);
1369 /* If the input filespec contained any lowercase characters,
1370 * downcase the result for compatibility with Unix-minded code. */
1372 for (out = myfab.fab$l_fna; *out; out++)
1373 if (islower(*out)) { haslower = 1; break; }
1374 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1375 else { out = esa; speclen = mynam.nam$b_esl; }
1376 /* Trim off null fields added by $PARSE
1377 * If type > 1 char, must have been specified in original or default spec
1378 * (not true for version; $SEARCH may have added version of existing file).
1380 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1381 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1382 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1383 if (trimver || trimtype) {
1384 if (defspec && *defspec) {
1385 char defesa[NAM$C_MAXRSS];
1386 struct FAB deffab = cc$rms_fab;
1387 struct NAM defnam = cc$rms_nam;
1389 deffab.fab$l_nam = &defnam;
1390 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1391 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1392 defnam.nam$b_nop = NAM$M_SYNCHK;
1393 if (sys$parse(&deffab,0,0) & 1) {
1394 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1395 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1398 if (trimver) speclen = mynam.nam$l_ver - out;
1400 /* If we didn't already trim version, copy down */
1401 if (speclen > mynam.nam$l_ver - out)
1402 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1403 speclen - (mynam.nam$l_ver - out));
1404 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1407 /* If we just had a directory spec on input, $PARSE "helpfully"
1408 * adds an empty name and type for us */
1409 if (mynam.nam$l_name == mynam.nam$l_type &&
1410 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1411 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1412 speclen = mynam.nam$l_name - out;
1413 out[speclen] = '\0';
1414 if (haslower) __mystrtolower(out);
1416 /* Have we been working with an expanded, but not resultant, spec? */
1417 /* Also, convert back to Unix syntax if necessary. */
1418 if (!mynam.nam$b_rsl) {
1420 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1422 else strcpy(outbuf,esa);
1425 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1426 strcpy(outbuf,tmpfspec);
1428 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1429 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1430 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1434 /* External entry points */
1435 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1436 { return do_rmsexpand(spec,buf,0,def,opt); }
1437 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1438 { return do_rmsexpand(spec,buf,1,def,opt); }
1442 ** The following routines are provided to make life easier when
1443 ** converting among VMS-style and Unix-style directory specifications.
1444 ** All will take input specifications in either VMS or Unix syntax. On
1445 ** failure, all return NULL. If successful, the routines listed below
1446 ** return a pointer to a buffer containing the appropriately
1447 ** reformatted spec (and, therefore, subsequent calls to that routine
1448 ** will clobber the result), while the routines of the same names with
1449 ** a _ts suffix appended will return a pointer to a mallocd string
1450 ** containing the appropriately reformatted spec.
1451 ** In all cases, only explicit syntax is altered; no check is made that
1452 ** the resulting string is valid or that the directory in question
1455 ** fileify_dirspec() - convert a directory spec into the name of the
1456 ** directory file (i.e. what you can stat() to see if it's a dir).
1457 ** The style (VMS or Unix) of the result is the same as the style
1458 ** of the parameter passed in.
1459 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1460 ** what you prepend to a filename to indicate what directory it's in).
1461 ** The style (VMS or Unix) of the result is the same as the style
1462 ** of the parameter passed in.
1463 ** tounixpath() - convert a directory spec into a Unix-style path.
1464 ** tovmspath() - convert a directory spec into a VMS-style path.
1465 ** tounixspec() - convert any file spec into a Unix-style file spec.
1466 ** tovmsspec() - convert any file spec into a VMS-style spec.
1468 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1469 ** Permission is given to distribute this code as part of the Perl
1470 ** standard distribution under the terms of the GNU General Public
1471 ** License or the Perl Artistic License. Copies of each may be
1472 ** found in the Perl standard distribution.
1475 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1476 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1478 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1479 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1480 char *retspec, *cp1, *cp2, *lastdir;
1481 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1483 if (!dir || !*dir) {
1484 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1486 dirlen = strlen(dir);
1487 while (dir[dirlen-1] == '/') --dirlen;
1488 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1489 strcpy(trndir,"/sys$disk/000000");
1493 if (dirlen > NAM$C_MAXRSS) {
1494 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1496 if (!strpbrk(dir+1,"/]>:")) {
1497 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1498 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1500 dirlen = strlen(dir);
1503 strncpy(trndir,dir,dirlen);
1504 trndir[dirlen] = '\0';
1507 /* If we were handed a rooted logical name or spec, treat it like a
1508 * simple directory, so that
1509 * $ Define myroot dev:[dir.]
1510 * ... do_fileify_dirspec("myroot",buf,1) ...
1511 * does something useful.
1513 if (!strcmp(dir+dirlen-2,".]")) {
1514 dir[--dirlen] = '\0';
1515 dir[dirlen-1] = ']';
1518 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1519 /* If we've got an explicit filename, we can just shuffle the string. */
1520 if (*(cp1+1)) hasfilename = 1;
1521 /* Similarly, we can just back up a level if we've got multiple levels
1522 of explicit directories in a VMS spec which ends with directories. */
1524 for (cp2 = cp1; cp2 > dir; cp2--) {
1526 *cp2 = *cp1; *cp1 = '\0';
1530 if (*cp2 == '[' || *cp2 == '<') break;
1535 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1536 if (dir[0] == '.') {
1537 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1538 return do_fileify_dirspec("[]",buf,ts);
1539 else if (dir[1] == '.' &&
1540 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1541 return do_fileify_dirspec("[-]",buf,ts);
1543 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1544 dirlen -= 1; /* to last element */
1545 lastdir = strrchr(dir,'/');
1547 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1548 /* If we have "/." or "/..", VMSify it and let the VMS code
1549 * below expand it, rather than repeating the code to handle
1550 * relative components of a filespec here */
1552 if (*(cp1+2) == '.') cp1++;
1553 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1554 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1555 if (strchr(vmsdir,'/') != NULL) {
1556 /* If do_tovmsspec() returned it, it must have VMS syntax
1557 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1558 * the time to check this here only so we avoid a recursion
1559 * loop; otherwise, gigo.
1561 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1563 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1564 return do_tounixspec(trndir,buf,ts);
1567 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1568 lastdir = strrchr(dir,'/');
1570 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1571 /* Ditto for specs that end in an MFD -- let the VMS code
1572 * figure out whether it's a real device or a rooted logical. */
1573 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1574 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1575 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1576 return do_tounixspec(trndir,buf,ts);
1579 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1580 !(lastdir = cp1 = strrchr(dir,']')) &&
1581 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1582 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1584 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1585 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1586 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1587 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1588 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1589 (ver || *cp3)))))) {
1591 set_vaxc_errno(RMS$_DIR);
1597 /* If we lead off with a device or rooted logical, add the MFD
1598 if we're specifying a top-level directory. */
1599 if (lastdir && *dir == '/') {
1601 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1608 retlen = dirlen + (addmfd ? 13 : 6);
1609 if (buf) retspec = buf;
1610 else if (ts) New(1309,retspec,retlen+1,char);
1611 else retspec = __fileify_retbuf;
1613 dirlen = lastdir - dir;
1614 memcpy(retspec,dir,dirlen);
1615 strcpy(&retspec[dirlen],"/000000");
1616 strcpy(&retspec[dirlen+7],lastdir);
1619 memcpy(retspec,dir,dirlen);
1620 retspec[dirlen] = '\0';
1622 /* We've picked up everything up to the directory file name.
1623 Now just add the type and version, and we're set. */
1624 strcat(retspec,".dir;1");
1627 else { /* VMS-style directory spec */
1628 char esa[NAM$C_MAXRSS+1], term, *cp;
1629 unsigned long int sts, cmplen, haslower = 0;
1630 struct FAB dirfab = cc$rms_fab;
1631 struct NAM savnam, dirnam = cc$rms_nam;
1633 dirfab.fab$b_fns = strlen(dir);
1634 dirfab.fab$l_fna = dir;
1635 dirfab.fab$l_nam = &dirnam;
1636 dirfab.fab$l_dna = ".DIR;1";
1637 dirfab.fab$b_dns = 6;
1638 dirnam.nam$b_ess = NAM$C_MAXRSS;
1639 dirnam.nam$l_esa = esa;
1641 for (cp = dir; *cp; cp++)
1642 if (islower(*cp)) { haslower = 1; break; }
1643 if (!((sts = sys$parse(&dirfab))&1)) {
1644 if (dirfab.fab$l_sts == RMS$_DIR) {
1645 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1646 sts = sys$parse(&dirfab) & 1;
1650 set_vaxc_errno(dirfab.fab$l_sts);
1656 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1657 /* Yes; fake the fnb bits so we'll check type below */
1658 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1660 else { /* No; just work with potential name */
1661 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1663 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1664 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1665 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1670 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1671 cp1 = strchr(esa,']');
1672 if (!cp1) cp1 = strchr(esa,'>');
1673 if (cp1) { /* Should always be true */
1674 dirnam.nam$b_esl -= cp1 - esa - 1;
1675 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1678 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1679 /* Yep; check version while we're at it, if it's there. */
1680 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1681 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1682 /* Something other than .DIR[;1]. Bzzt. */
1683 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1684 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1686 set_vaxc_errno(RMS$_DIR);
1690 esa[dirnam.nam$b_esl] = '\0';
1691 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1692 /* They provided at least the name; we added the type, if necessary, */
1693 if (buf) retspec = buf; /* in sys$parse() */
1694 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1695 else retspec = __fileify_retbuf;
1696 strcpy(retspec,esa);
1697 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1698 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1701 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1702 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1704 dirnam.nam$b_esl -= 9;
1706 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1707 if (cp1 == NULL) { /* should never happen */
1708 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1709 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1714 retlen = strlen(esa);
1715 if ((cp1 = strrchr(esa,'.')) != NULL) {
1716 /* There's more than one directory in the path. Just roll back. */
1718 if (buf) retspec = buf;
1719 else if (ts) New(1311,retspec,retlen+7,char);
1720 else retspec = __fileify_retbuf;
1721 strcpy(retspec,esa);
1724 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1725 /* Go back and expand rooted logical name */
1726 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1727 if (!(sys$parse(&dirfab) & 1)) {
1728 dirnam.nam$l_rlf = NULL;
1729 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1731 set_vaxc_errno(dirfab.fab$l_sts);
1734 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1735 if (buf) retspec = buf;
1736 else if (ts) New(1312,retspec,retlen+16,char);
1737 else retspec = __fileify_retbuf;
1738 cp1 = strstr(esa,"][");
1740 memcpy(retspec,esa,dirlen);
1741 if (!strncmp(cp1+2,"000000]",7)) {
1742 retspec[dirlen-1] = '\0';
1743 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1744 if (*cp1 == '.') *cp1 = ']';
1746 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1747 memcpy(cp1+1,"000000]",7);
1751 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1752 retspec[retlen] = '\0';
1753 /* Convert last '.' to ']' */
1754 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1755 if (*cp1 == '.') *cp1 = ']';
1757 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1758 memcpy(cp1+1,"000000]",7);
1762 else { /* This is a top-level dir. Add the MFD to the path. */
1763 if (buf) retspec = buf;
1764 else if (ts) New(1312,retspec,retlen+16,char);
1765 else retspec = __fileify_retbuf;
1768 while (*cp1 != ':') *(cp2++) = *(cp1++);
1769 strcpy(cp2,":[000000]");
1774 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1775 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1776 /* We've set up the string up through the filename. Add the
1777 type and version, and we're done. */
1778 strcat(retspec,".DIR;1");
1780 /* $PARSE may have upcased filespec, so convert output to lower
1781 * case if input contained any lowercase characters. */
1782 if (haslower) __mystrtolower(retspec);
1785 } /* end of do_fileify_dirspec() */
1787 /* External entry points */
1788 char *fileify_dirspec(char *dir, char *buf)
1789 { return do_fileify_dirspec(dir,buf,0); }
1790 char *fileify_dirspec_ts(char *dir, char *buf)
1791 { return do_fileify_dirspec(dir,buf,1); }
1793 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1794 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1796 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1797 unsigned long int retlen;
1798 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1800 if (!dir || !*dir) {
1801 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1804 if (*dir) strcpy(trndir,dir);
1805 else getcwd(trndir,sizeof trndir - 1);
1807 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1808 && my_trnlnm(trndir,trndir,0)) {
1809 STRLEN trnlen = strlen(trndir);
1811 /* Trap simple rooted lnms, and return lnm:[000000] */
1812 if (!strcmp(trndir+trnlen-2,".]")) {
1813 if (buf) retpath = buf;
1814 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1815 else retpath = __pathify_retbuf;
1816 strcpy(retpath,dir);
1817 strcat(retpath,":[000000]");
1823 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1824 if (*dir == '.' && (*(dir+1) == '\0' ||
1825 (*(dir+1) == '.' && *(dir+2) == '\0')))
1826 retlen = 2 + (*(dir+1) != '\0');
1828 if ( !(cp1 = strrchr(dir,'/')) &&
1829 !(cp1 = strrchr(dir,']')) &&
1830 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1831 if ((cp2 = strchr(cp1,'.')) != NULL &&
1832 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1833 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1834 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1835 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1837 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1838 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1839 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1840 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1841 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1842 (ver || *cp3)))))) {
1844 set_vaxc_errno(RMS$_DIR);
1847 retlen = cp2 - dir + 1;
1849 else { /* No file type present. Treat the filename as a directory. */
1850 retlen = strlen(dir) + 1;
1853 if (buf) retpath = buf;
1854 else if (ts) New(1313,retpath,retlen+1,char);
1855 else retpath = __pathify_retbuf;
1856 strncpy(retpath,dir,retlen-1);
1857 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1858 retpath[retlen-1] = '/'; /* with '/', add it. */
1859 retpath[retlen] = '\0';
1861 else retpath[retlen-1] = '\0';
1863 else { /* VMS-style directory spec */
1864 char esa[NAM$C_MAXRSS+1], *cp;
1865 unsigned long int sts, cmplen, haslower;
1866 struct FAB dirfab = cc$rms_fab;
1867 struct NAM savnam, dirnam = cc$rms_nam;
1869 /* If we've got an explicit filename, we can just shuffle the string. */
1870 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1871 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1872 if ((cp2 = strchr(cp1,'.')) != NULL) {
1874 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1875 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1876 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1877 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1878 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1879 (ver || *cp3)))))) {
1881 set_vaxc_errno(RMS$_DIR);
1885 else { /* No file type, so just draw name into directory part */
1886 for (cp2 = cp1; *cp2; cp2++) ;
1889 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1891 /* We've now got a VMS 'path'; fall through */
1893 dirfab.fab$b_fns = strlen(dir);
1894 dirfab.fab$l_fna = dir;
1895 if (dir[dirfab.fab$b_fns-1] == ']' ||
1896 dir[dirfab.fab$b_fns-1] == '>' ||
1897 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1898 if (buf) retpath = buf;
1899 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1900 else retpath = __pathify_retbuf;
1901 strcpy(retpath,dir);
1904 dirfab.fab$l_dna = ".DIR;1";
1905 dirfab.fab$b_dns = 6;
1906 dirfab.fab$l_nam = &dirnam;
1907 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1908 dirnam.nam$l_esa = esa;
1910 for (cp = dir; *cp; cp++)
1911 if (islower(*cp)) { haslower = 1; break; }
1913 if (!(sts = (sys$parse(&dirfab)&1))) {
1914 if (dirfab.fab$l_sts == RMS$_DIR) {
1915 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1916 sts = sys$parse(&dirfab) & 1;
1920 set_vaxc_errno(dirfab.fab$l_sts);
1926 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1927 if (dirfab.fab$l_sts != RMS$_FNF) {
1928 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1929 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1931 set_vaxc_errno(dirfab.fab$l_sts);
1934 dirnam = savnam; /* No; just work with potential name */
1937 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1938 /* Yep; check version while we're at it, if it's there. */
1939 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1940 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1941 /* Something other than .DIR[;1]. Bzzt. */
1942 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1943 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1945 set_vaxc_errno(RMS$_DIR);
1949 /* OK, the type was fine. Now pull any file name into the
1951 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1953 cp1 = strrchr(esa,'>');
1954 *dirnam.nam$l_type = '>';
1957 *(dirnam.nam$l_type + 1) = '\0';
1958 retlen = dirnam.nam$l_type - esa + 2;
1959 if (buf) retpath = buf;
1960 else if (ts) New(1314,retpath,retlen,char);
1961 else retpath = __pathify_retbuf;
1962 strcpy(retpath,esa);
1963 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1964 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1965 /* $PARSE may have upcased filespec, so convert output to lower
1966 * case if input contained any lowercase characters. */
1967 if (haslower) __mystrtolower(retpath);
1971 } /* end of do_pathify_dirspec() */
1973 /* External entry points */
1974 char *pathify_dirspec(char *dir, char *buf)
1975 { return do_pathify_dirspec(dir,buf,0); }
1976 char *pathify_dirspec_ts(char *dir, char *buf)
1977 { return do_pathify_dirspec(dir,buf,1); }
1979 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1980 static char *do_tounixspec(char *spec, char *buf, int ts)
1982 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1983 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1984 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1986 if (spec == NULL) return NULL;
1987 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1988 if (buf) rslt = buf;
1990 retlen = strlen(spec);
1991 cp1 = strchr(spec,'[');
1992 if (!cp1) cp1 = strchr(spec,'<');
1994 for (cp1++; *cp1; cp1++) {
1995 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1996 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1997 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
2000 New(1315,rslt,retlen+2+2*expand,char);
2002 else rslt = __tounixspec_retbuf;
2003 if (strchr(spec,'/') != NULL) {
2010 dirend = strrchr(spec,']');
2011 if (dirend == NULL) dirend = strrchr(spec,'>');
2012 if (dirend == NULL) dirend = strchr(spec,':');
2013 if (dirend == NULL) {
2017 if (*cp2 != '[' && *cp2 != '<') {
2020 else { /* the VMS spec begins with directories */
2022 if (*cp2 == ']' || *cp2 == '>') {
2023 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2026 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2027 if (getcwd(tmp,sizeof tmp,1) == NULL) {
2028 if (ts) Safefree(rslt);
2033 while (*cp3 != ':' && *cp3) cp3++;
2035 if (strchr(cp3,']') != NULL) break;
2036 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2038 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2039 retlen = devlen + dirlen;
2040 Renew(rslt,retlen+1+2*expand,char);
2046 *(cp1++) = *(cp3++);
2047 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2051 else if ( *cp2 == '.') {
2052 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2053 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2059 for (; cp2 <= dirend; cp2++) {
2062 if (*(cp2+1) == '[') cp2++;
2064 else if (*cp2 == ']' || *cp2 == '>') {
2065 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2067 else if (*cp2 == '.') {
2069 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2070 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2071 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2072 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2073 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2075 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2076 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2080 else if (*cp2 == '-') {
2081 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2082 while (*cp2 == '-') {
2084 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2086 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2087 if (ts) Safefree(rslt); /* filespecs like */
2088 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2092 else *(cp1++) = *cp2;
2094 else *(cp1++) = *cp2;
2096 while (*cp2) *(cp1++) = *(cp2++);
2101 } /* end of do_tounixspec() */
2103 /* External entry points */
2104 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2105 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2107 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2108 static char *do_tovmsspec(char *path, char *buf, int ts) {
2109 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2110 char *rslt, *dirend;
2111 register char *cp1, *cp2;
2112 unsigned long int infront = 0, hasdir = 1;
2114 if (path == NULL) return NULL;
2115 if (buf) rslt = buf;
2116 else if (ts) New(1316,rslt,strlen(path)+9,char);
2117 else rslt = __tovmsspec_retbuf;
2118 if (strpbrk(path,"]:>") ||
2119 (dirend = strrchr(path,'/')) == NULL) {
2120 if (path[0] == '.') {
2121 if (path[1] == '\0') strcpy(rslt,"[]");
2122 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2123 else strcpy(rslt,path); /* probably garbage */
2125 else strcpy(rslt,path);
2128 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2129 if (!*(dirend+2)) dirend +=2;
2130 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2131 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2136 char trndev[NAM$C_MAXRSS+1];
2140 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2142 if (!buf & ts) Renew(rslt,18,char);
2143 strcpy(rslt,"sys$disk:[000000]");
2146 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2148 islnm = my_trnlnm(rslt,trndev,0);
2149 trnend = islnm ? strlen(trndev) - 1 : 0;
2150 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2151 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2152 /* If the first element of the path is a logical name, determine
2153 * whether it has to be translated so we can add more directories. */
2154 if (!islnm || rooted) {
2157 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2161 if (cp2 != dirend) {
2162 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2163 strcpy(rslt,trndev);
2164 cp1 = rslt + trnend;
2177 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2178 cp2 += 2; /* skip over "./" - it's redundant */
2179 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2181 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2182 *(cp1++) = '-'; /* "../" --> "-" */
2185 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2186 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2187 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2188 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2191 if (cp2 > dirend) cp2 = dirend;
2193 else *(cp1++) = '.';
2195 for (; cp2 < dirend; cp2++) {
2197 if (*(cp2-1) == '/') continue;
2198 if (*(cp1-1) != '.') *(cp1++) = '.';
2201 else if (!infront && *cp2 == '.') {
2202 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2203 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2204 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2205 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2206 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2207 else { /* back up over previous directory name */
2209 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2210 if (*(cp1-1) == '[') {
2211 memcpy(cp1,"000000.",7);
2216 if (cp2 == dirend) break;
2218 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2219 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2220 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2221 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2223 *(cp1++) = '.'; /* Simulate trailing '/' */
2224 cp2 += 2; /* for loop will incr this to == dirend */
2226 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2228 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2231 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2232 if (*cp2 == '.') *(cp1++) = '_';
2233 else *(cp1++) = *cp2;
2237 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2238 if (hasdir) *(cp1++) = ']';
2239 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2240 while (*cp2) *(cp1++) = *(cp2++);
2245 } /* end of do_tovmsspec() */
2247 /* External entry points */
2248 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2249 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2251 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2252 static char *do_tovmspath(char *path, char *buf, int ts) {
2253 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2255 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2257 if (path == NULL) return NULL;
2258 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2259 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2260 if (buf) return buf;
2262 vmslen = strlen(vmsified);
2263 New(1317,cp,vmslen+1,char);
2264 memcpy(cp,vmsified,vmslen);
2269 strcpy(__tovmspath_retbuf,vmsified);
2270 return __tovmspath_retbuf;
2273 } /* end of do_tovmspath() */
2275 /* External entry points */
2276 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2277 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2280 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2281 static char *do_tounixpath(char *path, char *buf, int ts) {
2282 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2284 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2286 if (path == NULL) return NULL;
2287 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2288 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2289 if (buf) return buf;
2291 unixlen = strlen(unixified);
2292 New(1317,cp,unixlen+1,char);
2293 memcpy(cp,unixified,unixlen);
2298 strcpy(__tounixpath_retbuf,unixified);
2299 return __tounixpath_retbuf;
2302 } /* end of do_tounixpath() */
2304 /* External entry points */
2305 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2306 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2309 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2311 *****************************************************************************
2313 * Copyright (C) 1989-1994 by *
2314 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2316 * Permission is hereby granted for the reproduction of this software, *
2317 * on condition that this copyright notice is included in the reproduction, *
2318 * and that such reproduction is not for purposes of profit or material *
2321 * 27-Aug-1994 Modified for inclusion in perl5 *
2322 * by Charles Bailey bailey@newman.upenn.edu *
2323 *****************************************************************************
2327 * getredirection() is intended to aid in porting C programs
2328 * to VMS (Vax-11 C). The native VMS environment does not support
2329 * '>' and '<' I/O redirection, or command line wild card expansion,
2330 * or a command line pipe mechanism using the '|' AND background
2331 * command execution '&'. All of these capabilities are provided to any
2332 * C program which calls this procedure as the first thing in the
2334 * The piping mechanism will probably work with almost any 'filter' type
2335 * of program. With suitable modification, it may useful for other
2336 * portability problems as well.
2338 * Author: Mark Pizzolato mark@infocomm.com
2342 struct list_item *next;
2346 static void add_item(struct list_item **head,
2347 struct list_item **tail,
2351 static void expand_wild_cards(char *item,
2352 struct list_item **head,
2353 struct list_item **tail,
2356 static int background_process(int argc, char **argv);
2358 static void pipe_and_fork(char **cmargv);
2360 /*{{{ void getredirection(int *ac, char ***av)*/
2362 getredirection(int *ac, char ***av)
2364 * Process vms redirection arg's. Exit if any error is seen.
2365 * If getredirection() processes an argument, it is erased
2366 * from the vector. getredirection() returns a new argc and argv value.
2367 * In the event that a background command is requested (by a trailing "&"),
2368 * this routine creates a background subprocess, and simply exits the program.
2370 * Warning: do not try to simplify the code for vms. The code
2371 * presupposes that getredirection() is called before any data is
2372 * read from stdin or written to stdout.
2374 * Normal usage is as follows:
2380 * getredirection(&argc, &argv);
2384 int argc = *ac; /* Argument Count */
2385 char **argv = *av; /* Argument Vector */
2386 char *ap; /* Argument pointer */
2387 int j; /* argv[] index */
2388 int item_count = 0; /* Count of Items in List */
2389 struct list_item *list_head = 0; /* First Item in List */
2390 struct list_item *list_tail; /* Last Item in List */
2391 char *in = NULL; /* Input File Name */
2392 char *out = NULL; /* Output File Name */
2393 char *outmode = "w"; /* Mode to Open Output File */
2394 char *err = NULL; /* Error File Name */
2395 char *errmode = "w"; /* Mode to Open Error File */
2396 int cmargc = 0; /* Piped Command Arg Count */
2397 char **cmargv = NULL;/* Piped Command Arg Vector */
2400 * First handle the case where the last thing on the line ends with
2401 * a '&'. This indicates the desire for the command to be run in a
2402 * subprocess, so we satisfy that desire.
2405 if (0 == strcmp("&", ap))
2406 exit(background_process(--argc, argv));
2407 if (*ap && '&' == ap[strlen(ap)-1])
2409 ap[strlen(ap)-1] = '\0';
2410 exit(background_process(argc, argv));
2413 * Now we handle the general redirection cases that involve '>', '>>',
2414 * '<', and pipes '|'.
2416 for (j = 0; j < argc; ++j)
2418 if (0 == strcmp("<", argv[j]))
2422 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2423 exit(LIB$_WRONUMARG);
2428 if ('<' == *(ap = argv[j]))
2433 if (0 == strcmp(">", ap))
2437 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2438 exit(LIB$_WRONUMARG);
2457 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2458 exit(LIB$_WRONUMARG);
2462 if (('2' == *ap) && ('>' == ap[1]))
2479 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2480 exit(LIB$_WRONUMARG);
2484 if (0 == strcmp("|", argv[j]))
2488 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2489 exit(LIB$_WRONUMARG);
2491 cmargc = argc-(j+1);
2492 cmargv = &argv[j+1];
2496 if ('|' == *(ap = argv[j]))
2504 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2507 * Allocate and fill in the new argument vector, Some Unix's terminate
2508 * the list with an extra null pointer.
2510 New(1302, argv, item_count+1, char *);
2512 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2513 argv[j] = list_head->value;
2519 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2520 exit(LIB$_INVARGORD);
2522 pipe_and_fork(cmargv);
2525 /* Check for input from a pipe (mailbox) */
2527 if (in == NULL && 1 == isapipe(0))
2529 char mbxname[L_tmpnam];
2531 long int dvi_item = DVI$_DEVBUFSIZ;
2532 $DESCRIPTOR(mbxnam, "");
2533 $DESCRIPTOR(mbxdevnam, "");
2535 /* Input from a pipe, reopen it in binary mode to disable */
2536 /* carriage control processing. */
2538 PerlIO_getname(stdin, mbxname);
2539 mbxnam.dsc$a_pointer = mbxname;
2540 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2541 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2542 mbxdevnam.dsc$a_pointer = mbxname;
2543 mbxdevnam.dsc$w_length = sizeof(mbxname);
2544 dvi_item = DVI$_DEVNAM;
2545 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2546 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2549 freopen(mbxname, "rb", stdin);
2552 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2556 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2558 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2561 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2563 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2567 if (strcmp(err,"&1") == 0) {
2568 dup2(fileno(stdout), fileno(Perl_debug_log));
2571 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2573 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2577 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2583 #ifdef ARGPROC_DEBUG
2584 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2585 for (j = 0; j < *ac; ++j)
2586 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2588 /* Clear errors we may have hit expanding wildcards, so they don't
2589 show up in Perl's $! later */
2590 set_errno(0); set_vaxc_errno(1);
2591 } /* end of getredirection() */
2594 static void add_item(struct list_item **head,
2595 struct list_item **tail,
2601 New(1303,*head,1,struct list_item);
2605 New(1304,(*tail)->next,1,struct list_item);
2606 *tail = (*tail)->next;
2608 (*tail)->value = value;
2612 static void expand_wild_cards(char *item,
2613 struct list_item **head,
2614 struct list_item **tail,
2618 unsigned long int context = 0;
2624 char vmsspec[NAM$C_MAXRSS+1];
2625 $DESCRIPTOR(filespec, "");
2626 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2627 $DESCRIPTOR(resultspec, "");
2628 unsigned long int zero = 0, sts;
2630 for (cp = item; *cp; cp++) {
2631 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2632 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2634 if (!*cp || isspace(*cp))
2636 add_item(head, tail, item, count);
2639 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2640 resultspec.dsc$b_class = DSC$K_CLASS_D;
2641 resultspec.dsc$a_pointer = NULL;
2642 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2643 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2644 if (!isunix || !filespec.dsc$a_pointer)
2645 filespec.dsc$a_pointer = item;
2646 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2648 * Only return version specs, if the caller specified a version
2650 had_version = strchr(item, ';');
2652 * Only return device and directory specs, if the caller specifed either.
2654 had_device = strchr(item, ':');
2655 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2657 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2658 &defaultspec, 0, 0, &zero))))
2663 New(1305,string,resultspec.dsc$w_length+1,char);
2664 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2665 string[resultspec.dsc$w_length] = '\0';
2666 if (NULL == had_version)
2667 *((char *)strrchr(string, ';')) = '\0';
2668 if ((!had_directory) && (had_device == NULL))
2670 if (NULL == (devdir = strrchr(string, ']')))
2671 devdir = strrchr(string, '>');
2672 strcpy(string, devdir + 1);
2675 * Be consistent with what the C RTL has already done to the rest of
2676 * the argv items and lowercase all of these names.
2678 for (c = string; *c; ++c)
2681 if (isunix) trim_unixpath(string,item,1);
2682 add_item(head, tail, string, count);
2685 if (sts != RMS$_NMF)
2687 set_vaxc_errno(sts);
2693 set_errno(ENOENT); break;
2695 set_errno(ENODEV); break;
2698 set_errno(EINVAL); break;
2700 set_errno(EACCES); break;
2702 _ckvmssts_noperl(sts);
2706 add_item(head, tail, item, count);
2707 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2708 _ckvmssts_noperl(lib$find_file_end(&context));
2711 static int child_st[2];/* Event Flag set when child process completes */
2713 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2715 static unsigned long int exit_handler(int *status)
2719 if (0 == child_st[0])
2721 #ifdef ARGPROC_DEBUG
2722 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2724 fflush(stdout); /* Have to flush pipe for binary data to */
2725 /* terminate properly -- <tp@mccall.com> */
2726 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2727 sys$dassgn(child_chan);
2729 sys$synch(0, child_st);
2734 static void sig_child(int chan)
2736 #ifdef ARGPROC_DEBUG
2737 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2739 if (child_st[0] == 0)
2743 static struct exit_control_block exit_block =
2748 &exit_block.exit_status,
2752 static void pipe_and_fork(char **cmargv)
2755 $DESCRIPTOR(cmddsc, "");
2756 static char mbxname[64];
2757 $DESCRIPTOR(mbxdsc, mbxname);
2759 unsigned long int zero = 0, one = 1;
2761 strcpy(subcmd, cmargv[0]);
2762 for (j = 1; NULL != cmargv[j]; ++j)
2764 strcat(subcmd, " \"");
2765 strcat(subcmd, cmargv[j]);
2766 strcat(subcmd, "\"");
2768 cmddsc.dsc$a_pointer = subcmd;
2769 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2771 create_mbx(&child_chan,&mbxdsc);
2772 #ifdef ARGPROC_DEBUG
2773 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2774 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2776 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2777 0, &pid, child_st, &zero, sig_child,
2779 #ifdef ARGPROC_DEBUG
2780 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2782 sys$dclexh(&exit_block);
2783 if (NULL == freopen(mbxname, "wb", stdout))
2785 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2789 static int background_process(int argc, char **argv)
2791 char command[2048] = "$";
2792 $DESCRIPTOR(value, "");
2793 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2794 static $DESCRIPTOR(null, "NLA0:");
2795 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2797 $DESCRIPTOR(pidstr, "");
2799 unsigned long int flags = 17, one = 1, retsts;
2801 strcat(command, argv[0]);
2804 strcat(command, " \"");
2805 strcat(command, *(++argv));
2806 strcat(command, "\"");
2808 value.dsc$a_pointer = command;
2809 value.dsc$w_length = strlen(value.dsc$a_pointer);
2810 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2811 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2812 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2813 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2816 _ckvmssts_noperl(retsts);
2818 #ifdef ARGPROC_DEBUG
2819 PerlIO_printf(Perl_debug_log, "%s\n", command);
2821 sprintf(pidstring, "%08X", pid);
2822 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2823 pidstr.dsc$a_pointer = pidstring;
2824 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2825 lib$set_symbol(&pidsymbol, &pidstr);
2829 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2832 /* OS-specific initialization at image activation (not thread startup) */
2833 /* Older VAXC header files lack these constants */
2834 #ifndef JPI$_RIGHTS_SIZE
2835 # define JPI$_RIGHTS_SIZE 817
2837 #ifndef KGB$M_SUBSYSTEM
2838 # define KGB$M_SUBSYSTEM 0x8
2841 /*{{{void vms_image_init(int *, char ***)*/
2843 vms_image_init(int *argcp, char ***argvp)
2845 char eqv[LNM$C_NAMLENGTH+1] = "";
2846 unsigned int len, tabct = 8, tabidx = 0;
2847 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2848 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2849 unsigned short int dummy, rlen;
2850 struct dsc$descriptor_s **tabvec;
2852 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2853 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2854 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2857 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2859 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2860 if (iprv[i]) { /* Running image installed with privs? */
2861 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2866 /* Rights identifiers might trigger tainting as well. */
2867 if (!will_taint && (rlen || rsz)) {
2868 while (rlen < rsz) {
2869 /* We didn't get all the identifiers on the first pass. Allocate a
2870 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2871 * were needed to hold all identifiers at time of last call; we'll
2872 * allocate that many unsigned long ints), and go back and get 'em.
2874 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2875 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2876 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2877 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2880 mask = jpilist[1].bufadr;
2881 /* Check attribute flags for each identifier (2nd longword); protected
2882 * subsystem identifiers trigger tainting.
2884 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2885 if (mask[i] & KGB$M_SUBSYSTEM) {
2890 if (mask != rlst) Safefree(mask);
2892 /* We need to use this hack to tell Perl it should run with tainting,
2893 * since its tainting flag may be part of the PL_curinterp struct, which
2894 * hasn't been allocated when vms_image_init() is called.
2898 New(1320,newap,*argcp+2,char **);
2899 newap[0] = argvp[0];
2901 Copy(argvp[1],newap[2],*argcp-1,char **);
2902 /* We orphan the old argv, since we don't know where it's come from,
2903 * so we don't know how to free it.
2905 *argcp++; argvp = newap;
2907 else { /* Did user explicitly request tainting? */
2909 char *cp, **av = *argvp;
2910 for (i = 1; i < *argcp; i++) {
2911 if (*av[i] != '-') break;
2912 for (cp = av[i]+1; *cp; cp++) {
2913 if (*cp == 'T') { will_taint = 1; break; }
2914 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2915 strchr("DFIiMmx",*cp)) break;
2917 if (will_taint) break;
2922 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2924 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2925 else if (tabidx >= tabct) {
2927 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2929 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2930 tabvec[tabidx]->dsc$w_length = 0;
2931 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2932 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2933 tabvec[tabidx]->dsc$a_pointer = NULL;
2934 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2936 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2938 getredirection(argcp,argvp);
2939 #if defined(USE_THREADS) && defined(__DECC)
2941 # include <reentrancy.h>
2942 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2951 * Trim Unix-style prefix off filespec, so it looks like what a shell
2952 * glob expansion would return (i.e. from specified prefix on, not
2953 * full path). Note that returned filespec is Unix-style, regardless
2954 * of whether input filespec was VMS-style or Unix-style.
2956 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2957 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2958 * vector of options; at present, only bit 0 is used, and if set tells
2959 * trim unixpath to try the current default directory as a prefix when
2960 * presented with a possibly ambiguous ... wildcard.
2962 * Returns !=0 on success, with trimmed filespec replacing contents of
2963 * fspec, and 0 on failure, with contents of fpsec unchanged.
2965 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2967 trim_unixpath(char *fspec, char *wildspec, int opts)
2969 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2970 *template, *base, *end, *cp1, *cp2;
2971 register int tmplen, reslen = 0, dirs = 0;
2973 if (!wildspec || !fspec) return 0;
2974 if (strpbrk(wildspec,"]>:") != NULL) {
2975 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2976 else template = unixwild;
2978 else template = wildspec;
2979 if (strpbrk(fspec,"]>:") != NULL) {
2980 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2981 else base = unixified;
2982 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2983 * check to see that final result fits into (isn't longer than) fspec */
2984 reslen = strlen(fspec);
2988 /* No prefix or absolute path on wildcard, so nothing to remove */
2989 if (!*template || *template == '/') {
2990 if (base == fspec) return 1;
2991 tmplen = strlen(unixified);
2992 if (tmplen > reslen) return 0; /* not enough space */
2993 /* Copy unixified resultant, including trailing NUL */
2994 memmove(fspec,unixified,tmplen+1);
2998 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2999 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
3000 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
3001 for (cp1 = end ;cp1 >= base; cp1--)
3002 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3004 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3008 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3009 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3010 int ells = 1, totells, segdirs, match;
3011 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3012 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3014 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3016 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3017 if (ellipsis == template && opts & 1) {
3018 /* Template begins with an ellipsis. Since we can't tell how many
3019 * directory names at the front of the resultant to keep for an
3020 * arbitrary starting point, we arbitrarily choose the current
3021 * default directory as a starting point. If it's there as a prefix,
3022 * clip it off. If not, fall through and act as if the leading
3023 * ellipsis weren't there (i.e. return shortest possible path that
3024 * could match template).
3026 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3027 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3028 if (_tolower(*cp1) != _tolower(*cp2)) break;
3029 segdirs = dirs - totells; /* Min # of dirs we must have left */
3030 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3031 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3032 memcpy(fspec,cp2+1,end - cp2);
3036 /* First off, back up over constant elements at end of path */
3038 for (front = end ; front >= base; front--)
3039 if (*front == '/' && !dirs--) { front++; break; }
3041 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3042 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3043 if (cp1 != '\0') return 0; /* Path too long. */
3045 *cp2 = '\0'; /* Pick up with memcpy later */
3046 lcfront = lcres + (front - base);
3047 /* Now skip over each ellipsis and try to match the path in front of it. */
3049 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3050 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3051 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3052 if (cp1 < template) break; /* template started with an ellipsis */
3053 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3054 ellipsis = cp1; continue;
3056 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3058 for (segdirs = 0, cp2 = tpl;
3059 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3061 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3062 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3063 if (*cp2 == '/') segdirs++;
3065 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3066 /* Back up at least as many dirs as in template before matching */
3067 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3068 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3069 for (match = 0; cp1 > lcres;) {
3070 resdsc.dsc$a_pointer = cp1;
3071 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3073 if (match == 1) lcfront = cp1;
3075 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3077 if (!match) return 0; /* Can't find prefix ??? */
3078 if (match > 1 && opts & 1) {
3079 /* This ... wildcard could cover more than one set of dirs (i.e.
3080 * a set of similar dir names is repeated). If the template
3081 * contains more than 1 ..., upstream elements could resolve the
3082 * ambiguity, but it's not worth a full backtracking setup here.
3083 * As a quick heuristic, clip off the current default directory
3084 * if it's present to find the trimmed spec, else use the
3085 * shortest string that this ... could cover.
3087 char def[NAM$C_MAXRSS+1], *st;
3089 if (getcwd(def, sizeof def,0) == NULL) return 0;
3090 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3091 if (_tolower(*cp1) != _tolower(*cp2)) break;
3092 segdirs = dirs - totells; /* Min # of dirs we must have left */
3093 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3094 if (*cp1 == '\0' && *cp2 == '/') {
3095 memcpy(fspec,cp2+1,end - cp2);
3098 /* Nope -- stick with lcfront from above and keep going. */
3101 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3106 } /* end of trim_unixpath() */
3111 * VMS readdir() routines.
3112 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3114 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3115 * Minor modifications to original routines.
3118 /* Number of elements in vms_versions array */
3119 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3122 * Open a directory, return a handle for later use.
3124 /*{{{ DIR *opendir(char*name) */
3129 char dir[NAM$C_MAXRSS+1];
3132 if (do_tovmspath(name,dir,0) == NULL) {
3135 if (flex_stat(dir,&sb) == -1) return NULL;
3136 if (!S_ISDIR(sb.st_mode)) {
3137 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3140 if (!cando_by_name(S_IRUSR,0,dir)) {
3141 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3144 /* Get memory for the handle, and the pattern. */
3146 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3148 /* Fill in the fields; mainly playing with the descriptor. */
3149 (void)sprintf(dd->pattern, "%s*.*",dir);
3152 dd->vms_wantversions = 0;
3153 dd->pat.dsc$a_pointer = dd->pattern;
3154 dd->pat.dsc$w_length = strlen(dd->pattern);
3155 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3156 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3159 } /* end of opendir() */
3163 * Set the flag to indicate we want versions or not.
3165 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3167 vmsreaddirversions(DIR *dd, int flag)
3169 dd->vms_wantversions = flag;
3174 * Free up an opened directory.
3176 /*{{{ void closedir(DIR *dd)*/
3180 (void)lib$find_file_end(&dd->context);
3181 Safefree(dd->pattern);
3182 Safefree((char *)dd);
3187 * Collect all the version numbers for the current file.
3193 struct dsc$descriptor_s pat;
3194 struct dsc$descriptor_s res;
3196 char *p, *text, buff[sizeof dd->entry.d_name];
3198 unsigned long context, tmpsts;
3201 /* Convenient shorthand. */
3204 /* Add the version wildcard, ignoring the "*.*" put on before */
3205 i = strlen(dd->pattern);
3206 New(1308,text,i + e->d_namlen + 3,char);
3207 (void)strcpy(text, dd->pattern);
3208 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3210 /* Set up the pattern descriptor. */
3211 pat.dsc$a_pointer = text;
3212 pat.dsc$w_length = i + e->d_namlen - 1;
3213 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3214 pat.dsc$b_class = DSC$K_CLASS_S;
3216 /* Set up result descriptor. */
3217 res.dsc$a_pointer = buff;
3218 res.dsc$w_length = sizeof buff - 2;
3219 res.dsc$b_dtype = DSC$K_DTYPE_T;
3220 res.dsc$b_class = DSC$K_CLASS_S;
3222 /* Read files, collecting versions. */
3223 for (context = 0, e->vms_verscount = 0;
3224 e->vms_verscount < VERSIZE(e);
3225 e->vms_verscount++) {
3226 tmpsts = lib$find_file(&pat, &res, &context);
3227 if (tmpsts == RMS$_NMF || context == 0) break;
3229 buff[sizeof buff - 1] = '\0';
3230 if ((p = strchr(buff, ';')))
3231 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3233 e->vms_versions[e->vms_verscount] = -1;
3236 _ckvmssts(lib$find_file_end(&context));
3239 } /* end of collectversions() */
3242 * Read the next entry from the directory.
3244 /*{{{ struct dirent *readdir(DIR *dd)*/
3248 struct dsc$descriptor_s res;
3249 char *p, buff[sizeof dd->entry.d_name];
3250 unsigned long int tmpsts;
3252 /* Set up result descriptor, and get next file. */
3253 res.dsc$a_pointer = buff;
3254 res.dsc$w_length = sizeof buff - 2;
3255 res.dsc$b_dtype = DSC$K_DTYPE_T;
3256 res.dsc$b_class = DSC$K_CLASS_S;
3257 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3258 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3259 if (!(tmpsts & 1)) {
3260 set_vaxc_errno(tmpsts);
3263 set_errno(EACCES); break;
3265 set_errno(ENODEV); break;
3268 set_errno(ENOENT); break;
3275 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3276 buff[sizeof buff - 1] = '\0';
3277 for (p = buff; *p; p++) *p = _tolower(*p);
3278 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3281 /* Skip any directory component and just copy the name. */
3282 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3283 else (void)strcpy(dd->entry.d_name, buff);
3285 /* Clobber the version. */
3286 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3288 dd->entry.d_namlen = strlen(dd->entry.d_name);
3289 dd->entry.vms_verscount = 0;
3290 if (dd->vms_wantversions) collectversions(dd);
3293 } /* end of readdir() */
3297 * Return something that can be used in a seekdir later.
3299 /*{{{ long telldir(DIR *dd)*/
3308 * Return to a spot where we used to be. Brute force.
3310 /*{{{ void seekdir(DIR *dd,long count)*/
3312 seekdir(DIR *dd, long count)
3314 int vms_wantversions;
3317 /* If we haven't done anything yet... */
3321 /* Remember some state, and clear it. */
3322 vms_wantversions = dd->vms_wantversions;
3323 dd->vms_wantversions = 0;
3324 _ckvmssts(lib$find_file_end(&dd->context));
3327 /* The increment is in readdir(). */
3328 for (dd->count = 0; dd->count < count; )
3331 dd->vms_wantversions = vms_wantversions;
3333 } /* end of seekdir() */
3336 /* VMS subprocess management
3338 * my_vfork() - just a vfork(), after setting a flag to record that
3339 * the current script is trying a Unix-style fork/exec.
3341 * vms_do_aexec() and vms_do_exec() are called in response to the
3342 * perl 'exec' function. If this follows a vfork call, then they
3343 * call out the the regular perl routines in doio.c which do an
3344 * execvp (for those who really want to try this under VMS).
3345 * Otherwise, they do exactly what the perl docs say exec should
3346 * do - terminate the current script and invoke a new command
3347 * (See below for notes on command syntax.)
3349 * do_aspawn() and do_spawn() implement the VMS side of the perl
3350 * 'system' function.
3352 * Note on command arguments to perl 'exec' and 'system': When handled
3353 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3354 * are concatenated to form a DCL command string. If the first arg
3355 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3356 * the the command string is handed off to DCL directly. Otherwise,
3357 * the first token of the command is taken as the filespec of an image
3358 * to run. The filespec is expanded using a default type of '.EXE' and
3359 * the process defaults for device, directory, etc., and if found, the resultant
3360 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3361 * the command string as parameters. This is perhaps a bit complicated,
3362 * but I hope it will form a happy medium between what VMS folks expect
3363 * from lib$spawn and what Unix folks expect from exec.
3366 static int vfork_called;
3368 /*{{{int my_vfork()*/
3381 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3384 if (VMScmd.dsc$a_pointer) {
3385 Safefree(VMScmd.dsc$a_pointer);
3386 VMScmd.dsc$w_length = 0;
3387 VMScmd.dsc$a_pointer = Nullch;
3392 setup_argstr(SV *really, SV **mark, SV **sp)
3395 char *junk, *tmps = Nullch;
3396 register size_t cmdlen = 0;
3403 tmps = SvPV(really,rlen);
3410 for (idx++; idx <= sp; idx++) {
3412 junk = SvPVx(*idx,rlen);
3413 cmdlen += rlen ? rlen + 1 : 0;
3416 New(401,PL_Cmd,cmdlen+1,char);
3418 if (tmps && *tmps) {
3419 strcpy(PL_Cmd,tmps);
3422 else *PL_Cmd = '\0';
3423 while (++mark <= sp) {
3425 char *s = SvPVx(*mark,n_a);
3427 if (*PL_Cmd) strcat(PL_Cmd," ");
3433 } /* end of setup_argstr() */
3436 static unsigned long int
3437 setup_cmddsc(char *cmd, int check_img)
3439 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3440 $DESCRIPTOR(defdsc,".EXE");
3441 $DESCRIPTOR(defdsc2,".");
3442 $DESCRIPTOR(resdsc,resspec);
3443 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3444 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3445 register char *s, *rest, *cp, *wordbreak;
3450 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3453 while (*s && isspace(*s)) s++;
3455 if (*s == '@' || *s == '$') {
3456 vmsspec[0] = *s; rest = s + 1;
3457 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3459 else { cp = vmsspec; rest = s; }
3460 if (*rest == '.' || *rest == '/') {
3463 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3464 rest++, cp2++) *cp2 = *rest;
3466 if (do_tovmsspec(resspec,cp,0)) {
3469 for (cp2 = vmsspec + strlen(vmsspec);
3470 *rest && cp2 - vmsspec < sizeof vmsspec;
3471 rest++, cp2++) *cp2 = *rest;
3476 /* Intuit whether verb (first word of cmd) is a DCL command:
3477 * - if first nonspace char is '@', it's a DCL indirection
3479 * - if verb contains a filespec separator, it's not a DCL command
3480 * - if it doesn't, caller tells us whether to default to a DCL
3481 * command, or to a local image unless told it's DCL (by leading '$')
3483 if (*s == '@') isdcl = 1;
3485 register char *filespec = strpbrk(s,":<[.;");
3486 rest = wordbreak = strpbrk(s," \"\t/");
3487 if (!wordbreak) wordbreak = s + strlen(s);
3488 if (*s == '$') check_img = 0;
3489 if (filespec && (filespec < wordbreak)) isdcl = 0;
3490 else isdcl = !check_img;
3494 imgdsc.dsc$a_pointer = s;
3495 imgdsc.dsc$w_length = wordbreak - s;
3496 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3498 _ckvmssts(lib$find_file_end(&cxt));
3499 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3500 if (!(retsts & 1) && *s == '$') {
3501 _ckvmssts(lib$find_file_end(&cxt));
3502 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3503 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3505 _ckvmssts(lib$find_file_end(&cxt));
3506 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3510 _ckvmssts(lib$find_file_end(&cxt));
3515 while (*s && !isspace(*s)) s++;
3518 /* check that it's really not DCL with no file extension */
3519 fp = fopen(resspec,"r","ctx=bin,shr=get");
3521 char b[4] = {0,0,0,0};
3522 read(fileno(fp),b,4);
3523 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3526 if (check_img && isdcl) return RMS$_FNF;
3528 if (cando_by_name(S_IXUSR,0,resspec)) {
3529 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3531 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3533 strcpy(VMScmd.dsc$a_pointer,"@");
3535 strcat(VMScmd.dsc$a_pointer,resspec);
3536 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3537 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3540 else retsts = RMS$_PRV;
3543 /* It's either a DCL command or we couldn't find a suitable image */
3544 VMScmd.dsc$w_length = strlen(cmd);
3545 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3546 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3547 if (!(retsts & 1)) {
3548 /* just hand off status values likely to be due to user error */
3549 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3550 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3551 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3552 else { _ckvmssts(retsts); }
3555 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3557 } /* end of setup_cmddsc() */
3560 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3562 vms_do_aexec(SV *really,SV **mark,SV **sp)
3566 if (vfork_called) { /* this follows a vfork - act Unixish */
3568 if (vfork_called < 0) {
3569 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3572 else return do_aexec(really,mark,sp);
3574 /* no vfork - act VMSish */
3575 return vms_do_exec(setup_argstr(really,mark,sp));
3580 } /* end of vms_do_aexec() */
3583 /* {{{bool vms_do_exec(char *cmd) */
3585 vms_do_exec(char *cmd)
3589 if (vfork_called) { /* this follows a vfork - act Unixish */
3591 if (vfork_called < 0) {
3592 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3595 else return do_exec(cmd);
3598 { /* no vfork - act VMSish */
3599 unsigned long int retsts;
3602 TAINT_PROPER("exec");
3603 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3604 retsts = lib$do_command(&VMScmd);
3608 set_errno(ENOENT); break;
3609 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3610 set_errno(ENOTDIR); break;
3612 set_errno(EACCES); break;
3614 set_errno(EINVAL); break;
3616 set_errno(E2BIG); break;
3617 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3618 _ckvmssts(retsts); /* fall through */
3619 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3622 set_vaxc_errno(retsts);
3623 if (ckWARN(WARN_EXEC)) {
3624 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3625 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3632 } /* end of vms_do_exec() */
3635 unsigned long int do_spawn(char *);
3637 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3639 do_aspawn(void *really,void **mark,void **sp)
3642 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3645 } /* end of do_aspawn() */
3648 /* {{{unsigned long int do_spawn(char *cmd) */
3652 unsigned long int sts, substs, hadcmd = 1;
3656 TAINT_PROPER("spawn");
3657 if (!cmd || !*cmd) {
3659 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3661 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3662 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3668 set_errno(ENOENT); break;
3669 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3670 set_errno(ENOTDIR); break;
3672 set_errno(EACCES); break;
3674 set_errno(EINVAL); break;
3676 set_errno(E2BIG); break;
3677 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3678 _ckvmssts(sts); /* fall through */
3679 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3682 set_vaxc_errno(sts);
3683 if (ckWARN(WARN_EXEC)) {
3684 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3685 hadcmd ? VMScmd.dsc$w_length : 0,
3686 hadcmd ? VMScmd.dsc$a_pointer : "",
3693 } /* end of do_spawn() */
3697 * A simple fwrite replacement which outputs itmsz*nitm chars without
3698 * introducing record boundaries every itmsz chars.
3700 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3702 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3704 register char *cp, *end;
3706 end = (char *)src + itmsz * nitm;
3708 while ((char *)src <= end) {
3709 for (cp = src; cp <= end; cp++) if (!*cp) break;
3710 if (fputs(src,dest) == EOF) return EOF;
3712 if (fputc('\0',dest) == EOF) return EOF;
3718 } /* end of my_fwrite() */
3721 /*{{{ int my_flush(FILE *fp)*/
3726 if ((res = fflush(fp)) == 0 && fp) {
3727 #ifdef VMS_DO_SOCKETS
3729 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3731 res = fsync(fileno(fp));
3738 * Here are replacements for the following Unix routines in the VMS environment:
3739 * getpwuid Get information for a particular UIC or UID
3740 * getpwnam Get information for a named user
3741 * getpwent Get information for each user in the rights database
3742 * setpwent Reset search to the start of the rights database
3743 * endpwent Finish searching for users in the rights database
3745 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3746 * (defined in pwd.h), which contains the following fields:-
3748 * char *pw_name; Username (in lower case)
3749 * char *pw_passwd; Hashed password
3750 * unsigned int pw_uid; UIC
3751 * unsigned int pw_gid; UIC group number
3752 * char *pw_unixdir; Default device/directory (VMS-style)
3753 * char *pw_gecos; Owner name
3754 * char *pw_dir; Default device/directory (Unix-style)
3755 * char *pw_shell; Default CLI name (eg. DCL)
3757 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3759 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3760 * not the UIC member number (eg. what's returned by getuid()),
3761 * getpwuid() can accept either as input (if uid is specified, the caller's
3762 * UIC group is used), though it won't recognise gid=0.
3764 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3765 * information about other users in your group or in other groups, respectively.
3766 * If the required privilege is not available, then these routines fill only
3767 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3770 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3773 /* sizes of various UAF record fields */
3774 #define UAI$S_USERNAME 12
3775 #define UAI$S_IDENT 31
3776 #define UAI$S_OWNER 31
3777 #define UAI$S_DEFDEV 31
3778 #define UAI$S_DEFDIR 63
3779 #define UAI$S_DEFCLI 31
3782 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3783 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3784 (uic).uic$v_group != UIC$K_WILD_GROUP)
3786 static char __empty[]= "";
3787 static struct passwd __passwd_empty=
3788 {(char *) __empty, (char *) __empty, 0, 0,
3789 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3790 static int contxt= 0;
3791 static struct passwd __pwdcache;
3792 static char __pw_namecache[UAI$S_IDENT+1];
3795 * This routine does most of the work extracting the user information.
3797 static int fillpasswd (const char *name, struct passwd *pwd)
3801 unsigned char length;
3802 char pw_gecos[UAI$S_OWNER+1];
3804 static union uicdef uic;
3806 unsigned char length;
3807 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3810 unsigned char length;
3811 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3814 unsigned char length;
3815 char pw_shell[UAI$S_DEFCLI+1];
3817 static char pw_passwd[UAI$S_PWD+1];
3819 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3820 struct dsc$descriptor_s name_desc;
3821 unsigned long int sts;
3823 static struct itmlst_3 itmlst[]= {
3824 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3825 {sizeof(uic), UAI$_UIC, &uic, &luic},
3826 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3827 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3828 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3829 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3830 {0, 0, NULL, NULL}};
3832 name_desc.dsc$w_length= strlen(name);
3833 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3834 name_desc.dsc$b_class= DSC$K_CLASS_S;
3835 name_desc.dsc$a_pointer= (char *) name;
3837 /* Note that sys$getuai returns many fields as counted strings. */
3838 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3839 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3840 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3842 else { _ckvmssts(sts); }
3843 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3845 if ((int) owner.length < lowner) lowner= (int) owner.length;
3846 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3847 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3848 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3849 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3850 owner.pw_gecos[lowner]= '\0';
3851 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3852 defcli.pw_shell[ldefcli]= '\0';
3853 if (valid_uic(uic)) {
3854 pwd->pw_uid= uic.uic$l_uic;
3855 pwd->pw_gid= uic.uic$v_group;
3858 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3859 pwd->pw_passwd= pw_passwd;
3860 pwd->pw_gecos= owner.pw_gecos;
3861 pwd->pw_dir= defdev.pw_dir;
3862 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3863 pwd->pw_shell= defcli.pw_shell;
3864 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3866 ldir= strlen(pwd->pw_unixdir) - 1;
3867 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3870 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3871 __mystrtolower(pwd->pw_unixdir);
3876 * Get information for a named user.
3878 /*{{{struct passwd *getpwnam(char *name)*/
3879 struct passwd *my_getpwnam(char *name)
3881 struct dsc$descriptor_s name_desc;
3883 unsigned long int status, sts;
3886 __pwdcache = __passwd_empty;
3887 if (!fillpasswd(name, &__pwdcache)) {
3888 /* We still may be able to determine pw_uid and pw_gid */
3889 name_desc.dsc$w_length= strlen(name);
3890 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3891 name_desc.dsc$b_class= DSC$K_CLASS_S;
3892 name_desc.dsc$a_pointer= (char *) name;
3893 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3894 __pwdcache.pw_uid= uic.uic$l_uic;
3895 __pwdcache.pw_gid= uic.uic$v_group;
3898 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3899 set_vaxc_errno(sts);
3900 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3903 else { _ckvmssts(sts); }
3906 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3907 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3908 __pwdcache.pw_name= __pw_namecache;
3910 } /* end of my_getpwnam() */
3914 * Get information for a particular UIC or UID.
3915 * Called by my_getpwent with uid=-1 to list all users.
3917 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3918 struct passwd *my_getpwuid(Uid_t uid)
3920 const $DESCRIPTOR(name_desc,__pw_namecache);
3921 unsigned short lname;
3923 unsigned long int status;
3926 if (uid == (unsigned int) -1) {
3928 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3929 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3930 set_vaxc_errno(status);
3931 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3935 else { _ckvmssts(status); }
3936 } while (!valid_uic (uic));
3940 if (!uic.uic$v_group)
3941 uic.uic$v_group= PerlProc_getgid();
3943 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3944 else status = SS$_IVIDENT;
3945 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3946 status == RMS$_PRV) {
3947 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3950 else { _ckvmssts(status); }
3952 __pw_namecache[lname]= '\0';
3953 __mystrtolower(__pw_namecache);
3955 __pwdcache = __passwd_empty;
3956 __pwdcache.pw_name = __pw_namecache;
3958 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3959 The identifier's value is usually the UIC, but it doesn't have to be,
3960 so if we can, we let fillpasswd update this. */
3961 __pwdcache.pw_uid = uic.uic$l_uic;
3962 __pwdcache.pw_gid = uic.uic$v_group;
3964 fillpasswd(__pw_namecache, &__pwdcache);
3967 } /* end of my_getpwuid() */
3971 * Get information for next user.
3973 /*{{{struct passwd *my_getpwent()*/
3974 struct passwd *my_getpwent()
3976 return (my_getpwuid((unsigned int) -1));
3981 * Finish searching rights database for users.
3983 /*{{{void my_endpwent()*/
3988 _ckvmssts(sys$finish_rdb(&contxt));
3994 #ifdef HOMEGROWN_POSIX_SIGNALS
3995 /* Signal handling routines, pulled into the core from POSIX.xs.
3997 * We need these for threads, so they've been rolled into the core,
3998 * rather than left in POSIX.xs.
4000 * (DRS, Oct 23, 1997)
4003 /* sigset_t is atomic under VMS, so these routines are easy */
4004 /*{{{int my_sigemptyset(sigset_t *) */
4005 int my_sigemptyset(sigset_t *set) {
4006 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4012 /*{{{int my_sigfillset(sigset_t *)*/
4013 int my_sigfillset(sigset_t *set) {
4015 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4016 for (i = 0; i < NSIG; i++) *set |= (1 << i);
4022 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4023 int my_sigaddset(sigset_t *set, int sig) {
4024 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4025 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4026 *set |= (1 << (sig - 1));
4032 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4033 int my_sigdelset(sigset_t *set, int sig) {
4034 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4035 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4036 *set &= ~(1 << (sig - 1));
4042 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4043 int my_sigismember(sigset_t *set, int sig) {
4044 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4045 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4046 *set & (1 << (sig - 1));
4051 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4052 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4055 /* If set and oset are both null, then things are badly wrong. Bail out. */
4056 if ((oset == NULL) && (set == NULL)) {
4057 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4061 /* If set's null, then we're just handling a fetch. */
4063 tempmask = sigblock(0);
4068 tempmask = sigsetmask(*set);
4071 tempmask = sigblock(*set);
4074 tempmask = sigblock(0);
4075 sigsetmask(*oset & ~tempmask);
4078 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4083 /* Did they pass us an oset? If so, stick our holding mask into it */
4090 #endif /* HOMEGROWN_POSIX_SIGNALS */
4093 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4094 * my_utime(), and flex_stat(), all of which operate on UTC unless
4095 * VMSISH_TIMES is true.
4097 /* method used to handle UTC conversions:
4098 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4100 static int gmtime_emulation_type;
4101 /* number of secs to add to UTC POSIX-style time to get local time */
4102 static long int utc_offset_secs;
4104 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4105 * in vmsish.h. #undef them here so we can call the CRTL routines
4112 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4113 # define RTL_USES_UTC 1
4117 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4118 * qualifier with the extern prefix pragma. This provisional
4119 * hack circumvents this prefix pragma problem in previous
4122 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4123 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4124 # pragma __extern_prefix save
4125 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4126 # define gmtime decc$__utctz_gmtime
4127 # define localtime decc$__utctz_localtime
4128 # define time decc$__utc_time
4129 # pragma __extern_prefix restore
4131 struct tm *gmtime(), *localtime();
4137 static time_t toutc_dst(time_t loc) {
4140 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4141 loc -= utc_offset_secs;
4142 if (rsltmp->tm_isdst) loc -= 3600;
4145 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4146 ((gmtime_emulation_type || my_time(NULL)), \
4147 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4148 ((secs) - utc_offset_secs))))
4150 static time_t toloc_dst(time_t utc) {
4153 utc += utc_offset_secs;
4154 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4155 if (rsltmp->tm_isdst) utc += 3600;
4158 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4159 ((gmtime_emulation_type || my_time(NULL)), \
4160 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4161 ((secs) + utc_offset_secs))))
4164 /* my_time(), my_localtime(), my_gmtime()
4165 * By default traffic in UTC time values, using CRTL gmtime() or
4166 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4167 * Note: We need to use these functions even when the CRTL has working
4168 * UTC support, since they also handle C<use vmsish qw(times);>
4170 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4171 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4174 /*{{{time_t my_time(time_t *timep)*/
4175 time_t my_time(time_t *timep)
4181 if (gmtime_emulation_type == 0) {
4183 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4184 /* results of calls to gmtime() and localtime() */
4185 /* for same &base */
4187 gmtime_emulation_type++;
4188 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4189 char off[LNM$C_NAMLENGTH+1];;
4191 gmtime_emulation_type++;
4192 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4193 gmtime_emulation_type++;
4194 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4196 else { utc_offset_secs = atol(off); }
4198 else { /* We've got a working gmtime() */
4199 struct tm gmt, local;
4202 tm_p = localtime(&base);
4204 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4205 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4206 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4207 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4213 # ifdef RTL_USES_UTC
4214 if (VMSISH_TIME) when = _toloc(when);
4216 if (!VMSISH_TIME) when = _toutc(when);
4219 if (timep != NULL) *timep = when;
4222 } /* end of my_time() */
4226 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4228 my_gmtime(const time_t *timep)
4235 if (timep == NULL) {
4236 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4239 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4243 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4245 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4246 return gmtime(&when);
4248 /* CRTL localtime() wants local time as input, so does no tz correction */
4249 rsltmp = localtime(&when);
4250 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4253 } /* end of my_gmtime() */
4257 /*{{{struct tm *my_localtime(const time_t *timep)*/
4259 my_localtime(const time_t *timep)
4265 if (timep == NULL) {
4266 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4269 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4270 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4273 # ifdef RTL_USES_UTC
4275 if (VMSISH_TIME) when = _toutc(when);
4277 /* CRTL localtime() wants UTC as input, does tz correction itself */
4278 return localtime(&when);
4281 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4284 /* CRTL localtime() wants local time as input, so does no tz correction */
4285 rsltmp = localtime(&when);
4286 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4289 } /* end of my_localtime() */
4292 /* Reset definitions for later calls */
4293 #define gmtime(t) my_gmtime(t)
4294 #define localtime(t) my_localtime(t)
4295 #define time(t) my_time(t)
4298 /* my_utime - update modification time of a file
4299 * calling sequence is identical to POSIX utime(), but under
4300 * VMS only the modification time is changed; ODS-2 does not
4301 * maintain access times. Restrictions differ from the POSIX
4302 * definition in that the time can be changed as long as the
4303 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4304 * no separate checks are made to insure that the caller is the
4305 * owner of the file or has special privs enabled.
4306 * Code here is based on Joe Meadows' FILE utility.
4309 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4310 * to VMS epoch (01-JAN-1858 00:00:00.00)
4311 * in 100 ns intervals.
4313 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4315 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4316 int my_utime(char *file, struct utimbuf *utimes)
4320 long int bintime[2], len = 2, lowbit, unixtime,
4321 secscale = 10000000; /* seconds --> 100 ns intervals */
4322 unsigned long int chan, iosb[2], retsts;
4323 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4324 struct FAB myfab = cc$rms_fab;
4325 struct NAM mynam = cc$rms_nam;
4326 #if defined (__DECC) && defined (__VAX)
4327 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4328 * at least through VMS V6.1, which causes a type-conversion warning.
4330 # pragma message save
4331 # pragma message disable cvtdiftypes
4333 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4334 struct fibdef myfib;
4335 #if defined (__DECC) && defined (__VAX)
4336 /* This should be right after the declaration of myatr, but due
4337 * to a bug in VAX DEC C, this takes effect a statement early.
4339 # pragma message restore
4341 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4342 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4343 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4345 if (file == NULL || *file == '\0') {
4347 set_vaxc_errno(LIB$_INVARG);
4350 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4352 if (utimes != NULL) {
4353 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4354 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4355 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4356 * as input, we force the sign bit to be clear by shifting unixtime right
4357 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4359 lowbit = (utimes->modtime & 1) ? secscale : 0;
4360 unixtime = (long int) utimes->modtime;
4362 /* If input was UTC; convert to local for sys svc */
4363 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4365 unixtime >>= 1; secscale <<= 1;
4366 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4367 if (!(retsts & 1)) {
4369 set_vaxc_errno(retsts);
4372 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4373 if (!(retsts & 1)) {
4375 set_vaxc_errno(retsts);
4380 /* Just get the current time in VMS format directly */
4381 retsts = sys$gettim(bintime);
4382 if (!(retsts & 1)) {
4384 set_vaxc_errno(retsts);
4389 myfab.fab$l_fna = vmsspec;
4390 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4391 myfab.fab$l_nam = &mynam;
4392 mynam.nam$l_esa = esa;
4393 mynam.nam$b_ess = (unsigned char) sizeof esa;
4394 mynam.nam$l_rsa = rsa;
4395 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4397 /* Look for the file to be affected, letting RMS parse the file
4398 * specification for us as well. I have set errno using only
4399 * values documented in the utime() man page for VMS POSIX.
4401 retsts = sys$parse(&myfab,0,0);
4402 if (!(retsts & 1)) {
4403 set_vaxc_errno(retsts);
4404 if (retsts == RMS$_PRV) set_errno(EACCES);
4405 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4406 else set_errno(EVMSERR);
4409 retsts = sys$search(&myfab,0,0);
4410 if (!(retsts & 1)) {
4411 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4412 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4413 set_vaxc_errno(retsts);
4414 if (retsts == RMS$_PRV) set_errno(EACCES);
4415 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4416 else set_errno(EVMSERR);
4420 devdsc.dsc$w_length = mynam.nam$b_dev;
4421 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4423 retsts = sys$assign(&devdsc,&chan,0,0);
4424 if (!(retsts & 1)) {
4425 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4426 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4427 set_vaxc_errno(retsts);
4428 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4429 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4430 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4431 else set_errno(EVMSERR);
4435 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4436 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4438 memset((void *) &myfib, 0, sizeof myfib);
4440 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4441 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4442 /* This prevents the revision time of the file being reset to the current
4443 * time as a result of our IO$_MODIFY $QIO. */
4444 myfib.fib$l_acctl = FIB$M_NORECORD;
4446 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4447 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4448 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4450 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4451 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4452 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4453 _ckvmssts(sys$dassgn(chan));
4454 if (retsts & 1) retsts = iosb[0];
4455 if (!(retsts & 1)) {
4456 set_vaxc_errno(retsts);
4457 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4458 else set_errno(EVMSERR);
4463 } /* end of my_utime() */
4467 * flex_stat, flex_fstat
4468 * basic stat, but gets it right when asked to stat
4469 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4472 /* encode_dev packs a VMS device name string into an integer to allow
4473 * simple comparisons. This can be used, for example, to check whether two
4474 * files are located on the same device, by comparing their encoded device
4475 * names. Even a string comparison would not do, because stat() reuses the
4476 * device name buffer for each call; so without encode_dev, it would be
4477 * necessary to save the buffer and use strcmp (this would mean a number of
4478 * changes to the standard Perl code, to say nothing of what a Perl script
4481 * The device lock id, if it exists, should be unique (unless perhaps compared
4482 * with lock ids transferred from other nodes). We have a lock id if the disk is
4483 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4484 * device names. Thus we use the lock id in preference, and only if that isn't
4485 * available, do we try to pack the device name into an integer (flagged by
4486 * the sign bit (LOCKID_MASK) being set).
4488 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4489 * name and its encoded form, but it seems very unlikely that we will find
4490 * two files on different disks that share the same encoded device names,
4491 * and even more remote that they will share the same file id (if the test
4492 * is to check for the same file).
4494 * A better method might be to use sys$device_scan on the first call, and to
4495 * search for the device, returning an index into the cached array.
4496 * The number returned would be more intelligable.
4497 * This is probably not worth it, and anyway would take quite a bit longer
4498 * on the first call.
4500 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4501 static mydev_t encode_dev (const char *dev)
4504 unsigned long int f;
4510 if (!dev || !dev[0]) return 0;
4514 struct dsc$descriptor_s dev_desc;
4515 unsigned long int status, lockid, item = DVI$_LOCKID;
4517 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4518 can try that first. */
4519 dev_desc.dsc$w_length = strlen (dev);
4520 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4521 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4522 dev_desc.dsc$a_pointer = (char *) dev;
4523 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4524 if (lockid) return (lockid & ~LOCKID_MASK);
4528 /* Otherwise we try to encode the device name */
4532 for (q = dev + strlen(dev); q--; q >= dev) {
4535 else if (isalpha (toupper (*q)))
4536 c= toupper (*q) - 'A' + (char)10;
4538 continue; /* Skip '$'s */
4540 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4542 enc += f * (unsigned long int) c;
4544 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4546 } /* end of encode_dev() */
4548 static char namecache[NAM$C_MAXRSS+1];
4551 is_null_device(name)
4555 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4556 The underscore prefix, controller letter, and unit number are
4557 independently optional; for our purposes, the colon punctuation
4558 is not. The colon can be trailed by optional directory and/or
4559 filename, but two consecutive colons indicates a nodename rather
4560 than a device. [pr] */
4561 if (*name == '_') ++name;
4562 if (tolower(*name++) != 'n') return 0;
4563 if (tolower(*name++) != 'l') return 0;
4564 if (tolower(*name) == 'a') ++name;
4565 if (*name == '0') ++name;
4566 return (*name++ == ':') && (*name != ':');
4569 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4570 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4571 * subset of the applicable information.
4574 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4576 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4578 char fname[NAM$C_MAXRSS+1];
4579 unsigned long int retsts;
4580 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4581 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4583 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4584 device name on successive calls */
4585 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4586 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4587 namdsc.dsc$a_pointer = fname;
4588 namdsc.dsc$w_length = sizeof fname - 1;
4590 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4591 &namdsc,&namdsc.dsc$w_length,0,0);
4593 fname[namdsc.dsc$w_length] = '\0';
4594 return cando_by_name(bit,effective,fname);
4596 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4597 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4601 return FALSE; /* Should never get to here */
4603 } /* end of cando() */
4607 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4609 cando_by_name(I32 bit, Uid_t effective, char *fname)
4611 static char usrname[L_cuserid];
4612 static struct dsc$descriptor_s usrdsc =
4613 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4614 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4615 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4616 unsigned short int retlen;
4618 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4619 union prvdef curprv;
4620 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4621 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4622 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4625 if (!fname || !*fname) return FALSE;
4626 /* Make sure we expand logical names, since sys$check_access doesn't */
4627 if (!strpbrk(fname,"/]>:")) {
4628 strcpy(fileified,fname);
4629 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4632 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4633 retlen = namdsc.dsc$w_length = strlen(vmsname);
4634 namdsc.dsc$a_pointer = vmsname;
4635 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4636 vmsname[retlen-1] == ':') {
4637 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4638 namdsc.dsc$w_length = strlen(fileified);
4639 namdsc.dsc$a_pointer = fileified;
4642 if (!usrdsc.dsc$w_length) {
4644 usrdsc.dsc$w_length = strlen(usrname);
4651 access = ARM$M_EXECUTE;
4656 access = ARM$M_READ;
4661 access = ARM$M_WRITE;
4666 access = ARM$M_DELETE;
4672 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4673 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4674 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4675 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4676 set_vaxc_errno(retsts);
4677 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4678 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4679 else set_errno(ENOENT);
4682 if (retsts == SS$_NORMAL) {
4683 if (!privused) return TRUE;
4684 /* We can get access, but only by using privs. Do we have the
4685 necessary privs currently enabled? */
4686 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4687 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4688 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4689 !curprv.prv$v_bypass) return FALSE;
4690 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4691 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4692 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4695 if (retsts == SS$_ACCONFLICT) {
4699 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 && defined(__DECC_VER) && __DECC_VER == 6009001
4700 /* XXX Hideous kluge to accomodate error in specific version of RTL;
4701 we hope it'll be buried soon */
4702 if (retsts == 114762) return TRUE;
4706 return FALSE; /* Should never get here */
4708 } /* end of cando_by_name() */
4712 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4714 flex_fstat(int fd, Stat_t *statbufp)
4717 if (!fstat(fd,(stat_t *) statbufp)) {
4718 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4719 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4720 # ifdef RTL_USES_UTC
4723 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4724 statbufp->st_atime = _toloc(statbufp->st_atime);
4725 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4730 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4734 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4735 statbufp->st_atime = _toutc(statbufp->st_atime);
4736 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4743 } /* end of flex_fstat() */
4746 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4748 flex_stat(const char *fspec, Stat_t *statbufp)
4751 char fileified[NAM$C_MAXRSS+1];
4752 char temp_fspec[NAM$C_MAXRSS+300];
4755 strcpy(temp_fspec, fspec);
4756 if (statbufp == (Stat_t *) &PL_statcache)
4757 do_tovmsspec(temp_fspec,namecache,0);
4758 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4759 memset(statbufp,0,sizeof *statbufp);
4760 statbufp->st_dev = encode_dev("_NLA0:");
4761 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4762 statbufp->st_uid = 0x00010001;
4763 statbufp->st_gid = 0x0001;
4764 time((time_t *)&statbufp->st_mtime);
4765 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4769 /* Try for a directory name first. If fspec contains a filename without
4770 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4771 * and sea:[wine.dark]water. exist, we prefer the directory here.
4772 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4773 * not sea:[wine.dark]., if the latter exists. If the intended target is
4774 * the file with null type, specify this by calling flex_stat() with
4775 * a '.' at the end of fspec.
4777 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4778 retval = stat(fileified,(stat_t *) statbufp);
4779 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4780 strcpy(namecache,fileified);
4782 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4784 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4785 # ifdef RTL_USES_UTC
4788 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4789 statbufp->st_atime = _toloc(statbufp->st_atime);
4790 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4795 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4799 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4800 statbufp->st_atime = _toutc(statbufp->st_atime);
4801 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4807 } /* end of flex_stat() */
4811 /*{{{char *my_getlogin()*/
4812 /* VMS cuserid == Unix getlogin, except calling sequence */
4816 static char user[L_cuserid];
4817 return cuserid(user);
4822 /* rmscopy - copy a file using VMS RMS routines
4824 * Copies contents and attributes of spec_in to spec_out, except owner
4825 * and protection information. Name and type of spec_in are used as
4826 * defaults for spec_out. The third parameter specifies whether rmscopy()
4827 * should try to propagate timestamps from the input file to the output file.
4828 * If it is less than 0, no timestamps are preserved. If it is 0, then
4829 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4830 * propagated to the output file at creation iff the output file specification
4831 * did not contain an explicit name or type, and the revision date is always
4832 * updated at the end of the copy operation. If it is greater than 0, then
4833 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4834 * other than the revision date should be propagated, and bit 1 indicates
4835 * that the revision date should be propagated.
4837 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4839 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4840 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4841 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4842 * as part of the Perl standard distribution under the terms of the
4843 * GNU General Public License or the Perl Artistic License. Copies
4844 * of each may be found in the Perl standard distribution.
4846 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4848 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4850 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4851 rsa[NAM$C_MAXRSS], ubf[32256];
4852 unsigned long int i, sts, sts2;
4853 struct FAB fab_in, fab_out;
4854 struct RAB rab_in, rab_out;
4856 struct XABDAT xabdat;
4857 struct XABFHC xabfhc;
4858 struct XABRDT xabrdt;
4859 struct XABSUM xabsum;
4861 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4862 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4863 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4867 fab_in = cc$rms_fab;
4868 fab_in.fab$l_fna = vmsin;
4869 fab_in.fab$b_fns = strlen(vmsin);
4870 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4871 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4872 fab_in.fab$l_fop = FAB$M_SQO;
4873 fab_in.fab$l_nam = &nam;
4874 fab_in.fab$l_xab = (void *) &xabdat;
4877 nam.nam$l_rsa = rsa;
4878 nam.nam$b_rss = sizeof(rsa);
4879 nam.nam$l_esa = esa;
4880 nam.nam$b_ess = sizeof (esa);
4881 nam.nam$b_esl = nam.nam$b_rsl = 0;
4883 xabdat = cc$rms_xabdat; /* To get creation date */
4884 xabdat.xab$l_nxt = (void *) &xabfhc;
4886 xabfhc = cc$rms_xabfhc; /* To get record length */
4887 xabfhc.xab$l_nxt = (void *) &xabsum;
4889 xabsum = cc$rms_xabsum; /* To get key and area information */
4891 if (!((sts = sys$open(&fab_in)) & 1)) {
4892 set_vaxc_errno(sts);
4896 set_errno(ENOENT); break;
4898 set_errno(ENODEV); break;
4900 set_errno(EINVAL); break;
4902 set_errno(EACCES); break;
4910 fab_out.fab$w_ifi = 0;
4911 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4912 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4913 fab_out.fab$l_fop = FAB$M_SQO;
4914 fab_out.fab$l_fna = vmsout;
4915 fab_out.fab$b_fns = strlen(vmsout);
4916 fab_out.fab$l_dna = nam.nam$l_name;
4917 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4919 if (preserve_dates == 0) { /* Act like DCL COPY */
4920 nam.nam$b_nop = NAM$M_SYNCHK;
4921 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4922 if (!((sts = sys$parse(&fab_out)) & 1)) {
4923 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4924 set_vaxc_errno(sts);
4927 fab_out.fab$l_xab = (void *) &xabdat;
4928 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4930 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4931 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4932 preserve_dates =0; /* bitmask from this point forward */
4934 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4935 if (!((sts = sys$create(&fab_out)) & 1)) {
4936 set_vaxc_errno(sts);
4939 set_errno(ENOENT); break;
4941 set_errno(ENODEV); break;
4943 set_errno(EINVAL); break;
4945 set_errno(EACCES); break;
4951 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4952 if (preserve_dates & 2) {
4953 /* sys$close() will process xabrdt, not xabdat */
4954 xabrdt = cc$rms_xabrdt;
4956 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4958 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4959 * is unsigned long[2], while DECC & VAXC use a struct */
4960 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4962 fab_out.fab$l_xab = (void *) &xabrdt;
4965 rab_in = cc$rms_rab;
4966 rab_in.rab$l_fab = &fab_in;
4967 rab_in.rab$l_rop = RAB$M_BIO;
4968 rab_in.rab$l_ubf = ubf;
4969 rab_in.rab$w_usz = sizeof ubf;
4970 if (!((sts = sys$connect(&rab_in)) & 1)) {
4971 sys$close(&fab_in); sys$close(&fab_out);
4972 set_errno(EVMSERR); set_vaxc_errno(sts);
4976 rab_out = cc$rms_rab;
4977 rab_out.rab$l_fab = &fab_out;
4978 rab_out.rab$l_rbf = ubf;
4979 if (!((sts = sys$connect(&rab_out)) & 1)) {
4980 sys$close(&fab_in); sys$close(&fab_out);
4981 set_errno(EVMSERR); set_vaxc_errno(sts);
4985 while ((sts = sys$read(&rab_in))) { /* always true */
4986 if (sts == RMS$_EOF) break;
4987 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4988 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4989 sys$close(&fab_in); sys$close(&fab_out);
4990 set_errno(EVMSERR); set_vaxc_errno(sts);
4995 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4996 sys$close(&fab_in); sys$close(&fab_out);
4997 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4999 set_errno(EVMSERR); set_vaxc_errno(sts);
5005 } /* end of rmscopy() */
5009 /*** The following glue provides 'hooks' to make some of the routines
5010 * from this file available from Perl. These routines are sufficiently
5011 * basic, and are required sufficiently early in the build process,
5012 * that's it's nice to have them available to miniperl as well as the
5013 * full Perl, so they're set up here instead of in an extension. The
5014 * Perl code which handles importation of these names into a given
5015 * package lives in [.VMS]Filespec.pm in @INC.
5019 rmsexpand_fromperl(pTHX_ CV *cv)
5022 char *fspec, *defspec = NULL, *rslt;
5025 if (!items || items > 2)
5026 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5027 fspec = SvPV(ST(0),n_a);
5028 if (!fspec || !*fspec) XSRETURN_UNDEF;
5029 if (items == 2) defspec = SvPV(ST(1),n_a);
5031 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5032 ST(0) = sv_newmortal();
5033 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5038 vmsify_fromperl(pTHX_ CV *cv)
5044 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5045 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5046 ST(0) = sv_newmortal();
5047 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5052 unixify_fromperl(pTHX_ CV *cv)
5058 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5059 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5060 ST(0) = sv_newmortal();
5061 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5066 fileify_fromperl(pTHX_ CV *cv)
5072 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5073 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5074 ST(0) = sv_newmortal();
5075 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5080 pathify_fromperl(pTHX_ CV *cv)
5086 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5087 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5088 ST(0) = sv_newmortal();
5089 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5094 vmspath_fromperl(pTHX_ CV *cv)
5100 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5101 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5102 ST(0) = sv_newmortal();
5103 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5108 unixpath_fromperl(pTHX_ CV *cv)
5114 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5115 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5116 ST(0) = sv_newmortal();
5117 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5122 candelete_fromperl(pTHX_ CV *cv)
5125 char fspec[NAM$C_MAXRSS+1], *fsp;
5130 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5132 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5133 if (SvTYPE(mysv) == SVt_PVGV) {
5134 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5135 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5142 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5143 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5149 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5154 rmscopy_fromperl(pTHX_ CV *cv)
5157 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5159 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5160 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5161 unsigned long int sts;
5166 if (items < 2 || items > 3)
5167 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5169 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5170 if (SvTYPE(mysv) == SVt_PVGV) {
5171 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5172 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5179 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5180 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5185 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5186 if (SvTYPE(mysv) == SVt_PVGV) {
5187 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5188 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5195 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5196 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5201 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5203 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5210 char* file = __FILE__;
5212 char temp_buff[512];
5213 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5214 no_translate_barewords = TRUE;
5216 no_translate_barewords = FALSE;
5219 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5220 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5221 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5222 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5223 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5224 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5225 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5226 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5227 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);