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
73 unsigned short int buflen;
74 unsigned short int itmcode;
76 unsigned short int *retlen;
79 static char *__mystrtolower(char *str)
81 if (str) for (; *str; ++str) *str= tolower(*str);
85 static struct dsc$descriptor_s fildevdsc =
86 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
87 static struct dsc$descriptor_s crtlenvdsc =
88 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
89 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
90 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
91 static struct dsc$descriptor_s **env_tables = defenv;
92 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
94 /* True if we shouldn't treat barewords as logicals during directory */
96 static int no_translate_barewords;
98 /* Temp for subprocess commands */
99 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
101 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
103 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
104 struct dsc$descriptor_s **tabvec, unsigned long int flags)
106 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
107 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
108 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
109 unsigned char acmode;
110 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
111 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
112 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
113 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
115 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
116 #if defined(USE_THREADS)
117 /* We jump through these hoops because we can be called at */
118 /* platform-specific initialization time, which is before anything is */
119 /* set up--we can't even do a plain dTHX since that relies on the */
120 /* interpreter structure to be initialized */
121 struct perl_thread *thr;
123 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
129 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
130 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
132 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
133 *cp2 = _toupper(*cp1);
134 if (cp1 - lnm > LNM$C_NAMLENGTH) {
135 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
139 lnmdsc.dsc$w_length = cp1 - lnm;
140 lnmdsc.dsc$a_pointer = uplnm;
141 secure = flags & PERL__TRNENV_SECURE;
142 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
143 if (!tabvec || !*tabvec) tabvec = env_tables;
145 for (curtab = 0; tabvec[curtab]; curtab++) {
146 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
147 if (!ivenv && !secure) {
152 Perl_warn(aTHX_ "Can't read CRTL environ\n");
155 retsts = SS$_NOLOGNAM;
156 for (i = 0; environ[i]; i++) {
157 if ((eq = strchr(environ[i],'=')) &&
158 !strncmp(environ[i],uplnm,eq - environ[i])) {
160 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
161 if (!eqvlen) continue;
166 if (retsts != SS$_NOLOGNAM) break;
169 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
170 !str$case_blind_compare(&tmpdsc,&clisym)) {
171 if (!ivsym && !secure) {
172 unsigned short int deflen = LNM$C_NAMLENGTH;
173 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
174 /* dynamic dsc to accomodate possible long value */
175 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
176 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
179 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
181 /* Special hack--we might be called before the interpreter's */
182 /* fully initialized, in which case either thr or PL_curcop */
183 /* might be bogus. We have to check, since ckWARN needs them */
184 /* both to be valid if running threaded */
185 #if defined(USE_THREADS)
186 if (thr && PL_curcop) {
188 if (ckWARN(WARN_MISC)) {
189 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
191 #if defined(USE_THREADS)
193 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
198 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
200 _ckvmssts(lib$sfree1_dd(&eqvdsc));
201 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
202 if (retsts == LIB$_NOSUCHSYM) continue;
207 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
208 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
209 if (retsts == SS$_NOLOGNAM) continue;
213 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
214 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
215 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
216 retsts == SS$_NOLOGNAM) {
217 set_errno(EINVAL); set_vaxc_errno(retsts);
219 else _ckvmssts(retsts);
221 } /* end of vmstrnenv */
224 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
225 /* Define as a function so we can access statics. */
226 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
228 return vmstrnenv(lnm,eqv,idx,fildev,
229 #ifdef SECURE_INTERNAL_GETENV
230 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
239 * Note: Uses Perl temp to store result so char * can be returned to
240 * caller; this pointer will be invalidated at next Perl statement
242 * We define this as a function rather than a macro in terms of my_getenv_len()
243 * so that it'll work when PL_curinterp is undefined (and we therefore can't
246 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
248 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
250 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
251 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
252 unsigned long int idx = 0;
256 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
257 /* Set up a temporary buffer for the return value; Perl will
258 * clean it up at the next statement transition */
259 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
260 if (!tmpsv) return NULL;
263 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
264 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
265 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
266 getcwd(eqv,LNM$C_NAMLENGTH);
270 if ((cp2 = strchr(lnm,';')) != NULL) {
272 uplnm[cp2-lnm] = '\0';
273 idx = strtoul(cp2+1,NULL,0);
276 /* Impose security constraints only if tainting */
277 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
278 if (vmstrnenv(lnm,eqv,idx,
280 #ifdef SECURE_INTERNAL_GETENV
281 sys ? PERL__TRNENV_SECURE : 0
289 } /* end of my_getenv() */
293 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
295 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
298 char *buf, *cp1, *cp2;
299 unsigned long idx = 0;
300 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
303 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
304 /* Set up a temporary buffer for the return value; Perl will
305 * clean it up at the next statement transition */
306 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
307 if (!tmpsv) return NULL;
310 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
311 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
312 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
313 getcwd(buf,LNM$C_NAMLENGTH);
318 if ((cp2 = strchr(lnm,';')) != NULL) {
321 idx = strtoul(cp2+1,NULL,0);
324 /* Impose security constraints only if tainting */
325 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
326 if ((*len = vmstrnenv(lnm,buf,idx,
328 #ifdef SECURE_INTERNAL_GETENV
329 sys ? PERL__TRNENV_SECURE : 0
339 } /* end of my_getenv_len() */
342 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
344 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
346 /*{{{ void prime_env_iter() */
349 /* Fill the %ENV associative array with all logical names we can
350 * find, in preparation for iterating over it.
354 static int primed = 0;
355 HV *seenhv = NULL, *envhv;
356 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
357 unsigned short int chan;
358 #ifndef CLI$M_TRUSTED
359 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
361 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
362 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
364 bool have_sym = FALSE, have_lnm = FALSE;
365 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
366 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
367 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
368 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
369 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
371 static perl_mutex primenv_mutex;
372 MUTEX_INIT(&primenv_mutex);
375 if (primed || !PL_envgv) return;
376 MUTEX_LOCK(&primenv_mutex);
377 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
378 envhv = GvHVn(PL_envgv);
379 /* Perform a dummy fetch as an lval to insure that the hash table is
380 * set up. Otherwise, the hv_store() will turn into a nullop. */
381 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
383 for (i = 0; env_tables[i]; i++) {
384 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
385 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
386 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
388 if (have_sym || have_lnm) {
389 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
390 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
391 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
392 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
395 for (i--; i >= 0; i--) {
396 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
399 for (j = 0; environ[j]; j++) {
400 if (!(start = strchr(environ[j],'='))) {
401 if (ckWARN(WARN_INTERNAL))
402 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
406 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
412 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
413 !str$case_blind_compare(&tmpdsc,&clisym)) {
414 strcpy(cmd,"Show Symbol/Global *");
415 cmddsc.dsc$w_length = 20;
416 if (env_tables[i]->dsc$w_length == 12 &&
417 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
418 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
419 flags = defflags | CLI$M_NOLOGNAM;
422 strcpy(cmd,"Show Logical *");
423 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
424 strcat(cmd," /Table=");
425 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
426 cmddsc.dsc$w_length = strlen(cmd);
428 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
429 flags = defflags | CLI$M_NOCLISYM;
432 /* Create a new subprocess to execute each command, to exclude the
433 * remote possibility that someone could subvert a mbx or file used
434 * to write multiple commands to a single subprocess.
437 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
438 0,&riseandshine,0,0,&clidsc,&clitabdsc);
439 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
440 defflags &= ~CLI$M_TRUSTED;
441 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
443 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
444 if (seenhv) SvREFCNT_dec(seenhv);
447 char *cp1, *cp2, *key;
448 unsigned long int sts, iosb[2], retlen, keylen;
451 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
452 if (sts & 1) sts = iosb[0] & 0xffff;
453 if (sts == SS$_ENDOFFILE) {
455 while (substs == 0) { sys$hiber(); wakect++;}
456 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
461 retlen = iosb[0] >> 16;
462 if (!retlen) continue; /* blank line */
464 if (iosb[1] != subpid) {
466 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
470 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
471 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
473 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
474 if (*cp1 == '(' || /* Logical name table name */
475 *cp1 == '=' /* Next eqv of searchlist */) continue;
476 if (*cp1 == '"') cp1++;
477 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
478 key = cp1; keylen = cp2 - cp1;
479 if (keylen && hv_exists(seenhv,key,keylen)) continue;
480 while (*cp2 && *cp2 != '=') cp2++;
481 while (*cp2 && *cp2 == '=') cp2++;
482 while (*cp2 && *cp2 == ' ') cp2++;
483 if (*cp2 == '"') { /* String translation; may embed "" */
484 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
485 cp2++; cp1--; /* Skip "" surrounding translation */
487 else { /* Numeric translation */
488 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
489 cp1--; /* stop on last non-space char */
491 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
492 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
495 PERL_HASH(hash,key,keylen);
496 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
497 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
499 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
500 /* get the PPFs for this process, not the subprocess */
501 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
502 char eqv[LNM$C_NAMLENGTH+1];
504 for (i = 0; ppfs[i]; i++) {
505 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
506 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
511 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
512 if (buf) Safefree(buf);
513 if (seenhv) SvREFCNT_dec(seenhv);
514 MUTEX_UNLOCK(&primenv_mutex);
517 } /* end of prime_env_iter */
521 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
522 /* Define or delete an element in the same "environment" as
523 * vmstrnenv(). If an element is to be deleted, it's removed from
524 * the first place it's found. If it's to be set, it's set in the
525 * place designated by the first element of the table vector.
526 * Like setenv() returns 0 for success, non-zero on error.
529 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
531 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
532 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
533 unsigned long int retsts, usermode = PSL$C_USER;
534 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
535 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
536 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
537 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
538 $DESCRIPTOR(local,"_LOCAL");
541 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
542 *cp2 = _toupper(*cp1);
543 if (cp1 - lnm > LNM$C_NAMLENGTH) {
544 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
548 lnmdsc.dsc$w_length = cp1 - lnm;
549 if (!tabvec || !*tabvec) tabvec = env_tables;
551 if (!eqv) { /* we're deleting n element */
552 for (curtab = 0; tabvec[curtab]; curtab++) {
553 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
555 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
556 if ((cp1 = strchr(environ[i],'=')) &&
557 !strncmp(environ[i],lnm,cp1 - environ[i])) {
559 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
562 ivenv = 1; retsts = SS$_NOLOGNAM;
564 if (ckWARN(WARN_INTERNAL))
565 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
566 ivenv = 1; retsts = SS$_NOSUCHPGM;
572 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
573 !str$case_blind_compare(&tmpdsc,&clisym)) {
574 unsigned int symtype;
575 if (tabvec[curtab]->dsc$w_length == 12 &&
576 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
577 !str$case_blind_compare(&tmpdsc,&local))
578 symtype = LIB$K_CLI_LOCAL_SYM;
579 else symtype = LIB$K_CLI_GLOBAL_SYM;
580 retsts = lib$delete_symbol(&lnmdsc,&symtype);
581 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
582 if (retsts == LIB$_NOSUCHSYM) continue;
586 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
587 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
588 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
589 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
590 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
594 else { /* we're defining a value */
595 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
597 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
599 if (ckWARN(WARN_INTERNAL))
600 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
601 retsts = SS$_NOSUCHPGM;
605 eqvdsc.dsc$a_pointer = eqv;
606 eqvdsc.dsc$w_length = strlen(eqv);
607 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
608 !str$case_blind_compare(&tmpdsc,&clisym)) {
609 unsigned int symtype;
610 if (tabvec[0]->dsc$w_length == 12 &&
611 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
612 !str$case_blind_compare(&tmpdsc,&local))
613 symtype = LIB$K_CLI_LOCAL_SYM;
614 else symtype = LIB$K_CLI_GLOBAL_SYM;
615 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
618 if (!*eqv) eqvdsc.dsc$w_length = 1;
619 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
620 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
621 if (ckWARN(WARN_MISC)) {
622 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
625 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
631 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
632 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
633 set_errno(EVMSERR); break;
634 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
635 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
636 set_errno(EINVAL); break;
643 set_vaxc_errno(retsts);
644 return (int) retsts || 44; /* retsts should never be 0, but just in case */
647 /* We reset error values on success because Perl does an hv_fetch()
648 * before each hv_store(), and if the thing we're setting didn't
649 * previously exist, we've got a leftover error message. (Of course,
650 * this fails in the face of
651 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
652 * in that the error reported in $! isn't spurious,
653 * but it's right more often than not.)
655 set_errno(0); set_vaxc_errno(retsts);
659 } /* end of vmssetenv() */
662 /*{{{ void my_setenv(char *lnm, char *eqv)*/
663 /* This has to be a function since there's a prototype for it in proto.h */
665 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
667 if (lnm && *lnm && strlen(lnm) == 7) {
670 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
671 if (!strcmp(uplnm,"DEFAULT")) {
672 if (eqv && *eqv) chdir(eqv);
676 (void) vmssetenv(lnm,eqv,NULL);
682 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
683 /* my_crypt - VMS password hashing
684 * my_crypt() provides an interface compatible with the Unix crypt()
685 * C library function, and uses sys$hash_password() to perform VMS
686 * password hashing. The quadword hashed password value is returned
687 * as a NUL-terminated 8 character string. my_crypt() does not change
688 * the case of its string arguments; in order to match the behavior
689 * of LOGINOUT et al., alphabetic characters in both arguments must
690 * be upcased by the caller.
693 my_crypt(const char *textpasswd, const char *usrname)
695 # ifndef UAI$C_PREFERRED_ALGORITHM
696 # define UAI$C_PREFERRED_ALGORITHM 127
698 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
699 unsigned short int salt = 0;
700 unsigned long int sts;
702 unsigned short int dsc$w_length;
703 unsigned char dsc$b_type;
704 unsigned char dsc$b_class;
705 const char * dsc$a_pointer;
706 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
707 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
708 struct itmlst_3 uailst[3] = {
709 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
710 { sizeof salt, UAI$_SALT, &salt, 0},
711 { 0, 0, NULL, NULL}};
714 usrdsc.dsc$w_length = strlen(usrname);
715 usrdsc.dsc$a_pointer = usrname;
716 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
723 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
729 if (sts != RMS$_RNF) return NULL;
732 txtdsc.dsc$w_length = strlen(textpasswd);
733 txtdsc.dsc$a_pointer = textpasswd;
734 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
735 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
738 return (char *) hash;
740 } /* end of my_crypt() */
744 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
745 static char *do_fileify_dirspec(char *, char *, int);
746 static char *do_tovmsspec(char *, char *, int);
748 /*{{{int do_rmdir(char *name)*/
752 char dirfile[NAM$C_MAXRSS+1];
756 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
757 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
758 else retval = kill_file(dirfile);
761 } /* end of do_rmdir */
765 * Delete any file to which user has control access, regardless of whether
766 * delete access is explicitly allowed.
767 * Limitations: User must have write access to parent directory.
768 * Does not block signals or ASTs; if interrupted in midstream
769 * may leave file with an altered ACL.
772 /*{{{int kill_file(char *name)*/
774 kill_file(char *name)
776 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
777 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
778 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
780 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
782 unsigned char myace$b_length;
783 unsigned char myace$b_type;
784 unsigned short int myace$w_flags;
785 unsigned long int myace$l_access;
786 unsigned long int myace$l_ident;
787 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
788 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
789 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
791 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
792 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
793 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
794 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
795 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
796 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
798 /* Expand the input spec using RMS, since the CRTL remove() and
799 * system services won't do this by themselves, so we may miss
800 * a file "hiding" behind a logical name or search list. */
801 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
802 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
803 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
804 /* If not, can changing protections help? */
805 if (vaxc$errno != RMS$_PRV) return -1;
807 /* No, so we get our own UIC to use as a rights identifier,
808 * and the insert an ACE at the head of the ACL which allows us
809 * to delete the file.
811 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
812 fildsc.dsc$w_length = strlen(rspec);
813 fildsc.dsc$a_pointer = rspec;
815 newace.myace$l_ident = oldace.myace$l_ident;
816 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
821 case SS$_NOSUCHOBJECT:
822 set_errno(ENOENT); break;
824 set_errno(ENODEV); break;
826 case SS$_INVFILFOROP:
827 set_errno(EINVAL); break;
829 set_errno(EACCES); break;
833 set_vaxc_errno(aclsts);
836 /* Grab any existing ACEs with this identifier in case we fail */
837 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
838 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
839 || fndsts == SS$_NOMOREACE ) {
840 /* Add the new ACE . . . */
841 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
843 if ((rmsts = remove(name))) {
844 /* We blew it - dir with files in it, no write priv for
845 * parent directory, etc. Put things back the way they were. */
846 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
849 addlst[0].bufadr = &oldace;
850 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
857 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
858 /* We just deleted it, so of course it's not there. Some versions of
859 * VMS seem to return success on the unlock operation anyhow (after all
860 * the unlock is successful), but others don't.
862 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
863 if (aclsts & 1) aclsts = fndsts;
866 set_vaxc_errno(aclsts);
872 } /* end of kill_file() */
876 /*{{{int my_mkdir(char *,Mode_t)*/
878 my_mkdir(char *dir, Mode_t mode)
880 STRLEN dirlen = strlen(dir);
883 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
884 * null file name/type. However, it's commonplace under Unix,
885 * so we'll allow it for a gain in portability.
887 if (dir[dirlen-1] == '/') {
888 char *newdir = savepvn(dir,dirlen-1);
889 int ret = mkdir(newdir,mode);
893 else return mkdir(dir,mode);
894 } /* end of my_mkdir */
899 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
901 static unsigned long int mbxbufsiz;
902 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
907 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
908 * preprocessor consant BUFSIZ from stdio.h as the size of the
911 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
912 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
914 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
916 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
917 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
919 } /* end of create_mbx() */
921 /*{{{ my_popen and my_pclose*/
924 struct pipe_details *next;
925 PerlIO *fp; /* stdio file pointer to pipe mailbox */
926 int pid; /* PID of subprocess */
927 int mode; /* == 'r' if pipe open for reading */
928 int done; /* subprocess has completed */
929 unsigned long int completion; /* termination status of subprocess */
932 struct exit_control_block
934 struct exit_control_block *flink;
935 unsigned long int (*exit_routine)();
936 unsigned long int arg_count;
937 unsigned long int *status_address;
938 unsigned long int exit_status;
941 static struct pipe_details *open_pipes = NULL;
942 static $DESCRIPTOR(nl_desc, "NL:");
943 static int waitpid_asleep = 0;
945 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
946 * to a mbx; that's the caller's responsibility.
948 static unsigned long int
949 pipe_eof(FILE *fp, int immediate)
951 char devnam[NAM$C_MAXRSS+1], *cp;
952 unsigned long int chan, iosb[2], retsts, retsts2;
953 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
956 if (fgetname(fp,devnam,1)) {
957 /* It oughta be a mailbox, so fgetname should give just the device
958 * name, but just in case . . . */
959 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
960 devdsc.dsc$w_length = strlen(devnam);
961 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
962 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
963 iosb,0,0,0,0,0,0,0,0);
964 if (retsts & 1) retsts = iosb[0];
965 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
966 if (retsts & 1) retsts = retsts2;
970 else _ckvmssts(vaxc$errno); /* Should never happen */
971 return (unsigned long int) vaxc$errno;
974 static unsigned long int
977 struct pipe_details *info;
978 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
983 first we try sending an EOF...ignore if doesn't work, make sure we
990 if (info->mode != 'r' && !info->done) {
991 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
995 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1000 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1001 sts = sys$forcex(&info->pid,0,&abort);
1002 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1007 if (did_stuff) sleep(1); /* wait for them to respond */
1011 if (!info->done) { /* We tried to be nice . . . */
1012 sts = sys$delprc(&info->pid,0);
1013 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1014 info->done = 1; /* so my_pclose doesn't try to write EOF */
1020 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1021 else if (!(sts & 1)) retsts = sts;
1026 static struct exit_control_block pipe_exitblock =
1027 {(struct exit_control_block *) 0,
1028 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1032 popen_completion_ast(struct pipe_details *thispipe)
1034 thispipe->done = TRUE;
1035 if (waitpid_asleep) {
1041 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1042 static void vms_execfree();
1045 safe_popen(char *cmd, char *mode)
1047 static int handler_set_up = FALSE;
1049 unsigned short int chan;
1050 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1052 struct pipe_details *info;
1053 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1054 DSC$K_CLASS_S, mbxname},
1055 cmddsc = {0, DSC$K_DTYPE_T,
1059 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1060 New(1301,info,1,struct pipe_details);
1062 /* create mailbox */
1063 create_mbx(&chan,&namdsc);
1065 /* open a FILE* onto it */
1066 info->fp = PerlIO_open(mbxname, mode);
1068 /* give up other channel onto it */
1069 _ckvmssts(sys$dassgn(chan));
1079 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1080 0 /* name */, &info->pid, &info->completion,
1081 0, popen_completion_ast,info,0,0,0));
1084 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1085 0 /* name */, &info->pid, &info->completion,
1086 0, popen_completion_ast,info,0,0,0));
1090 if (!handler_set_up) {
1091 _ckvmssts(sys$dclexh(&pipe_exitblock));
1092 handler_set_up = TRUE;
1094 info->next=open_pipes; /* prepend to list */
1097 PL_forkprocess = info->pid;
1099 } /* end of safe_popen */
1102 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1104 Perl_my_popen(pTHX_ char *cmd, char *mode)
1107 TAINT_PROPER("popen");
1108 PERL_FLUSHALL_FOR_CHILD;
1109 return safe_popen(cmd,mode);
1114 /*{{{ I32 my_pclose(FILE *fp)*/
1115 I32 Perl_my_pclose(pTHX_ FILE *fp)
1117 struct pipe_details *info, *last = NULL;
1118 unsigned long int retsts;
1120 for (info = open_pipes; info != NULL; last = info, info = info->next)
1121 if (info->fp == fp) break;
1123 if (info == NULL) { /* no such pipe open */
1124 set_errno(ECHILD); /* quoth POSIX */
1125 set_vaxc_errno(SS$_NONEXPR);
1129 /* If we were writing to a subprocess, insure that someone reading from
1130 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1131 * produce an EOF record in the mailbox. */
1132 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,1);
1133 PerlIO_close(info->fp);
1135 if (info->done) retsts = info->completion;
1136 else waitpid(info->pid,(int *) &retsts,0);
1138 /* remove from list of open pipes */
1139 if (last) last->next = info->next;
1140 else open_pipes = info->next;
1145 } /* end of my_pclose() */
1147 /* sort-of waitpid; use only with popen() */
1148 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1150 my_waitpid(Pid_t pid, int *statusp, int flags)
1152 struct pipe_details *info;
1155 for (info = open_pipes; info != NULL; info = info->next)
1156 if (info->pid == pid) break;
1158 if (info != NULL) { /* we know about this child */
1159 while (!info->done) {
1164 *statusp = info->completion;
1167 else { /* we haven't heard of this child */
1168 $DESCRIPTOR(intdsc,"0 00:00:01");
1169 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1170 unsigned long int interval[2],sts;
1172 if (ckWARN(WARN_EXEC)) {
1173 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1174 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1175 if (ownerpid != mypid)
1176 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1179 _ckvmssts(sys$bintim(&intdsc,interval));
1180 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1181 _ckvmssts(sys$schdwk(0,0,interval,0));
1182 _ckvmssts(sys$hiber());
1186 /* There's no easy way to find the termination status a child we're
1187 * not aware of beforehand. If we're really interested in the future,
1188 * we can go looking for a termination mailbox, or chase after the
1189 * accounting record for the process.
1195 } /* end of waitpid() */
1200 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1202 my_gconvert(double val, int ndig, int trail, char *buf)
1204 static char __gcvtbuf[DBL_DIG+1];
1207 loc = buf ? buf : __gcvtbuf;
1209 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1211 sprintf(loc,"%.*g",ndig,val);
1217 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1218 return gcvt(val,ndig,loc);
1221 loc[0] = '0'; loc[1] = '\0';
1229 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1230 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1231 * to expand file specification. Allows for a single default file
1232 * specification and a simple mask of options. If outbuf is non-NULL,
1233 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1234 * the resultant file specification is placed. If outbuf is NULL, the
1235 * resultant file specification is placed into a static buffer.
1236 * The third argument, if non-NULL, is taken to be a default file
1237 * specification string. The fourth argument is unused at present.
1238 * rmesexpand() returns the address of the resultant string if
1239 * successful, and NULL on error.
1241 static char *do_tounixspec(char *, char *, int);
1244 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1246 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1247 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1248 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1249 struct FAB myfab = cc$rms_fab;
1250 struct NAM mynam = cc$rms_nam;
1252 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1254 if (!filespec || !*filespec) {
1255 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1259 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1260 else outbuf = __rmsexpand_retbuf;
1262 if ((isunix = (strchr(filespec,'/') != NULL))) {
1263 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1264 filespec = vmsfspec;
1267 myfab.fab$l_fna = filespec;
1268 myfab.fab$b_fns = strlen(filespec);
1269 myfab.fab$l_nam = &mynam;
1271 if (defspec && *defspec) {
1272 if (strchr(defspec,'/') != NULL) {
1273 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1276 myfab.fab$l_dna = defspec;
1277 myfab.fab$b_dns = strlen(defspec);
1280 mynam.nam$l_esa = esa;
1281 mynam.nam$b_ess = sizeof esa;
1282 mynam.nam$l_rsa = outbuf;
1283 mynam.nam$b_rss = NAM$C_MAXRSS;
1285 retsts = sys$parse(&myfab,0,0);
1286 if (!(retsts & 1)) {
1287 mynam.nam$b_nop |= NAM$M_SYNCHK;
1288 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1289 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1290 retsts = sys$parse(&myfab,0,0);
1291 if (retsts & 1) goto expanded;
1293 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1294 (void) sys$parse(&myfab,0,0); /* Free search context */
1295 if (out) Safefree(out);
1296 set_vaxc_errno(retsts);
1297 if (retsts == RMS$_PRV) set_errno(EACCES);
1298 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1299 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1300 else set_errno(EVMSERR);
1303 retsts = sys$search(&myfab,0,0);
1304 if (!(retsts & 1) && retsts != RMS$_FNF) {
1305 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1306 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1307 if (out) Safefree(out);
1308 set_vaxc_errno(retsts);
1309 if (retsts == RMS$_PRV) set_errno(EACCES);
1310 else set_errno(EVMSERR);
1314 /* If the input filespec contained any lowercase characters,
1315 * downcase the result for compatibility with Unix-minded code. */
1317 for (out = myfab.fab$l_fna; *out; out++)
1318 if (islower(*out)) { haslower = 1; break; }
1319 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1320 else { out = esa; speclen = mynam.nam$b_esl; }
1321 /* Trim off null fields added by $PARSE
1322 * If type > 1 char, must have been specified in original or default spec
1323 * (not true for version; $SEARCH may have added version of existing file).
1325 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1326 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1327 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1328 if (trimver || trimtype) {
1329 if (defspec && *defspec) {
1330 char defesa[NAM$C_MAXRSS];
1331 struct FAB deffab = cc$rms_fab;
1332 struct NAM defnam = cc$rms_nam;
1334 deffab.fab$l_nam = &defnam;
1335 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1336 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1337 defnam.nam$b_nop = NAM$M_SYNCHK;
1338 if (sys$parse(&deffab,0,0) & 1) {
1339 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1340 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1343 if (trimver) speclen = mynam.nam$l_ver - out;
1345 /* If we didn't already trim version, copy down */
1346 if (speclen > mynam.nam$l_ver - out)
1347 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1348 speclen - (mynam.nam$l_ver - out));
1349 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1352 /* If we just had a directory spec on input, $PARSE "helpfully"
1353 * adds an empty name and type for us */
1354 if (mynam.nam$l_name == mynam.nam$l_type &&
1355 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1356 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1357 speclen = mynam.nam$l_name - out;
1358 out[speclen] = '\0';
1359 if (haslower) __mystrtolower(out);
1361 /* Have we been working with an expanded, but not resultant, spec? */
1362 /* Also, convert back to Unix syntax if necessary. */
1363 if (!mynam.nam$b_rsl) {
1365 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1367 else strcpy(outbuf,esa);
1370 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1371 strcpy(outbuf,tmpfspec);
1373 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1374 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1375 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1379 /* External entry points */
1380 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1381 { return do_rmsexpand(spec,buf,0,def,opt); }
1382 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1383 { return do_rmsexpand(spec,buf,1,def,opt); }
1387 ** The following routines are provided to make life easier when
1388 ** converting among VMS-style and Unix-style directory specifications.
1389 ** All will take input specifications in either VMS or Unix syntax. On
1390 ** failure, all return NULL. If successful, the routines listed below
1391 ** return a pointer to a buffer containing the appropriately
1392 ** reformatted spec (and, therefore, subsequent calls to that routine
1393 ** will clobber the result), while the routines of the same names with
1394 ** a _ts suffix appended will return a pointer to a mallocd string
1395 ** containing the appropriately reformatted spec.
1396 ** In all cases, only explicit syntax is altered; no check is made that
1397 ** the resulting string is valid or that the directory in question
1400 ** fileify_dirspec() - convert a directory spec into the name of the
1401 ** directory file (i.e. what you can stat() to see if it's a dir).
1402 ** The style (VMS or Unix) of the result is the same as the style
1403 ** of the parameter passed in.
1404 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1405 ** what you prepend to a filename to indicate what directory it's in).
1406 ** The style (VMS or Unix) of the result is the same as the style
1407 ** of the parameter passed in.
1408 ** tounixpath() - convert a directory spec into a Unix-style path.
1409 ** tovmspath() - convert a directory spec into a VMS-style path.
1410 ** tounixspec() - convert any file spec into a Unix-style file spec.
1411 ** tovmsspec() - convert any file spec into a VMS-style spec.
1413 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1414 ** Permission is given to distribute this code as part of the Perl
1415 ** standard distribution under the terms of the GNU General Public
1416 ** License or the Perl Artistic License. Copies of each may be
1417 ** found in the Perl standard distribution.
1420 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1421 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1423 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1424 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1425 char *retspec, *cp1, *cp2, *lastdir;
1426 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1428 if (!dir || !*dir) {
1429 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1431 dirlen = strlen(dir);
1432 while (dir[dirlen-1] == '/') --dirlen;
1433 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1434 strcpy(trndir,"/sys$disk/000000");
1438 if (dirlen > NAM$C_MAXRSS) {
1439 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1441 if (!strpbrk(dir+1,"/]>:")) {
1442 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1443 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1445 dirlen = strlen(dir);
1448 strncpy(trndir,dir,dirlen);
1449 trndir[dirlen] = '\0';
1452 /* If we were handed a rooted logical name or spec, treat it like a
1453 * simple directory, so that
1454 * $ Define myroot dev:[dir.]
1455 * ... do_fileify_dirspec("myroot",buf,1) ...
1456 * does something useful.
1458 if (!strcmp(dir+dirlen-2,".]")) {
1459 dir[--dirlen] = '\0';
1460 dir[dirlen-1] = ']';
1463 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1464 /* If we've got an explicit filename, we can just shuffle the string. */
1465 if (*(cp1+1)) hasfilename = 1;
1466 /* Similarly, we can just back up a level if we've got multiple levels
1467 of explicit directories in a VMS spec which ends with directories. */
1469 for (cp2 = cp1; cp2 > dir; cp2--) {
1471 *cp2 = *cp1; *cp1 = '\0';
1475 if (*cp2 == '[' || *cp2 == '<') break;
1480 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1481 if (dir[0] == '.') {
1482 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1483 return do_fileify_dirspec("[]",buf,ts);
1484 else if (dir[1] == '.' &&
1485 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1486 return do_fileify_dirspec("[-]",buf,ts);
1488 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1489 dirlen -= 1; /* to last element */
1490 lastdir = strrchr(dir,'/');
1492 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1493 /* If we have "/." or "/..", VMSify it and let the VMS code
1494 * below expand it, rather than repeating the code to handle
1495 * relative components of a filespec here */
1497 if (*(cp1+2) == '.') cp1++;
1498 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1499 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1500 if (strchr(vmsdir,'/') != NULL) {
1501 /* If do_tovmsspec() returned it, it must have VMS syntax
1502 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1503 * the time to check this here only so we avoid a recursion
1504 * loop; otherwise, gigo.
1506 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1508 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1509 return do_tounixspec(trndir,buf,ts);
1512 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1513 lastdir = strrchr(dir,'/');
1515 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1516 /* Ditto for specs that end in an MFD -- let the VMS code
1517 * figure out whether it's a real device or a rooted logical. */
1518 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1519 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1520 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1521 return do_tounixspec(trndir,buf,ts);
1524 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1525 !(lastdir = cp1 = strrchr(dir,']')) &&
1526 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1527 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1529 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1530 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1531 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1532 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1533 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1534 (ver || *cp3)))))) {
1536 set_vaxc_errno(RMS$_DIR);
1542 /* If we lead off with a device or rooted logical, add the MFD
1543 if we're specifying a top-level directory. */
1544 if (lastdir && *dir == '/') {
1546 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1553 retlen = dirlen + (addmfd ? 13 : 6);
1554 if (buf) retspec = buf;
1555 else if (ts) New(1309,retspec,retlen+1,char);
1556 else retspec = __fileify_retbuf;
1558 dirlen = lastdir - dir;
1559 memcpy(retspec,dir,dirlen);
1560 strcpy(&retspec[dirlen],"/000000");
1561 strcpy(&retspec[dirlen+7],lastdir);
1564 memcpy(retspec,dir,dirlen);
1565 retspec[dirlen] = '\0';
1567 /* We've picked up everything up to the directory file name.
1568 Now just add the type and version, and we're set. */
1569 strcat(retspec,".dir;1");
1572 else { /* VMS-style directory spec */
1573 char esa[NAM$C_MAXRSS+1], term, *cp;
1574 unsigned long int sts, cmplen, haslower = 0;
1575 struct FAB dirfab = cc$rms_fab;
1576 struct NAM savnam, dirnam = cc$rms_nam;
1578 dirfab.fab$b_fns = strlen(dir);
1579 dirfab.fab$l_fna = dir;
1580 dirfab.fab$l_nam = &dirnam;
1581 dirfab.fab$l_dna = ".DIR;1";
1582 dirfab.fab$b_dns = 6;
1583 dirnam.nam$b_ess = NAM$C_MAXRSS;
1584 dirnam.nam$l_esa = esa;
1586 for (cp = dir; *cp; cp++)
1587 if (islower(*cp)) { haslower = 1; break; }
1588 if (!((sts = sys$parse(&dirfab))&1)) {
1589 if (dirfab.fab$l_sts == RMS$_DIR) {
1590 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1591 sts = sys$parse(&dirfab) & 1;
1595 set_vaxc_errno(dirfab.fab$l_sts);
1601 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1602 /* Yes; fake the fnb bits so we'll check type below */
1603 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1605 else { /* No; just work with potential name */
1606 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1608 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1609 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1610 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1615 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1616 cp1 = strchr(esa,']');
1617 if (!cp1) cp1 = strchr(esa,'>');
1618 if (cp1) { /* Should always be true */
1619 dirnam.nam$b_esl -= cp1 - esa - 1;
1620 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1623 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1624 /* Yep; check version while we're at it, if it's there. */
1625 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1626 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1627 /* Something other than .DIR[;1]. Bzzt. */
1628 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1629 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1631 set_vaxc_errno(RMS$_DIR);
1635 esa[dirnam.nam$b_esl] = '\0';
1636 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1637 /* They provided at least the name; we added the type, if necessary, */
1638 if (buf) retspec = buf; /* in sys$parse() */
1639 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1640 else retspec = __fileify_retbuf;
1641 strcpy(retspec,esa);
1642 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1643 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1646 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1647 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1649 dirnam.nam$b_esl -= 9;
1651 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1652 if (cp1 == NULL) { /* should never happen */
1653 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1654 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1659 retlen = strlen(esa);
1660 if ((cp1 = strrchr(esa,'.')) != NULL) {
1661 /* There's more than one directory in the path. Just roll back. */
1663 if (buf) retspec = buf;
1664 else if (ts) New(1311,retspec,retlen+7,char);
1665 else retspec = __fileify_retbuf;
1666 strcpy(retspec,esa);
1669 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1670 /* Go back and expand rooted logical name */
1671 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1672 if (!(sys$parse(&dirfab) & 1)) {
1673 dirnam.nam$l_rlf = NULL;
1674 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1676 set_vaxc_errno(dirfab.fab$l_sts);
1679 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1680 if (buf) retspec = buf;
1681 else if (ts) New(1312,retspec,retlen+16,char);
1682 else retspec = __fileify_retbuf;
1683 cp1 = strstr(esa,"][");
1685 memcpy(retspec,esa,dirlen);
1686 if (!strncmp(cp1+2,"000000]",7)) {
1687 retspec[dirlen-1] = '\0';
1688 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1689 if (*cp1 == '.') *cp1 = ']';
1691 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1692 memcpy(cp1+1,"000000]",7);
1696 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1697 retspec[retlen] = '\0';
1698 /* Convert last '.' to ']' */
1699 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1700 if (*cp1 == '.') *cp1 = ']';
1702 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1703 memcpy(cp1+1,"000000]",7);
1707 else { /* This is a top-level dir. Add the MFD to the path. */
1708 if (buf) retspec = buf;
1709 else if (ts) New(1312,retspec,retlen+16,char);
1710 else retspec = __fileify_retbuf;
1713 while (*cp1 != ':') *(cp2++) = *(cp1++);
1714 strcpy(cp2,":[000000]");
1719 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1720 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1721 /* We've set up the string up through the filename. Add the
1722 type and version, and we're done. */
1723 strcat(retspec,".DIR;1");
1725 /* $PARSE may have upcased filespec, so convert output to lower
1726 * case if input contained any lowercase characters. */
1727 if (haslower) __mystrtolower(retspec);
1730 } /* end of do_fileify_dirspec() */
1732 /* External entry points */
1733 char *fileify_dirspec(char *dir, char *buf)
1734 { return do_fileify_dirspec(dir,buf,0); }
1735 char *fileify_dirspec_ts(char *dir, char *buf)
1736 { return do_fileify_dirspec(dir,buf,1); }
1738 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1739 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1741 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1742 unsigned long int retlen;
1743 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1745 if (!dir || !*dir) {
1746 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1749 if (*dir) strcpy(trndir,dir);
1750 else getcwd(trndir,sizeof trndir - 1);
1752 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1753 && my_trnlnm(trndir,trndir,0)) {
1754 STRLEN trnlen = strlen(trndir);
1756 /* Trap simple rooted lnms, and return lnm:[000000] */
1757 if (!strcmp(trndir+trnlen-2,".]")) {
1758 if (buf) retpath = buf;
1759 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1760 else retpath = __pathify_retbuf;
1761 strcpy(retpath,dir);
1762 strcat(retpath,":[000000]");
1768 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1769 if (*dir == '.' && (*(dir+1) == '\0' ||
1770 (*(dir+1) == '.' && *(dir+2) == '\0')))
1771 retlen = 2 + (*(dir+1) != '\0');
1773 if ( !(cp1 = strrchr(dir,'/')) &&
1774 !(cp1 = strrchr(dir,']')) &&
1775 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1776 if ((cp2 = strchr(cp1,'.')) != NULL &&
1777 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1778 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1779 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1780 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1782 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1783 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1784 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1785 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1786 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1787 (ver || *cp3)))))) {
1789 set_vaxc_errno(RMS$_DIR);
1792 retlen = cp2 - dir + 1;
1794 else { /* No file type present. Treat the filename as a directory. */
1795 retlen = strlen(dir) + 1;
1798 if (buf) retpath = buf;
1799 else if (ts) New(1313,retpath,retlen+1,char);
1800 else retpath = __pathify_retbuf;
1801 strncpy(retpath,dir,retlen-1);
1802 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1803 retpath[retlen-1] = '/'; /* with '/', add it. */
1804 retpath[retlen] = '\0';
1806 else retpath[retlen-1] = '\0';
1808 else { /* VMS-style directory spec */
1809 char esa[NAM$C_MAXRSS+1], *cp;
1810 unsigned long int sts, cmplen, haslower;
1811 struct FAB dirfab = cc$rms_fab;
1812 struct NAM savnam, dirnam = cc$rms_nam;
1814 /* If we've got an explicit filename, we can just shuffle the string. */
1815 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1816 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1817 if ((cp2 = strchr(cp1,'.')) != NULL) {
1819 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1820 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1821 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1822 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1823 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1824 (ver || *cp3)))))) {
1826 set_vaxc_errno(RMS$_DIR);
1830 else { /* No file type, so just draw name into directory part */
1831 for (cp2 = cp1; *cp2; cp2++) ;
1834 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1836 /* We've now got a VMS 'path'; fall through */
1838 dirfab.fab$b_fns = strlen(dir);
1839 dirfab.fab$l_fna = dir;
1840 if (dir[dirfab.fab$b_fns-1] == ']' ||
1841 dir[dirfab.fab$b_fns-1] == '>' ||
1842 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1843 if (buf) retpath = buf;
1844 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1845 else retpath = __pathify_retbuf;
1846 strcpy(retpath,dir);
1849 dirfab.fab$l_dna = ".DIR;1";
1850 dirfab.fab$b_dns = 6;
1851 dirfab.fab$l_nam = &dirnam;
1852 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1853 dirnam.nam$l_esa = esa;
1855 for (cp = dir; *cp; cp++)
1856 if (islower(*cp)) { haslower = 1; break; }
1858 if (!(sts = (sys$parse(&dirfab)&1))) {
1859 if (dirfab.fab$l_sts == RMS$_DIR) {
1860 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1861 sts = sys$parse(&dirfab) & 1;
1865 set_vaxc_errno(dirfab.fab$l_sts);
1871 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1872 if (dirfab.fab$l_sts != RMS$_FNF) {
1873 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1874 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1876 set_vaxc_errno(dirfab.fab$l_sts);
1879 dirnam = savnam; /* No; just work with potential name */
1882 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1883 /* Yep; check version while we're at it, if it's there. */
1884 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1885 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1886 /* Something other than .DIR[;1]. Bzzt. */
1887 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1888 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1890 set_vaxc_errno(RMS$_DIR);
1894 /* OK, the type was fine. Now pull any file name into the
1896 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1898 cp1 = strrchr(esa,'>');
1899 *dirnam.nam$l_type = '>';
1902 *(dirnam.nam$l_type + 1) = '\0';
1903 retlen = dirnam.nam$l_type - esa + 2;
1904 if (buf) retpath = buf;
1905 else if (ts) New(1314,retpath,retlen,char);
1906 else retpath = __pathify_retbuf;
1907 strcpy(retpath,esa);
1908 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1909 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1910 /* $PARSE may have upcased filespec, so convert output to lower
1911 * case if input contained any lowercase characters. */
1912 if (haslower) __mystrtolower(retpath);
1916 } /* end of do_pathify_dirspec() */
1918 /* External entry points */
1919 char *pathify_dirspec(char *dir, char *buf)
1920 { return do_pathify_dirspec(dir,buf,0); }
1921 char *pathify_dirspec_ts(char *dir, char *buf)
1922 { return do_pathify_dirspec(dir,buf,1); }
1924 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1925 static char *do_tounixspec(char *spec, char *buf, int ts)
1927 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1928 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1929 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1931 if (spec == NULL) return NULL;
1932 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1933 if (buf) rslt = buf;
1935 retlen = strlen(spec);
1936 cp1 = strchr(spec,'[');
1937 if (!cp1) cp1 = strchr(spec,'<');
1939 for (cp1++; *cp1; cp1++) {
1940 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1941 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1942 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1945 New(1315,rslt,retlen+2+2*expand,char);
1947 else rslt = __tounixspec_retbuf;
1948 if (strchr(spec,'/') != NULL) {
1955 dirend = strrchr(spec,']');
1956 if (dirend == NULL) dirend = strrchr(spec,'>');
1957 if (dirend == NULL) dirend = strchr(spec,':');
1958 if (dirend == NULL) {
1962 if (*cp2 != '[' && *cp2 != '<') {
1965 else { /* the VMS spec begins with directories */
1967 if (*cp2 == ']' || *cp2 == '>') {
1968 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1971 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1972 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1973 if (ts) Safefree(rslt);
1978 while (*cp3 != ':' && *cp3) cp3++;
1980 if (strchr(cp3,']') != NULL) break;
1981 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1983 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1984 retlen = devlen + dirlen;
1985 Renew(rslt,retlen+1+2*expand,char);
1991 *(cp1++) = *(cp3++);
1992 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1996 else if ( *cp2 == '.') {
1997 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1998 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2004 for (; cp2 <= dirend; cp2++) {
2007 if (*(cp2+1) == '[') cp2++;
2009 else if (*cp2 == ']' || *cp2 == '>') {
2010 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2012 else if (*cp2 == '.') {
2014 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2015 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2016 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2017 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2018 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2020 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2021 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2025 else if (*cp2 == '-') {
2026 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2027 while (*cp2 == '-') {
2029 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2031 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2032 if (ts) Safefree(rslt); /* filespecs like */
2033 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2037 else *(cp1++) = *cp2;
2039 else *(cp1++) = *cp2;
2041 while (*cp2) *(cp1++) = *(cp2++);
2046 } /* end of do_tounixspec() */
2048 /* External entry points */
2049 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2050 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2052 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2053 static char *do_tovmsspec(char *path, char *buf, int ts) {
2054 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2055 char *rslt, *dirend;
2056 register char *cp1, *cp2;
2057 unsigned long int infront = 0, hasdir = 1;
2059 if (path == NULL) return NULL;
2060 if (buf) rslt = buf;
2061 else if (ts) New(1316,rslt,strlen(path)+9,char);
2062 else rslt = __tovmsspec_retbuf;
2063 if (strpbrk(path,"]:>") ||
2064 (dirend = strrchr(path,'/')) == NULL) {
2065 if (path[0] == '.') {
2066 if (path[1] == '\0') strcpy(rslt,"[]");
2067 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2068 else strcpy(rslt,path); /* probably garbage */
2070 else strcpy(rslt,path);
2073 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2074 if (!*(dirend+2)) dirend +=2;
2075 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2076 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2081 char trndev[NAM$C_MAXRSS+1];
2085 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2087 if (!buf & ts) Renew(rslt,18,char);
2088 strcpy(rslt,"sys$disk:[000000]");
2091 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2093 islnm = my_trnlnm(rslt,trndev,0);
2094 trnend = islnm ? strlen(trndev) - 1 : 0;
2095 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2096 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2097 /* If the first element of the path is a logical name, determine
2098 * whether it has to be translated so we can add more directories. */
2099 if (!islnm || rooted) {
2102 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2106 if (cp2 != dirend) {
2107 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2108 strcpy(rslt,trndev);
2109 cp1 = rslt + trnend;
2122 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2123 cp2 += 2; /* skip over "./" - it's redundant */
2124 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2126 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2127 *(cp1++) = '-'; /* "../" --> "-" */
2130 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2131 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2132 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2133 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2136 if (cp2 > dirend) cp2 = dirend;
2138 else *(cp1++) = '.';
2140 for (; cp2 < dirend; cp2++) {
2142 if (*(cp2-1) == '/') continue;
2143 if (*(cp1-1) != '.') *(cp1++) = '.';
2146 else if (!infront && *cp2 == '.') {
2147 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2148 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2149 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
2150 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-';
2151 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2153 /* if (*(cp1-1) != '.') *(cp1++) = '.'; */
2157 if (cp2 == dirend) break;
2159 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2160 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2161 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2162 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2164 *(cp1++) = '.'; /* Simulate trailing '/' */
2165 cp2 += 2; /* for loop will incr this to == dirend */
2167 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2169 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2172 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2173 if (*cp2 == '.') *(cp1++) = '_';
2174 else *(cp1++) = *cp2;
2178 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2179 if (hasdir) *(cp1++) = ']';
2180 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2181 while (*cp2) *(cp1++) = *(cp2++);
2186 } /* end of do_tovmsspec() */
2188 /* External entry points */
2189 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2190 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2192 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2193 static char *do_tovmspath(char *path, char *buf, int ts) {
2194 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2196 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2198 if (path == NULL) return NULL;
2199 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2200 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2201 if (buf) return buf;
2203 vmslen = strlen(vmsified);
2204 New(1317,cp,vmslen+1,char);
2205 memcpy(cp,vmsified,vmslen);
2210 strcpy(__tovmspath_retbuf,vmsified);
2211 return __tovmspath_retbuf;
2214 } /* end of do_tovmspath() */
2216 /* External entry points */
2217 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2218 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2221 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2222 static char *do_tounixpath(char *path, char *buf, int ts) {
2223 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2225 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2227 if (path == NULL) return NULL;
2228 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2229 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2230 if (buf) return buf;
2232 unixlen = strlen(unixified);
2233 New(1317,cp,unixlen+1,char);
2234 memcpy(cp,unixified,unixlen);
2239 strcpy(__tounixpath_retbuf,unixified);
2240 return __tounixpath_retbuf;
2243 } /* end of do_tounixpath() */
2245 /* External entry points */
2246 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2247 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2250 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2252 *****************************************************************************
2254 * Copyright (C) 1989-1994 by *
2255 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2257 * Permission is hereby granted for the reproduction of this software, *
2258 * on condition that this copyright notice is included in the reproduction, *
2259 * and that such reproduction is not for purposes of profit or material *
2262 * 27-Aug-1994 Modified for inclusion in perl5 *
2263 * by Charles Bailey bailey@newman.upenn.edu *
2264 *****************************************************************************
2268 * getredirection() is intended to aid in porting C programs
2269 * to VMS (Vax-11 C). The native VMS environment does not support
2270 * '>' and '<' I/O redirection, or command line wild card expansion,
2271 * or a command line pipe mechanism using the '|' AND background
2272 * command execution '&'. All of these capabilities are provided to any
2273 * C program which calls this procedure as the first thing in the
2275 * The piping mechanism will probably work with almost any 'filter' type
2276 * of program. With suitable modification, it may useful for other
2277 * portability problems as well.
2279 * Author: Mark Pizzolato mark@infocomm.com
2283 struct list_item *next;
2287 static void add_item(struct list_item **head,
2288 struct list_item **tail,
2292 static void expand_wild_cards(char *item,
2293 struct list_item **head,
2294 struct list_item **tail,
2297 static int background_process(int argc, char **argv);
2299 static void pipe_and_fork(char **cmargv);
2301 /*{{{ void getredirection(int *ac, char ***av)*/
2303 getredirection(int *ac, char ***av)
2305 * Process vms redirection arg's. Exit if any error is seen.
2306 * If getredirection() processes an argument, it is erased
2307 * from the vector. getredirection() returns a new argc and argv value.
2308 * In the event that a background command is requested (by a trailing "&"),
2309 * this routine creates a background subprocess, and simply exits the program.
2311 * Warning: do not try to simplify the code for vms. The code
2312 * presupposes that getredirection() is called before any data is
2313 * read from stdin or written to stdout.
2315 * Normal usage is as follows:
2321 * getredirection(&argc, &argv);
2325 int argc = *ac; /* Argument Count */
2326 char **argv = *av; /* Argument Vector */
2327 char *ap; /* Argument pointer */
2328 int j; /* argv[] index */
2329 int item_count = 0; /* Count of Items in List */
2330 struct list_item *list_head = 0; /* First Item in List */
2331 struct list_item *list_tail; /* Last Item in List */
2332 char *in = NULL; /* Input File Name */
2333 char *out = NULL; /* Output File Name */
2334 char *outmode = "w"; /* Mode to Open Output File */
2335 char *err = NULL; /* Error File Name */
2336 char *errmode = "w"; /* Mode to Open Error File */
2337 int cmargc = 0; /* Piped Command Arg Count */
2338 char **cmargv = NULL;/* Piped Command Arg Vector */
2341 * First handle the case where the last thing on the line ends with
2342 * a '&'. This indicates the desire for the command to be run in a
2343 * subprocess, so we satisfy that desire.
2346 if (0 == strcmp("&", ap))
2347 exit(background_process(--argc, argv));
2348 if (*ap && '&' == ap[strlen(ap)-1])
2350 ap[strlen(ap)-1] = '\0';
2351 exit(background_process(argc, argv));
2354 * Now we handle the general redirection cases that involve '>', '>>',
2355 * '<', and pipes '|'.
2357 for (j = 0; j < argc; ++j)
2359 if (0 == strcmp("<", argv[j]))
2363 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2364 exit(LIB$_WRONUMARG);
2369 if ('<' == *(ap = argv[j]))
2374 if (0 == strcmp(">", ap))
2378 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2379 exit(LIB$_WRONUMARG);
2398 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2399 exit(LIB$_WRONUMARG);
2403 if (('2' == *ap) && ('>' == ap[1]))
2420 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2421 exit(LIB$_WRONUMARG);
2425 if (0 == strcmp("|", argv[j]))
2429 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2430 exit(LIB$_WRONUMARG);
2432 cmargc = argc-(j+1);
2433 cmargv = &argv[j+1];
2437 if ('|' == *(ap = argv[j]))
2445 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2448 * Allocate and fill in the new argument vector, Some Unix's terminate
2449 * the list with an extra null pointer.
2451 New(1302, argv, item_count+1, char *);
2453 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2454 argv[j] = list_head->value;
2460 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2461 exit(LIB$_INVARGORD);
2463 pipe_and_fork(cmargv);
2466 /* Check for input from a pipe (mailbox) */
2468 if (in == NULL && 1 == isapipe(0))
2470 char mbxname[L_tmpnam];
2472 long int dvi_item = DVI$_DEVBUFSIZ;
2473 $DESCRIPTOR(mbxnam, "");
2474 $DESCRIPTOR(mbxdevnam, "");
2476 /* Input from a pipe, reopen it in binary mode to disable */
2477 /* carriage control processing. */
2479 PerlIO_getname(stdin, mbxname);
2480 mbxnam.dsc$a_pointer = mbxname;
2481 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2482 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2483 mbxdevnam.dsc$a_pointer = mbxname;
2484 mbxdevnam.dsc$w_length = sizeof(mbxname);
2485 dvi_item = DVI$_DEVNAM;
2486 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2487 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2490 freopen(mbxname, "rb", stdin);
2493 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2497 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2499 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2502 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2504 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2509 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2511 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2515 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2520 #ifdef ARGPROC_DEBUG
2521 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2522 for (j = 0; j < *ac; ++j)
2523 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2525 /* Clear errors we may have hit expanding wildcards, so they don't
2526 show up in Perl's $! later */
2527 set_errno(0); set_vaxc_errno(1);
2528 } /* end of getredirection() */
2531 static void add_item(struct list_item **head,
2532 struct list_item **tail,
2538 New(1303,*head,1,struct list_item);
2542 New(1304,(*tail)->next,1,struct list_item);
2543 *tail = (*tail)->next;
2545 (*tail)->value = value;
2549 static void expand_wild_cards(char *item,
2550 struct list_item **head,
2551 struct list_item **tail,
2555 unsigned long int context = 0;
2561 char vmsspec[NAM$C_MAXRSS+1];
2562 $DESCRIPTOR(filespec, "");
2563 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2564 $DESCRIPTOR(resultspec, "");
2565 unsigned long int zero = 0, sts;
2567 for (cp = item; *cp; cp++) {
2568 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2569 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2571 if (!*cp || isspace(*cp))
2573 add_item(head, tail, item, count);
2576 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2577 resultspec.dsc$b_class = DSC$K_CLASS_D;
2578 resultspec.dsc$a_pointer = NULL;
2579 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2580 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2581 if (!isunix || !filespec.dsc$a_pointer)
2582 filespec.dsc$a_pointer = item;
2583 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2585 * Only return version specs, if the caller specified a version
2587 had_version = strchr(item, ';');
2589 * Only return device and directory specs, if the caller specifed either.
2591 had_device = strchr(item, ':');
2592 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2594 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2595 &defaultspec, 0, 0, &zero))))
2600 New(1305,string,resultspec.dsc$w_length+1,char);
2601 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2602 string[resultspec.dsc$w_length] = '\0';
2603 if (NULL == had_version)
2604 *((char *)strrchr(string, ';')) = '\0';
2605 if ((!had_directory) && (had_device == NULL))
2607 if (NULL == (devdir = strrchr(string, ']')))
2608 devdir = strrchr(string, '>');
2609 strcpy(string, devdir + 1);
2612 * Be consistent with what the C RTL has already done to the rest of
2613 * the argv items and lowercase all of these names.
2615 for (c = string; *c; ++c)
2618 if (isunix) trim_unixpath(string,item,1);
2619 add_item(head, tail, string, count);
2622 if (sts != RMS$_NMF)
2624 set_vaxc_errno(sts);
2630 set_errno(ENOENT); break;
2632 set_errno(ENODEV); break;
2635 set_errno(EINVAL); break;
2637 set_errno(EACCES); break;
2639 _ckvmssts_noperl(sts);
2643 add_item(head, tail, item, count);
2644 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2645 _ckvmssts_noperl(lib$find_file_end(&context));
2648 static int child_st[2];/* Event Flag set when child process completes */
2650 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2652 static unsigned long int exit_handler(int *status)
2656 if (0 == child_st[0])
2658 #ifdef ARGPROC_DEBUG
2659 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2661 fflush(stdout); /* Have to flush pipe for binary data to */
2662 /* terminate properly -- <tp@mccall.com> */
2663 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2664 sys$dassgn(child_chan);
2666 sys$synch(0, child_st);
2671 static void sig_child(int chan)
2673 #ifdef ARGPROC_DEBUG
2674 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2676 if (child_st[0] == 0)
2680 static struct exit_control_block exit_block =
2685 &exit_block.exit_status,
2689 static void pipe_and_fork(char **cmargv)
2692 $DESCRIPTOR(cmddsc, "");
2693 static char mbxname[64];
2694 $DESCRIPTOR(mbxdsc, mbxname);
2696 unsigned long int zero = 0, one = 1;
2698 strcpy(subcmd, cmargv[0]);
2699 for (j = 1; NULL != cmargv[j]; ++j)
2701 strcat(subcmd, " \"");
2702 strcat(subcmd, cmargv[j]);
2703 strcat(subcmd, "\"");
2705 cmddsc.dsc$a_pointer = subcmd;
2706 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2708 create_mbx(&child_chan,&mbxdsc);
2709 #ifdef ARGPROC_DEBUG
2710 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2711 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2713 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2714 0, &pid, child_st, &zero, sig_child,
2716 #ifdef ARGPROC_DEBUG
2717 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2719 sys$dclexh(&exit_block);
2720 if (NULL == freopen(mbxname, "wb", stdout))
2722 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2726 static int background_process(int argc, char **argv)
2728 char command[2048] = "$";
2729 $DESCRIPTOR(value, "");
2730 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2731 static $DESCRIPTOR(null, "NLA0:");
2732 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2734 $DESCRIPTOR(pidstr, "");
2736 unsigned long int flags = 17, one = 1, retsts;
2738 strcat(command, argv[0]);
2741 strcat(command, " \"");
2742 strcat(command, *(++argv));
2743 strcat(command, "\"");
2745 value.dsc$a_pointer = command;
2746 value.dsc$w_length = strlen(value.dsc$a_pointer);
2747 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2748 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2749 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2750 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2753 _ckvmssts_noperl(retsts);
2755 #ifdef ARGPROC_DEBUG
2756 PerlIO_printf(Perl_debug_log, "%s\n", command);
2758 sprintf(pidstring, "%08X", pid);
2759 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2760 pidstr.dsc$a_pointer = pidstring;
2761 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2762 lib$set_symbol(&pidsymbol, &pidstr);
2766 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2769 /* OS-specific initialization at image activation (not thread startup) */
2770 /* Older VAXC header files lack these constants */
2771 #ifndef JPI$_RIGHTS_SIZE
2772 # define JPI$_RIGHTS_SIZE 817
2774 #ifndef KGB$M_SUBSYSTEM
2775 # define KGB$M_SUBSYSTEM 0x8
2778 /*{{{void vms_image_init(int *, char ***)*/
2780 vms_image_init(int *argcp, char ***argvp)
2782 char eqv[LNM$C_NAMLENGTH+1] = "";
2783 unsigned int len, tabct = 8, tabidx = 0;
2784 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2785 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2786 unsigned short int dummy, rlen;
2787 struct dsc$descriptor_s **tabvec;
2789 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2790 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2791 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2794 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2796 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2797 if (iprv[i]) { /* Running image installed with privs? */
2798 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2803 /* Rights identifiers might trigger tainting as well. */
2804 if (!will_taint && (rlen || rsz)) {
2805 while (rlen < rsz) {
2806 /* We didn't get all the identifiers on the first pass. Allocate a
2807 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2808 * were needed to hold all identifiers at time of last call; we'll
2809 * allocate that many unsigned long ints), and go back and get 'em.
2811 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2812 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2813 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2814 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2817 mask = jpilist[1].bufadr;
2818 /* Check attribute flags for each identifier (2nd longword); protected
2819 * subsystem identifiers trigger tainting.
2821 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2822 if (mask[i] & KGB$M_SUBSYSTEM) {
2827 if (mask != rlst) Safefree(mask);
2829 /* We need to use this hack to tell Perl it should run with tainting,
2830 * since its tainting flag may be part of the PL_curinterp struct, which
2831 * hasn't been allocated when vms_image_init() is called.
2835 New(1320,newap,*argcp+2,char **);
2836 newap[0] = argvp[0];
2838 Copy(argvp[1],newap[2],*argcp-1,char **);
2839 /* We orphan the old argv, since we don't know where it's come from,
2840 * so we don't know how to free it.
2842 *argcp++; argvp = newap;
2844 else { /* Did user explicitly request tainting? */
2846 char *cp, **av = *argvp;
2847 for (i = 1; i < *argcp; i++) {
2848 if (*av[i] != '-') break;
2849 for (cp = av[i]+1; *cp; cp++) {
2850 if (*cp == 'T') { will_taint = 1; break; }
2851 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2852 strchr("DFIiMmx",*cp)) break;
2854 if (will_taint) break;
2859 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2861 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2862 else if (tabidx >= tabct) {
2864 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2866 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2867 tabvec[tabidx]->dsc$w_length = 0;
2868 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2869 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2870 tabvec[tabidx]->dsc$a_pointer = NULL;
2871 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2873 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2875 getredirection(argcp,argvp);
2876 #if defined(USE_THREADS) && defined(__DECC)
2878 # include <reentrancy.h>
2879 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2888 * Trim Unix-style prefix off filespec, so it looks like what a shell
2889 * glob expansion would return (i.e. from specified prefix on, not
2890 * full path). Note that returned filespec is Unix-style, regardless
2891 * of whether input filespec was VMS-style or Unix-style.
2893 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2894 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2895 * vector of options; at present, only bit 0 is used, and if set tells
2896 * trim unixpath to try the current default directory as a prefix when
2897 * presented with a possibly ambiguous ... wildcard.
2899 * Returns !=0 on success, with trimmed filespec replacing contents of
2900 * fspec, and 0 on failure, with contents of fpsec unchanged.
2902 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2904 trim_unixpath(char *fspec, char *wildspec, int opts)
2906 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2907 *template, *base, *end, *cp1, *cp2;
2908 register int tmplen, reslen = 0, dirs = 0;
2910 if (!wildspec || !fspec) return 0;
2911 if (strpbrk(wildspec,"]>:") != NULL) {
2912 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2913 else template = unixwild;
2915 else template = wildspec;
2916 if (strpbrk(fspec,"]>:") != NULL) {
2917 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2918 else base = unixified;
2919 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2920 * check to see that final result fits into (isn't longer than) fspec */
2921 reslen = strlen(fspec);
2925 /* No prefix or absolute path on wildcard, so nothing to remove */
2926 if (!*template || *template == '/') {
2927 if (base == fspec) return 1;
2928 tmplen = strlen(unixified);
2929 if (tmplen > reslen) return 0; /* not enough space */
2930 /* Copy unixified resultant, including trailing NUL */
2931 memmove(fspec,unixified,tmplen+1);
2935 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2936 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2937 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2938 for (cp1 = end ;cp1 >= base; cp1--)
2939 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2941 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2945 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2946 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2947 int ells = 1, totells, segdirs, match;
2948 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2949 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2951 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2953 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2954 if (ellipsis == template && opts & 1) {
2955 /* Template begins with an ellipsis. Since we can't tell how many
2956 * directory names at the front of the resultant to keep for an
2957 * arbitrary starting point, we arbitrarily choose the current
2958 * default directory as a starting point. If it's there as a prefix,
2959 * clip it off. If not, fall through and act as if the leading
2960 * ellipsis weren't there (i.e. return shortest possible path that
2961 * could match template).
2963 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2964 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2965 if (_tolower(*cp1) != _tolower(*cp2)) break;
2966 segdirs = dirs - totells; /* Min # of dirs we must have left */
2967 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2968 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2969 memcpy(fspec,cp2+1,end - cp2);
2973 /* First off, back up over constant elements at end of path */
2975 for (front = end ; front >= base; front--)
2976 if (*front == '/' && !dirs--) { front++; break; }
2978 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2979 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2980 if (cp1 != '\0') return 0; /* Path too long. */
2982 *cp2 = '\0'; /* Pick up with memcpy later */
2983 lcfront = lcres + (front - base);
2984 /* Now skip over each ellipsis and try to match the path in front of it. */
2986 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2987 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2988 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2989 if (cp1 < template) break; /* template started with an ellipsis */
2990 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2991 ellipsis = cp1; continue;
2993 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2995 for (segdirs = 0, cp2 = tpl;
2996 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2998 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2999 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3000 if (*cp2 == '/') segdirs++;
3002 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3003 /* Back up at least as many dirs as in template before matching */
3004 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3005 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3006 for (match = 0; cp1 > lcres;) {
3007 resdsc.dsc$a_pointer = cp1;
3008 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3010 if (match == 1) lcfront = cp1;
3012 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3014 if (!match) return 0; /* Can't find prefix ??? */
3015 if (match > 1 && opts & 1) {
3016 /* This ... wildcard could cover more than one set of dirs (i.e.
3017 * a set of similar dir names is repeated). If the template
3018 * contains more than 1 ..., upstream elements could resolve the
3019 * ambiguity, but it's not worth a full backtracking setup here.
3020 * As a quick heuristic, clip off the current default directory
3021 * if it's present to find the trimmed spec, else use the
3022 * shortest string that this ... could cover.
3024 char def[NAM$C_MAXRSS+1], *st;
3026 if (getcwd(def, sizeof def,0) == NULL) return 0;
3027 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3028 if (_tolower(*cp1) != _tolower(*cp2)) break;
3029 segdirs = dirs - totells; /* Min # of dirs we must have left */
3030 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3031 if (*cp1 == '\0' && *cp2 == '/') {
3032 memcpy(fspec,cp2+1,end - cp2);
3035 /* Nope -- stick with lcfront from above and keep going. */
3038 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3043 } /* end of trim_unixpath() */
3048 * VMS readdir() routines.
3049 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3051 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3052 * Minor modifications to original routines.
3055 /* Number of elements in vms_versions array */
3056 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3059 * Open a directory, return a handle for later use.
3061 /*{{{ DIR *opendir(char*name) */
3066 char dir[NAM$C_MAXRSS+1];
3069 if (do_tovmspath(name,dir,0) == NULL) {
3072 if (flex_stat(dir,&sb) == -1) return NULL;
3073 if (!S_ISDIR(sb.st_mode)) {
3074 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3077 if (!cando_by_name(S_IRUSR,0,dir)) {
3078 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3081 /* Get memory for the handle, and the pattern. */
3083 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3085 /* Fill in the fields; mainly playing with the descriptor. */
3086 (void)sprintf(dd->pattern, "%s*.*",dir);
3089 dd->vms_wantversions = 0;
3090 dd->pat.dsc$a_pointer = dd->pattern;
3091 dd->pat.dsc$w_length = strlen(dd->pattern);
3092 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3093 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3096 } /* end of opendir() */
3100 * Set the flag to indicate we want versions or not.
3102 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3104 vmsreaddirversions(DIR *dd, int flag)
3106 dd->vms_wantversions = flag;
3111 * Free up an opened directory.
3113 /*{{{ void closedir(DIR *dd)*/
3117 (void)lib$find_file_end(&dd->context);
3118 Safefree(dd->pattern);
3119 Safefree((char *)dd);
3124 * Collect all the version numbers for the current file.
3130 struct dsc$descriptor_s pat;
3131 struct dsc$descriptor_s res;
3133 char *p, *text, buff[sizeof dd->entry.d_name];
3135 unsigned long context, tmpsts;
3138 /* Convenient shorthand. */
3141 /* Add the version wildcard, ignoring the "*.*" put on before */
3142 i = strlen(dd->pattern);
3143 New(1308,text,i + e->d_namlen + 3,char);
3144 (void)strcpy(text, dd->pattern);
3145 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3147 /* Set up the pattern descriptor. */
3148 pat.dsc$a_pointer = text;
3149 pat.dsc$w_length = i + e->d_namlen - 1;
3150 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3151 pat.dsc$b_class = DSC$K_CLASS_S;
3153 /* Set up result descriptor. */
3154 res.dsc$a_pointer = buff;
3155 res.dsc$w_length = sizeof buff - 2;
3156 res.dsc$b_dtype = DSC$K_DTYPE_T;
3157 res.dsc$b_class = DSC$K_CLASS_S;
3159 /* Read files, collecting versions. */
3160 for (context = 0, e->vms_verscount = 0;
3161 e->vms_verscount < VERSIZE(e);
3162 e->vms_verscount++) {
3163 tmpsts = lib$find_file(&pat, &res, &context);
3164 if (tmpsts == RMS$_NMF || context == 0) break;
3166 buff[sizeof buff - 1] = '\0';
3167 if ((p = strchr(buff, ';')))
3168 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3170 e->vms_versions[e->vms_verscount] = -1;
3173 _ckvmssts(lib$find_file_end(&context));
3176 } /* end of collectversions() */
3179 * Read the next entry from the directory.
3181 /*{{{ struct dirent *readdir(DIR *dd)*/
3185 struct dsc$descriptor_s res;
3186 char *p, buff[sizeof dd->entry.d_name];
3187 unsigned long int tmpsts;
3189 /* Set up result descriptor, and get next file. */
3190 res.dsc$a_pointer = buff;
3191 res.dsc$w_length = sizeof buff - 2;
3192 res.dsc$b_dtype = DSC$K_DTYPE_T;
3193 res.dsc$b_class = DSC$K_CLASS_S;
3194 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3195 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3196 if (!(tmpsts & 1)) {
3197 set_vaxc_errno(tmpsts);
3200 set_errno(EACCES); break;
3202 set_errno(ENODEV); break;
3205 set_errno(ENOENT); break;
3212 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3213 buff[sizeof buff - 1] = '\0';
3214 for (p = buff; *p; p++) *p = _tolower(*p);
3215 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3218 /* Skip any directory component and just copy the name. */
3219 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3220 else (void)strcpy(dd->entry.d_name, buff);
3222 /* Clobber the version. */
3223 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3225 dd->entry.d_namlen = strlen(dd->entry.d_name);
3226 dd->entry.vms_verscount = 0;
3227 if (dd->vms_wantversions) collectversions(dd);
3230 } /* end of readdir() */
3234 * Return something that can be used in a seekdir later.
3236 /*{{{ long telldir(DIR *dd)*/
3245 * Return to a spot where we used to be. Brute force.
3247 /*{{{ void seekdir(DIR *dd,long count)*/
3249 seekdir(DIR *dd, long count)
3251 int vms_wantversions;
3254 /* If we haven't done anything yet... */
3258 /* Remember some state, and clear it. */
3259 vms_wantversions = dd->vms_wantversions;
3260 dd->vms_wantversions = 0;
3261 _ckvmssts(lib$find_file_end(&dd->context));
3264 /* The increment is in readdir(). */
3265 for (dd->count = 0; dd->count < count; )
3268 dd->vms_wantversions = vms_wantversions;
3270 } /* end of seekdir() */
3273 /* VMS subprocess management
3275 * my_vfork() - just a vfork(), after setting a flag to record that
3276 * the current script is trying a Unix-style fork/exec.
3278 * vms_do_aexec() and vms_do_exec() are called in response to the
3279 * perl 'exec' function. If this follows a vfork call, then they
3280 * call out the the regular perl routines in doio.c which do an
3281 * execvp (for those who really want to try this under VMS).
3282 * Otherwise, they do exactly what the perl docs say exec should
3283 * do - terminate the current script and invoke a new command
3284 * (See below for notes on command syntax.)
3286 * do_aspawn() and do_spawn() implement the VMS side of the perl
3287 * 'system' function.
3289 * Note on command arguments to perl 'exec' and 'system': When handled
3290 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3291 * are concatenated to form a DCL command string. If the first arg
3292 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3293 * the the command string is handed off to DCL directly. Otherwise,
3294 * the first token of the command is taken as the filespec of an image
3295 * to run. The filespec is expanded using a default type of '.EXE' and
3296 * the process defaults for device, directory, etc., and if found, the resultant
3297 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3298 * the command string as parameters. This is perhaps a bit complicated,
3299 * but I hope it will form a happy medium between what VMS folks expect
3300 * from lib$spawn and what Unix folks expect from exec.
3303 static int vfork_called;
3305 /*{{{int my_vfork()*/
3318 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3321 if (VMScmd.dsc$a_pointer) {
3322 Safefree(VMScmd.dsc$a_pointer);
3323 VMScmd.dsc$w_length = 0;
3324 VMScmd.dsc$a_pointer = Nullch;
3329 setup_argstr(SV *really, SV **mark, SV **sp)
3332 char *junk, *tmps = Nullch;
3333 register size_t cmdlen = 0;
3340 tmps = SvPV(really,rlen);
3347 for (idx++; idx <= sp; idx++) {
3349 junk = SvPVx(*idx,rlen);
3350 cmdlen += rlen ? rlen + 1 : 0;
3353 New(401,PL_Cmd,cmdlen+1,char);
3355 if (tmps && *tmps) {
3356 strcpy(PL_Cmd,tmps);
3359 else *PL_Cmd = '\0';
3360 while (++mark <= sp) {
3362 char *s = SvPVx(*mark,n_a);
3364 if (*PL_Cmd) strcat(PL_Cmd," ");
3370 } /* end of setup_argstr() */
3373 static unsigned long int
3374 setup_cmddsc(char *cmd, int check_img)
3376 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3377 $DESCRIPTOR(defdsc,".EXE");
3378 $DESCRIPTOR(resdsc,resspec);
3379 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3380 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3381 register char *s, *rest, *cp, *wordbreak;
3386 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3389 while (*s && isspace(*s)) s++;
3391 if (*s == '@' || *s == '$') {
3392 vmsspec[0] = *s; rest = s + 1;
3393 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3395 else { cp = vmsspec; rest = s; }
3396 if (*rest == '.' || *rest == '/') {
3399 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3400 rest++, cp2++) *cp2 = *rest;
3402 if (do_tovmsspec(resspec,cp,0)) {
3405 for (cp2 = vmsspec + strlen(vmsspec);
3406 *rest && cp2 - vmsspec < sizeof vmsspec;
3407 rest++, cp2++) *cp2 = *rest;
3412 /* Intuit whether verb (first word of cmd) is a DCL command:
3413 * - if first nonspace char is '@', it's a DCL indirection
3415 * - if verb contains a filespec separator, it's not a DCL command
3416 * - if it doesn't, caller tells us whether to default to a DCL
3417 * command, or to a local image unless told it's DCL (by leading '$')
3419 if (*s == '@') isdcl = 1;
3421 register char *filespec = strpbrk(s,":<[.;");
3422 rest = wordbreak = strpbrk(s," \"\t/");
3423 if (!wordbreak) wordbreak = s + strlen(s);
3424 if (*s == '$') check_img = 0;
3425 if (filespec && (filespec < wordbreak)) isdcl = 0;
3426 else isdcl = !check_img;
3430 imgdsc.dsc$a_pointer = s;
3431 imgdsc.dsc$w_length = wordbreak - s;
3432 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3433 if (!(retsts & 1) && *s == '$') {
3434 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3435 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3436 _ckvmssts(lib$find_file_end(&cxt));
3440 while (*s && !isspace(*s)) s++;
3442 if (cando_by_name(S_IXUSR,0,resspec)) {
3443 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3444 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3445 strcat(VMScmd.dsc$a_pointer,resspec);
3446 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3447 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3450 else retsts = RMS$_PRV;
3453 /* It's either a DCL command or we couldn't find a suitable image */
3454 VMScmd.dsc$w_length = strlen(cmd);
3455 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3456 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3457 if (!(retsts & 1)) {
3458 /* just hand off status values likely to be due to user error */
3459 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3460 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3461 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3462 else { _ckvmssts(retsts); }
3465 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3467 } /* end of setup_cmddsc() */
3470 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3472 vms_do_aexec(SV *really,SV **mark,SV **sp)
3476 if (vfork_called) { /* this follows a vfork - act Unixish */
3478 if (vfork_called < 0) {
3479 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3482 else return do_aexec(really,mark,sp);
3484 /* no vfork - act VMSish */
3485 return vms_do_exec(setup_argstr(really,mark,sp));
3490 } /* end of vms_do_aexec() */
3493 /* {{{bool vms_do_exec(char *cmd) */
3495 vms_do_exec(char *cmd)
3499 if (vfork_called) { /* this follows a vfork - act Unixish */
3501 if (vfork_called < 0) {
3502 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3505 else return do_exec(cmd);
3508 { /* no vfork - act VMSish */
3509 unsigned long int retsts;
3512 TAINT_PROPER("exec");
3513 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3514 retsts = lib$do_command(&VMScmd);
3518 set_errno(ENOENT); break;
3519 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3520 set_errno(ENOTDIR); break;
3522 set_errno(EACCES); break;
3524 set_errno(EINVAL); break;
3526 set_errno(E2BIG); break;
3527 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3528 _ckvmssts(retsts); /* fall through */
3529 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3532 set_vaxc_errno(retsts);
3533 if (ckWARN(WARN_EXEC)) {
3534 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3535 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3542 } /* end of vms_do_exec() */
3545 unsigned long int do_spawn(char *);
3547 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3549 do_aspawn(void *really,void **mark,void **sp)
3552 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3555 } /* end of do_aspawn() */
3558 /* {{{unsigned long int do_spawn(char *cmd) */
3562 unsigned long int sts, substs, hadcmd = 1;
3566 TAINT_PROPER("spawn");
3567 if (!cmd || !*cmd) {
3569 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3571 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3572 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3578 set_errno(ENOENT); break;
3579 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3580 set_errno(ENOTDIR); break;
3582 set_errno(EACCES); break;
3584 set_errno(EINVAL); break;
3586 set_errno(E2BIG); break;
3587 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3588 _ckvmssts(sts); /* fall through */
3589 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3592 set_vaxc_errno(sts);
3593 if (ckWARN(WARN_EXEC)) {
3594 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3595 hadcmd ? VMScmd.dsc$w_length : 0,
3596 hadcmd ? VMScmd.dsc$a_pointer : "",
3603 } /* end of do_spawn() */
3607 * A simple fwrite replacement which outputs itmsz*nitm chars without
3608 * introducing record boundaries every itmsz chars.
3610 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3612 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3614 register char *cp, *end;
3616 end = (char *)src + itmsz * nitm;
3618 while ((char *)src <= end) {
3619 for (cp = src; cp <= end; cp++) if (!*cp) break;
3620 if (fputs(src,dest) == EOF) return EOF;
3622 if (fputc('\0',dest) == EOF) return EOF;
3628 } /* end of my_fwrite() */
3631 /*{{{ int my_flush(FILE *fp)*/
3636 if ((res = fflush(fp)) == 0 && fp) {
3637 #ifdef VMS_DO_SOCKETS
3639 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3641 res = fsync(fileno(fp));
3648 * Here are replacements for the following Unix routines in the VMS environment:
3649 * getpwuid Get information for a particular UIC or UID
3650 * getpwnam Get information for a named user
3651 * getpwent Get information for each user in the rights database
3652 * setpwent Reset search to the start of the rights database
3653 * endpwent Finish searching for users in the rights database
3655 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3656 * (defined in pwd.h), which contains the following fields:-
3658 * char *pw_name; Username (in lower case)
3659 * char *pw_passwd; Hashed password
3660 * unsigned int pw_uid; UIC
3661 * unsigned int pw_gid; UIC group number
3662 * char *pw_unixdir; Default device/directory (VMS-style)
3663 * char *pw_gecos; Owner name
3664 * char *pw_dir; Default device/directory (Unix-style)
3665 * char *pw_shell; Default CLI name (eg. DCL)
3667 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3669 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3670 * not the UIC member number (eg. what's returned by getuid()),
3671 * getpwuid() can accept either as input (if uid is specified, the caller's
3672 * UIC group is used), though it won't recognise gid=0.
3674 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3675 * information about other users in your group or in other groups, respectively.
3676 * If the required privilege is not available, then these routines fill only
3677 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3680 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3683 /* sizes of various UAF record fields */
3684 #define UAI$S_USERNAME 12
3685 #define UAI$S_IDENT 31
3686 #define UAI$S_OWNER 31
3687 #define UAI$S_DEFDEV 31
3688 #define UAI$S_DEFDIR 63
3689 #define UAI$S_DEFCLI 31
3692 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3693 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3694 (uic).uic$v_group != UIC$K_WILD_GROUP)
3696 static char __empty[]= "";
3697 static struct passwd __passwd_empty=
3698 {(char *) __empty, (char *) __empty, 0, 0,
3699 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3700 static int contxt= 0;
3701 static struct passwd __pwdcache;
3702 static char __pw_namecache[UAI$S_IDENT+1];
3705 * This routine does most of the work extracting the user information.
3707 static int fillpasswd (const char *name, struct passwd *pwd)
3711 unsigned char length;
3712 char pw_gecos[UAI$S_OWNER+1];
3714 static union uicdef uic;
3716 unsigned char length;
3717 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3720 unsigned char length;
3721 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3724 unsigned char length;
3725 char pw_shell[UAI$S_DEFCLI+1];
3727 static char pw_passwd[UAI$S_PWD+1];
3729 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3730 struct dsc$descriptor_s name_desc;
3731 unsigned long int sts;
3733 static struct itmlst_3 itmlst[]= {
3734 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3735 {sizeof(uic), UAI$_UIC, &uic, &luic},
3736 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3737 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3738 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3739 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3740 {0, 0, NULL, NULL}};
3742 name_desc.dsc$w_length= strlen(name);
3743 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3744 name_desc.dsc$b_class= DSC$K_CLASS_S;
3745 name_desc.dsc$a_pointer= (char *) name;
3747 /* Note that sys$getuai returns many fields as counted strings. */
3748 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3749 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3750 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3752 else { _ckvmssts(sts); }
3753 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3755 if ((int) owner.length < lowner) lowner= (int) owner.length;
3756 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3757 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3758 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3759 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3760 owner.pw_gecos[lowner]= '\0';
3761 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3762 defcli.pw_shell[ldefcli]= '\0';
3763 if (valid_uic(uic)) {
3764 pwd->pw_uid= uic.uic$l_uic;
3765 pwd->pw_gid= uic.uic$v_group;
3768 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3769 pwd->pw_passwd= pw_passwd;
3770 pwd->pw_gecos= owner.pw_gecos;
3771 pwd->pw_dir= defdev.pw_dir;
3772 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3773 pwd->pw_shell= defcli.pw_shell;
3774 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3776 ldir= strlen(pwd->pw_unixdir) - 1;
3777 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3780 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3781 __mystrtolower(pwd->pw_unixdir);
3786 * Get information for a named user.
3788 /*{{{struct passwd *getpwnam(char *name)*/
3789 struct passwd *my_getpwnam(char *name)
3791 struct dsc$descriptor_s name_desc;
3793 unsigned long int status, sts;
3796 __pwdcache = __passwd_empty;
3797 if (!fillpasswd(name, &__pwdcache)) {
3798 /* We still may be able to determine pw_uid and pw_gid */
3799 name_desc.dsc$w_length= strlen(name);
3800 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3801 name_desc.dsc$b_class= DSC$K_CLASS_S;
3802 name_desc.dsc$a_pointer= (char *) name;
3803 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3804 __pwdcache.pw_uid= uic.uic$l_uic;
3805 __pwdcache.pw_gid= uic.uic$v_group;
3808 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3809 set_vaxc_errno(sts);
3810 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3813 else { _ckvmssts(sts); }
3816 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3817 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3818 __pwdcache.pw_name= __pw_namecache;
3820 } /* end of my_getpwnam() */
3824 * Get information for a particular UIC or UID.
3825 * Called by my_getpwent with uid=-1 to list all users.
3827 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3828 struct passwd *my_getpwuid(Uid_t uid)
3830 const $DESCRIPTOR(name_desc,__pw_namecache);
3831 unsigned short lname;
3833 unsigned long int status;
3836 if (uid == (unsigned int) -1) {
3838 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3839 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3840 set_vaxc_errno(status);
3841 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3845 else { _ckvmssts(status); }
3846 } while (!valid_uic (uic));
3850 if (!uic.uic$v_group)
3851 uic.uic$v_group= PerlProc_getgid();
3853 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3854 else status = SS$_IVIDENT;
3855 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3856 status == RMS$_PRV) {
3857 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3860 else { _ckvmssts(status); }
3862 __pw_namecache[lname]= '\0';
3863 __mystrtolower(__pw_namecache);
3865 __pwdcache = __passwd_empty;
3866 __pwdcache.pw_name = __pw_namecache;
3868 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3869 The identifier's value is usually the UIC, but it doesn't have to be,
3870 so if we can, we let fillpasswd update this. */
3871 __pwdcache.pw_uid = uic.uic$l_uic;
3872 __pwdcache.pw_gid = uic.uic$v_group;
3874 fillpasswd(__pw_namecache, &__pwdcache);
3877 } /* end of my_getpwuid() */
3881 * Get information for next user.
3883 /*{{{struct passwd *my_getpwent()*/
3884 struct passwd *my_getpwent()
3886 return (my_getpwuid((unsigned int) -1));
3891 * Finish searching rights database for users.
3893 /*{{{void my_endpwent()*/
3898 _ckvmssts(sys$finish_rdb(&contxt));
3904 #ifdef HOMEGROWN_POSIX_SIGNALS
3905 /* Signal handling routines, pulled into the core from POSIX.xs.
3907 * We need these for threads, so they've been rolled into the core,
3908 * rather than left in POSIX.xs.
3910 * (DRS, Oct 23, 1997)
3913 /* sigset_t is atomic under VMS, so these routines are easy */
3914 /*{{{int my_sigemptyset(sigset_t *) */
3915 int my_sigemptyset(sigset_t *set) {
3916 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3922 /*{{{int my_sigfillset(sigset_t *)*/
3923 int my_sigfillset(sigset_t *set) {
3925 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3926 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3932 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3933 int my_sigaddset(sigset_t *set, int sig) {
3934 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3935 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3936 *set |= (1 << (sig - 1));
3942 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3943 int my_sigdelset(sigset_t *set, int sig) {
3944 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3945 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3946 *set &= ~(1 << (sig - 1));
3952 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3953 int my_sigismember(sigset_t *set, int sig) {
3954 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3955 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3956 *set & (1 << (sig - 1));
3961 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3962 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3965 /* If set and oset are both null, then things are badly wrong. Bail out. */
3966 if ((oset == NULL) && (set == NULL)) {
3967 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3971 /* If set's null, then we're just handling a fetch. */
3973 tempmask = sigblock(0);
3978 tempmask = sigsetmask(*set);
3981 tempmask = sigblock(*set);
3984 tempmask = sigblock(0);
3985 sigsetmask(*oset & ~tempmask);
3988 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3993 /* Did they pass us an oset? If so, stick our holding mask into it */
4000 #endif /* HOMEGROWN_POSIX_SIGNALS */
4003 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4004 * my_utime(), and flex_stat(), all of which operate on UTC unless
4005 * VMSISH_TIMES is true.
4007 /* method used to handle UTC conversions:
4008 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4010 static int gmtime_emulation_type;
4011 /* number of secs to add to UTC POSIX-style time to get local time */
4012 static long int utc_offset_secs;
4014 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4015 * in vmsish.h. #undef them here so we can call the CRTL routines
4022 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4023 # define RTL_USES_UTC 1
4027 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4028 * qualifier with the extern prefix pragma. This provisional
4029 * hack circumvents this prefix pragma problem in previous
4032 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4033 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4034 # pragma __extern_prefix save
4035 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4036 # define gmtime decc$__utctz_gmtime
4037 # define localtime decc$__utctz_localtime
4038 # define time decc$__utc_time
4039 # pragma __extern_prefix restore
4041 struct tm *gmtime(), *localtime();
4047 static time_t toutc_dst(time_t loc) {
4050 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4051 loc -= utc_offset_secs;
4052 if (rsltmp->tm_isdst) loc -= 3600;
4055 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4056 ((gmtime_emulation_type || my_time(NULL)), \
4057 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4058 ((secs) - utc_offset_secs))))
4060 static time_t toloc_dst(time_t utc) {
4063 utc += utc_offset_secs;
4064 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4065 if (rsltmp->tm_isdst) utc += 3600;
4068 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4069 ((gmtime_emulation_type || my_time(NULL)), \
4070 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4071 ((secs) + utc_offset_secs))))
4074 /* my_time(), my_localtime(), my_gmtime()
4075 * By default traffic in UTC time values, using CRTL gmtime() or
4076 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4077 * Note: We need to use these functions even when the CRTL has working
4078 * UTC support, since they also handle C<use vmsish qw(times);>
4080 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4081 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4084 /*{{{time_t my_time(time_t *timep)*/
4085 time_t my_time(time_t *timep)
4091 if (gmtime_emulation_type == 0) {
4093 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4094 /* results of calls to gmtime() and localtime() */
4095 /* for same &base */
4097 gmtime_emulation_type++;
4098 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4099 char off[LNM$C_NAMLENGTH+1];;
4101 gmtime_emulation_type++;
4102 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4103 gmtime_emulation_type++;
4104 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4106 else { utc_offset_secs = atol(off); }
4108 else { /* We've got a working gmtime() */
4109 struct tm gmt, local;
4112 tm_p = localtime(&base);
4114 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4115 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4116 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4117 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4123 # ifdef RTL_USES_UTC
4124 if (VMSISH_TIME) when = _toloc(when);
4126 if (!VMSISH_TIME) when = _toutc(when);
4129 if (timep != NULL) *timep = when;
4132 } /* end of my_time() */
4136 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4138 my_gmtime(const time_t *timep)
4145 if (timep == NULL) {
4146 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4149 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4153 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4155 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4156 return gmtime(&when);
4158 /* CRTL localtime() wants local time as input, so does no tz correction */
4159 rsltmp = localtime(&when);
4160 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4163 } /* end of my_gmtime() */
4167 /*{{{struct tm *my_localtime(const time_t *timep)*/
4169 my_localtime(const time_t *timep)
4175 if (timep == NULL) {
4176 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4179 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4180 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4183 # ifdef RTL_USES_UTC
4185 if (VMSISH_TIME) when = _toutc(when);
4187 /* CRTL localtime() wants UTC as input, does tz correction itself */
4188 return localtime(&when);
4191 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4194 /* CRTL localtime() wants local time as input, so does no tz correction */
4195 rsltmp = localtime(&when);
4196 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4199 } /* end of my_localtime() */
4202 /* Reset definitions for later calls */
4203 #define gmtime(t) my_gmtime(t)
4204 #define localtime(t) my_localtime(t)
4205 #define time(t) my_time(t)
4208 /* my_utime - update modification time of a file
4209 * calling sequence is identical to POSIX utime(), but under
4210 * VMS only the modification time is changed; ODS-2 does not
4211 * maintain access times. Restrictions differ from the POSIX
4212 * definition in that the time can be changed as long as the
4213 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4214 * no separate checks are made to insure that the caller is the
4215 * owner of the file or has special privs enabled.
4216 * Code here is based on Joe Meadows' FILE utility.
4219 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4220 * to VMS epoch (01-JAN-1858 00:00:00.00)
4221 * in 100 ns intervals.
4223 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4225 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4226 int my_utime(char *file, struct utimbuf *utimes)
4230 long int bintime[2], len = 2, lowbit, unixtime,
4231 secscale = 10000000; /* seconds --> 100 ns intervals */
4232 unsigned long int chan, iosb[2], retsts;
4233 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4234 struct FAB myfab = cc$rms_fab;
4235 struct NAM mynam = cc$rms_nam;
4236 #if defined (__DECC) && defined (__VAX)
4237 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4238 * at least through VMS V6.1, which causes a type-conversion warning.
4240 # pragma message save
4241 # pragma message disable cvtdiftypes
4243 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4244 struct fibdef myfib;
4245 #if defined (__DECC) && defined (__VAX)
4246 /* This should be right after the declaration of myatr, but due
4247 * to a bug in VAX DEC C, this takes effect a statement early.
4249 # pragma message restore
4251 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4252 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4253 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4255 if (file == NULL || *file == '\0') {
4257 set_vaxc_errno(LIB$_INVARG);
4260 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4262 if (utimes != NULL) {
4263 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4264 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4265 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4266 * as input, we force the sign bit to be clear by shifting unixtime right
4267 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4269 lowbit = (utimes->modtime & 1) ? secscale : 0;
4270 unixtime = (long int) utimes->modtime;
4272 /* If input was UTC; convert to local for sys svc */
4273 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4275 unixtime >>= 1; secscale <<= 1;
4276 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4277 if (!(retsts & 1)) {
4279 set_vaxc_errno(retsts);
4282 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4283 if (!(retsts & 1)) {
4285 set_vaxc_errno(retsts);
4290 /* Just get the current time in VMS format directly */
4291 retsts = sys$gettim(bintime);
4292 if (!(retsts & 1)) {
4294 set_vaxc_errno(retsts);
4299 myfab.fab$l_fna = vmsspec;
4300 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4301 myfab.fab$l_nam = &mynam;
4302 mynam.nam$l_esa = esa;
4303 mynam.nam$b_ess = (unsigned char) sizeof esa;
4304 mynam.nam$l_rsa = rsa;
4305 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4307 /* Look for the file to be affected, letting RMS parse the file
4308 * specification for us as well. I have set errno using only
4309 * values documented in the utime() man page for VMS POSIX.
4311 retsts = sys$parse(&myfab,0,0);
4312 if (!(retsts & 1)) {
4313 set_vaxc_errno(retsts);
4314 if (retsts == RMS$_PRV) set_errno(EACCES);
4315 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4316 else set_errno(EVMSERR);
4319 retsts = sys$search(&myfab,0,0);
4320 if (!(retsts & 1)) {
4321 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4322 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4323 set_vaxc_errno(retsts);
4324 if (retsts == RMS$_PRV) set_errno(EACCES);
4325 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4326 else set_errno(EVMSERR);
4330 devdsc.dsc$w_length = mynam.nam$b_dev;
4331 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4333 retsts = sys$assign(&devdsc,&chan,0,0);
4334 if (!(retsts & 1)) {
4335 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4336 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4337 set_vaxc_errno(retsts);
4338 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4339 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4340 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4341 else set_errno(EVMSERR);
4345 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4346 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4348 memset((void *) &myfib, 0, sizeof myfib);
4350 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4351 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4352 /* This prevents the revision time of the file being reset to the current
4353 * time as a result of our IO$_MODIFY $QIO. */
4354 myfib.fib$l_acctl = FIB$M_NORECORD;
4356 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4357 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4358 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4360 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4361 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4362 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4363 _ckvmssts(sys$dassgn(chan));
4364 if (retsts & 1) retsts = iosb[0];
4365 if (!(retsts & 1)) {
4366 set_vaxc_errno(retsts);
4367 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4368 else set_errno(EVMSERR);
4373 } /* end of my_utime() */
4377 * flex_stat, flex_fstat
4378 * basic stat, but gets it right when asked to stat
4379 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4382 /* encode_dev packs a VMS device name string into an integer to allow
4383 * simple comparisons. This can be used, for example, to check whether two
4384 * files are located on the same device, by comparing their encoded device
4385 * names. Even a string comparison would not do, because stat() reuses the
4386 * device name buffer for each call; so without encode_dev, it would be
4387 * necessary to save the buffer and use strcmp (this would mean a number of
4388 * changes to the standard Perl code, to say nothing of what a Perl script
4391 * The device lock id, if it exists, should be unique (unless perhaps compared
4392 * with lock ids transferred from other nodes). We have a lock id if the disk is
4393 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4394 * device names. Thus we use the lock id in preference, and only if that isn't
4395 * available, do we try to pack the device name into an integer (flagged by
4396 * the sign bit (LOCKID_MASK) being set).
4398 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4399 * name and its encoded form, but it seems very unlikely that we will find
4400 * two files on different disks that share the same encoded device names,
4401 * and even more remote that they will share the same file id (if the test
4402 * is to check for the same file).
4404 * A better method might be to use sys$device_scan on the first call, and to
4405 * search for the device, returning an index into the cached array.
4406 * The number returned would be more intelligable.
4407 * This is probably not worth it, and anyway would take quite a bit longer
4408 * on the first call.
4410 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4411 static mydev_t encode_dev (const char *dev)
4414 unsigned long int f;
4420 if (!dev || !dev[0]) return 0;
4424 struct dsc$descriptor_s dev_desc;
4425 unsigned long int status, lockid, item = DVI$_LOCKID;
4427 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4428 can try that first. */
4429 dev_desc.dsc$w_length = strlen (dev);
4430 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4431 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4432 dev_desc.dsc$a_pointer = (char *) dev;
4433 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4434 if (lockid) return (lockid & ~LOCKID_MASK);
4438 /* Otherwise we try to encode the device name */
4442 for (q = dev + strlen(dev); q--; q >= dev) {
4445 else if (isalpha (toupper (*q)))
4446 c= toupper (*q) - 'A' + (char)10;
4448 continue; /* Skip '$'s */
4450 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4452 enc += f * (unsigned long int) c;
4454 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4456 } /* end of encode_dev() */
4458 static char namecache[NAM$C_MAXRSS+1];
4461 is_null_device(name)
4465 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4466 The underscore prefix, controller letter, and unit number are
4467 independently optional; for our purposes, the colon punctuation
4468 is not. The colon can be trailed by optional directory and/or
4469 filename, but two consecutive colons indicates a nodename rather
4470 than a device. [pr] */
4471 if (*name == '_') ++name;
4472 if (tolower(*name++) != 'n') return 0;
4473 if (tolower(*name++) != 'l') return 0;
4474 if (tolower(*name) == 'a') ++name;
4475 if (*name == '0') ++name;
4476 return (*name++ == ':') && (*name != ':');
4479 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4480 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4481 * subset of the applicable information.
4484 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4486 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4488 char fname[NAM$C_MAXRSS+1];
4489 unsigned long int retsts;
4490 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4491 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4493 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4494 device name on successive calls */
4495 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4496 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4497 namdsc.dsc$a_pointer = fname;
4498 namdsc.dsc$w_length = sizeof fname - 1;
4500 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4501 &namdsc,&namdsc.dsc$w_length,0,0);
4503 fname[namdsc.dsc$w_length] = '\0';
4504 return cando_by_name(bit,effective,fname);
4506 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4507 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4511 return FALSE; /* Should never get to here */
4513 } /* end of cando() */
4517 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4519 cando_by_name(I32 bit, Uid_t effective, char *fname)
4521 static char usrname[L_cuserid];
4522 static struct dsc$descriptor_s usrdsc =
4523 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4524 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4525 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4526 unsigned short int retlen;
4528 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4529 union prvdef curprv;
4530 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4531 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4532 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4535 if (!fname || !*fname) return FALSE;
4536 /* Make sure we expand logical names, since sys$check_access doesn't */
4537 if (!strpbrk(fname,"/]>:")) {
4538 strcpy(fileified,fname);
4539 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4542 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4543 retlen = namdsc.dsc$w_length = strlen(vmsname);
4544 namdsc.dsc$a_pointer = vmsname;
4545 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4546 vmsname[retlen-1] == ':') {
4547 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4548 namdsc.dsc$w_length = strlen(fileified);
4549 namdsc.dsc$a_pointer = fileified;
4552 if (!usrdsc.dsc$w_length) {
4554 usrdsc.dsc$w_length = strlen(usrname);
4561 access = ARM$M_EXECUTE;
4566 access = ARM$M_READ;
4571 access = ARM$M_WRITE;
4576 access = ARM$M_DELETE;
4582 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4583 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4584 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4585 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4586 set_vaxc_errno(retsts);
4587 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4588 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4589 else set_errno(ENOENT);
4592 if (retsts == SS$_NORMAL) {
4593 if (!privused) return TRUE;
4594 /* We can get access, but only by using privs. Do we have the
4595 necessary privs currently enabled? */
4596 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4597 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4598 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4599 !curprv.prv$v_bypass) return FALSE;
4600 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4601 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4602 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4605 if (retsts == SS$_ACCONFLICT) {
4610 return FALSE; /* Should never get here */
4612 } /* end of cando_by_name() */
4616 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4618 flex_fstat(int fd, Stat_t *statbufp)
4621 if (!fstat(fd,(stat_t *) statbufp)) {
4622 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4623 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4624 # ifdef RTL_USES_UTC
4627 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4628 statbufp->st_atime = _toloc(statbufp->st_atime);
4629 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4634 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4638 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4639 statbufp->st_atime = _toutc(statbufp->st_atime);
4640 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4647 } /* end of flex_fstat() */
4650 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4652 flex_stat(const char *fspec, Stat_t *statbufp)
4655 char fileified[NAM$C_MAXRSS+1];
4656 char temp_fspec[NAM$C_MAXRSS+300];
4659 strcpy(temp_fspec, fspec);
4660 if (statbufp == (Stat_t *) &PL_statcache)
4661 do_tovmsspec(temp_fspec,namecache,0);
4662 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4663 memset(statbufp,0,sizeof *statbufp);
4664 statbufp->st_dev = encode_dev("_NLA0:");
4665 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4666 statbufp->st_uid = 0x00010001;
4667 statbufp->st_gid = 0x0001;
4668 time((time_t *)&statbufp->st_mtime);
4669 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4673 /* Try for a directory name first. If fspec contains a filename without
4674 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4675 * and sea:[wine.dark]water. exist, we prefer the directory here.
4676 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4677 * not sea:[wine.dark]., if the latter exists. If the intended target is
4678 * the file with null type, specify this by calling flex_stat() with
4679 * a '.' at the end of fspec.
4681 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4682 retval = stat(fileified,(stat_t *) statbufp);
4683 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4684 strcpy(namecache,fileified);
4686 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4688 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4689 # ifdef RTL_USES_UTC
4692 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4693 statbufp->st_atime = _toloc(statbufp->st_atime);
4694 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4699 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4703 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4704 statbufp->st_atime = _toutc(statbufp->st_atime);
4705 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4711 } /* end of flex_stat() */
4715 /*{{{char *my_getlogin()*/
4716 /* VMS cuserid == Unix getlogin, except calling sequence */
4720 static char user[L_cuserid];
4721 return cuserid(user);
4726 /* rmscopy - copy a file using VMS RMS routines
4728 * Copies contents and attributes of spec_in to spec_out, except owner
4729 * and protection information. Name and type of spec_in are used as
4730 * defaults for spec_out. The third parameter specifies whether rmscopy()
4731 * should try to propagate timestamps from the input file to the output file.
4732 * If it is less than 0, no timestamps are preserved. If it is 0, then
4733 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4734 * propagated to the output file at creation iff the output file specification
4735 * did not contain an explicit name or type, and the revision date is always
4736 * updated at the end of the copy operation. If it is greater than 0, then
4737 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4738 * other than the revision date should be propagated, and bit 1 indicates
4739 * that the revision date should be propagated.
4741 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4743 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4744 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4745 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4746 * as part of the Perl standard distribution under the terms of the
4747 * GNU General Public License or the Perl Artistic License. Copies
4748 * of each may be found in the Perl standard distribution.
4750 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4752 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4754 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4755 rsa[NAM$C_MAXRSS], ubf[32256];
4756 unsigned long int i, sts, sts2;
4757 struct FAB fab_in, fab_out;
4758 struct RAB rab_in, rab_out;
4760 struct XABDAT xabdat;
4761 struct XABFHC xabfhc;
4762 struct XABRDT xabrdt;
4763 struct XABSUM xabsum;
4765 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4766 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4767 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4771 fab_in = cc$rms_fab;
4772 fab_in.fab$l_fna = vmsin;
4773 fab_in.fab$b_fns = strlen(vmsin);
4774 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4775 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4776 fab_in.fab$l_fop = FAB$M_SQO;
4777 fab_in.fab$l_nam = &nam;
4778 fab_in.fab$l_xab = (void *) &xabdat;
4781 nam.nam$l_rsa = rsa;
4782 nam.nam$b_rss = sizeof(rsa);
4783 nam.nam$l_esa = esa;
4784 nam.nam$b_ess = sizeof (esa);
4785 nam.nam$b_esl = nam.nam$b_rsl = 0;
4787 xabdat = cc$rms_xabdat; /* To get creation date */
4788 xabdat.xab$l_nxt = (void *) &xabfhc;
4790 xabfhc = cc$rms_xabfhc; /* To get record length */
4791 xabfhc.xab$l_nxt = (void *) &xabsum;
4793 xabsum = cc$rms_xabsum; /* To get key and area information */
4795 if (!((sts = sys$open(&fab_in)) & 1)) {
4796 set_vaxc_errno(sts);
4800 set_errno(ENOENT); break;
4802 set_errno(ENODEV); break;
4804 set_errno(EINVAL); break;
4806 set_errno(EACCES); break;
4814 fab_out.fab$w_ifi = 0;
4815 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4816 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4817 fab_out.fab$l_fop = FAB$M_SQO;
4818 fab_out.fab$l_fna = vmsout;
4819 fab_out.fab$b_fns = strlen(vmsout);
4820 fab_out.fab$l_dna = nam.nam$l_name;
4821 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4823 if (preserve_dates == 0) { /* Act like DCL COPY */
4824 nam.nam$b_nop = NAM$M_SYNCHK;
4825 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4826 if (!((sts = sys$parse(&fab_out)) & 1)) {
4827 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4828 set_vaxc_errno(sts);
4831 fab_out.fab$l_xab = (void *) &xabdat;
4832 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4834 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4835 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4836 preserve_dates =0; /* bitmask from this point forward */
4838 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4839 if (!((sts = sys$create(&fab_out)) & 1)) {
4840 set_vaxc_errno(sts);
4843 set_errno(ENOENT); break;
4845 set_errno(ENODEV); break;
4847 set_errno(EINVAL); break;
4849 set_errno(EACCES); break;
4855 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4856 if (preserve_dates & 2) {
4857 /* sys$close() will process xabrdt, not xabdat */
4858 xabrdt = cc$rms_xabrdt;
4860 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4862 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4863 * is unsigned long[2], while DECC & VAXC use a struct */
4864 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4866 fab_out.fab$l_xab = (void *) &xabrdt;
4869 rab_in = cc$rms_rab;
4870 rab_in.rab$l_fab = &fab_in;
4871 rab_in.rab$l_rop = RAB$M_BIO;
4872 rab_in.rab$l_ubf = ubf;
4873 rab_in.rab$w_usz = sizeof ubf;
4874 if (!((sts = sys$connect(&rab_in)) & 1)) {
4875 sys$close(&fab_in); sys$close(&fab_out);
4876 set_errno(EVMSERR); set_vaxc_errno(sts);
4880 rab_out = cc$rms_rab;
4881 rab_out.rab$l_fab = &fab_out;
4882 rab_out.rab$l_rbf = ubf;
4883 if (!((sts = sys$connect(&rab_out)) & 1)) {
4884 sys$close(&fab_in); sys$close(&fab_out);
4885 set_errno(EVMSERR); set_vaxc_errno(sts);
4889 while ((sts = sys$read(&rab_in))) { /* always true */
4890 if (sts == RMS$_EOF) break;
4891 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4892 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4893 sys$close(&fab_in); sys$close(&fab_out);
4894 set_errno(EVMSERR); set_vaxc_errno(sts);
4899 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4900 sys$close(&fab_in); sys$close(&fab_out);
4901 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4903 set_errno(EVMSERR); set_vaxc_errno(sts);
4909 } /* end of rmscopy() */
4913 /*** The following glue provides 'hooks' to make some of the routines
4914 * from this file available from Perl. These routines are sufficiently
4915 * basic, and are required sufficiently early in the build process,
4916 * that's it's nice to have them available to miniperl as well as the
4917 * full Perl, so they're set up here instead of in an extension. The
4918 * Perl code which handles importation of these names into a given
4919 * package lives in [.VMS]Filespec.pm in @INC.
4923 rmsexpand_fromperl(pTHX_ CV *cv)
4926 char *fspec, *defspec = NULL, *rslt;
4929 if (!items || items > 2)
4930 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4931 fspec = SvPV(ST(0),n_a);
4932 if (!fspec || !*fspec) XSRETURN_UNDEF;
4933 if (items == 2) defspec = SvPV(ST(1),n_a);
4935 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4936 ST(0) = sv_newmortal();
4937 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4942 vmsify_fromperl(pTHX_ CV *cv)
4948 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4949 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4950 ST(0) = sv_newmortal();
4951 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4956 unixify_fromperl(pTHX_ CV *cv)
4962 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
4963 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4964 ST(0) = sv_newmortal();
4965 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4970 fileify_fromperl(pTHX_ CV *cv)
4976 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
4977 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4978 ST(0) = sv_newmortal();
4979 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4984 pathify_fromperl(pTHX_ CV *cv)
4990 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
4991 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4992 ST(0) = sv_newmortal();
4993 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4998 vmspath_fromperl(pTHX_ CV *cv)
5004 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5005 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5006 ST(0) = sv_newmortal();
5007 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5012 unixpath_fromperl(pTHX_ CV *cv)
5018 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5019 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5020 ST(0) = sv_newmortal();
5021 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5026 candelete_fromperl(pTHX_ CV *cv)
5029 char fspec[NAM$C_MAXRSS+1], *fsp;
5034 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5036 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5037 if (SvTYPE(mysv) == SVt_PVGV) {
5038 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5039 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5046 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5047 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5053 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5058 rmscopy_fromperl(pTHX_ CV *cv)
5061 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5063 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5064 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5065 unsigned long int sts;
5070 if (items < 2 || items > 3)
5071 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5073 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5074 if (SvTYPE(mysv) == SVt_PVGV) {
5075 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5076 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5083 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5084 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5089 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5090 if (SvTYPE(mysv) == SVt_PVGV) {
5091 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5092 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5099 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5100 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5105 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5107 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5114 char* file = __FILE__;
5116 char temp_buff[512];
5117 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5118 no_translate_barewords = TRUE;
5120 no_translate_barewords = FALSE;
5123 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5124 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5125 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5126 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5127 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5128 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5129 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5130 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5131 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);