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)) {
735 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
739 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
745 if (sts != RMS$_RNF) return NULL;
748 txtdsc.dsc$w_length = strlen(textpasswd);
749 txtdsc.dsc$a_pointer = textpasswd;
750 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
751 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
754 return (char *) hash;
756 } /* end of my_crypt() */
760 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
761 static char *do_fileify_dirspec(char *, char *, int);
762 static char *do_tovmsspec(char *, char *, int);
764 /*{{{int do_rmdir(char *name)*/
768 char dirfile[NAM$C_MAXRSS+1];
772 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
773 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
774 else retval = kill_file(dirfile);
777 } /* end of do_rmdir */
781 * Delete any file to which user has control access, regardless of whether
782 * delete access is explicitly allowed.
783 * Limitations: User must have write access to parent directory.
784 * Does not block signals or ASTs; if interrupted in midstream
785 * may leave file with an altered ACL.
788 /*{{{int kill_file(char *name)*/
790 kill_file(char *name)
792 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
793 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
794 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
796 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
798 unsigned char myace$b_length;
799 unsigned char myace$b_type;
800 unsigned short int myace$w_flags;
801 unsigned long int myace$l_access;
802 unsigned long int myace$l_ident;
803 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
804 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
805 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
807 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
808 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
809 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
810 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
811 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
812 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
814 /* Expand the input spec using RMS, since the CRTL remove() and
815 * system services won't do this by themselves, so we may miss
816 * a file "hiding" behind a logical name or search list. */
817 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
818 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
819 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
820 /* If not, can changing protections help? */
821 if (vaxc$errno != RMS$_PRV) return -1;
823 /* No, so we get our own UIC to use as a rights identifier,
824 * and the insert an ACE at the head of the ACL which allows us
825 * to delete the file.
827 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
828 fildsc.dsc$w_length = strlen(rspec);
829 fildsc.dsc$a_pointer = rspec;
831 newace.myace$l_ident = oldace.myace$l_ident;
832 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
834 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
835 set_errno(ENOENT); break;
837 set_errno(ENOTDIR); break;
839 set_errno(ENODEV); break;
840 case RMS$_SYN: case SS$_INVFILFOROP:
841 set_errno(EINVAL); break;
843 set_errno(EACCES); break;
847 set_vaxc_errno(aclsts);
850 /* Grab any existing ACEs with this identifier in case we fail */
851 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
852 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
853 || fndsts == SS$_NOMOREACE ) {
854 /* Add the new ACE . . . */
855 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
857 if ((rmsts = remove(name))) {
858 /* We blew it - dir with files in it, no write priv for
859 * parent directory, etc. Put things back the way they were. */
860 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
863 addlst[0].bufadr = &oldace;
864 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
871 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
872 /* We just deleted it, so of course it's not there. Some versions of
873 * VMS seem to return success on the unlock operation anyhow (after all
874 * the unlock is successful), but others don't.
876 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
877 if (aclsts & 1) aclsts = fndsts;
880 set_vaxc_errno(aclsts);
886 } /* end of kill_file() */
890 /*{{{int my_mkdir(char *,Mode_t)*/
892 my_mkdir(char *dir, Mode_t mode)
894 STRLEN dirlen = strlen(dir);
897 /* zero length string sometimes gives ACCVIO */
898 if (dirlen == 0) return -1;
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 || retsts == RMS$_DEV) {
1344 retsts = sys$parse(&myfab,0,0);
1345 if (retsts & 1) goto expanded;
1347 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1348 (void) sys$parse(&myfab,0,0); /* Free search context */
1349 if (out) Safefree(out);
1350 set_vaxc_errno(retsts);
1351 if (retsts == RMS$_PRV) set_errno(EACCES);
1352 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1353 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1354 else set_errno(EVMSERR);
1357 retsts = sys$search(&myfab,0,0);
1358 if (!(retsts & 1) && retsts != RMS$_FNF) {
1359 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1360 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1361 if (out) Safefree(out);
1362 set_vaxc_errno(retsts);
1363 if (retsts == RMS$_PRV) set_errno(EACCES);
1364 else set_errno(EVMSERR);
1368 /* If the input filespec contained any lowercase characters,
1369 * downcase the result for compatibility with Unix-minded code. */
1371 for (out = myfab.fab$l_fna; *out; out++)
1372 if (islower(*out)) { haslower = 1; break; }
1373 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1374 else { out = esa; speclen = mynam.nam$b_esl; }
1375 /* Trim off null fields added by $PARSE
1376 * If type > 1 char, must have been specified in original or default spec
1377 * (not true for version; $SEARCH may have added version of existing file).
1379 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1380 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1381 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1382 if (trimver || trimtype) {
1383 if (defspec && *defspec) {
1384 char defesa[NAM$C_MAXRSS];
1385 struct FAB deffab = cc$rms_fab;
1386 struct NAM defnam = cc$rms_nam;
1388 deffab.fab$l_nam = &defnam;
1389 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1390 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1391 defnam.nam$b_nop = NAM$M_SYNCHK;
1392 if (sys$parse(&deffab,0,0) & 1) {
1393 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1394 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1397 if (trimver) speclen = mynam.nam$l_ver - out;
1399 /* If we didn't already trim version, copy down */
1400 if (speclen > mynam.nam$l_ver - out)
1401 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1402 speclen - (mynam.nam$l_ver - out));
1403 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1406 /* If we just had a directory spec on input, $PARSE "helpfully"
1407 * adds an empty name and type for us */
1408 if (mynam.nam$l_name == mynam.nam$l_type &&
1409 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1410 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1411 speclen = mynam.nam$l_name - out;
1412 out[speclen] = '\0';
1413 if (haslower) __mystrtolower(out);
1415 /* Have we been working with an expanded, but not resultant, spec? */
1416 /* Also, convert back to Unix syntax if necessary. */
1417 if (!mynam.nam$b_rsl) {
1419 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1421 else strcpy(outbuf,esa);
1424 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1425 strcpy(outbuf,tmpfspec);
1427 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1428 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1429 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1433 /* External entry points */
1434 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1435 { return do_rmsexpand(spec,buf,0,def,opt); }
1436 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1437 { return do_rmsexpand(spec,buf,1,def,opt); }
1441 ** The following routines are provided to make life easier when
1442 ** converting among VMS-style and Unix-style directory specifications.
1443 ** All will take input specifications in either VMS or Unix syntax. On
1444 ** failure, all return NULL. If successful, the routines listed below
1445 ** return a pointer to a buffer containing the appropriately
1446 ** reformatted spec (and, therefore, subsequent calls to that routine
1447 ** will clobber the result), while the routines of the same names with
1448 ** a _ts suffix appended will return a pointer to a mallocd string
1449 ** containing the appropriately reformatted spec.
1450 ** In all cases, only explicit syntax is altered; no check is made that
1451 ** the resulting string is valid or that the directory in question
1454 ** fileify_dirspec() - convert a directory spec into the name of the
1455 ** directory file (i.e. what you can stat() to see if it's a dir).
1456 ** The style (VMS or Unix) of the result is the same as the style
1457 ** of the parameter passed in.
1458 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1459 ** what you prepend to a filename to indicate what directory it's in).
1460 ** The style (VMS or Unix) of the result is the same as the style
1461 ** of the parameter passed in.
1462 ** tounixpath() - convert a directory spec into a Unix-style path.
1463 ** tovmspath() - convert a directory spec into a VMS-style path.
1464 ** tounixspec() - convert any file spec into a Unix-style file spec.
1465 ** tovmsspec() - convert any file spec into a VMS-style spec.
1467 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1468 ** Permission is given to distribute this code as part of the Perl
1469 ** standard distribution under the terms of the GNU General Public
1470 ** License or the Perl Artistic License. Copies of each may be
1471 ** found in the Perl standard distribution.
1474 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1475 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1477 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1478 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1479 char *retspec, *cp1, *cp2, *lastdir;
1480 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1482 if (!dir || !*dir) {
1483 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1485 dirlen = strlen(dir);
1486 while (dirlen && dir[dirlen-1] == '/') --dirlen;
1487 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1488 strcpy(trndir,"/sys$disk/000000");
1492 if (dirlen > NAM$C_MAXRSS) {
1493 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1495 if (!strpbrk(dir+1,"/]>:")) {
1496 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1497 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1499 dirlen = strlen(dir);
1502 strncpy(trndir,dir,dirlen);
1503 trndir[dirlen] = '\0';
1506 /* If we were handed a rooted logical name or spec, treat it like a
1507 * simple directory, so that
1508 * $ Define myroot dev:[dir.]
1509 * ... do_fileify_dirspec("myroot",buf,1) ...
1510 * does something useful.
1512 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
1513 dir[--dirlen] = '\0';
1514 dir[dirlen-1] = ']';
1517 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1518 /* If we've got an explicit filename, we can just shuffle the string. */
1519 if (*(cp1+1)) hasfilename = 1;
1520 /* Similarly, we can just back up a level if we've got multiple levels
1521 of explicit directories in a VMS spec which ends with directories. */
1523 for (cp2 = cp1; cp2 > dir; cp2--) {
1525 *cp2 = *cp1; *cp1 = '\0';
1529 if (*cp2 == '[' || *cp2 == '<') break;
1534 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1535 if (dir[0] == '.') {
1536 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1537 return do_fileify_dirspec("[]",buf,ts);
1538 else if (dir[1] == '.' &&
1539 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1540 return do_fileify_dirspec("[-]",buf,ts);
1542 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1543 dirlen -= 1; /* to last element */
1544 lastdir = strrchr(dir,'/');
1546 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1547 /* If we have "/." or "/..", VMSify it and let the VMS code
1548 * below expand it, rather than repeating the code to handle
1549 * relative components of a filespec here */
1551 if (*(cp1+2) == '.') cp1++;
1552 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1553 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1554 if (strchr(vmsdir,'/') != NULL) {
1555 /* If do_tovmsspec() returned it, it must have VMS syntax
1556 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1557 * the time to check this here only so we avoid a recursion
1558 * loop; otherwise, gigo.
1560 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1562 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1563 return do_tounixspec(trndir,buf,ts);
1566 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1567 lastdir = strrchr(dir,'/');
1569 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
1570 /* Ditto for specs that end in an MFD -- let the VMS code
1571 * figure out whether it's a real device or a rooted logical. */
1572 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1573 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1574 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1575 return do_tounixspec(trndir,buf,ts);
1578 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1579 !(lastdir = cp1 = strrchr(dir,']')) &&
1580 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1581 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1583 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1584 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1585 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1586 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1587 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1588 (ver || *cp3)))))) {
1590 set_vaxc_errno(RMS$_DIR);
1596 /* If we lead off with a device or rooted logical, add the MFD
1597 if we're specifying a top-level directory. */
1598 if (lastdir && *dir == '/') {
1600 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1607 retlen = dirlen + (addmfd ? 13 : 6);
1608 if (buf) retspec = buf;
1609 else if (ts) New(1309,retspec,retlen+1,char);
1610 else retspec = __fileify_retbuf;
1612 dirlen = lastdir - dir;
1613 memcpy(retspec,dir,dirlen);
1614 strcpy(&retspec[dirlen],"/000000");
1615 strcpy(&retspec[dirlen+7],lastdir);
1618 memcpy(retspec,dir,dirlen);
1619 retspec[dirlen] = '\0';
1621 /* We've picked up everything up to the directory file name.
1622 Now just add the type and version, and we're set. */
1623 strcat(retspec,".dir;1");
1626 else { /* VMS-style directory spec */
1627 char esa[NAM$C_MAXRSS+1], term, *cp;
1628 unsigned long int sts, cmplen, haslower = 0;
1629 struct FAB dirfab = cc$rms_fab;
1630 struct NAM savnam, dirnam = cc$rms_nam;
1632 dirfab.fab$b_fns = strlen(dir);
1633 dirfab.fab$l_fna = dir;
1634 dirfab.fab$l_nam = &dirnam;
1635 dirfab.fab$l_dna = ".DIR;1";
1636 dirfab.fab$b_dns = 6;
1637 dirnam.nam$b_ess = NAM$C_MAXRSS;
1638 dirnam.nam$l_esa = esa;
1640 for (cp = dir; *cp; cp++)
1641 if (islower(*cp)) { haslower = 1; break; }
1642 if (!((sts = sys$parse(&dirfab))&1)) {
1643 if (dirfab.fab$l_sts == RMS$_DIR) {
1644 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1645 sts = sys$parse(&dirfab) & 1;
1649 set_vaxc_errno(dirfab.fab$l_sts);
1655 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1656 /* Yes; fake the fnb bits so we'll check type below */
1657 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1659 else { /* No; just work with potential name */
1660 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1662 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1663 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1664 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1669 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1670 cp1 = strchr(esa,']');
1671 if (!cp1) cp1 = strchr(esa,'>');
1672 if (cp1) { /* Should always be true */
1673 dirnam.nam$b_esl -= cp1 - esa - 1;
1674 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1677 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1678 /* Yep; check version while we're at it, if it's there. */
1679 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1680 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1681 /* Something other than .DIR[;1]. Bzzt. */
1682 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1683 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1685 set_vaxc_errno(RMS$_DIR);
1689 esa[dirnam.nam$b_esl] = '\0';
1690 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1691 /* They provided at least the name; we added the type, if necessary, */
1692 if (buf) retspec = buf; /* in sys$parse() */
1693 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1694 else retspec = __fileify_retbuf;
1695 strcpy(retspec,esa);
1696 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1697 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1700 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1701 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1703 dirnam.nam$b_esl -= 9;
1705 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1706 if (cp1 == NULL) { /* should never happen */
1707 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1708 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1713 retlen = strlen(esa);
1714 if ((cp1 = strrchr(esa,'.')) != NULL) {
1715 /* There's more than one directory in the path. Just roll back. */
1717 if (buf) retspec = buf;
1718 else if (ts) New(1311,retspec,retlen+7,char);
1719 else retspec = __fileify_retbuf;
1720 strcpy(retspec,esa);
1723 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1724 /* Go back and expand rooted logical name */
1725 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1726 if (!(sys$parse(&dirfab) & 1)) {
1727 dirnam.nam$l_rlf = NULL;
1728 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1730 set_vaxc_errno(dirfab.fab$l_sts);
1733 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1734 if (buf) retspec = buf;
1735 else if (ts) New(1312,retspec,retlen+16,char);
1736 else retspec = __fileify_retbuf;
1737 cp1 = strstr(esa,"][");
1739 memcpy(retspec,esa,dirlen);
1740 if (!strncmp(cp1+2,"000000]",7)) {
1741 retspec[dirlen-1] = '\0';
1742 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1743 if (*cp1 == '.') *cp1 = ']';
1745 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1746 memcpy(cp1+1,"000000]",7);
1750 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1751 retspec[retlen] = '\0';
1752 /* Convert last '.' to ']' */
1753 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1754 if (*cp1 == '.') *cp1 = ']';
1756 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1757 memcpy(cp1+1,"000000]",7);
1761 else { /* This is a top-level dir. Add the MFD to the path. */
1762 if (buf) retspec = buf;
1763 else if (ts) New(1312,retspec,retlen+16,char);
1764 else retspec = __fileify_retbuf;
1767 while (*cp1 != ':') *(cp2++) = *(cp1++);
1768 strcpy(cp2,":[000000]");
1773 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1774 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1775 /* We've set up the string up through the filename. Add the
1776 type and version, and we're done. */
1777 strcat(retspec,".DIR;1");
1779 /* $PARSE may have upcased filespec, so convert output to lower
1780 * case if input contained any lowercase characters. */
1781 if (haslower) __mystrtolower(retspec);
1784 } /* end of do_fileify_dirspec() */
1786 /* External entry points */
1787 char *fileify_dirspec(char *dir, char *buf)
1788 { return do_fileify_dirspec(dir,buf,0); }
1789 char *fileify_dirspec_ts(char *dir, char *buf)
1790 { return do_fileify_dirspec(dir,buf,1); }
1792 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1793 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1795 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1796 unsigned long int retlen;
1797 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1799 if (!dir || !*dir) {
1800 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1803 if (*dir) strcpy(trndir,dir);
1804 else getcwd(trndir,sizeof trndir - 1);
1806 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1807 && my_trnlnm(trndir,trndir,0)) {
1808 STRLEN trnlen = strlen(trndir);
1810 /* Trap simple rooted lnms, and return lnm:[000000] */
1811 if (!strcmp(trndir+trnlen-2,".]")) {
1812 if (buf) retpath = buf;
1813 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1814 else retpath = __pathify_retbuf;
1815 strcpy(retpath,dir);
1816 strcat(retpath,":[000000]");
1822 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1823 if (*dir == '.' && (*(dir+1) == '\0' ||
1824 (*(dir+1) == '.' && *(dir+2) == '\0')))
1825 retlen = 2 + (*(dir+1) != '\0');
1827 if ( !(cp1 = strrchr(dir,'/')) &&
1828 !(cp1 = strrchr(dir,']')) &&
1829 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1830 if ((cp2 = strchr(cp1,'.')) != NULL &&
1831 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1832 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1833 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1834 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1836 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1837 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1838 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1839 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1840 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1841 (ver || *cp3)))))) {
1843 set_vaxc_errno(RMS$_DIR);
1846 retlen = cp2 - dir + 1;
1848 else { /* No file type present. Treat the filename as a directory. */
1849 retlen = strlen(dir) + 1;
1852 if (buf) retpath = buf;
1853 else if (ts) New(1313,retpath,retlen+1,char);
1854 else retpath = __pathify_retbuf;
1855 strncpy(retpath,dir,retlen-1);
1856 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1857 retpath[retlen-1] = '/'; /* with '/', add it. */
1858 retpath[retlen] = '\0';
1860 else retpath[retlen-1] = '\0';
1862 else { /* VMS-style directory spec */
1863 char esa[NAM$C_MAXRSS+1], *cp;
1864 unsigned long int sts, cmplen, haslower;
1865 struct FAB dirfab = cc$rms_fab;
1866 struct NAM savnam, dirnam = cc$rms_nam;
1868 /* If we've got an explicit filename, we can just shuffle the string. */
1869 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1870 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1871 if ((cp2 = strchr(cp1,'.')) != NULL) {
1873 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1874 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1875 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1876 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1877 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1878 (ver || *cp3)))))) {
1880 set_vaxc_errno(RMS$_DIR);
1884 else { /* No file type, so just draw name into directory part */
1885 for (cp2 = cp1; *cp2; cp2++) ;
1888 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1890 /* We've now got a VMS 'path'; fall through */
1892 dirfab.fab$b_fns = strlen(dir);
1893 dirfab.fab$l_fna = dir;
1894 if (dir[dirfab.fab$b_fns-1] == ']' ||
1895 dir[dirfab.fab$b_fns-1] == '>' ||
1896 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1897 if (buf) retpath = buf;
1898 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1899 else retpath = __pathify_retbuf;
1900 strcpy(retpath,dir);
1903 dirfab.fab$l_dna = ".DIR;1";
1904 dirfab.fab$b_dns = 6;
1905 dirfab.fab$l_nam = &dirnam;
1906 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1907 dirnam.nam$l_esa = esa;
1909 for (cp = dir; *cp; cp++)
1910 if (islower(*cp)) { haslower = 1; break; }
1912 if (!(sts = (sys$parse(&dirfab)&1))) {
1913 if (dirfab.fab$l_sts == RMS$_DIR) {
1914 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1915 sts = sys$parse(&dirfab) & 1;
1919 set_vaxc_errno(dirfab.fab$l_sts);
1925 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1926 if (dirfab.fab$l_sts != RMS$_FNF) {
1927 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1928 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1930 set_vaxc_errno(dirfab.fab$l_sts);
1933 dirnam = savnam; /* No; just work with potential name */
1936 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1937 /* Yep; check version while we're at it, if it's there. */
1938 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1939 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1940 /* Something other than .DIR[;1]. Bzzt. */
1941 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1942 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1944 set_vaxc_errno(RMS$_DIR);
1948 /* OK, the type was fine. Now pull any file name into the
1950 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1952 cp1 = strrchr(esa,'>');
1953 *dirnam.nam$l_type = '>';
1956 *(dirnam.nam$l_type + 1) = '\0';
1957 retlen = dirnam.nam$l_type - esa + 2;
1958 if (buf) retpath = buf;
1959 else if (ts) New(1314,retpath,retlen,char);
1960 else retpath = __pathify_retbuf;
1961 strcpy(retpath,esa);
1962 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1963 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1964 /* $PARSE may have upcased filespec, so convert output to lower
1965 * case if input contained any lowercase characters. */
1966 if (haslower) __mystrtolower(retpath);
1970 } /* end of do_pathify_dirspec() */
1972 /* External entry points */
1973 char *pathify_dirspec(char *dir, char *buf)
1974 { return do_pathify_dirspec(dir,buf,0); }
1975 char *pathify_dirspec_ts(char *dir, char *buf)
1976 { return do_pathify_dirspec(dir,buf,1); }
1978 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1979 static char *do_tounixspec(char *spec, char *buf, int ts)
1981 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1982 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1983 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1985 if (spec == NULL) return NULL;
1986 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1987 if (buf) rslt = buf;
1989 retlen = strlen(spec);
1990 cp1 = strchr(spec,'[');
1991 if (!cp1) cp1 = strchr(spec,'<');
1993 for (cp1++; *cp1; cp1++) {
1994 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1995 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1996 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1999 New(1315,rslt,retlen+2+2*expand,char);
2001 else rslt = __tounixspec_retbuf;
2002 if (strchr(spec,'/') != NULL) {
2009 dirend = strrchr(spec,']');
2010 if (dirend == NULL) dirend = strrchr(spec,'>');
2011 if (dirend == NULL) dirend = strchr(spec,':');
2012 if (dirend == NULL) {
2016 if (*cp2 != '[' && *cp2 != '<') {
2019 else { /* the VMS spec begins with directories */
2021 if (*cp2 == ']' || *cp2 == '>') {
2022 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
2025 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
2026 if (getcwd(tmp,sizeof tmp,1) == NULL) {
2027 if (ts) Safefree(rslt);
2032 while (*cp3 != ':' && *cp3) cp3++;
2034 if (strchr(cp3,']') != NULL) break;
2035 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2037 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2038 retlen = devlen + dirlen;
2039 Renew(rslt,retlen+1+2*expand,char);
2045 *(cp1++) = *(cp3++);
2046 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2050 else if ( *cp2 == '.') {
2051 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2052 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2058 for (; cp2 <= dirend; cp2++) {
2061 if (*(cp2+1) == '[') cp2++;
2063 else if (*cp2 == ']' || *cp2 == '>') {
2064 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2066 else if (*cp2 == '.') {
2068 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2069 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2070 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2071 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2072 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2074 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2075 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2079 else if (*cp2 == '-') {
2080 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2081 while (*cp2 == '-') {
2083 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2085 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2086 if (ts) Safefree(rslt); /* filespecs like */
2087 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2091 else *(cp1++) = *cp2;
2093 else *(cp1++) = *cp2;
2095 while (*cp2) *(cp1++) = *(cp2++);
2100 } /* end of do_tounixspec() */
2102 /* External entry points */
2103 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2104 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2106 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2107 static char *do_tovmsspec(char *path, char *buf, int ts) {
2108 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2109 char *rslt, *dirend;
2110 register char *cp1, *cp2;
2111 unsigned long int infront = 0, hasdir = 1;
2113 if (path == NULL) return NULL;
2114 if (buf) rslt = buf;
2115 else if (ts) New(1316,rslt,strlen(path)+9,char);
2116 else rslt = __tovmsspec_retbuf;
2117 if (strpbrk(path,"]:>") ||
2118 (dirend = strrchr(path,'/')) == NULL) {
2119 if (path[0] == '.') {
2120 if (path[1] == '\0') strcpy(rslt,"[]");
2121 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2122 else strcpy(rslt,path); /* probably garbage */
2124 else strcpy(rslt,path);
2127 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2128 if (!*(dirend+2)) dirend +=2;
2129 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2130 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2135 char trndev[NAM$C_MAXRSS+1];
2139 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2141 if (!buf & ts) Renew(rslt,18,char);
2142 strcpy(rslt,"sys$disk:[000000]");
2145 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2147 islnm = my_trnlnm(rslt,trndev,0);
2148 trnend = islnm ? strlen(trndev) - 1 : 0;
2149 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2150 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2151 /* If the first element of the path is a logical name, determine
2152 * whether it has to be translated so we can add more directories. */
2153 if (!islnm || rooted) {
2156 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2160 if (cp2 != dirend) {
2161 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2162 strcpy(rslt,trndev);
2163 cp1 = rslt + trnend;
2176 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2177 cp2 += 2; /* skip over "./" - it's redundant */
2178 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2180 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2181 *(cp1++) = '-'; /* "../" --> "-" */
2184 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2185 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2186 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2187 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2190 if (cp2 > dirend) cp2 = dirend;
2192 else *(cp1++) = '.';
2194 for (; cp2 < dirend; cp2++) {
2196 if (*(cp2-1) == '/') continue;
2197 if (*(cp1-1) != '.') *(cp1++) = '.';
2200 else if (!infront && *cp2 == '.') {
2201 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2202 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2203 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2204 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2205 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2206 else { /* back up over previous directory name */
2208 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2209 if (*(cp1-1) == '[') {
2210 memcpy(cp1,"000000.",7);
2215 if (cp2 == dirend) break;
2217 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2218 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2219 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2220 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2222 *(cp1++) = '.'; /* Simulate trailing '/' */
2223 cp2 += 2; /* for loop will incr this to == dirend */
2225 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2227 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2230 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2231 if (*cp2 == '.') *(cp1++) = '_';
2232 else *(cp1++) = *cp2;
2236 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2237 if (hasdir) *(cp1++) = ']';
2238 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2239 while (*cp2) *(cp1++) = *(cp2++);
2244 } /* end of do_tovmsspec() */
2246 /* External entry points */
2247 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2248 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2250 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2251 static char *do_tovmspath(char *path, char *buf, int ts) {
2252 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2254 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2256 if (path == NULL) return NULL;
2257 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2258 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2259 if (buf) return buf;
2261 vmslen = strlen(vmsified);
2262 New(1317,cp,vmslen+1,char);
2263 memcpy(cp,vmsified,vmslen);
2268 strcpy(__tovmspath_retbuf,vmsified);
2269 return __tovmspath_retbuf;
2272 } /* end of do_tovmspath() */
2274 /* External entry points */
2275 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2276 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2279 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2280 static char *do_tounixpath(char *path, char *buf, int ts) {
2281 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2283 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2285 if (path == NULL) return NULL;
2286 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2287 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2288 if (buf) return buf;
2290 unixlen = strlen(unixified);
2291 New(1317,cp,unixlen+1,char);
2292 memcpy(cp,unixified,unixlen);
2297 strcpy(__tounixpath_retbuf,unixified);
2298 return __tounixpath_retbuf;
2301 } /* end of do_tounixpath() */
2303 /* External entry points */
2304 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2305 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2308 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2310 *****************************************************************************
2312 * Copyright (C) 1989-1994 by *
2313 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2315 * Permission is hereby granted for the reproduction of this software, *
2316 * on condition that this copyright notice is included in the reproduction, *
2317 * and that such reproduction is not for purposes of profit or material *
2320 * 27-Aug-1994 Modified for inclusion in perl5 *
2321 * by Charles Bailey bailey@newman.upenn.edu *
2322 *****************************************************************************
2326 * getredirection() is intended to aid in porting C programs
2327 * to VMS (Vax-11 C). The native VMS environment does not support
2328 * '>' and '<' I/O redirection, or command line wild card expansion,
2329 * or a command line pipe mechanism using the '|' AND background
2330 * command execution '&'. All of these capabilities are provided to any
2331 * C program which calls this procedure as the first thing in the
2333 * The piping mechanism will probably work with almost any 'filter' type
2334 * of program. With suitable modification, it may useful for other
2335 * portability problems as well.
2337 * Author: Mark Pizzolato mark@infocomm.com
2341 struct list_item *next;
2345 static void add_item(struct list_item **head,
2346 struct list_item **tail,
2350 static void expand_wild_cards(char *item,
2351 struct list_item **head,
2352 struct list_item **tail,
2355 static int background_process(int argc, char **argv);
2357 static void pipe_and_fork(char **cmargv);
2359 /*{{{ void getredirection(int *ac, char ***av)*/
2361 getredirection(int *ac, char ***av)
2363 * Process vms redirection arg's. Exit if any error is seen.
2364 * If getredirection() processes an argument, it is erased
2365 * from the vector. getredirection() returns a new argc and argv value.
2366 * In the event that a background command is requested (by a trailing "&"),
2367 * this routine creates a background subprocess, and simply exits the program.
2369 * Warning: do not try to simplify the code for vms. The code
2370 * presupposes that getredirection() is called before any data is
2371 * read from stdin or written to stdout.
2373 * Normal usage is as follows:
2379 * getredirection(&argc, &argv);
2383 int argc = *ac; /* Argument Count */
2384 char **argv = *av; /* Argument Vector */
2385 char *ap; /* Argument pointer */
2386 int j; /* argv[] index */
2387 int item_count = 0; /* Count of Items in List */
2388 struct list_item *list_head = 0; /* First Item in List */
2389 struct list_item *list_tail; /* Last Item in List */
2390 char *in = NULL; /* Input File Name */
2391 char *out = NULL; /* Output File Name */
2392 char *outmode = "w"; /* Mode to Open Output File */
2393 char *err = NULL; /* Error File Name */
2394 char *errmode = "w"; /* Mode to Open Error File */
2395 int cmargc = 0; /* Piped Command Arg Count */
2396 char **cmargv = NULL;/* Piped Command Arg Vector */
2399 * First handle the case where the last thing on the line ends with
2400 * a '&'. This indicates the desire for the command to be run in a
2401 * subprocess, so we satisfy that desire.
2404 if (0 == strcmp("&", ap))
2405 exit(background_process(--argc, argv));
2406 if (*ap && '&' == ap[strlen(ap)-1])
2408 ap[strlen(ap)-1] = '\0';
2409 exit(background_process(argc, argv));
2412 * Now we handle the general redirection cases that involve '>', '>>',
2413 * '<', and pipes '|'.
2415 for (j = 0; j < argc; ++j)
2417 if (0 == strcmp("<", argv[j]))
2421 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2422 exit(LIB$_WRONUMARG);
2427 if ('<' == *(ap = argv[j]))
2432 if (0 == strcmp(">", ap))
2436 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2437 exit(LIB$_WRONUMARG);
2456 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2457 exit(LIB$_WRONUMARG);
2461 if (('2' == *ap) && ('>' == ap[1]))
2478 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2479 exit(LIB$_WRONUMARG);
2483 if (0 == strcmp("|", argv[j]))
2487 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2488 exit(LIB$_WRONUMARG);
2490 cmargc = argc-(j+1);
2491 cmargv = &argv[j+1];
2495 if ('|' == *(ap = argv[j]))
2503 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2506 * Allocate and fill in the new argument vector, Some Unix's terminate
2507 * the list with an extra null pointer.
2509 New(1302, argv, item_count+1, char *);
2511 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2512 argv[j] = list_head->value;
2518 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2519 exit(LIB$_INVARGORD);
2521 pipe_and_fork(cmargv);
2524 /* Check for input from a pipe (mailbox) */
2526 if (in == NULL && 1 == isapipe(0))
2528 char mbxname[L_tmpnam];
2530 long int dvi_item = DVI$_DEVBUFSIZ;
2531 $DESCRIPTOR(mbxnam, "");
2532 $DESCRIPTOR(mbxdevnam, "");
2534 /* Input from a pipe, reopen it in binary mode to disable */
2535 /* carriage control processing. */
2537 PerlIO_getname(stdin, mbxname);
2538 mbxnam.dsc$a_pointer = mbxname;
2539 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2540 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2541 mbxdevnam.dsc$a_pointer = mbxname;
2542 mbxdevnam.dsc$w_length = sizeof(mbxname);
2543 dvi_item = DVI$_DEVNAM;
2544 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2545 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2548 freopen(mbxname, "rb", stdin);
2551 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2555 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2557 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2560 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2562 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2566 if (strcmp(err,"&1") == 0) {
2567 dup2(fileno(stdout), fileno(Perl_debug_log));
2570 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2572 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2576 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2582 #ifdef ARGPROC_DEBUG
2583 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2584 for (j = 0; j < *ac; ++j)
2585 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2587 /* Clear errors we may have hit expanding wildcards, so they don't
2588 show up in Perl's $! later */
2589 set_errno(0); set_vaxc_errno(1);
2590 } /* end of getredirection() */
2593 static void add_item(struct list_item **head,
2594 struct list_item **tail,
2600 New(1303,*head,1,struct list_item);
2604 New(1304,(*tail)->next,1,struct list_item);
2605 *tail = (*tail)->next;
2607 (*tail)->value = value;
2611 static void expand_wild_cards(char *item,
2612 struct list_item **head,
2613 struct list_item **tail,
2617 unsigned long int context = 0;
2623 char vmsspec[NAM$C_MAXRSS+1];
2624 $DESCRIPTOR(filespec, "");
2625 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2626 $DESCRIPTOR(resultspec, "");
2627 unsigned long int zero = 0, sts;
2629 for (cp = item; *cp; cp++) {
2630 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2631 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2633 if (!*cp || isspace(*cp))
2635 add_item(head, tail, item, count);
2638 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2639 resultspec.dsc$b_class = DSC$K_CLASS_D;
2640 resultspec.dsc$a_pointer = NULL;
2641 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2642 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2643 if (!isunix || !filespec.dsc$a_pointer)
2644 filespec.dsc$a_pointer = item;
2645 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2647 * Only return version specs, if the caller specified a version
2649 had_version = strchr(item, ';');
2651 * Only return device and directory specs, if the caller specifed either.
2653 had_device = strchr(item, ':');
2654 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2656 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2657 &defaultspec, 0, 0, &zero))))
2662 New(1305,string,resultspec.dsc$w_length+1,char);
2663 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2664 string[resultspec.dsc$w_length] = '\0';
2665 if (NULL == had_version)
2666 *((char *)strrchr(string, ';')) = '\0';
2667 if ((!had_directory) && (had_device == NULL))
2669 if (NULL == (devdir = strrchr(string, ']')))
2670 devdir = strrchr(string, '>');
2671 strcpy(string, devdir + 1);
2674 * Be consistent with what the C RTL has already done to the rest of
2675 * the argv items and lowercase all of these names.
2677 for (c = string; *c; ++c)
2680 if (isunix) trim_unixpath(string,item,1);
2681 add_item(head, tail, string, count);
2684 if (sts != RMS$_NMF)
2686 set_vaxc_errno(sts);
2689 case RMS$_FNF: case RMS$_DNF:
2690 set_errno(ENOENT); break;
2692 set_errno(ENOTDIR); break;
2694 set_errno(ENODEV); break;
2695 case RMS$_FNM: case RMS$_SYN:
2696 set_errno(EINVAL); break;
2698 set_errno(EACCES); break;
2700 _ckvmssts_noperl(sts);
2704 add_item(head, tail, item, count);
2705 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2706 _ckvmssts_noperl(lib$find_file_end(&context));
2709 static int child_st[2];/* Event Flag set when child process completes */
2711 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2713 static unsigned long int exit_handler(int *status)
2717 if (0 == child_st[0])
2719 #ifdef ARGPROC_DEBUG
2720 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2722 fflush(stdout); /* Have to flush pipe for binary data to */
2723 /* terminate properly -- <tp@mccall.com> */
2724 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2725 sys$dassgn(child_chan);
2727 sys$synch(0, child_st);
2732 static void sig_child(int chan)
2734 #ifdef ARGPROC_DEBUG
2735 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2737 if (child_st[0] == 0)
2741 static struct exit_control_block exit_block =
2746 &exit_block.exit_status,
2750 static void pipe_and_fork(char **cmargv)
2753 $DESCRIPTOR(cmddsc, "");
2754 static char mbxname[64];
2755 $DESCRIPTOR(mbxdsc, mbxname);
2757 unsigned long int zero = 0, one = 1;
2759 strcpy(subcmd, cmargv[0]);
2760 for (j = 1; NULL != cmargv[j]; ++j)
2762 strcat(subcmd, " \"");
2763 strcat(subcmd, cmargv[j]);
2764 strcat(subcmd, "\"");
2766 cmddsc.dsc$a_pointer = subcmd;
2767 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2769 create_mbx(&child_chan,&mbxdsc);
2770 #ifdef ARGPROC_DEBUG
2771 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2772 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2774 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2775 0, &pid, child_st, &zero, sig_child,
2777 #ifdef ARGPROC_DEBUG
2778 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2780 sys$dclexh(&exit_block);
2781 if (NULL == freopen(mbxname, "wb", stdout))
2783 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2787 static int background_process(int argc, char **argv)
2789 char command[2048] = "$";
2790 $DESCRIPTOR(value, "");
2791 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2792 static $DESCRIPTOR(null, "NLA0:");
2793 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2795 $DESCRIPTOR(pidstr, "");
2797 unsigned long int flags = 17, one = 1, retsts;
2799 strcat(command, argv[0]);
2802 strcat(command, " \"");
2803 strcat(command, *(++argv));
2804 strcat(command, "\"");
2806 value.dsc$a_pointer = command;
2807 value.dsc$w_length = strlen(value.dsc$a_pointer);
2808 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2809 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2810 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2811 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2814 _ckvmssts_noperl(retsts);
2816 #ifdef ARGPROC_DEBUG
2817 PerlIO_printf(Perl_debug_log, "%s\n", command);
2819 sprintf(pidstring, "%08X", pid);
2820 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2821 pidstr.dsc$a_pointer = pidstring;
2822 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2823 lib$set_symbol(&pidsymbol, &pidstr);
2827 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2830 /* OS-specific initialization at image activation (not thread startup) */
2831 /* Older VAXC header files lack these constants */
2832 #ifndef JPI$_RIGHTS_SIZE
2833 # define JPI$_RIGHTS_SIZE 817
2835 #ifndef KGB$M_SUBSYSTEM
2836 # define KGB$M_SUBSYSTEM 0x8
2839 /*{{{void vms_image_init(int *, char ***)*/
2841 vms_image_init(int *argcp, char ***argvp)
2843 char eqv[LNM$C_NAMLENGTH+1] = "";
2844 unsigned int len, tabct = 8, tabidx = 0;
2845 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2846 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2847 unsigned short int dummy, rlen;
2848 struct dsc$descriptor_s **tabvec;
2850 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2851 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2852 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2855 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2857 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2858 if (iprv[i]) { /* Running image installed with privs? */
2859 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2864 /* Rights identifiers might trigger tainting as well. */
2865 if (!will_taint && (rlen || rsz)) {
2866 while (rlen < rsz) {
2867 /* We didn't get all the identifiers on the first pass. Allocate a
2868 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2869 * were needed to hold all identifiers at time of last call; we'll
2870 * allocate that many unsigned long ints), and go back and get 'em.
2872 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2873 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2874 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2875 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2878 mask = jpilist[1].bufadr;
2879 /* Check attribute flags for each identifier (2nd longword); protected
2880 * subsystem identifiers trigger tainting.
2882 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2883 if (mask[i] & KGB$M_SUBSYSTEM) {
2888 if (mask != rlst) Safefree(mask);
2890 /* We need to use this hack to tell Perl it should run with tainting,
2891 * since its tainting flag may be part of the PL_curinterp struct, which
2892 * hasn't been allocated when vms_image_init() is called.
2896 New(1320,newap,*argcp+2,char **);
2897 newap[0] = argvp[0];
2899 Copy(argvp[1],newap[2],*argcp-1,char **);
2900 /* We orphan the old argv, since we don't know where it's come from,
2901 * so we don't know how to free it.
2903 *argcp++; argvp = newap;
2905 else { /* Did user explicitly request tainting? */
2907 char *cp, **av = *argvp;
2908 for (i = 1; i < *argcp; i++) {
2909 if (*av[i] != '-') break;
2910 for (cp = av[i]+1; *cp; cp++) {
2911 if (*cp == 'T') { will_taint = 1; break; }
2912 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2913 strchr("DFIiMmx",*cp)) break;
2915 if (will_taint) break;
2920 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2922 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2923 else if (tabidx >= tabct) {
2925 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2927 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2928 tabvec[tabidx]->dsc$w_length = 0;
2929 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2930 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2931 tabvec[tabidx]->dsc$a_pointer = NULL;
2932 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2934 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2936 getredirection(argcp,argvp);
2937 #if defined(USE_THREADS) && defined(__DECC)
2939 # include <reentrancy.h>
2940 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2949 * Trim Unix-style prefix off filespec, so it looks like what a shell
2950 * glob expansion would return (i.e. from specified prefix on, not
2951 * full path). Note that returned filespec is Unix-style, regardless
2952 * of whether input filespec was VMS-style or Unix-style.
2954 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2955 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2956 * vector of options; at present, only bit 0 is used, and if set tells
2957 * trim unixpath to try the current default directory as a prefix when
2958 * presented with a possibly ambiguous ... wildcard.
2960 * Returns !=0 on success, with trimmed filespec replacing contents of
2961 * fspec, and 0 on failure, with contents of fpsec unchanged.
2963 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2965 trim_unixpath(char *fspec, char *wildspec, int opts)
2967 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2968 *template, *base, *end, *cp1, *cp2;
2969 register int tmplen, reslen = 0, dirs = 0;
2971 if (!wildspec || !fspec) return 0;
2972 if (strpbrk(wildspec,"]>:") != NULL) {
2973 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2974 else template = unixwild;
2976 else template = wildspec;
2977 if (strpbrk(fspec,"]>:") != NULL) {
2978 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2979 else base = unixified;
2980 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2981 * check to see that final result fits into (isn't longer than) fspec */
2982 reslen = strlen(fspec);
2986 /* No prefix or absolute path on wildcard, so nothing to remove */
2987 if (!*template || *template == '/') {
2988 if (base == fspec) return 1;
2989 tmplen = strlen(unixified);
2990 if (tmplen > reslen) return 0; /* not enough space */
2991 /* Copy unixified resultant, including trailing NUL */
2992 memmove(fspec,unixified,tmplen+1);
2996 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2997 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2998 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2999 for (cp1 = end ;cp1 >= base; cp1--)
3000 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
3002 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
3006 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
3007 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
3008 int ells = 1, totells, segdirs, match;
3009 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
3010 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3012 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
3014 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
3015 if (ellipsis == template && opts & 1) {
3016 /* Template begins with an ellipsis. Since we can't tell how many
3017 * directory names at the front of the resultant to keep for an
3018 * arbitrary starting point, we arbitrarily choose the current
3019 * default directory as a starting point. If it's there as a prefix,
3020 * clip it off. If not, fall through and act as if the leading
3021 * ellipsis weren't there (i.e. return shortest possible path that
3022 * could match template).
3024 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
3025 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3026 if (_tolower(*cp1) != _tolower(*cp2)) break;
3027 segdirs = dirs - totells; /* Min # of dirs we must have left */
3028 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
3029 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
3030 memcpy(fspec,cp2+1,end - cp2);
3034 /* First off, back up over constant elements at end of path */
3036 for (front = end ; front >= base; front--)
3037 if (*front == '/' && !dirs--) { front++; break; }
3039 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3040 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3041 if (cp1 != '\0') return 0; /* Path too long. */
3043 *cp2 = '\0'; /* Pick up with memcpy later */
3044 lcfront = lcres + (front - base);
3045 /* Now skip over each ellipsis and try to match the path in front of it. */
3047 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3048 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3049 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3050 if (cp1 < template) break; /* template started with an ellipsis */
3051 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3052 ellipsis = cp1; continue;
3054 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3056 for (segdirs = 0, cp2 = tpl;
3057 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3059 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3060 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3061 if (*cp2 == '/') segdirs++;
3063 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3064 /* Back up at least as many dirs as in template before matching */
3065 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3066 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3067 for (match = 0; cp1 > lcres;) {
3068 resdsc.dsc$a_pointer = cp1;
3069 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3071 if (match == 1) lcfront = cp1;
3073 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3075 if (!match) return 0; /* Can't find prefix ??? */
3076 if (match > 1 && opts & 1) {
3077 /* This ... wildcard could cover more than one set of dirs (i.e.
3078 * a set of similar dir names is repeated). If the template
3079 * contains more than 1 ..., upstream elements could resolve the
3080 * ambiguity, but it's not worth a full backtracking setup here.
3081 * As a quick heuristic, clip off the current default directory
3082 * if it's present to find the trimmed spec, else use the
3083 * shortest string that this ... could cover.
3085 char def[NAM$C_MAXRSS+1], *st;
3087 if (getcwd(def, sizeof def,0) == NULL) return 0;
3088 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3089 if (_tolower(*cp1) != _tolower(*cp2)) break;
3090 segdirs = dirs - totells; /* Min # of dirs we must have left */
3091 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3092 if (*cp1 == '\0' && *cp2 == '/') {
3093 memcpy(fspec,cp2+1,end - cp2);
3096 /* Nope -- stick with lcfront from above and keep going. */
3099 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3104 } /* end of trim_unixpath() */
3109 * VMS readdir() routines.
3110 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3112 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3113 * Minor modifications to original routines.
3116 /* Number of elements in vms_versions array */
3117 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3120 * Open a directory, return a handle for later use.
3122 /*{{{ DIR *opendir(char*name) */
3127 char dir[NAM$C_MAXRSS+1];
3130 if (do_tovmspath(name,dir,0) == NULL) {
3133 if (flex_stat(dir,&sb) == -1) return NULL;
3134 if (!S_ISDIR(sb.st_mode)) {
3135 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3138 if (!cando_by_name(S_IRUSR,0,dir)) {
3139 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3142 /* Get memory for the handle, and the pattern. */
3144 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3146 /* Fill in the fields; mainly playing with the descriptor. */
3147 (void)sprintf(dd->pattern, "%s*.*",dir);
3150 dd->vms_wantversions = 0;
3151 dd->pat.dsc$a_pointer = dd->pattern;
3152 dd->pat.dsc$w_length = strlen(dd->pattern);
3153 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3154 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3157 } /* end of opendir() */
3161 * Set the flag to indicate we want versions or not.
3163 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3165 vmsreaddirversions(DIR *dd, int flag)
3167 dd->vms_wantversions = flag;
3172 * Free up an opened directory.
3174 /*{{{ void closedir(DIR *dd)*/
3178 (void)lib$find_file_end(&dd->context);
3179 Safefree(dd->pattern);
3180 Safefree((char *)dd);
3185 * Collect all the version numbers for the current file.
3191 struct dsc$descriptor_s pat;
3192 struct dsc$descriptor_s res;
3194 char *p, *text, buff[sizeof dd->entry.d_name];
3196 unsigned long context, tmpsts;
3199 /* Convenient shorthand. */
3202 /* Add the version wildcard, ignoring the "*.*" put on before */
3203 i = strlen(dd->pattern);
3204 New(1308,text,i + e->d_namlen + 3,char);
3205 (void)strcpy(text, dd->pattern);
3206 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3208 /* Set up the pattern descriptor. */
3209 pat.dsc$a_pointer = text;
3210 pat.dsc$w_length = i + e->d_namlen - 1;
3211 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3212 pat.dsc$b_class = DSC$K_CLASS_S;
3214 /* Set up result descriptor. */
3215 res.dsc$a_pointer = buff;
3216 res.dsc$w_length = sizeof buff - 2;
3217 res.dsc$b_dtype = DSC$K_DTYPE_T;
3218 res.dsc$b_class = DSC$K_CLASS_S;
3220 /* Read files, collecting versions. */
3221 for (context = 0, e->vms_verscount = 0;
3222 e->vms_verscount < VERSIZE(e);
3223 e->vms_verscount++) {
3224 tmpsts = lib$find_file(&pat, &res, &context);
3225 if (tmpsts == RMS$_NMF || context == 0) break;
3227 buff[sizeof buff - 1] = '\0';
3228 if ((p = strchr(buff, ';')))
3229 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3231 e->vms_versions[e->vms_verscount] = -1;
3234 _ckvmssts(lib$find_file_end(&context));
3237 } /* end of collectversions() */
3240 * Read the next entry from the directory.
3242 /*{{{ struct dirent *readdir(DIR *dd)*/
3246 struct dsc$descriptor_s res;
3247 char *p, buff[sizeof dd->entry.d_name];
3248 unsigned long int tmpsts;
3250 /* Set up result descriptor, and get next file. */
3251 res.dsc$a_pointer = buff;
3252 res.dsc$w_length = sizeof buff - 2;
3253 res.dsc$b_dtype = DSC$K_DTYPE_T;
3254 res.dsc$b_class = DSC$K_CLASS_S;
3255 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3256 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3257 if (!(tmpsts & 1)) {
3258 set_vaxc_errno(tmpsts);
3261 set_errno(EACCES); break;
3263 set_errno(ENODEV); break;
3265 set_errno(ENOTDIR); break;
3266 case RMS$_FNF: case RMS$_DNF:
3267 set_errno(ENOENT); break;
3274 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3275 buff[sizeof buff - 1] = '\0';
3276 for (p = buff; *p; p++) *p = _tolower(*p);
3277 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3280 /* Skip any directory component and just copy the name. */
3281 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3282 else (void)strcpy(dd->entry.d_name, buff);
3284 /* Clobber the version. */
3285 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3287 dd->entry.d_namlen = strlen(dd->entry.d_name);
3288 dd->entry.vms_verscount = 0;
3289 if (dd->vms_wantversions) collectversions(dd);
3292 } /* end of readdir() */
3296 * Return something that can be used in a seekdir later.
3298 /*{{{ long telldir(DIR *dd)*/
3307 * Return to a spot where we used to be. Brute force.
3309 /*{{{ void seekdir(DIR *dd,long count)*/
3311 seekdir(DIR *dd, long count)
3313 int vms_wantversions;
3316 /* If we haven't done anything yet... */
3320 /* Remember some state, and clear it. */
3321 vms_wantversions = dd->vms_wantversions;
3322 dd->vms_wantversions = 0;
3323 _ckvmssts(lib$find_file_end(&dd->context));
3326 /* The increment is in readdir(). */
3327 for (dd->count = 0; dd->count < count; )
3330 dd->vms_wantversions = vms_wantversions;
3332 } /* end of seekdir() */
3335 /* VMS subprocess management
3337 * my_vfork() - just a vfork(), after setting a flag to record that
3338 * the current script is trying a Unix-style fork/exec.
3340 * vms_do_aexec() and vms_do_exec() are called in response to the
3341 * perl 'exec' function. If this follows a vfork call, then they
3342 * call out the the regular perl routines in doio.c which do an
3343 * execvp (for those who really want to try this under VMS).
3344 * Otherwise, they do exactly what the perl docs say exec should
3345 * do - terminate the current script and invoke a new command
3346 * (See below for notes on command syntax.)
3348 * do_aspawn() and do_spawn() implement the VMS side of the perl
3349 * 'system' function.
3351 * Note on command arguments to perl 'exec' and 'system': When handled
3352 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3353 * are concatenated to form a DCL command string. If the first arg
3354 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3355 * the the command string is handed off to DCL directly. Otherwise,
3356 * the first token of the command is taken as the filespec of an image
3357 * to run. The filespec is expanded using a default type of '.EXE' and
3358 * the process defaults for device, directory, etc., and if found, the resultant
3359 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3360 * the command string as parameters. This is perhaps a bit complicated,
3361 * but I hope it will form a happy medium between what VMS folks expect
3362 * from lib$spawn and what Unix folks expect from exec.
3365 static int vfork_called;
3367 /*{{{int my_vfork()*/
3380 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3383 if (VMScmd.dsc$a_pointer) {
3384 Safefree(VMScmd.dsc$a_pointer);
3385 VMScmd.dsc$w_length = 0;
3386 VMScmd.dsc$a_pointer = Nullch;
3391 setup_argstr(SV *really, SV **mark, SV **sp)
3394 char *junk, *tmps = Nullch;
3395 register size_t cmdlen = 0;
3402 tmps = SvPV(really,rlen);
3409 for (idx++; idx <= sp; idx++) {
3411 junk = SvPVx(*idx,rlen);
3412 cmdlen += rlen ? rlen + 1 : 0;
3415 New(401,PL_Cmd,cmdlen+1,char);
3417 if (tmps && *tmps) {
3418 strcpy(PL_Cmd,tmps);
3421 else *PL_Cmd = '\0';
3422 while (++mark <= sp) {
3424 char *s = SvPVx(*mark,n_a);
3426 if (*PL_Cmd) strcat(PL_Cmd," ");
3432 } /* end of setup_argstr() */
3435 static unsigned long int
3436 setup_cmddsc(char *cmd, int check_img)
3438 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3439 $DESCRIPTOR(defdsc,".EXE");
3440 $DESCRIPTOR(defdsc2,".");
3441 $DESCRIPTOR(resdsc,resspec);
3442 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3443 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3444 register char *s, *rest, *cp, *wordbreak;
3449 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3452 while (*s && isspace(*s)) s++;
3454 if (*s == '@' || *s == '$') {
3455 vmsspec[0] = *s; rest = s + 1;
3456 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3458 else { cp = vmsspec; rest = s; }
3459 if (*rest == '.' || *rest == '/') {
3462 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3463 rest++, cp2++) *cp2 = *rest;
3465 if (do_tovmsspec(resspec,cp,0)) {
3468 for (cp2 = vmsspec + strlen(vmsspec);
3469 *rest && cp2 - vmsspec < sizeof vmsspec;
3470 rest++, cp2++) *cp2 = *rest;
3475 /* Intuit whether verb (first word of cmd) is a DCL command:
3476 * - if first nonspace char is '@', it's a DCL indirection
3478 * - if verb contains a filespec separator, it's not a DCL command
3479 * - if it doesn't, caller tells us whether to default to a DCL
3480 * command, or to a local image unless told it's DCL (by leading '$')
3482 if (*s == '@') isdcl = 1;
3484 register char *filespec = strpbrk(s,":<[.;");
3485 rest = wordbreak = strpbrk(s," \"\t/");
3486 if (!wordbreak) wordbreak = s + strlen(s);
3487 if (*s == '$') check_img = 0;
3488 if (filespec && (filespec < wordbreak)) isdcl = 0;
3489 else isdcl = !check_img;
3493 imgdsc.dsc$a_pointer = s;
3494 imgdsc.dsc$w_length = wordbreak - s;
3495 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3497 _ckvmssts(lib$find_file_end(&cxt));
3498 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3499 if (!(retsts & 1) && *s == '$') {
3500 _ckvmssts(lib$find_file_end(&cxt));
3501 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3502 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3504 _ckvmssts(lib$find_file_end(&cxt));
3505 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3509 _ckvmssts(lib$find_file_end(&cxt));
3514 while (*s && !isspace(*s)) s++;
3517 /* check that it's really not DCL with no file extension */
3518 fp = fopen(resspec,"r","ctx=bin,shr=get");
3520 char b[4] = {0,0,0,0};
3521 read(fileno(fp),b,4);
3522 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3525 if (check_img && isdcl) return RMS$_FNF;
3527 if (cando_by_name(S_IXUSR,0,resspec)) {
3528 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3530 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3532 strcpy(VMScmd.dsc$a_pointer,"@");
3534 strcat(VMScmd.dsc$a_pointer,resspec);
3535 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3536 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3539 else retsts = RMS$_PRV;
3542 /* It's either a DCL command or we couldn't find a suitable image */
3543 VMScmd.dsc$w_length = strlen(cmd);
3544 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3545 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3546 if (!(retsts & 1)) {
3547 /* just hand off status values likely to be due to user error */
3548 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3549 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3550 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3551 else { _ckvmssts(retsts); }
3554 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3556 } /* end of setup_cmddsc() */
3559 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3561 vms_do_aexec(SV *really,SV **mark,SV **sp)
3565 if (vfork_called) { /* this follows a vfork - act Unixish */
3567 if (vfork_called < 0) {
3568 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3571 else return do_aexec(really,mark,sp);
3573 /* no vfork - act VMSish */
3574 return vms_do_exec(setup_argstr(really,mark,sp));
3579 } /* end of vms_do_aexec() */
3582 /* {{{bool vms_do_exec(char *cmd) */
3584 vms_do_exec(char *cmd)
3588 if (vfork_called) { /* this follows a vfork - act Unixish */
3590 if (vfork_called < 0) {
3591 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3594 else return do_exec(cmd);
3597 { /* no vfork - act VMSish */
3598 unsigned long int retsts;
3601 TAINT_PROPER("exec");
3602 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3603 retsts = lib$do_command(&VMScmd);
3606 case RMS$_FNF: case RMS$_DNF:
3607 set_errno(ENOENT); break;
3609 set_errno(ENOTDIR); break;
3611 set_errno(ENODEV); break;
3613 set_errno(EACCES); break;
3615 set_errno(EINVAL); break;
3617 set_errno(E2BIG); break;
3618 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3619 _ckvmssts(retsts); /* fall through */
3620 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3623 set_vaxc_errno(retsts);
3624 if (ckWARN(WARN_EXEC)) {
3625 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3626 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3633 } /* end of vms_do_exec() */
3636 unsigned long int do_spawn(char *);
3638 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3640 do_aspawn(void *really,void **mark,void **sp)
3643 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3646 } /* end of do_aspawn() */
3649 /* {{{unsigned long int do_spawn(char *cmd) */
3653 unsigned long int sts, substs, hadcmd = 1;
3657 TAINT_PROPER("spawn");
3658 if (!cmd || !*cmd) {
3660 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3662 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3663 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3668 case RMS$_FNF: case RMS$_DNF:
3669 set_errno(ENOENT); break;
3671 set_errno(ENOTDIR); break;
3673 set_errno(ENODEV); break;
3675 set_errno(EACCES); break;
3677 set_errno(EINVAL); break;
3679 set_errno(E2BIG); break;
3680 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3681 _ckvmssts(sts); /* fall through */
3682 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3685 set_vaxc_errno(sts);
3686 if (ckWARN(WARN_EXEC)) {
3687 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3688 hadcmd ? VMScmd.dsc$w_length : 0,
3689 hadcmd ? VMScmd.dsc$a_pointer : "",
3696 } /* end of do_spawn() */
3700 * A simple fwrite replacement which outputs itmsz*nitm chars without
3701 * introducing record boundaries every itmsz chars.
3703 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3705 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3707 register char *cp, *end;
3709 end = (char *)src + itmsz * nitm;
3711 while ((char *)src <= end) {
3712 for (cp = src; cp <= end; cp++) if (!*cp) break;
3713 if (fputs(src,dest) == EOF) return EOF;
3715 if (fputc('\0',dest) == EOF) return EOF;
3721 } /* end of my_fwrite() */
3724 /*{{{ int my_flush(FILE *fp)*/
3729 if ((res = fflush(fp)) == 0 && fp) {
3730 #ifdef VMS_DO_SOCKETS
3732 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3734 res = fsync(fileno(fp));
3741 * Here are replacements for the following Unix routines in the VMS environment:
3742 * getpwuid Get information for a particular UIC or UID
3743 * getpwnam Get information for a named user
3744 * getpwent Get information for each user in the rights database
3745 * setpwent Reset search to the start of the rights database
3746 * endpwent Finish searching for users in the rights database
3748 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3749 * (defined in pwd.h), which contains the following fields:-
3751 * char *pw_name; Username (in lower case)
3752 * char *pw_passwd; Hashed password
3753 * unsigned int pw_uid; UIC
3754 * unsigned int pw_gid; UIC group number
3755 * char *pw_unixdir; Default device/directory (VMS-style)
3756 * char *pw_gecos; Owner name
3757 * char *pw_dir; Default device/directory (Unix-style)
3758 * char *pw_shell; Default CLI name (eg. DCL)
3760 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3762 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3763 * not the UIC member number (eg. what's returned by getuid()),
3764 * getpwuid() can accept either as input (if uid is specified, the caller's
3765 * UIC group is used), though it won't recognise gid=0.
3767 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3768 * information about other users in your group or in other groups, respectively.
3769 * If the required privilege is not available, then these routines fill only
3770 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3773 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3776 /* sizes of various UAF record fields */
3777 #define UAI$S_USERNAME 12
3778 #define UAI$S_IDENT 31
3779 #define UAI$S_OWNER 31
3780 #define UAI$S_DEFDEV 31
3781 #define UAI$S_DEFDIR 63
3782 #define UAI$S_DEFCLI 31
3785 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3786 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3787 (uic).uic$v_group != UIC$K_WILD_GROUP)
3789 static char __empty[]= "";
3790 static struct passwd __passwd_empty=
3791 {(char *) __empty, (char *) __empty, 0, 0,
3792 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3793 static int contxt= 0;
3794 static struct passwd __pwdcache;
3795 static char __pw_namecache[UAI$S_IDENT+1];
3798 * This routine does most of the work extracting the user information.
3800 static int fillpasswd (const char *name, struct passwd *pwd)
3804 unsigned char length;
3805 char pw_gecos[UAI$S_OWNER+1];
3807 static union uicdef uic;
3809 unsigned char length;
3810 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3813 unsigned char length;
3814 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3817 unsigned char length;
3818 char pw_shell[UAI$S_DEFCLI+1];
3820 static char pw_passwd[UAI$S_PWD+1];
3822 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3823 struct dsc$descriptor_s name_desc;
3824 unsigned long int sts;
3826 static struct itmlst_3 itmlst[]= {
3827 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3828 {sizeof(uic), UAI$_UIC, &uic, &luic},
3829 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3830 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3831 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3832 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3833 {0, 0, NULL, NULL}};
3835 name_desc.dsc$w_length= strlen(name);
3836 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3837 name_desc.dsc$b_class= DSC$K_CLASS_S;
3838 name_desc.dsc$a_pointer= (char *) name;
3840 /* Note that sys$getuai returns many fields as counted strings. */
3841 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3842 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3843 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3845 else { _ckvmssts(sts); }
3846 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3848 if ((int) owner.length < lowner) lowner= (int) owner.length;
3849 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3850 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3851 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3852 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3853 owner.pw_gecos[lowner]= '\0';
3854 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3855 defcli.pw_shell[ldefcli]= '\0';
3856 if (valid_uic(uic)) {
3857 pwd->pw_uid= uic.uic$l_uic;
3858 pwd->pw_gid= uic.uic$v_group;
3861 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3862 pwd->pw_passwd= pw_passwd;
3863 pwd->pw_gecos= owner.pw_gecos;
3864 pwd->pw_dir= defdev.pw_dir;
3865 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3866 pwd->pw_shell= defcli.pw_shell;
3867 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3869 ldir= strlen(pwd->pw_unixdir) - 1;
3870 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3873 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3874 __mystrtolower(pwd->pw_unixdir);
3879 * Get information for a named user.
3881 /*{{{struct passwd *getpwnam(char *name)*/
3882 struct passwd *my_getpwnam(char *name)
3884 struct dsc$descriptor_s name_desc;
3886 unsigned long int status, sts;
3889 __pwdcache = __passwd_empty;
3890 if (!fillpasswd(name, &__pwdcache)) {
3891 /* We still may be able to determine pw_uid and pw_gid */
3892 name_desc.dsc$w_length= strlen(name);
3893 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3894 name_desc.dsc$b_class= DSC$K_CLASS_S;
3895 name_desc.dsc$a_pointer= (char *) name;
3896 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3897 __pwdcache.pw_uid= uic.uic$l_uic;
3898 __pwdcache.pw_gid= uic.uic$v_group;
3901 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3902 set_vaxc_errno(sts);
3903 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3906 else { _ckvmssts(sts); }
3909 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3910 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3911 __pwdcache.pw_name= __pw_namecache;
3913 } /* end of my_getpwnam() */
3917 * Get information for a particular UIC or UID.
3918 * Called by my_getpwent with uid=-1 to list all users.
3920 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3921 struct passwd *my_getpwuid(Uid_t uid)
3923 const $DESCRIPTOR(name_desc,__pw_namecache);
3924 unsigned short lname;
3926 unsigned long int status;
3929 if (uid == (unsigned int) -1) {
3931 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3932 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3933 set_vaxc_errno(status);
3934 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3938 else { _ckvmssts(status); }
3939 } while (!valid_uic (uic));
3943 if (!uic.uic$v_group)
3944 uic.uic$v_group= PerlProc_getgid();
3946 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3947 else status = SS$_IVIDENT;
3948 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3949 status == RMS$_PRV) {
3950 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3953 else { _ckvmssts(status); }
3955 __pw_namecache[lname]= '\0';
3956 __mystrtolower(__pw_namecache);
3958 __pwdcache = __passwd_empty;
3959 __pwdcache.pw_name = __pw_namecache;
3961 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3962 The identifier's value is usually the UIC, but it doesn't have to be,
3963 so if we can, we let fillpasswd update this. */
3964 __pwdcache.pw_uid = uic.uic$l_uic;
3965 __pwdcache.pw_gid = uic.uic$v_group;
3967 fillpasswd(__pw_namecache, &__pwdcache);
3970 } /* end of my_getpwuid() */
3974 * Get information for next user.
3976 /*{{{struct passwd *my_getpwent()*/
3977 struct passwd *my_getpwent()
3979 return (my_getpwuid((unsigned int) -1));
3984 * Finish searching rights database for users.
3986 /*{{{void my_endpwent()*/
3991 _ckvmssts(sys$finish_rdb(&contxt));
3997 #ifdef HOMEGROWN_POSIX_SIGNALS
3998 /* Signal handling routines, pulled into the core from POSIX.xs.
4000 * We need these for threads, so they've been rolled into the core,
4001 * rather than left in POSIX.xs.
4003 * (DRS, Oct 23, 1997)
4006 /* sigset_t is atomic under VMS, so these routines are easy */
4007 /*{{{int my_sigemptyset(sigset_t *) */
4008 int my_sigemptyset(sigset_t *set) {
4009 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4015 /*{{{int my_sigfillset(sigset_t *)*/
4016 int my_sigfillset(sigset_t *set) {
4018 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4019 for (i = 0; i < NSIG; i++) *set |= (1 << i);
4025 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
4026 int my_sigaddset(sigset_t *set, int sig) {
4027 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4028 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4029 *set |= (1 << (sig - 1));
4035 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
4036 int my_sigdelset(sigset_t *set, int sig) {
4037 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4038 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4039 *set &= ~(1 << (sig - 1));
4045 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4046 int my_sigismember(sigset_t *set, int sig) {
4047 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4048 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4049 *set & (1 << (sig - 1));
4054 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4055 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4058 /* If set and oset are both null, then things are badly wrong. Bail out. */
4059 if ((oset == NULL) && (set == NULL)) {
4060 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4064 /* If set's null, then we're just handling a fetch. */
4066 tempmask = sigblock(0);
4071 tempmask = sigsetmask(*set);
4074 tempmask = sigblock(*set);
4077 tempmask = sigblock(0);
4078 sigsetmask(*oset & ~tempmask);
4081 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4086 /* Did they pass us an oset? If so, stick our holding mask into it */
4093 #endif /* HOMEGROWN_POSIX_SIGNALS */
4096 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4097 * my_utime(), and flex_stat(), all of which operate on UTC unless
4098 * VMSISH_TIMES is true.
4100 /* method used to handle UTC conversions:
4101 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4103 static int gmtime_emulation_type;
4104 /* number of secs to add to UTC POSIX-style time to get local time */
4105 static long int utc_offset_secs;
4107 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4108 * in vmsish.h. #undef them here so we can call the CRTL routines
4115 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4116 # define RTL_USES_UTC 1
4120 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4121 * qualifier with the extern prefix pragma. This provisional
4122 * hack circumvents this prefix pragma problem in previous
4125 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4126 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4127 # pragma __extern_prefix save
4128 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4129 # define gmtime decc$__utctz_gmtime
4130 # define localtime decc$__utctz_localtime
4131 # define time decc$__utc_time
4132 # pragma __extern_prefix restore
4134 struct tm *gmtime(), *localtime();
4140 static time_t toutc_dst(time_t loc) {
4143 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4144 loc -= utc_offset_secs;
4145 if (rsltmp->tm_isdst) loc -= 3600;
4148 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4149 ((gmtime_emulation_type || my_time(NULL)), \
4150 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4151 ((secs) - utc_offset_secs))))
4153 static time_t toloc_dst(time_t utc) {
4156 utc += utc_offset_secs;
4157 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4158 if (rsltmp->tm_isdst) utc += 3600;
4161 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4162 ((gmtime_emulation_type || my_time(NULL)), \
4163 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4164 ((secs) + utc_offset_secs))))
4167 /* my_time(), my_localtime(), my_gmtime()
4168 * By default traffic in UTC time values, using CRTL gmtime() or
4169 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4170 * Note: We need to use these functions even when the CRTL has working
4171 * UTC support, since they also handle C<use vmsish qw(times);>
4173 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4174 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4177 /*{{{time_t my_time(time_t *timep)*/
4178 time_t my_time(time_t *timep)
4184 if (gmtime_emulation_type == 0) {
4186 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4187 /* results of calls to gmtime() and localtime() */
4188 /* for same &base */
4190 gmtime_emulation_type++;
4191 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4192 char off[LNM$C_NAMLENGTH+1];;
4194 gmtime_emulation_type++;
4195 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4196 gmtime_emulation_type++;
4197 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4199 else { utc_offset_secs = atol(off); }
4201 else { /* We've got a working gmtime() */
4202 struct tm gmt, local;
4205 tm_p = localtime(&base);
4207 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4208 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4209 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4210 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4216 # ifdef RTL_USES_UTC
4217 if (VMSISH_TIME) when = _toloc(when);
4219 if (!VMSISH_TIME) when = _toutc(when);
4222 if (timep != NULL) *timep = when;
4225 } /* end of my_time() */
4229 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4231 my_gmtime(const time_t *timep)
4238 if (timep == NULL) {
4239 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4242 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4246 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4248 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4249 return gmtime(&when);
4251 /* CRTL localtime() wants local time as input, so does no tz correction */
4252 rsltmp = localtime(&when);
4253 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4256 } /* end of my_gmtime() */
4260 /*{{{struct tm *my_localtime(const time_t *timep)*/
4262 my_localtime(const time_t *timep)
4268 if (timep == NULL) {
4269 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4272 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4273 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4276 # ifdef RTL_USES_UTC
4278 if (VMSISH_TIME) when = _toutc(when);
4280 /* CRTL localtime() wants UTC as input, does tz correction itself */
4281 return localtime(&when);
4284 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4287 /* CRTL localtime() wants local time as input, so does no tz correction */
4288 rsltmp = localtime(&when);
4289 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4292 } /* end of my_localtime() */
4295 /* Reset definitions for later calls */
4296 #define gmtime(t) my_gmtime(t)
4297 #define localtime(t) my_localtime(t)
4298 #define time(t) my_time(t)
4301 /* my_utime - update modification time of a file
4302 * calling sequence is identical to POSIX utime(), but under
4303 * VMS only the modification time is changed; ODS-2 does not
4304 * maintain access times. Restrictions differ from the POSIX
4305 * definition in that the time can be changed as long as the
4306 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4307 * no separate checks are made to insure that the caller is the
4308 * owner of the file or has special privs enabled.
4309 * Code here is based on Joe Meadows' FILE utility.
4312 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4313 * to VMS epoch (01-JAN-1858 00:00:00.00)
4314 * in 100 ns intervals.
4316 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4318 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4319 int my_utime(char *file, struct utimbuf *utimes)
4323 long int bintime[2], len = 2, lowbit, unixtime,
4324 secscale = 10000000; /* seconds --> 100 ns intervals */
4325 unsigned long int chan, iosb[2], retsts;
4326 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4327 struct FAB myfab = cc$rms_fab;
4328 struct NAM mynam = cc$rms_nam;
4329 #if defined (__DECC) && defined (__VAX)
4330 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4331 * at least through VMS V6.1, which causes a type-conversion warning.
4333 # pragma message save
4334 # pragma message disable cvtdiftypes
4336 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4337 struct fibdef myfib;
4338 #if defined (__DECC) && defined (__VAX)
4339 /* This should be right after the declaration of myatr, but due
4340 * to a bug in VAX DEC C, this takes effect a statement early.
4342 # pragma message restore
4344 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4345 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4346 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4348 if (file == NULL || *file == '\0') {
4350 set_vaxc_errno(LIB$_INVARG);
4353 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4355 if (utimes != NULL) {
4356 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4357 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4358 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4359 * as input, we force the sign bit to be clear by shifting unixtime right
4360 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4362 lowbit = (utimes->modtime & 1) ? secscale : 0;
4363 unixtime = (long int) utimes->modtime;
4365 /* If input was UTC; convert to local for sys svc */
4366 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4368 unixtime >>= 1; secscale <<= 1;
4369 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4370 if (!(retsts & 1)) {
4372 set_vaxc_errno(retsts);
4375 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4376 if (!(retsts & 1)) {
4378 set_vaxc_errno(retsts);
4383 /* Just get the current time in VMS format directly */
4384 retsts = sys$gettim(bintime);
4385 if (!(retsts & 1)) {
4387 set_vaxc_errno(retsts);
4392 myfab.fab$l_fna = vmsspec;
4393 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4394 myfab.fab$l_nam = &mynam;
4395 mynam.nam$l_esa = esa;
4396 mynam.nam$b_ess = (unsigned char) sizeof esa;
4397 mynam.nam$l_rsa = rsa;
4398 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4400 /* Look for the file to be affected, letting RMS parse the file
4401 * specification for us as well. I have set errno using only
4402 * values documented in the utime() man page for VMS POSIX.
4404 retsts = sys$parse(&myfab,0,0);
4405 if (!(retsts & 1)) {
4406 set_vaxc_errno(retsts);
4407 if (retsts == RMS$_PRV) set_errno(EACCES);
4408 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4409 else set_errno(EVMSERR);
4412 retsts = sys$search(&myfab,0,0);
4413 if (!(retsts & 1)) {
4414 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4415 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4416 set_vaxc_errno(retsts);
4417 if (retsts == RMS$_PRV) set_errno(EACCES);
4418 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4419 else set_errno(EVMSERR);
4423 devdsc.dsc$w_length = mynam.nam$b_dev;
4424 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4426 retsts = sys$assign(&devdsc,&chan,0,0);
4427 if (!(retsts & 1)) {
4428 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4429 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4430 set_vaxc_errno(retsts);
4431 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4432 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4433 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4434 else set_errno(EVMSERR);
4438 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4439 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4441 memset((void *) &myfib, 0, sizeof myfib);
4443 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4444 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4445 /* This prevents the revision time of the file being reset to the current
4446 * time as a result of our IO$_MODIFY $QIO. */
4447 myfib.fib$l_acctl = FIB$M_NORECORD;
4449 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4450 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4451 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4453 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4454 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4455 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4456 _ckvmssts(sys$dassgn(chan));
4457 if (retsts & 1) retsts = iosb[0];
4458 if (!(retsts & 1)) {
4459 set_vaxc_errno(retsts);
4460 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4461 else set_errno(EVMSERR);
4466 } /* end of my_utime() */
4470 * flex_stat, flex_fstat
4471 * basic stat, but gets it right when asked to stat
4472 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4475 /* encode_dev packs a VMS device name string into an integer to allow
4476 * simple comparisons. This can be used, for example, to check whether two
4477 * files are located on the same device, by comparing their encoded device
4478 * names. Even a string comparison would not do, because stat() reuses the
4479 * device name buffer for each call; so without encode_dev, it would be
4480 * necessary to save the buffer and use strcmp (this would mean a number of
4481 * changes to the standard Perl code, to say nothing of what a Perl script
4484 * The device lock id, if it exists, should be unique (unless perhaps compared
4485 * with lock ids transferred from other nodes). We have a lock id if the disk is
4486 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4487 * device names. Thus we use the lock id in preference, and only if that isn't
4488 * available, do we try to pack the device name into an integer (flagged by
4489 * the sign bit (LOCKID_MASK) being set).
4491 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4492 * name and its encoded form, but it seems very unlikely that we will find
4493 * two files on different disks that share the same encoded device names,
4494 * and even more remote that they will share the same file id (if the test
4495 * is to check for the same file).
4497 * A better method might be to use sys$device_scan on the first call, and to
4498 * search for the device, returning an index into the cached array.
4499 * The number returned would be more intelligable.
4500 * This is probably not worth it, and anyway would take quite a bit longer
4501 * on the first call.
4503 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4504 static mydev_t encode_dev (const char *dev)
4507 unsigned long int f;
4513 if (!dev || !dev[0]) return 0;
4517 struct dsc$descriptor_s dev_desc;
4518 unsigned long int status, lockid, item = DVI$_LOCKID;
4520 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4521 can try that first. */
4522 dev_desc.dsc$w_length = strlen (dev);
4523 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4524 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4525 dev_desc.dsc$a_pointer = (char *) dev;
4526 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4527 if (lockid) return (lockid & ~LOCKID_MASK);
4531 /* Otherwise we try to encode the device name */
4535 for (q = dev + strlen(dev); q--; q >= dev) {
4538 else if (isalpha (toupper (*q)))
4539 c= toupper (*q) - 'A' + (char)10;
4541 continue; /* Skip '$'s */
4543 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4545 enc += f * (unsigned long int) c;
4547 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4549 } /* end of encode_dev() */
4551 static char namecache[NAM$C_MAXRSS+1];
4554 is_null_device(name)
4558 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4559 The underscore prefix, controller letter, and unit number are
4560 independently optional; for our purposes, the colon punctuation
4561 is not. The colon can be trailed by optional directory and/or
4562 filename, but two consecutive colons indicates a nodename rather
4563 than a device. [pr] */
4564 if (*name == '_') ++name;
4565 if (tolower(*name++) != 'n') return 0;
4566 if (tolower(*name++) != 'l') return 0;
4567 if (tolower(*name) == 'a') ++name;
4568 if (*name == '0') ++name;
4569 return (*name++ == ':') && (*name != ':');
4572 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4573 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4574 * subset of the applicable information.
4577 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4579 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4581 char fname[NAM$C_MAXRSS+1];
4582 unsigned long int retsts;
4583 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4584 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4586 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4587 device name on successive calls */
4588 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4589 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4590 namdsc.dsc$a_pointer = fname;
4591 namdsc.dsc$w_length = sizeof fname - 1;
4593 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4594 &namdsc,&namdsc.dsc$w_length,0,0);
4596 fname[namdsc.dsc$w_length] = '\0';
4597 return cando_by_name(bit,effective,fname);
4599 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4600 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4604 return FALSE; /* Should never get to here */
4606 } /* end of cando() */
4610 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4612 cando_by_name(I32 bit, Uid_t effective, char *fname)
4614 static char usrname[L_cuserid];
4615 static struct dsc$descriptor_s usrdsc =
4616 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4617 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4618 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4619 unsigned short int retlen;
4621 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4622 union prvdef curprv;
4623 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4624 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4625 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4628 if (!fname || !*fname) return FALSE;
4629 /* Make sure we expand logical names, since sys$check_access doesn't */
4630 if (!strpbrk(fname,"/]>:")) {
4631 strcpy(fileified,fname);
4632 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4635 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4636 retlen = namdsc.dsc$w_length = strlen(vmsname);
4637 namdsc.dsc$a_pointer = vmsname;
4638 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4639 vmsname[retlen-1] == ':') {
4640 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4641 namdsc.dsc$w_length = strlen(fileified);
4642 namdsc.dsc$a_pointer = fileified;
4645 if (!usrdsc.dsc$w_length) {
4647 usrdsc.dsc$w_length = strlen(usrname);
4651 case S_IXUSR: case S_IXGRP: case S_IXOTH:
4652 access = ARM$M_EXECUTE; break;
4653 case S_IRUSR: case S_IRGRP: case S_IROTH:
4654 access = ARM$M_READ; break;
4655 case S_IWUSR: case S_IWGRP: case S_IWOTH:
4656 access = ARM$M_WRITE; break;
4657 case S_IDUSR: case S_IDGRP: case S_IDOTH:
4658 access = ARM$M_DELETE; break;
4663 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4664 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4665 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4666 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4667 set_vaxc_errno(retsts);
4668 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4669 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4670 else set_errno(ENOENT);
4673 if (retsts == SS$_NORMAL) {
4674 if (!privused) return TRUE;
4675 /* We can get access, but only by using privs. Do we have the
4676 necessary privs currently enabled? */
4677 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4678 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4679 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4680 !curprv.prv$v_bypass) return FALSE;
4681 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4682 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4683 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4686 if (retsts == SS$_ACCONFLICT) {
4690 #if defined(__ALPHA) && defined(__VMS_VER) && __VMS_VER == 70100022 && defined(__DECC_VER) && __DECC_VER == 6009001
4691 /* XXX Hideous kluge to accomodate error in specific version of RTL;
4692 we hope it'll be buried soon */
4693 if (retsts == 114762) return TRUE;
4697 return FALSE; /* Should never get here */
4699 } /* end of cando_by_name() */
4703 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4705 flex_fstat(int fd, Stat_t *statbufp)
4708 if (!fstat(fd,(stat_t *) statbufp)) {
4709 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4710 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4711 # ifdef RTL_USES_UTC
4714 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4715 statbufp->st_atime = _toloc(statbufp->st_atime);
4716 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4721 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4725 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4726 statbufp->st_atime = _toutc(statbufp->st_atime);
4727 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4734 } /* end of flex_fstat() */
4737 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4739 flex_stat(const char *fspec, Stat_t *statbufp)
4742 char fileified[NAM$C_MAXRSS+1];
4743 char temp_fspec[NAM$C_MAXRSS+300];
4746 strcpy(temp_fspec, fspec);
4747 if (statbufp == (Stat_t *) &PL_statcache)
4748 do_tovmsspec(temp_fspec,namecache,0);
4749 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4750 memset(statbufp,0,sizeof *statbufp);
4751 statbufp->st_dev = encode_dev("_NLA0:");
4752 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4753 statbufp->st_uid = 0x00010001;
4754 statbufp->st_gid = 0x0001;
4755 time((time_t *)&statbufp->st_mtime);
4756 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4760 /* Try for a directory name first. If fspec contains a filename without
4761 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4762 * and sea:[wine.dark]water. exist, we prefer the directory here.
4763 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4764 * not sea:[wine.dark]., if the latter exists. If the intended target is
4765 * the file with null type, specify this by calling flex_stat() with
4766 * a '.' at the end of fspec.
4768 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4769 retval = stat(fileified,(stat_t *) statbufp);
4770 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4771 strcpy(namecache,fileified);
4773 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4775 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4776 # ifdef RTL_USES_UTC
4779 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4780 statbufp->st_atime = _toloc(statbufp->st_atime);
4781 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4786 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4790 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4791 statbufp->st_atime = _toutc(statbufp->st_atime);
4792 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4798 } /* end of flex_stat() */
4802 /*{{{char *my_getlogin()*/
4803 /* VMS cuserid == Unix getlogin, except calling sequence */
4807 static char user[L_cuserid];
4808 return cuserid(user);
4813 /* rmscopy - copy a file using VMS RMS routines
4815 * Copies contents and attributes of spec_in to spec_out, except owner
4816 * and protection information. Name and type of spec_in are used as
4817 * defaults for spec_out. The third parameter specifies whether rmscopy()
4818 * should try to propagate timestamps from the input file to the output file.
4819 * If it is less than 0, no timestamps are preserved. If it is 0, then
4820 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4821 * propagated to the output file at creation iff the output file specification
4822 * did not contain an explicit name or type, and the revision date is always
4823 * updated at the end of the copy operation. If it is greater than 0, then
4824 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4825 * other than the revision date should be propagated, and bit 1 indicates
4826 * that the revision date should be propagated.
4828 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4830 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4831 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4832 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4833 * as part of the Perl standard distribution under the terms of the
4834 * GNU General Public License or the Perl Artistic License. Copies
4835 * of each may be found in the Perl standard distribution.
4837 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4839 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4841 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4842 rsa[NAM$C_MAXRSS], ubf[32256];
4843 unsigned long int i, sts, sts2;
4844 struct FAB fab_in, fab_out;
4845 struct RAB rab_in, rab_out;
4847 struct XABDAT xabdat;
4848 struct XABFHC xabfhc;
4849 struct XABRDT xabrdt;
4850 struct XABSUM xabsum;
4852 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4853 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4854 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4858 fab_in = cc$rms_fab;
4859 fab_in.fab$l_fna = vmsin;
4860 fab_in.fab$b_fns = strlen(vmsin);
4861 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4862 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4863 fab_in.fab$l_fop = FAB$M_SQO;
4864 fab_in.fab$l_nam = &nam;
4865 fab_in.fab$l_xab = (void *) &xabdat;
4868 nam.nam$l_rsa = rsa;
4869 nam.nam$b_rss = sizeof(rsa);
4870 nam.nam$l_esa = esa;
4871 nam.nam$b_ess = sizeof (esa);
4872 nam.nam$b_esl = nam.nam$b_rsl = 0;
4874 xabdat = cc$rms_xabdat; /* To get creation date */
4875 xabdat.xab$l_nxt = (void *) &xabfhc;
4877 xabfhc = cc$rms_xabfhc; /* To get record length */
4878 xabfhc.xab$l_nxt = (void *) &xabsum;
4880 xabsum = cc$rms_xabsum; /* To get key and area information */
4882 if (!((sts = sys$open(&fab_in)) & 1)) {
4883 set_vaxc_errno(sts);
4885 case RMS$_FNF: case RMS$_DNF:
4886 set_errno(ENOENT); break;
4888 set_errno(ENOTDIR); break;
4890 set_errno(ENODEV); break;
4892 set_errno(EINVAL); break;
4894 set_errno(EACCES); break;
4902 fab_out.fab$w_ifi = 0;
4903 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4904 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4905 fab_out.fab$l_fop = FAB$M_SQO;
4906 fab_out.fab$l_fna = vmsout;
4907 fab_out.fab$b_fns = strlen(vmsout);
4908 fab_out.fab$l_dna = nam.nam$l_name;
4909 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4911 if (preserve_dates == 0) { /* Act like DCL COPY */
4912 nam.nam$b_nop = NAM$M_SYNCHK;
4913 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4914 if (!((sts = sys$parse(&fab_out)) & 1)) {
4915 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4916 set_vaxc_errno(sts);
4919 fab_out.fab$l_xab = (void *) &xabdat;
4920 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4922 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4923 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4924 preserve_dates =0; /* bitmask from this point forward */
4926 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4927 if (!((sts = sys$create(&fab_out)) & 1)) {
4928 set_vaxc_errno(sts);
4931 set_errno(ENOENT); break;
4933 set_errno(ENOTDIR); break;
4935 set_errno(ENODEV); break;
4937 set_errno(EINVAL); break;
4939 set_errno(EACCES); break;
4945 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4946 if (preserve_dates & 2) {
4947 /* sys$close() will process xabrdt, not xabdat */
4948 xabrdt = cc$rms_xabrdt;
4950 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4952 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4953 * is unsigned long[2], while DECC & VAXC use a struct */
4954 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4956 fab_out.fab$l_xab = (void *) &xabrdt;
4959 rab_in = cc$rms_rab;
4960 rab_in.rab$l_fab = &fab_in;
4961 rab_in.rab$l_rop = RAB$M_BIO;
4962 rab_in.rab$l_ubf = ubf;
4963 rab_in.rab$w_usz = sizeof ubf;
4964 if (!((sts = sys$connect(&rab_in)) & 1)) {
4965 sys$close(&fab_in); sys$close(&fab_out);
4966 set_errno(EVMSERR); set_vaxc_errno(sts);
4970 rab_out = cc$rms_rab;
4971 rab_out.rab$l_fab = &fab_out;
4972 rab_out.rab$l_rbf = ubf;
4973 if (!((sts = sys$connect(&rab_out)) & 1)) {
4974 sys$close(&fab_in); sys$close(&fab_out);
4975 set_errno(EVMSERR); set_vaxc_errno(sts);
4979 while ((sts = sys$read(&rab_in))) { /* always true */
4980 if (sts == RMS$_EOF) break;
4981 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4982 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4983 sys$close(&fab_in); sys$close(&fab_out);
4984 set_errno(EVMSERR); set_vaxc_errno(sts);
4989 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4990 sys$close(&fab_in); sys$close(&fab_out);
4991 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4993 set_errno(EVMSERR); set_vaxc_errno(sts);
4999 } /* end of rmscopy() */
5003 /*** The following glue provides 'hooks' to make some of the routines
5004 * from this file available from Perl. These routines are sufficiently
5005 * basic, and are required sufficiently early in the build process,
5006 * that's it's nice to have them available to miniperl as well as the
5007 * full Perl, so they're set up here instead of in an extension. The
5008 * Perl code which handles importation of these names into a given
5009 * package lives in [.VMS]Filespec.pm in @INC.
5013 rmsexpand_fromperl(pTHX_ CV *cv)
5016 char *fspec, *defspec = NULL, *rslt;
5019 if (!items || items > 2)
5020 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
5021 fspec = SvPV(ST(0),n_a);
5022 if (!fspec || !*fspec) XSRETURN_UNDEF;
5023 if (items == 2) defspec = SvPV(ST(1),n_a);
5025 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
5026 ST(0) = sv_newmortal();
5027 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
5032 vmsify_fromperl(pTHX_ CV *cv)
5038 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
5039 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
5040 ST(0) = sv_newmortal();
5041 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5046 unixify_fromperl(pTHX_ CV *cv)
5052 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5053 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5054 ST(0) = sv_newmortal();
5055 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5060 fileify_fromperl(pTHX_ CV *cv)
5066 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5067 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5068 ST(0) = sv_newmortal();
5069 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5074 pathify_fromperl(pTHX_ CV *cv)
5080 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5081 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5082 ST(0) = sv_newmortal();
5083 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5088 vmspath_fromperl(pTHX_ CV *cv)
5094 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5095 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5096 ST(0) = sv_newmortal();
5097 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5102 unixpath_fromperl(pTHX_ CV *cv)
5108 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5109 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5110 ST(0) = sv_newmortal();
5111 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5116 candelete_fromperl(pTHX_ CV *cv)
5119 char fspec[NAM$C_MAXRSS+1], *fsp;
5124 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5126 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5127 if (SvTYPE(mysv) == SVt_PVGV) {
5128 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5129 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5136 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5137 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5143 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5148 rmscopy_fromperl(pTHX_ CV *cv)
5151 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5153 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5154 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5155 unsigned long int sts;
5160 if (items < 2 || items > 3)
5161 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5163 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5164 if (SvTYPE(mysv) == SVt_PVGV) {
5165 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5166 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5173 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5174 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5179 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5180 if (SvTYPE(mysv) == SVt_PVGV) {
5181 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5182 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5189 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5190 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5195 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5197 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5204 char* file = __FILE__;
5206 char temp_buff[512];
5207 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5208 no_translate_barewords = TRUE;
5210 no_translate_barewords = FALSE;
5213 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5214 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5215 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5216 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5217 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5218 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5219 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5220 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5221 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);