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. "
623 "Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
626 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
632 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
633 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
634 set_errno(EVMSERR); break;
635 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
636 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
637 set_errno(EINVAL); break;
644 set_vaxc_errno(retsts);
645 return (int) retsts || 44; /* retsts should never be 0, but just in case */
648 /* We reset error values on success because Perl does an hv_fetch()
649 * before each hv_store(), and if the thing we're setting didn't
650 * previously exist, we've got a leftover error message. (Of course,
651 * this fails in the face of
652 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
653 * in that the error reported in $! isn't spurious,
654 * but it's right more often than not.)
656 set_errno(0); set_vaxc_errno(retsts);
660 } /* end of vmssetenv() */
663 /*{{{ void my_setenv(char *lnm, char *eqv)*/
664 /* This has to be a function since there's a prototype for it in proto.h */
666 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
668 if (lnm && *lnm && strlen(lnm) == 7) {
671 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
672 if (!strcmp(uplnm,"DEFAULT")) {
673 if (eqv && *eqv) chdir(eqv);
677 (void) vmssetenv(lnm,eqv,NULL);
683 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
684 /* my_crypt - VMS password hashing
685 * my_crypt() provides an interface compatible with the Unix crypt()
686 * C library function, and uses sys$hash_password() to perform VMS
687 * password hashing. The quadword hashed password value is returned
688 * as a NUL-terminated 8 character string. my_crypt() does not change
689 * the case of its string arguments; in order to match the behavior
690 * of LOGINOUT et al., alphabetic characters in both arguments must
691 * be upcased by the caller.
694 my_crypt(const char *textpasswd, const char *usrname)
696 # ifndef UAI$C_PREFERRED_ALGORITHM
697 # define UAI$C_PREFERRED_ALGORITHM 127
699 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
700 unsigned short int salt = 0;
701 unsigned long int sts;
703 unsigned short int dsc$w_length;
704 unsigned char dsc$b_type;
705 unsigned char dsc$b_class;
706 const char * dsc$a_pointer;
707 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
708 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
709 struct itmlst_3 uailst[3] = {
710 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
711 { sizeof salt, UAI$_SALT, &salt, 0},
712 { 0, 0, NULL, NULL}};
715 usrdsc.dsc$w_length = strlen(usrname);
716 usrdsc.dsc$a_pointer = usrname;
717 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
724 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
730 if (sts != RMS$_RNF) return NULL;
733 txtdsc.dsc$w_length = strlen(textpasswd);
734 txtdsc.dsc$a_pointer = textpasswd;
735 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
736 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
739 return (char *) hash;
741 } /* end of my_crypt() */
745 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
746 static char *do_fileify_dirspec(char *, char *, int);
747 static char *do_tovmsspec(char *, char *, int);
749 /*{{{int do_rmdir(char *name)*/
753 char dirfile[NAM$C_MAXRSS+1];
757 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
758 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
759 else retval = kill_file(dirfile);
762 } /* end of do_rmdir */
766 * Delete any file to which user has control access, regardless of whether
767 * delete access is explicitly allowed.
768 * Limitations: User must have write access to parent directory.
769 * Does not block signals or ASTs; if interrupted in midstream
770 * may leave file with an altered ACL.
773 /*{{{int kill_file(char *name)*/
775 kill_file(char *name)
777 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
778 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
779 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
781 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
783 unsigned char myace$b_length;
784 unsigned char myace$b_type;
785 unsigned short int myace$w_flags;
786 unsigned long int myace$l_access;
787 unsigned long int myace$l_ident;
788 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
789 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
790 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
792 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
793 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
794 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
795 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
796 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
797 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
799 /* Expand the input spec using RMS, since the CRTL remove() and
800 * system services won't do this by themselves, so we may miss
801 * a file "hiding" behind a logical name or search list. */
802 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
803 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
804 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
805 /* If not, can changing protections help? */
806 if (vaxc$errno != RMS$_PRV) return -1;
808 /* No, so we get our own UIC to use as a rights identifier,
809 * and the insert an ACE at the head of the ACL which allows us
810 * to delete the file.
812 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
813 fildsc.dsc$w_length = strlen(rspec);
814 fildsc.dsc$a_pointer = rspec;
816 newace.myace$l_ident = oldace.myace$l_ident;
817 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
822 case SS$_NOSUCHOBJECT:
823 set_errno(ENOENT); break;
825 set_errno(ENODEV); break;
827 case SS$_INVFILFOROP:
828 set_errno(EINVAL); break;
830 set_errno(EACCES); break;
834 set_vaxc_errno(aclsts);
837 /* Grab any existing ACEs with this identifier in case we fail */
838 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
839 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
840 || fndsts == SS$_NOMOREACE ) {
841 /* Add the new ACE . . . */
842 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
844 if ((rmsts = remove(name))) {
845 /* We blew it - dir with files in it, no write priv for
846 * parent directory, etc. Put things back the way they were. */
847 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
850 addlst[0].bufadr = &oldace;
851 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
858 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
859 /* We just deleted it, so of course it's not there. Some versions of
860 * VMS seem to return success on the unlock operation anyhow (after all
861 * the unlock is successful), but others don't.
863 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
864 if (aclsts & 1) aclsts = fndsts;
867 set_vaxc_errno(aclsts);
873 } /* end of kill_file() */
877 /*{{{int my_mkdir(char *,Mode_t)*/
879 my_mkdir(char *dir, Mode_t mode)
881 STRLEN dirlen = strlen(dir);
884 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
885 * null file name/type. However, it's commonplace under Unix,
886 * so we'll allow it for a gain in portability.
888 if (dir[dirlen-1] == '/') {
889 char *newdir = savepvn(dir,dirlen-1);
890 int ret = mkdir(newdir,mode);
894 else return mkdir(dir,mode);
895 } /* end of my_mkdir */
900 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
902 static unsigned long int mbxbufsiz;
903 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
908 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
909 * preprocessor consant BUFSIZ from stdio.h as the size of the
912 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
913 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
915 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
917 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
918 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
920 } /* end of create_mbx() */
922 /*{{{ my_popen and my_pclose*/
925 struct pipe_details *next;
926 PerlIO *fp; /* stdio file pointer to pipe mailbox */
927 int pid; /* PID of subprocess */
928 int mode; /* == 'r' if pipe open for reading */
929 int done; /* subprocess has completed */
930 unsigned long int completion; /* termination status of subprocess */
933 struct exit_control_block
935 struct exit_control_block *flink;
936 unsigned long int (*exit_routine)();
937 unsigned long int arg_count;
938 unsigned long int *status_address;
939 unsigned long int exit_status;
942 static struct pipe_details *open_pipes = NULL;
943 static $DESCRIPTOR(nl_desc, "NL:");
944 static int waitpid_asleep = 0;
946 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
947 * to a mbx; that's the caller's responsibility.
949 static unsigned long int
950 pipe_eof(FILE *fp, int immediate)
952 char devnam[NAM$C_MAXRSS+1], *cp;
953 unsigned long int chan, iosb[2], retsts, retsts2;
954 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
957 if (fgetname(fp,devnam,1)) {
958 /* It oughta be a mailbox, so fgetname should give just the device
959 * name, but just in case . . . */
960 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
961 devdsc.dsc$w_length = strlen(devnam);
962 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
963 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
964 iosb,0,0,0,0,0,0,0,0);
965 if (retsts & 1) retsts = iosb[0];
966 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
967 if (retsts & 1) retsts = retsts2;
971 else _ckvmssts(vaxc$errno); /* Should never happen */
972 return (unsigned long int) vaxc$errno;
975 static unsigned long int
978 struct pipe_details *info;
979 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
984 first we try sending an EOF...ignore if doesn't work, make sure we
991 if (info->mode != 'r' && !info->done) {
992 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
996 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1001 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1002 sts = sys$forcex(&info->pid,0,&abort);
1003 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1008 if (did_stuff) sleep(1); /* wait for them to respond */
1012 if (!info->done) { /* We tried to be nice . . . */
1013 sts = sys$delprc(&info->pid,0);
1014 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1015 info->done = 1; /* so my_pclose doesn't try to write EOF */
1021 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1022 else if (!(sts & 1)) retsts = sts;
1027 static struct exit_control_block pipe_exitblock =
1028 {(struct exit_control_block *) 0,
1029 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1033 popen_completion_ast(struct pipe_details *thispipe)
1035 thispipe->done = TRUE;
1036 if (waitpid_asleep) {
1042 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1043 static void vms_execfree();
1046 safe_popen(char *cmd, char *mode)
1048 static int handler_set_up = FALSE;
1050 unsigned short int chan;
1051 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1053 struct pipe_details *info;
1054 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1055 DSC$K_CLASS_S, mbxname},
1056 cmddsc = {0, DSC$K_DTYPE_T,
1060 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1061 New(1301,info,1,struct pipe_details);
1063 /* create mailbox */
1064 create_mbx(&chan,&namdsc);
1066 /* open a FILE* onto it */
1067 info->fp = PerlIO_open(mbxname, mode);
1069 /* give up other channel onto it */
1070 _ckvmssts(sys$dassgn(chan));
1080 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1081 0 /* name */, &info->pid, &info->completion,
1082 0, popen_completion_ast,info,0,0,0));
1085 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1086 0 /* name */, &info->pid, &info->completion,
1087 0, popen_completion_ast,info,0,0,0));
1091 if (!handler_set_up) {
1092 _ckvmssts(sys$dclexh(&pipe_exitblock));
1093 handler_set_up = TRUE;
1095 info->next=open_pipes; /* prepend to list */
1098 PL_forkprocess = info->pid;
1100 } /* end of safe_popen */
1103 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1105 Perl_my_popen(pTHX_ char *cmd, char *mode)
1108 TAINT_PROPER("popen");
1109 PERL_FLUSHALL_FOR_CHILD;
1110 return safe_popen(cmd,mode);
1115 /*{{{ I32 my_pclose(FILE *fp)*/
1116 I32 Perl_my_pclose(pTHX_ FILE *fp)
1118 struct pipe_details *info, *last = NULL;
1119 unsigned long int retsts;
1121 for (info = open_pipes; info != NULL; last = info, info = info->next)
1122 if (info->fp == fp) break;
1124 if (info == NULL) { /* no such pipe open */
1125 set_errno(ECHILD); /* quoth POSIX */
1126 set_vaxc_errno(SS$_NONEXPR);
1130 /* If we were writing to a subprocess, insure that someone reading from
1131 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1132 * produce an EOF record in the mailbox. */
1133 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,1);
1134 PerlIO_close(info->fp);
1136 if (info->done) retsts = info->completion;
1137 else waitpid(info->pid,(int *) &retsts,0);
1139 /* remove from list of open pipes */
1140 if (last) last->next = info->next;
1141 else open_pipes = info->next;
1146 } /* end of my_pclose() */
1148 /* sort-of waitpid; use only with popen() */
1149 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1151 my_waitpid(Pid_t pid, int *statusp, int flags)
1153 struct pipe_details *info;
1156 for (info = open_pipes; info != NULL; info = info->next)
1157 if (info->pid == pid) break;
1159 if (info != NULL) { /* we know about this child */
1160 while (!info->done) {
1165 *statusp = info->completion;
1168 else { /* we haven't heard of this child */
1169 $DESCRIPTOR(intdsc,"0 00:00:01");
1170 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1171 unsigned long int interval[2],sts;
1173 if (ckWARN(WARN_EXEC)) {
1174 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1175 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1176 if (ownerpid != mypid)
1177 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1180 _ckvmssts(sys$bintim(&intdsc,interval));
1181 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1182 _ckvmssts(sys$schdwk(0,0,interval,0));
1183 _ckvmssts(sys$hiber());
1187 /* There's no easy way to find the termination status a child we're
1188 * not aware of beforehand. If we're really interested in the future,
1189 * we can go looking for a termination mailbox, or chase after the
1190 * accounting record for the process.
1196 } /* end of waitpid() */
1201 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1203 my_gconvert(double val, int ndig, int trail, char *buf)
1205 static char __gcvtbuf[DBL_DIG+1];
1208 loc = buf ? buf : __gcvtbuf;
1210 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1212 sprintf(loc,"%.*g",ndig,val);
1218 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1219 return gcvt(val,ndig,loc);
1222 loc[0] = '0'; loc[1] = '\0';
1230 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1231 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1232 * to expand file specification. Allows for a single default file
1233 * specification and a simple mask of options. If outbuf is non-NULL,
1234 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1235 * the resultant file specification is placed. If outbuf is NULL, the
1236 * resultant file specification is placed into a static buffer.
1237 * The third argument, if non-NULL, is taken to be a default file
1238 * specification string. The fourth argument is unused at present.
1239 * rmesexpand() returns the address of the resultant string if
1240 * successful, and NULL on error.
1242 static char *do_tounixspec(char *, char *, int);
1245 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1247 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1248 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1249 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1250 struct FAB myfab = cc$rms_fab;
1251 struct NAM mynam = cc$rms_nam;
1253 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1255 if (!filespec || !*filespec) {
1256 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1260 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1261 else outbuf = __rmsexpand_retbuf;
1263 if ((isunix = (strchr(filespec,'/') != NULL))) {
1264 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1265 filespec = vmsfspec;
1268 myfab.fab$l_fna = filespec;
1269 myfab.fab$b_fns = strlen(filespec);
1270 myfab.fab$l_nam = &mynam;
1272 if (defspec && *defspec) {
1273 if (strchr(defspec,'/') != NULL) {
1274 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1277 myfab.fab$l_dna = defspec;
1278 myfab.fab$b_dns = strlen(defspec);
1281 mynam.nam$l_esa = esa;
1282 mynam.nam$b_ess = sizeof esa;
1283 mynam.nam$l_rsa = outbuf;
1284 mynam.nam$b_rss = NAM$C_MAXRSS;
1286 retsts = sys$parse(&myfab,0,0);
1287 if (!(retsts & 1)) {
1288 mynam.nam$b_nop |= NAM$M_SYNCHK;
1289 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1290 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1291 retsts = sys$parse(&myfab,0,0);
1292 if (retsts & 1) goto expanded;
1294 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1295 (void) sys$parse(&myfab,0,0); /* Free search context */
1296 if (out) Safefree(out);
1297 set_vaxc_errno(retsts);
1298 if (retsts == RMS$_PRV) set_errno(EACCES);
1299 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1300 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1301 else set_errno(EVMSERR);
1304 retsts = sys$search(&myfab,0,0);
1305 if (!(retsts & 1) && retsts != RMS$_FNF) {
1306 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1307 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1308 if (out) Safefree(out);
1309 set_vaxc_errno(retsts);
1310 if (retsts == RMS$_PRV) set_errno(EACCES);
1311 else set_errno(EVMSERR);
1315 /* If the input filespec contained any lowercase characters,
1316 * downcase the result for compatibility with Unix-minded code. */
1318 for (out = myfab.fab$l_fna; *out; out++)
1319 if (islower(*out)) { haslower = 1; break; }
1320 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1321 else { out = esa; speclen = mynam.nam$b_esl; }
1322 /* Trim off null fields added by $PARSE
1323 * If type > 1 char, must have been specified in original or default spec
1324 * (not true for version; $SEARCH may have added version of existing file).
1326 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1327 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1328 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1329 if (trimver || trimtype) {
1330 if (defspec && *defspec) {
1331 char defesa[NAM$C_MAXRSS];
1332 struct FAB deffab = cc$rms_fab;
1333 struct NAM defnam = cc$rms_nam;
1335 deffab.fab$l_nam = &defnam;
1336 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1337 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1338 defnam.nam$b_nop = NAM$M_SYNCHK;
1339 if (sys$parse(&deffab,0,0) & 1) {
1340 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1341 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1344 if (trimver) speclen = mynam.nam$l_ver - out;
1346 /* If we didn't already trim version, copy down */
1347 if (speclen > mynam.nam$l_ver - out)
1348 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1349 speclen - (mynam.nam$l_ver - out));
1350 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1353 /* If we just had a directory spec on input, $PARSE "helpfully"
1354 * adds an empty name and type for us */
1355 if (mynam.nam$l_name == mynam.nam$l_type &&
1356 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1357 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1358 speclen = mynam.nam$l_name - out;
1359 out[speclen] = '\0';
1360 if (haslower) __mystrtolower(out);
1362 /* Have we been working with an expanded, but not resultant, spec? */
1363 /* Also, convert back to Unix syntax if necessary. */
1364 if (!mynam.nam$b_rsl) {
1366 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1368 else strcpy(outbuf,esa);
1371 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1372 strcpy(outbuf,tmpfspec);
1374 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1375 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1376 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1380 /* External entry points */
1381 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1382 { return do_rmsexpand(spec,buf,0,def,opt); }
1383 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1384 { return do_rmsexpand(spec,buf,1,def,opt); }
1388 ** The following routines are provided to make life easier when
1389 ** converting among VMS-style and Unix-style directory specifications.
1390 ** All will take input specifications in either VMS or Unix syntax. On
1391 ** failure, all return NULL. If successful, the routines listed below
1392 ** return a pointer to a buffer containing the appropriately
1393 ** reformatted spec (and, therefore, subsequent calls to that routine
1394 ** will clobber the result), while the routines of the same names with
1395 ** a _ts suffix appended will return a pointer to a mallocd string
1396 ** containing the appropriately reformatted spec.
1397 ** In all cases, only explicit syntax is altered; no check is made that
1398 ** the resulting string is valid or that the directory in question
1401 ** fileify_dirspec() - convert a directory spec into the name of the
1402 ** directory file (i.e. what you can stat() to see if it's a dir).
1403 ** The style (VMS or Unix) of the result is the same as the style
1404 ** of the parameter passed in.
1405 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1406 ** what you prepend to a filename to indicate what directory it's in).
1407 ** The style (VMS or Unix) of the result is the same as the style
1408 ** of the parameter passed in.
1409 ** tounixpath() - convert a directory spec into a Unix-style path.
1410 ** tovmspath() - convert a directory spec into a VMS-style path.
1411 ** tounixspec() - convert any file spec into a Unix-style file spec.
1412 ** tovmsspec() - convert any file spec into a VMS-style spec.
1414 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1415 ** Permission is given to distribute this code as part of the Perl
1416 ** standard distribution under the terms of the GNU General Public
1417 ** License or the Perl Artistic License. Copies of each may be
1418 ** found in the Perl standard distribution.
1421 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1422 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1424 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1425 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1426 char *retspec, *cp1, *cp2, *lastdir;
1427 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1429 if (!dir || !*dir) {
1430 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1432 dirlen = strlen(dir);
1433 while (dir[dirlen-1] == '/') --dirlen;
1434 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1435 strcpy(trndir,"/sys$disk/000000");
1439 if (dirlen > NAM$C_MAXRSS) {
1440 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1442 if (!strpbrk(dir+1,"/]>:")) {
1443 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1444 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1446 dirlen = strlen(dir);
1449 strncpy(trndir,dir,dirlen);
1450 trndir[dirlen] = '\0';
1453 /* If we were handed a rooted logical name or spec, treat it like a
1454 * simple directory, so that
1455 * $ Define myroot dev:[dir.]
1456 * ... do_fileify_dirspec("myroot",buf,1) ...
1457 * does something useful.
1459 if (!strcmp(dir+dirlen-2,".]")) {
1460 dir[--dirlen] = '\0';
1461 dir[dirlen-1] = ']';
1464 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1465 /* If we've got an explicit filename, we can just shuffle the string. */
1466 if (*(cp1+1)) hasfilename = 1;
1467 /* Similarly, we can just back up a level if we've got multiple levels
1468 of explicit directories in a VMS spec which ends with directories. */
1470 for (cp2 = cp1; cp2 > dir; cp2--) {
1472 *cp2 = *cp1; *cp1 = '\0';
1476 if (*cp2 == '[' || *cp2 == '<') break;
1481 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1482 if (dir[0] == '.') {
1483 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1484 return do_fileify_dirspec("[]",buf,ts);
1485 else if (dir[1] == '.' &&
1486 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1487 return do_fileify_dirspec("[-]",buf,ts);
1489 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1490 dirlen -= 1; /* to last element */
1491 lastdir = strrchr(dir,'/');
1493 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1494 /* If we have "/." or "/..", VMSify it and let the VMS code
1495 * below expand it, rather than repeating the code to handle
1496 * relative components of a filespec here */
1498 if (*(cp1+2) == '.') cp1++;
1499 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1500 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1501 if (strchr(vmsdir,'/') != NULL) {
1502 /* If do_tovmsspec() returned it, it must have VMS syntax
1503 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1504 * the time to check this here only so we avoid a recursion
1505 * loop; otherwise, gigo.
1507 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1509 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1510 return do_tounixspec(trndir,buf,ts);
1513 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1514 lastdir = strrchr(dir,'/');
1516 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1517 /* Ditto for specs that end in an MFD -- let the VMS code
1518 * figure out whether it's a real device or a rooted logical. */
1519 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1520 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1521 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1522 return do_tounixspec(trndir,buf,ts);
1525 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1526 !(lastdir = cp1 = strrchr(dir,']')) &&
1527 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1528 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1530 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1531 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1532 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1533 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1534 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1535 (ver || *cp3)))))) {
1537 set_vaxc_errno(RMS$_DIR);
1543 /* If we lead off with a device or rooted logical, add the MFD
1544 if we're specifying a top-level directory. */
1545 if (lastdir && *dir == '/') {
1547 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1554 retlen = dirlen + (addmfd ? 13 : 6);
1555 if (buf) retspec = buf;
1556 else if (ts) New(1309,retspec,retlen+1,char);
1557 else retspec = __fileify_retbuf;
1559 dirlen = lastdir - dir;
1560 memcpy(retspec,dir,dirlen);
1561 strcpy(&retspec[dirlen],"/000000");
1562 strcpy(&retspec[dirlen+7],lastdir);
1565 memcpy(retspec,dir,dirlen);
1566 retspec[dirlen] = '\0';
1568 /* We've picked up everything up to the directory file name.
1569 Now just add the type and version, and we're set. */
1570 strcat(retspec,".dir;1");
1573 else { /* VMS-style directory spec */
1574 char esa[NAM$C_MAXRSS+1], term, *cp;
1575 unsigned long int sts, cmplen, haslower = 0;
1576 struct FAB dirfab = cc$rms_fab;
1577 struct NAM savnam, dirnam = cc$rms_nam;
1579 dirfab.fab$b_fns = strlen(dir);
1580 dirfab.fab$l_fna = dir;
1581 dirfab.fab$l_nam = &dirnam;
1582 dirfab.fab$l_dna = ".DIR;1";
1583 dirfab.fab$b_dns = 6;
1584 dirnam.nam$b_ess = NAM$C_MAXRSS;
1585 dirnam.nam$l_esa = esa;
1587 for (cp = dir; *cp; cp++)
1588 if (islower(*cp)) { haslower = 1; break; }
1589 if (!((sts = sys$parse(&dirfab))&1)) {
1590 if (dirfab.fab$l_sts == RMS$_DIR) {
1591 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1592 sts = sys$parse(&dirfab) & 1;
1596 set_vaxc_errno(dirfab.fab$l_sts);
1602 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1603 /* Yes; fake the fnb bits so we'll check type below */
1604 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1606 else { /* No; just work with potential name */
1607 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1609 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1610 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1611 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1616 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1617 cp1 = strchr(esa,']');
1618 if (!cp1) cp1 = strchr(esa,'>');
1619 if (cp1) { /* Should always be true */
1620 dirnam.nam$b_esl -= cp1 - esa - 1;
1621 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1624 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1625 /* Yep; check version while we're at it, if it's there. */
1626 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1627 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1628 /* Something other than .DIR[;1]. Bzzt. */
1629 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1630 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1632 set_vaxc_errno(RMS$_DIR);
1636 esa[dirnam.nam$b_esl] = '\0';
1637 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1638 /* They provided at least the name; we added the type, if necessary, */
1639 if (buf) retspec = buf; /* in sys$parse() */
1640 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1641 else retspec = __fileify_retbuf;
1642 strcpy(retspec,esa);
1643 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1644 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1647 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1648 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1650 dirnam.nam$b_esl -= 9;
1652 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1653 if (cp1 == NULL) { /* should never happen */
1654 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1655 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1660 retlen = strlen(esa);
1661 if ((cp1 = strrchr(esa,'.')) != NULL) {
1662 /* There's more than one directory in the path. Just roll back. */
1664 if (buf) retspec = buf;
1665 else if (ts) New(1311,retspec,retlen+7,char);
1666 else retspec = __fileify_retbuf;
1667 strcpy(retspec,esa);
1670 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1671 /* Go back and expand rooted logical name */
1672 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1673 if (!(sys$parse(&dirfab) & 1)) {
1674 dirnam.nam$l_rlf = NULL;
1675 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1677 set_vaxc_errno(dirfab.fab$l_sts);
1680 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1681 if (buf) retspec = buf;
1682 else if (ts) New(1312,retspec,retlen+16,char);
1683 else retspec = __fileify_retbuf;
1684 cp1 = strstr(esa,"][");
1686 memcpy(retspec,esa,dirlen);
1687 if (!strncmp(cp1+2,"000000]",7)) {
1688 retspec[dirlen-1] = '\0';
1689 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1690 if (*cp1 == '.') *cp1 = ']';
1692 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1693 memcpy(cp1+1,"000000]",7);
1697 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1698 retspec[retlen] = '\0';
1699 /* Convert last '.' to ']' */
1700 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1701 if (*cp1 == '.') *cp1 = ']';
1703 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1704 memcpy(cp1+1,"000000]",7);
1708 else { /* This is a top-level dir. Add the MFD to the path. */
1709 if (buf) retspec = buf;
1710 else if (ts) New(1312,retspec,retlen+16,char);
1711 else retspec = __fileify_retbuf;
1714 while (*cp1 != ':') *(cp2++) = *(cp1++);
1715 strcpy(cp2,":[000000]");
1720 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1721 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1722 /* We've set up the string up through the filename. Add the
1723 type and version, and we're done. */
1724 strcat(retspec,".DIR;1");
1726 /* $PARSE may have upcased filespec, so convert output to lower
1727 * case if input contained any lowercase characters. */
1728 if (haslower) __mystrtolower(retspec);
1731 } /* end of do_fileify_dirspec() */
1733 /* External entry points */
1734 char *fileify_dirspec(char *dir, char *buf)
1735 { return do_fileify_dirspec(dir,buf,0); }
1736 char *fileify_dirspec_ts(char *dir, char *buf)
1737 { return do_fileify_dirspec(dir,buf,1); }
1739 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1740 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1742 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1743 unsigned long int retlen;
1744 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1746 if (!dir || !*dir) {
1747 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1750 if (*dir) strcpy(trndir,dir);
1751 else getcwd(trndir,sizeof trndir - 1);
1753 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1754 && my_trnlnm(trndir,trndir,0)) {
1755 STRLEN trnlen = strlen(trndir);
1757 /* Trap simple rooted lnms, and return lnm:[000000] */
1758 if (!strcmp(trndir+trnlen-2,".]")) {
1759 if (buf) retpath = buf;
1760 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1761 else retpath = __pathify_retbuf;
1762 strcpy(retpath,dir);
1763 strcat(retpath,":[000000]");
1769 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1770 if (*dir == '.' && (*(dir+1) == '\0' ||
1771 (*(dir+1) == '.' && *(dir+2) == '\0')))
1772 retlen = 2 + (*(dir+1) != '\0');
1774 if ( !(cp1 = strrchr(dir,'/')) &&
1775 !(cp1 = strrchr(dir,']')) &&
1776 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1777 if ((cp2 = strchr(cp1,'.')) != NULL &&
1778 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1779 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1780 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1781 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1783 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1784 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1785 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1786 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1787 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1788 (ver || *cp3)))))) {
1790 set_vaxc_errno(RMS$_DIR);
1793 retlen = cp2 - dir + 1;
1795 else { /* No file type present. Treat the filename as a directory. */
1796 retlen = strlen(dir) + 1;
1799 if (buf) retpath = buf;
1800 else if (ts) New(1313,retpath,retlen+1,char);
1801 else retpath = __pathify_retbuf;
1802 strncpy(retpath,dir,retlen-1);
1803 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1804 retpath[retlen-1] = '/'; /* with '/', add it. */
1805 retpath[retlen] = '\0';
1807 else retpath[retlen-1] = '\0';
1809 else { /* VMS-style directory spec */
1810 char esa[NAM$C_MAXRSS+1], *cp;
1811 unsigned long int sts, cmplen, haslower;
1812 struct FAB dirfab = cc$rms_fab;
1813 struct NAM savnam, dirnam = cc$rms_nam;
1815 /* If we've got an explicit filename, we can just shuffle the string. */
1816 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1817 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1818 if ((cp2 = strchr(cp1,'.')) != NULL) {
1820 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1821 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1822 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1823 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1824 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1825 (ver || *cp3)))))) {
1827 set_vaxc_errno(RMS$_DIR);
1831 else { /* No file type, so just draw name into directory part */
1832 for (cp2 = cp1; *cp2; cp2++) ;
1835 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1837 /* We've now got a VMS 'path'; fall through */
1839 dirfab.fab$b_fns = strlen(dir);
1840 dirfab.fab$l_fna = dir;
1841 if (dir[dirfab.fab$b_fns-1] == ']' ||
1842 dir[dirfab.fab$b_fns-1] == '>' ||
1843 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1844 if (buf) retpath = buf;
1845 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1846 else retpath = __pathify_retbuf;
1847 strcpy(retpath,dir);
1850 dirfab.fab$l_dna = ".DIR;1";
1851 dirfab.fab$b_dns = 6;
1852 dirfab.fab$l_nam = &dirnam;
1853 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1854 dirnam.nam$l_esa = esa;
1856 for (cp = dir; *cp; cp++)
1857 if (islower(*cp)) { haslower = 1; break; }
1859 if (!(sts = (sys$parse(&dirfab)&1))) {
1860 if (dirfab.fab$l_sts == RMS$_DIR) {
1861 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1862 sts = sys$parse(&dirfab) & 1;
1866 set_vaxc_errno(dirfab.fab$l_sts);
1872 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1873 if (dirfab.fab$l_sts != RMS$_FNF) {
1874 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1875 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1877 set_vaxc_errno(dirfab.fab$l_sts);
1880 dirnam = savnam; /* No; just work with potential name */
1883 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1884 /* Yep; check version while we're at it, if it's there. */
1885 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1886 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1887 /* Something other than .DIR[;1]. Bzzt. */
1888 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1889 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1891 set_vaxc_errno(RMS$_DIR);
1895 /* OK, the type was fine. Now pull any file name into the
1897 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1899 cp1 = strrchr(esa,'>');
1900 *dirnam.nam$l_type = '>';
1903 *(dirnam.nam$l_type + 1) = '\0';
1904 retlen = dirnam.nam$l_type - esa + 2;
1905 if (buf) retpath = buf;
1906 else if (ts) New(1314,retpath,retlen,char);
1907 else retpath = __pathify_retbuf;
1908 strcpy(retpath,esa);
1909 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1910 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1911 /* $PARSE may have upcased filespec, so convert output to lower
1912 * case if input contained any lowercase characters. */
1913 if (haslower) __mystrtolower(retpath);
1917 } /* end of do_pathify_dirspec() */
1919 /* External entry points */
1920 char *pathify_dirspec(char *dir, char *buf)
1921 { return do_pathify_dirspec(dir,buf,0); }
1922 char *pathify_dirspec_ts(char *dir, char *buf)
1923 { return do_pathify_dirspec(dir,buf,1); }
1925 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1926 static char *do_tounixspec(char *spec, char *buf, int ts)
1928 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1929 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1930 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1932 if (spec == NULL) return NULL;
1933 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1934 if (buf) rslt = buf;
1936 retlen = strlen(spec);
1937 cp1 = strchr(spec,'[');
1938 if (!cp1) cp1 = strchr(spec,'<');
1940 for (cp1++; *cp1; cp1++) {
1941 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1942 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1943 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1946 New(1315,rslt,retlen+2+2*expand,char);
1948 else rslt = __tounixspec_retbuf;
1949 if (strchr(spec,'/') != NULL) {
1956 dirend = strrchr(spec,']');
1957 if (dirend == NULL) dirend = strrchr(spec,'>');
1958 if (dirend == NULL) dirend = strchr(spec,':');
1959 if (dirend == NULL) {
1963 if (*cp2 != '[' && *cp2 != '<') {
1966 else { /* the VMS spec begins with directories */
1968 if (*cp2 == ']' || *cp2 == '>') {
1969 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1972 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1973 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1974 if (ts) Safefree(rslt);
1979 while (*cp3 != ':' && *cp3) cp3++;
1981 if (strchr(cp3,']') != NULL) break;
1982 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1984 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1985 retlen = devlen + dirlen;
1986 Renew(rslt,retlen+1+2*expand,char);
1992 *(cp1++) = *(cp3++);
1993 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1997 else if ( *cp2 == '.') {
1998 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1999 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2005 for (; cp2 <= dirend; cp2++) {
2008 if (*(cp2+1) == '[') cp2++;
2010 else if (*cp2 == ']' || *cp2 == '>') {
2011 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2013 else if (*cp2 == '.') {
2015 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2016 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2017 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2018 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2019 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2021 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2022 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2026 else if (*cp2 == '-') {
2027 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2028 while (*cp2 == '-') {
2030 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2032 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2033 if (ts) Safefree(rslt); /* filespecs like */
2034 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2038 else *(cp1++) = *cp2;
2040 else *(cp1++) = *cp2;
2042 while (*cp2) *(cp1++) = *(cp2++);
2047 } /* end of do_tounixspec() */
2049 /* External entry points */
2050 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2051 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2053 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2054 static char *do_tovmsspec(char *path, char *buf, int ts) {
2055 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2056 char *rslt, *dirend;
2057 register char *cp1, *cp2;
2058 unsigned long int infront = 0, hasdir = 1;
2060 if (path == NULL) return NULL;
2061 if (buf) rslt = buf;
2062 else if (ts) New(1316,rslt,strlen(path)+9,char);
2063 else rslt = __tovmsspec_retbuf;
2064 if (strpbrk(path,"]:>") ||
2065 (dirend = strrchr(path,'/')) == NULL) {
2066 if (path[0] == '.') {
2067 if (path[1] == '\0') strcpy(rslt,"[]");
2068 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2069 else strcpy(rslt,path); /* probably garbage */
2071 else strcpy(rslt,path);
2074 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2075 if (!*(dirend+2)) dirend +=2;
2076 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2077 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2082 char trndev[NAM$C_MAXRSS+1];
2086 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2088 if (!buf & ts) Renew(rslt,18,char);
2089 strcpy(rslt,"sys$disk:[000000]");
2092 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2094 islnm = my_trnlnm(rslt,trndev,0);
2095 trnend = islnm ? strlen(trndev) - 1 : 0;
2096 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2097 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2098 /* If the first element of the path is a logical name, determine
2099 * whether it has to be translated so we can add more directories. */
2100 if (!islnm || rooted) {
2103 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2107 if (cp2 != dirend) {
2108 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2109 strcpy(rslt,trndev);
2110 cp1 = rslt + trnend;
2123 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2124 cp2 += 2; /* skip over "./" - it's redundant */
2125 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2127 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2128 *(cp1++) = '-'; /* "../" --> "-" */
2131 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2132 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2133 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2134 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2137 if (cp2 > dirend) cp2 = dirend;
2139 else *(cp1++) = '.';
2141 for (; cp2 < dirend; cp2++) {
2143 if (*(cp2-1) == '/') continue;
2144 if (*(cp1-1) != '.') *(cp1++) = '.';
2147 else if (!infront && *cp2 == '.') {
2148 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2149 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2150 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
2151 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-';
2152 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2154 /* if (*(cp1-1) != '.') *(cp1++) = '.'; */
2158 if (cp2 == dirend) break;
2160 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2161 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2162 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2163 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2165 *(cp1++) = '.'; /* Simulate trailing '/' */
2166 cp2 += 2; /* for loop will incr this to == dirend */
2168 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2170 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2173 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2174 if (*cp2 == '.') *(cp1++) = '_';
2175 else *(cp1++) = *cp2;
2179 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2180 if (hasdir) *(cp1++) = ']';
2181 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2182 while (*cp2) *(cp1++) = *(cp2++);
2187 } /* end of do_tovmsspec() */
2189 /* External entry points */
2190 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2191 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2193 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2194 static char *do_tovmspath(char *path, char *buf, int ts) {
2195 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2197 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2199 if (path == NULL) return NULL;
2200 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2201 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2202 if (buf) return buf;
2204 vmslen = strlen(vmsified);
2205 New(1317,cp,vmslen+1,char);
2206 memcpy(cp,vmsified,vmslen);
2211 strcpy(__tovmspath_retbuf,vmsified);
2212 return __tovmspath_retbuf;
2215 } /* end of do_tovmspath() */
2217 /* External entry points */
2218 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2219 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2222 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2223 static char *do_tounixpath(char *path, char *buf, int ts) {
2224 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2226 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2228 if (path == NULL) return NULL;
2229 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2230 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2231 if (buf) return buf;
2233 unixlen = strlen(unixified);
2234 New(1317,cp,unixlen+1,char);
2235 memcpy(cp,unixified,unixlen);
2240 strcpy(__tounixpath_retbuf,unixified);
2241 return __tounixpath_retbuf;
2244 } /* end of do_tounixpath() */
2246 /* External entry points */
2247 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2248 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2251 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2253 *****************************************************************************
2255 * Copyright (C) 1989-1994 by *
2256 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2258 * Permission is hereby granted for the reproduction of this software, *
2259 * on condition that this copyright notice is included in the reproduction, *
2260 * and that such reproduction is not for purposes of profit or material *
2263 * 27-Aug-1994 Modified for inclusion in perl5 *
2264 * by Charles Bailey bailey@newman.upenn.edu *
2265 *****************************************************************************
2269 * getredirection() is intended to aid in porting C programs
2270 * to VMS (Vax-11 C). The native VMS environment does not support
2271 * '>' and '<' I/O redirection, or command line wild card expansion,
2272 * or a command line pipe mechanism using the '|' AND background
2273 * command execution '&'. All of these capabilities are provided to any
2274 * C program which calls this procedure as the first thing in the
2276 * The piping mechanism will probably work with almost any 'filter' type
2277 * of program. With suitable modification, it may useful for other
2278 * portability problems as well.
2280 * Author: Mark Pizzolato mark@infocomm.com
2284 struct list_item *next;
2288 static void add_item(struct list_item **head,
2289 struct list_item **tail,
2293 static void expand_wild_cards(char *item,
2294 struct list_item **head,
2295 struct list_item **tail,
2298 static int background_process(int argc, char **argv);
2300 static void pipe_and_fork(char **cmargv);
2302 /*{{{ void getredirection(int *ac, char ***av)*/
2304 getredirection(int *ac, char ***av)
2306 * Process vms redirection arg's. Exit if any error is seen.
2307 * If getredirection() processes an argument, it is erased
2308 * from the vector. getredirection() returns a new argc and argv value.
2309 * In the event that a background command is requested (by a trailing "&"),
2310 * this routine creates a background subprocess, and simply exits the program.
2312 * Warning: do not try to simplify the code for vms. The code
2313 * presupposes that getredirection() is called before any data is
2314 * read from stdin or written to stdout.
2316 * Normal usage is as follows:
2322 * getredirection(&argc, &argv);
2326 int argc = *ac; /* Argument Count */
2327 char **argv = *av; /* Argument Vector */
2328 char *ap; /* Argument pointer */
2329 int j; /* argv[] index */
2330 int item_count = 0; /* Count of Items in List */
2331 struct list_item *list_head = 0; /* First Item in List */
2332 struct list_item *list_tail; /* Last Item in List */
2333 char *in = NULL; /* Input File Name */
2334 char *out = NULL; /* Output File Name */
2335 char *outmode = "w"; /* Mode to Open Output File */
2336 char *err = NULL; /* Error File Name */
2337 char *errmode = "w"; /* Mode to Open Error File */
2338 int cmargc = 0; /* Piped Command Arg Count */
2339 char **cmargv = NULL;/* Piped Command Arg Vector */
2342 * First handle the case where the last thing on the line ends with
2343 * a '&'. This indicates the desire for the command to be run in a
2344 * subprocess, so we satisfy that desire.
2347 if (0 == strcmp("&", ap))
2348 exit(background_process(--argc, argv));
2349 if (*ap && '&' == ap[strlen(ap)-1])
2351 ap[strlen(ap)-1] = '\0';
2352 exit(background_process(argc, argv));
2355 * Now we handle the general redirection cases that involve '>', '>>',
2356 * '<', and pipes '|'.
2358 for (j = 0; j < argc; ++j)
2360 if (0 == strcmp("<", argv[j]))
2364 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2365 exit(LIB$_WRONUMARG);
2370 if ('<' == *(ap = argv[j]))
2375 if (0 == strcmp(">", ap))
2379 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2380 exit(LIB$_WRONUMARG);
2399 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2400 exit(LIB$_WRONUMARG);
2404 if (('2' == *ap) && ('>' == ap[1]))
2421 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2422 exit(LIB$_WRONUMARG);
2426 if (0 == strcmp("|", argv[j]))
2430 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2431 exit(LIB$_WRONUMARG);
2433 cmargc = argc-(j+1);
2434 cmargv = &argv[j+1];
2438 if ('|' == *(ap = argv[j]))
2446 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2449 * Allocate and fill in the new argument vector, Some Unix's terminate
2450 * the list with an extra null pointer.
2452 New(1302, argv, item_count+1, char *);
2454 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2455 argv[j] = list_head->value;
2461 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2462 exit(LIB$_INVARGORD);
2464 pipe_and_fork(cmargv);
2467 /* Check for input from a pipe (mailbox) */
2469 if (in == NULL && 1 == isapipe(0))
2471 char mbxname[L_tmpnam];
2473 long int dvi_item = DVI$_DEVBUFSIZ;
2474 $DESCRIPTOR(mbxnam, "");
2475 $DESCRIPTOR(mbxdevnam, "");
2477 /* Input from a pipe, reopen it in binary mode to disable */
2478 /* carriage control processing. */
2480 PerlIO_getname(stdin, mbxname);
2481 mbxnam.dsc$a_pointer = mbxname;
2482 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2483 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2484 mbxdevnam.dsc$a_pointer = mbxname;
2485 mbxdevnam.dsc$w_length = sizeof(mbxname);
2486 dvi_item = DVI$_DEVNAM;
2487 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2488 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2491 freopen(mbxname, "rb", stdin);
2494 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2498 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2500 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2503 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2505 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2510 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2512 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2516 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2521 #ifdef ARGPROC_DEBUG
2522 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2523 for (j = 0; j < *ac; ++j)
2524 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2526 /* Clear errors we may have hit expanding wildcards, so they don't
2527 show up in Perl's $! later */
2528 set_errno(0); set_vaxc_errno(1);
2529 } /* end of getredirection() */
2532 static void add_item(struct list_item **head,
2533 struct list_item **tail,
2539 New(1303,*head,1,struct list_item);
2543 New(1304,(*tail)->next,1,struct list_item);
2544 *tail = (*tail)->next;
2546 (*tail)->value = value;
2550 static void expand_wild_cards(char *item,
2551 struct list_item **head,
2552 struct list_item **tail,
2556 unsigned long int context = 0;
2562 char vmsspec[NAM$C_MAXRSS+1];
2563 $DESCRIPTOR(filespec, "");
2564 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2565 $DESCRIPTOR(resultspec, "");
2566 unsigned long int zero = 0, sts;
2568 for (cp = item; *cp; cp++) {
2569 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2570 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2572 if (!*cp || isspace(*cp))
2574 add_item(head, tail, item, count);
2577 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2578 resultspec.dsc$b_class = DSC$K_CLASS_D;
2579 resultspec.dsc$a_pointer = NULL;
2580 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2581 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2582 if (!isunix || !filespec.dsc$a_pointer)
2583 filespec.dsc$a_pointer = item;
2584 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2586 * Only return version specs, if the caller specified a version
2588 had_version = strchr(item, ';');
2590 * Only return device and directory specs, if the caller specifed either.
2592 had_device = strchr(item, ':');
2593 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2595 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2596 &defaultspec, 0, 0, &zero))))
2601 New(1305,string,resultspec.dsc$w_length+1,char);
2602 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2603 string[resultspec.dsc$w_length] = '\0';
2604 if (NULL == had_version)
2605 *((char *)strrchr(string, ';')) = '\0';
2606 if ((!had_directory) && (had_device == NULL))
2608 if (NULL == (devdir = strrchr(string, ']')))
2609 devdir = strrchr(string, '>');
2610 strcpy(string, devdir + 1);
2613 * Be consistent with what the C RTL has already done to the rest of
2614 * the argv items and lowercase all of these names.
2616 for (c = string; *c; ++c)
2619 if (isunix) trim_unixpath(string,item,1);
2620 add_item(head, tail, string, count);
2623 if (sts != RMS$_NMF)
2625 set_vaxc_errno(sts);
2631 set_errno(ENOENT); break;
2633 set_errno(ENODEV); break;
2636 set_errno(EINVAL); break;
2638 set_errno(EACCES); break;
2640 _ckvmssts_noperl(sts);
2644 add_item(head, tail, item, count);
2645 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2646 _ckvmssts_noperl(lib$find_file_end(&context));
2649 static int child_st[2];/* Event Flag set when child process completes */
2651 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2653 static unsigned long int exit_handler(int *status)
2657 if (0 == child_st[0])
2659 #ifdef ARGPROC_DEBUG
2660 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2662 fflush(stdout); /* Have to flush pipe for binary data to */
2663 /* terminate properly -- <tp@mccall.com> */
2664 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2665 sys$dassgn(child_chan);
2667 sys$synch(0, child_st);
2672 static void sig_child(int chan)
2674 #ifdef ARGPROC_DEBUG
2675 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2677 if (child_st[0] == 0)
2681 static struct exit_control_block exit_block =
2686 &exit_block.exit_status,
2690 static void pipe_and_fork(char **cmargv)
2693 $DESCRIPTOR(cmddsc, "");
2694 static char mbxname[64];
2695 $DESCRIPTOR(mbxdsc, mbxname);
2697 unsigned long int zero = 0, one = 1;
2699 strcpy(subcmd, cmargv[0]);
2700 for (j = 1; NULL != cmargv[j]; ++j)
2702 strcat(subcmd, " \"");
2703 strcat(subcmd, cmargv[j]);
2704 strcat(subcmd, "\"");
2706 cmddsc.dsc$a_pointer = subcmd;
2707 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2709 create_mbx(&child_chan,&mbxdsc);
2710 #ifdef ARGPROC_DEBUG
2711 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2712 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2714 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2715 0, &pid, child_st, &zero, sig_child,
2717 #ifdef ARGPROC_DEBUG
2718 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2720 sys$dclexh(&exit_block);
2721 if (NULL == freopen(mbxname, "wb", stdout))
2723 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2727 static int background_process(int argc, char **argv)
2729 char command[2048] = "$";
2730 $DESCRIPTOR(value, "");
2731 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2732 static $DESCRIPTOR(null, "NLA0:");
2733 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2735 $DESCRIPTOR(pidstr, "");
2737 unsigned long int flags = 17, one = 1, retsts;
2739 strcat(command, argv[0]);
2742 strcat(command, " \"");
2743 strcat(command, *(++argv));
2744 strcat(command, "\"");
2746 value.dsc$a_pointer = command;
2747 value.dsc$w_length = strlen(value.dsc$a_pointer);
2748 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2749 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2750 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2751 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2754 _ckvmssts_noperl(retsts);
2756 #ifdef ARGPROC_DEBUG
2757 PerlIO_printf(Perl_debug_log, "%s\n", command);
2759 sprintf(pidstring, "%08X", pid);
2760 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2761 pidstr.dsc$a_pointer = pidstring;
2762 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2763 lib$set_symbol(&pidsymbol, &pidstr);
2767 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2770 /* OS-specific initialization at image activation (not thread startup) */
2771 /* Older VAXC header files lack these constants */
2772 #ifndef JPI$_RIGHTS_SIZE
2773 # define JPI$_RIGHTS_SIZE 817
2775 #ifndef KGB$M_SUBSYSTEM
2776 # define KGB$M_SUBSYSTEM 0x8
2779 /*{{{void vms_image_init(int *, char ***)*/
2781 vms_image_init(int *argcp, char ***argvp)
2783 char eqv[LNM$C_NAMLENGTH+1] = "";
2784 unsigned int len, tabct = 8, tabidx = 0;
2785 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2786 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2787 unsigned short int dummy, rlen;
2788 struct dsc$descriptor_s **tabvec;
2790 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2791 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2792 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2795 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2797 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2798 if (iprv[i]) { /* Running image installed with privs? */
2799 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2804 /* Rights identifiers might trigger tainting as well. */
2805 if (!will_taint && (rlen || rsz)) {
2806 while (rlen < rsz) {
2807 /* We didn't get all the identifiers on the first pass. Allocate a
2808 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2809 * were needed to hold all identifiers at time of last call; we'll
2810 * allocate that many unsigned long ints), and go back and get 'em.
2812 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2813 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2814 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2815 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2818 mask = jpilist[1].bufadr;
2819 /* Check attribute flags for each identifier (2nd longword); protected
2820 * subsystem identifiers trigger tainting.
2822 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2823 if (mask[i] & KGB$M_SUBSYSTEM) {
2828 if (mask != rlst) Safefree(mask);
2830 /* We need to use this hack to tell Perl it should run with tainting,
2831 * since its tainting flag may be part of the PL_curinterp struct, which
2832 * hasn't been allocated when vms_image_init() is called.
2836 New(1320,newap,*argcp+2,char **);
2837 newap[0] = argvp[0];
2839 Copy(argvp[1],newap[2],*argcp-1,char **);
2840 /* We orphan the old argv, since we don't know where it's come from,
2841 * so we don't know how to free it.
2843 *argcp++; argvp = newap;
2845 else { /* Did user explicitly request tainting? */
2847 char *cp, **av = *argvp;
2848 for (i = 1; i < *argcp; i++) {
2849 if (*av[i] != '-') break;
2850 for (cp = av[i]+1; *cp; cp++) {
2851 if (*cp == 'T') { will_taint = 1; break; }
2852 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2853 strchr("DFIiMmx",*cp)) break;
2855 if (will_taint) break;
2860 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2862 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2863 else if (tabidx >= tabct) {
2865 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2867 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2868 tabvec[tabidx]->dsc$w_length = 0;
2869 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2870 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2871 tabvec[tabidx]->dsc$a_pointer = NULL;
2872 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2874 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2876 getredirection(argcp,argvp);
2877 #if defined(USE_THREADS) && defined(__DECC)
2879 # include <reentrancy.h>
2880 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2889 * Trim Unix-style prefix off filespec, so it looks like what a shell
2890 * glob expansion would return (i.e. from specified prefix on, not
2891 * full path). Note that returned filespec is Unix-style, regardless
2892 * of whether input filespec was VMS-style or Unix-style.
2894 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2895 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2896 * vector of options; at present, only bit 0 is used, and if set tells
2897 * trim unixpath to try the current default directory as a prefix when
2898 * presented with a possibly ambiguous ... wildcard.
2900 * Returns !=0 on success, with trimmed filespec replacing contents of
2901 * fspec, and 0 on failure, with contents of fpsec unchanged.
2903 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2905 trim_unixpath(char *fspec, char *wildspec, int opts)
2907 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2908 *template, *base, *end, *cp1, *cp2;
2909 register int tmplen, reslen = 0, dirs = 0;
2911 if (!wildspec || !fspec) return 0;
2912 if (strpbrk(wildspec,"]>:") != NULL) {
2913 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2914 else template = unixwild;
2916 else template = wildspec;
2917 if (strpbrk(fspec,"]>:") != NULL) {
2918 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2919 else base = unixified;
2920 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2921 * check to see that final result fits into (isn't longer than) fspec */
2922 reslen = strlen(fspec);
2926 /* No prefix or absolute path on wildcard, so nothing to remove */
2927 if (!*template || *template == '/') {
2928 if (base == fspec) return 1;
2929 tmplen = strlen(unixified);
2930 if (tmplen > reslen) return 0; /* not enough space */
2931 /* Copy unixified resultant, including trailing NUL */
2932 memmove(fspec,unixified,tmplen+1);
2936 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2937 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2938 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2939 for (cp1 = end ;cp1 >= base; cp1--)
2940 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2942 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2946 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2947 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2948 int ells = 1, totells, segdirs, match;
2949 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2950 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2952 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2954 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2955 if (ellipsis == template && opts & 1) {
2956 /* Template begins with an ellipsis. Since we can't tell how many
2957 * directory names at the front of the resultant to keep for an
2958 * arbitrary starting point, we arbitrarily choose the current
2959 * default directory as a starting point. If it's there as a prefix,
2960 * clip it off. If not, fall through and act as if the leading
2961 * ellipsis weren't there (i.e. return shortest possible path that
2962 * could match template).
2964 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2965 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2966 if (_tolower(*cp1) != _tolower(*cp2)) break;
2967 segdirs = dirs - totells; /* Min # of dirs we must have left */
2968 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2969 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2970 memcpy(fspec,cp2+1,end - cp2);
2974 /* First off, back up over constant elements at end of path */
2976 for (front = end ; front >= base; front--)
2977 if (*front == '/' && !dirs--) { front++; break; }
2979 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2980 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2981 if (cp1 != '\0') return 0; /* Path too long. */
2983 *cp2 = '\0'; /* Pick up with memcpy later */
2984 lcfront = lcres + (front - base);
2985 /* Now skip over each ellipsis and try to match the path in front of it. */
2987 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2988 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2989 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2990 if (cp1 < template) break; /* template started with an ellipsis */
2991 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2992 ellipsis = cp1; continue;
2994 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2996 for (segdirs = 0, cp2 = tpl;
2997 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2999 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3000 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3001 if (*cp2 == '/') segdirs++;
3003 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3004 /* Back up at least as many dirs as in template before matching */
3005 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3006 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3007 for (match = 0; cp1 > lcres;) {
3008 resdsc.dsc$a_pointer = cp1;
3009 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3011 if (match == 1) lcfront = cp1;
3013 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3015 if (!match) return 0; /* Can't find prefix ??? */
3016 if (match > 1 && opts & 1) {
3017 /* This ... wildcard could cover more than one set of dirs (i.e.
3018 * a set of similar dir names is repeated). If the template
3019 * contains more than 1 ..., upstream elements could resolve the
3020 * ambiguity, but it's not worth a full backtracking setup here.
3021 * As a quick heuristic, clip off the current default directory
3022 * if it's present to find the trimmed spec, else use the
3023 * shortest string that this ... could cover.
3025 char def[NAM$C_MAXRSS+1], *st;
3027 if (getcwd(def, sizeof def,0) == NULL) return 0;
3028 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3029 if (_tolower(*cp1) != _tolower(*cp2)) break;
3030 segdirs = dirs - totells; /* Min # of dirs we must have left */
3031 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3032 if (*cp1 == '\0' && *cp2 == '/') {
3033 memcpy(fspec,cp2+1,end - cp2);
3036 /* Nope -- stick with lcfront from above and keep going. */
3039 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3044 } /* end of trim_unixpath() */
3049 * VMS readdir() routines.
3050 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3052 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3053 * Minor modifications to original routines.
3056 /* Number of elements in vms_versions array */
3057 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3060 * Open a directory, return a handle for later use.
3062 /*{{{ DIR *opendir(char*name) */
3067 char dir[NAM$C_MAXRSS+1];
3070 if (do_tovmspath(name,dir,0) == NULL) {
3073 if (flex_stat(dir,&sb) == -1) return NULL;
3074 if (!S_ISDIR(sb.st_mode)) {
3075 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3078 if (!cando_by_name(S_IRUSR,0,dir)) {
3079 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3082 /* Get memory for the handle, and the pattern. */
3084 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3086 /* Fill in the fields; mainly playing with the descriptor. */
3087 (void)sprintf(dd->pattern, "%s*.*",dir);
3090 dd->vms_wantversions = 0;
3091 dd->pat.dsc$a_pointer = dd->pattern;
3092 dd->pat.dsc$w_length = strlen(dd->pattern);
3093 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3094 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3097 } /* end of opendir() */
3101 * Set the flag to indicate we want versions or not.
3103 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3105 vmsreaddirversions(DIR *dd, int flag)
3107 dd->vms_wantversions = flag;
3112 * Free up an opened directory.
3114 /*{{{ void closedir(DIR *dd)*/
3118 (void)lib$find_file_end(&dd->context);
3119 Safefree(dd->pattern);
3120 Safefree((char *)dd);
3125 * Collect all the version numbers for the current file.
3131 struct dsc$descriptor_s pat;
3132 struct dsc$descriptor_s res;
3134 char *p, *text, buff[sizeof dd->entry.d_name];
3136 unsigned long context, tmpsts;
3139 /* Convenient shorthand. */
3142 /* Add the version wildcard, ignoring the "*.*" put on before */
3143 i = strlen(dd->pattern);
3144 New(1308,text,i + e->d_namlen + 3,char);
3145 (void)strcpy(text, dd->pattern);
3146 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3148 /* Set up the pattern descriptor. */
3149 pat.dsc$a_pointer = text;
3150 pat.dsc$w_length = i + e->d_namlen - 1;
3151 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3152 pat.dsc$b_class = DSC$K_CLASS_S;
3154 /* Set up result descriptor. */
3155 res.dsc$a_pointer = buff;
3156 res.dsc$w_length = sizeof buff - 2;
3157 res.dsc$b_dtype = DSC$K_DTYPE_T;
3158 res.dsc$b_class = DSC$K_CLASS_S;
3160 /* Read files, collecting versions. */
3161 for (context = 0, e->vms_verscount = 0;
3162 e->vms_verscount < VERSIZE(e);
3163 e->vms_verscount++) {
3164 tmpsts = lib$find_file(&pat, &res, &context);
3165 if (tmpsts == RMS$_NMF || context == 0) break;
3167 buff[sizeof buff - 1] = '\0';
3168 if ((p = strchr(buff, ';')))
3169 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3171 e->vms_versions[e->vms_verscount] = -1;
3174 _ckvmssts(lib$find_file_end(&context));
3177 } /* end of collectversions() */
3180 * Read the next entry from the directory.
3182 /*{{{ struct dirent *readdir(DIR *dd)*/
3186 struct dsc$descriptor_s res;
3187 char *p, buff[sizeof dd->entry.d_name];
3188 unsigned long int tmpsts;
3190 /* Set up result descriptor, and get next file. */
3191 res.dsc$a_pointer = buff;
3192 res.dsc$w_length = sizeof buff - 2;
3193 res.dsc$b_dtype = DSC$K_DTYPE_T;
3194 res.dsc$b_class = DSC$K_CLASS_S;
3195 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3196 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3197 if (!(tmpsts & 1)) {
3198 set_vaxc_errno(tmpsts);
3201 set_errno(EACCES); break;
3203 set_errno(ENODEV); break;
3206 set_errno(ENOENT); break;
3213 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3214 buff[sizeof buff - 1] = '\0';
3215 for (p = buff; *p; p++) *p = _tolower(*p);
3216 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3219 /* Skip any directory component and just copy the name. */
3220 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3221 else (void)strcpy(dd->entry.d_name, buff);
3223 /* Clobber the version. */
3224 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3226 dd->entry.d_namlen = strlen(dd->entry.d_name);
3227 dd->entry.vms_verscount = 0;
3228 if (dd->vms_wantversions) collectversions(dd);
3231 } /* end of readdir() */
3235 * Return something that can be used in a seekdir later.
3237 /*{{{ long telldir(DIR *dd)*/
3246 * Return to a spot where we used to be. Brute force.
3248 /*{{{ void seekdir(DIR *dd,long count)*/
3250 seekdir(DIR *dd, long count)
3252 int vms_wantversions;
3255 /* If we haven't done anything yet... */
3259 /* Remember some state, and clear it. */
3260 vms_wantversions = dd->vms_wantversions;
3261 dd->vms_wantversions = 0;
3262 _ckvmssts(lib$find_file_end(&dd->context));
3265 /* The increment is in readdir(). */
3266 for (dd->count = 0; dd->count < count; )
3269 dd->vms_wantversions = vms_wantversions;
3271 } /* end of seekdir() */
3274 /* VMS subprocess management
3276 * my_vfork() - just a vfork(), after setting a flag to record that
3277 * the current script is trying a Unix-style fork/exec.
3279 * vms_do_aexec() and vms_do_exec() are called in response to the
3280 * perl 'exec' function. If this follows a vfork call, then they
3281 * call out the the regular perl routines in doio.c which do an
3282 * execvp (for those who really want to try this under VMS).
3283 * Otherwise, they do exactly what the perl docs say exec should
3284 * do - terminate the current script and invoke a new command
3285 * (See below for notes on command syntax.)
3287 * do_aspawn() and do_spawn() implement the VMS side of the perl
3288 * 'system' function.
3290 * Note on command arguments to perl 'exec' and 'system': When handled
3291 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3292 * are concatenated to form a DCL command string. If the first arg
3293 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3294 * the the command string is handed off to DCL directly. Otherwise,
3295 * the first token of the command is taken as the filespec of an image
3296 * to run. The filespec is expanded using a default type of '.EXE' and
3297 * the process defaults for device, directory, etc., and if found, the resultant
3298 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3299 * the command string as parameters. This is perhaps a bit complicated,
3300 * but I hope it will form a happy medium between what VMS folks expect
3301 * from lib$spawn and what Unix folks expect from exec.
3304 static int vfork_called;
3306 /*{{{int my_vfork()*/
3319 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3322 if (VMScmd.dsc$a_pointer) {
3323 Safefree(VMScmd.dsc$a_pointer);
3324 VMScmd.dsc$w_length = 0;
3325 VMScmd.dsc$a_pointer = Nullch;
3330 setup_argstr(SV *really, SV **mark, SV **sp)
3333 char *junk, *tmps = Nullch;
3334 register size_t cmdlen = 0;
3341 tmps = SvPV(really,rlen);
3348 for (idx++; idx <= sp; idx++) {
3350 junk = SvPVx(*idx,rlen);
3351 cmdlen += rlen ? rlen + 1 : 0;
3354 New(401,PL_Cmd,cmdlen+1,char);
3356 if (tmps && *tmps) {
3357 strcpy(PL_Cmd,tmps);
3360 else *PL_Cmd = '\0';
3361 while (++mark <= sp) {
3363 char *s = SvPVx(*mark,n_a);
3365 if (*PL_Cmd) strcat(PL_Cmd," ");
3371 } /* end of setup_argstr() */
3374 static unsigned long int
3375 setup_cmddsc(char *cmd, int check_img)
3377 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3378 $DESCRIPTOR(defdsc,".EXE");
3379 $DESCRIPTOR(resdsc,resspec);
3380 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3381 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3382 register char *s, *rest, *cp, *wordbreak;
3387 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3390 while (*s && isspace(*s)) s++;
3392 if (*s == '@' || *s == '$') {
3393 vmsspec[0] = *s; rest = s + 1;
3394 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3396 else { cp = vmsspec; rest = s; }
3397 if (*rest == '.' || *rest == '/') {
3400 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3401 rest++, cp2++) *cp2 = *rest;
3403 if (do_tovmsspec(resspec,cp,0)) {
3406 for (cp2 = vmsspec + strlen(vmsspec);
3407 *rest && cp2 - vmsspec < sizeof vmsspec;
3408 rest++, cp2++) *cp2 = *rest;
3413 /* Intuit whether verb (first word of cmd) is a DCL command:
3414 * - if first nonspace char is '@', it's a DCL indirection
3416 * - if verb contains a filespec separator, it's not a DCL command
3417 * - if it doesn't, caller tells us whether to default to a DCL
3418 * command, or to a local image unless told it's DCL (by leading '$')
3420 if (*s == '@') isdcl = 1;
3422 register char *filespec = strpbrk(s,":<[.;");
3423 rest = wordbreak = strpbrk(s," \"\t/");
3424 if (!wordbreak) wordbreak = s + strlen(s);
3425 if (*s == '$') check_img = 0;
3426 if (filespec && (filespec < wordbreak)) isdcl = 0;
3427 else isdcl = !check_img;
3431 imgdsc.dsc$a_pointer = s;
3432 imgdsc.dsc$w_length = wordbreak - s;
3433 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3434 if (!(retsts & 1) && *s == '$') {
3435 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3436 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3437 _ckvmssts(lib$find_file_end(&cxt));
3441 while (*s && !isspace(*s)) s++;
3443 if (cando_by_name(S_IXUSR,0,resspec)) {
3444 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3445 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3446 strcat(VMScmd.dsc$a_pointer,resspec);
3447 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3448 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3451 else retsts = RMS$_PRV;
3454 /* It's either a DCL command or we couldn't find a suitable image */
3455 VMScmd.dsc$w_length = strlen(cmd);
3456 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3457 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3458 if (!(retsts & 1)) {
3459 /* just hand off status values likely to be due to user error */
3460 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3461 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3462 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3463 else { _ckvmssts(retsts); }
3466 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3468 } /* end of setup_cmddsc() */
3471 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3473 vms_do_aexec(SV *really,SV **mark,SV **sp)
3477 if (vfork_called) { /* this follows a vfork - act Unixish */
3479 if (vfork_called < 0) {
3480 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3483 else return do_aexec(really,mark,sp);
3485 /* no vfork - act VMSish */
3486 return vms_do_exec(setup_argstr(really,mark,sp));
3491 } /* end of vms_do_aexec() */
3494 /* {{{bool vms_do_exec(char *cmd) */
3496 vms_do_exec(char *cmd)
3500 if (vfork_called) { /* this follows a vfork - act Unixish */
3502 if (vfork_called < 0) {
3503 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3506 else return do_exec(cmd);
3509 { /* no vfork - act VMSish */
3510 unsigned long int retsts;
3513 TAINT_PROPER("exec");
3514 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3515 retsts = lib$do_command(&VMScmd);
3519 set_errno(ENOENT); break;
3520 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3521 set_errno(ENOTDIR); break;
3523 set_errno(EACCES); break;
3525 set_errno(EINVAL); break;
3527 set_errno(E2BIG); break;
3528 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3529 _ckvmssts(retsts); /* fall through */
3530 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3533 set_vaxc_errno(retsts);
3534 if (ckWARN(WARN_EXEC)) {
3535 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3536 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3543 } /* end of vms_do_exec() */
3546 unsigned long int do_spawn(char *);
3548 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3550 do_aspawn(void *really,void **mark,void **sp)
3553 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3556 } /* end of do_aspawn() */
3559 /* {{{unsigned long int do_spawn(char *cmd) */
3563 unsigned long int sts, substs, hadcmd = 1;
3567 TAINT_PROPER("spawn");
3568 if (!cmd || !*cmd) {
3570 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3572 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3573 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3579 set_errno(ENOENT); break;
3580 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3581 set_errno(ENOTDIR); break;
3583 set_errno(EACCES); break;
3585 set_errno(EINVAL); break;
3587 set_errno(E2BIG); break;
3588 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3589 _ckvmssts(sts); /* fall through */
3590 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3593 set_vaxc_errno(sts);
3594 if (ckWARN(WARN_EXEC)) {
3595 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3596 hadcmd ? VMScmd.dsc$w_length : 0,
3597 hadcmd ? VMScmd.dsc$a_pointer : "",
3604 } /* end of do_spawn() */
3608 * A simple fwrite replacement which outputs itmsz*nitm chars without
3609 * introducing record boundaries every itmsz chars.
3611 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3613 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3615 register char *cp, *end;
3617 end = (char *)src + itmsz * nitm;
3619 while ((char *)src <= end) {
3620 for (cp = src; cp <= end; cp++) if (!*cp) break;
3621 if (fputs(src,dest) == EOF) return EOF;
3623 if (fputc('\0',dest) == EOF) return EOF;
3629 } /* end of my_fwrite() */
3632 /*{{{ int my_flush(FILE *fp)*/
3637 if ((res = fflush(fp)) == 0 && fp) {
3638 #ifdef VMS_DO_SOCKETS
3640 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3642 res = fsync(fileno(fp));
3649 * Here are replacements for the following Unix routines in the VMS environment:
3650 * getpwuid Get information for a particular UIC or UID
3651 * getpwnam Get information for a named user
3652 * getpwent Get information for each user in the rights database
3653 * setpwent Reset search to the start of the rights database
3654 * endpwent Finish searching for users in the rights database
3656 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3657 * (defined in pwd.h), which contains the following fields:-
3659 * char *pw_name; Username (in lower case)
3660 * char *pw_passwd; Hashed password
3661 * unsigned int pw_uid; UIC
3662 * unsigned int pw_gid; UIC group number
3663 * char *pw_unixdir; Default device/directory (VMS-style)
3664 * char *pw_gecos; Owner name
3665 * char *pw_dir; Default device/directory (Unix-style)
3666 * char *pw_shell; Default CLI name (eg. DCL)
3668 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3670 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3671 * not the UIC member number (eg. what's returned by getuid()),
3672 * getpwuid() can accept either as input (if uid is specified, the caller's
3673 * UIC group is used), though it won't recognise gid=0.
3675 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3676 * information about other users in your group or in other groups, respectively.
3677 * If the required privilege is not available, then these routines fill only
3678 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3681 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3684 /* sizes of various UAF record fields */
3685 #define UAI$S_USERNAME 12
3686 #define UAI$S_IDENT 31
3687 #define UAI$S_OWNER 31
3688 #define UAI$S_DEFDEV 31
3689 #define UAI$S_DEFDIR 63
3690 #define UAI$S_DEFCLI 31
3693 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3694 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3695 (uic).uic$v_group != UIC$K_WILD_GROUP)
3697 static char __empty[]= "";
3698 static struct passwd __passwd_empty=
3699 {(char *) __empty, (char *) __empty, 0, 0,
3700 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3701 static int contxt= 0;
3702 static struct passwd __pwdcache;
3703 static char __pw_namecache[UAI$S_IDENT+1];
3706 * This routine does most of the work extracting the user information.
3708 static int fillpasswd (const char *name, struct passwd *pwd)
3712 unsigned char length;
3713 char pw_gecos[UAI$S_OWNER+1];
3715 static union uicdef uic;
3717 unsigned char length;
3718 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3721 unsigned char length;
3722 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3725 unsigned char length;
3726 char pw_shell[UAI$S_DEFCLI+1];
3728 static char pw_passwd[UAI$S_PWD+1];
3730 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3731 struct dsc$descriptor_s name_desc;
3732 unsigned long int sts;
3734 static struct itmlst_3 itmlst[]= {
3735 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3736 {sizeof(uic), UAI$_UIC, &uic, &luic},
3737 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3738 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3739 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3740 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3741 {0, 0, NULL, NULL}};
3743 name_desc.dsc$w_length= strlen(name);
3744 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3745 name_desc.dsc$b_class= DSC$K_CLASS_S;
3746 name_desc.dsc$a_pointer= (char *) name;
3748 /* Note that sys$getuai returns many fields as counted strings. */
3749 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3750 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3751 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3753 else { _ckvmssts(sts); }
3754 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3756 if ((int) owner.length < lowner) lowner= (int) owner.length;
3757 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3758 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3759 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3760 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3761 owner.pw_gecos[lowner]= '\0';
3762 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3763 defcli.pw_shell[ldefcli]= '\0';
3764 if (valid_uic(uic)) {
3765 pwd->pw_uid= uic.uic$l_uic;
3766 pwd->pw_gid= uic.uic$v_group;
3769 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3770 pwd->pw_passwd= pw_passwd;
3771 pwd->pw_gecos= owner.pw_gecos;
3772 pwd->pw_dir= defdev.pw_dir;
3773 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3774 pwd->pw_shell= defcli.pw_shell;
3775 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3777 ldir= strlen(pwd->pw_unixdir) - 1;
3778 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3781 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3782 __mystrtolower(pwd->pw_unixdir);
3787 * Get information for a named user.
3789 /*{{{struct passwd *getpwnam(char *name)*/
3790 struct passwd *my_getpwnam(char *name)
3792 struct dsc$descriptor_s name_desc;
3794 unsigned long int status, sts;
3797 __pwdcache = __passwd_empty;
3798 if (!fillpasswd(name, &__pwdcache)) {
3799 /* We still may be able to determine pw_uid and pw_gid */
3800 name_desc.dsc$w_length= strlen(name);
3801 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3802 name_desc.dsc$b_class= DSC$K_CLASS_S;
3803 name_desc.dsc$a_pointer= (char *) name;
3804 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3805 __pwdcache.pw_uid= uic.uic$l_uic;
3806 __pwdcache.pw_gid= uic.uic$v_group;
3809 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3810 set_vaxc_errno(sts);
3811 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3814 else { _ckvmssts(sts); }
3817 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3818 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3819 __pwdcache.pw_name= __pw_namecache;
3821 } /* end of my_getpwnam() */
3825 * Get information for a particular UIC or UID.
3826 * Called by my_getpwent with uid=-1 to list all users.
3828 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3829 struct passwd *my_getpwuid(Uid_t uid)
3831 const $DESCRIPTOR(name_desc,__pw_namecache);
3832 unsigned short lname;
3834 unsigned long int status;
3837 if (uid == (unsigned int) -1) {
3839 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3840 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3841 set_vaxc_errno(status);
3842 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3846 else { _ckvmssts(status); }
3847 } while (!valid_uic (uic));
3851 if (!uic.uic$v_group)
3852 uic.uic$v_group= PerlProc_getgid();
3854 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3855 else status = SS$_IVIDENT;
3856 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3857 status == RMS$_PRV) {
3858 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3861 else { _ckvmssts(status); }
3863 __pw_namecache[lname]= '\0';
3864 __mystrtolower(__pw_namecache);
3866 __pwdcache = __passwd_empty;
3867 __pwdcache.pw_name = __pw_namecache;
3869 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3870 The identifier's value is usually the UIC, but it doesn't have to be,
3871 so if we can, we let fillpasswd update this. */
3872 __pwdcache.pw_uid = uic.uic$l_uic;
3873 __pwdcache.pw_gid = uic.uic$v_group;
3875 fillpasswd(__pw_namecache, &__pwdcache);
3878 } /* end of my_getpwuid() */
3882 * Get information for next user.
3884 /*{{{struct passwd *my_getpwent()*/
3885 struct passwd *my_getpwent()
3887 return (my_getpwuid((unsigned int) -1));
3892 * Finish searching rights database for users.
3894 /*{{{void my_endpwent()*/
3899 _ckvmssts(sys$finish_rdb(&contxt));
3905 #ifdef HOMEGROWN_POSIX_SIGNALS
3906 /* Signal handling routines, pulled into the core from POSIX.xs.
3908 * We need these for threads, so they've been rolled into the core,
3909 * rather than left in POSIX.xs.
3911 * (DRS, Oct 23, 1997)
3914 /* sigset_t is atomic under VMS, so these routines are easy */
3915 /*{{{int my_sigemptyset(sigset_t *) */
3916 int my_sigemptyset(sigset_t *set) {
3917 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3923 /*{{{int my_sigfillset(sigset_t *)*/
3924 int my_sigfillset(sigset_t *set) {
3926 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3927 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3933 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3934 int my_sigaddset(sigset_t *set, int sig) {
3935 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3936 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3937 *set |= (1 << (sig - 1));
3943 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3944 int my_sigdelset(sigset_t *set, int sig) {
3945 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3946 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3947 *set &= ~(1 << (sig - 1));
3953 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3954 int my_sigismember(sigset_t *set, int sig) {
3955 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3956 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3957 *set & (1 << (sig - 1));
3962 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3963 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3966 /* If set and oset are both null, then things are badly wrong. Bail out. */
3967 if ((oset == NULL) && (set == NULL)) {
3968 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3972 /* If set's null, then we're just handling a fetch. */
3974 tempmask = sigblock(0);
3979 tempmask = sigsetmask(*set);
3982 tempmask = sigblock(*set);
3985 tempmask = sigblock(0);
3986 sigsetmask(*oset & ~tempmask);
3989 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3994 /* Did they pass us an oset? If so, stick our holding mask into it */
4001 #endif /* HOMEGROWN_POSIX_SIGNALS */
4004 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4005 * my_utime(), and flex_stat(), all of which operate on UTC unless
4006 * VMSISH_TIMES is true.
4008 /* method used to handle UTC conversions:
4009 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4011 static int gmtime_emulation_type;
4012 /* number of secs to add to UTC POSIX-style time to get local time */
4013 static long int utc_offset_secs;
4015 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4016 * in vmsish.h. #undef them here so we can call the CRTL routines
4023 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4024 # define RTL_USES_UTC 1
4028 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4029 * qualifier with the extern prefix pragma. This provisional
4030 * hack circumvents this prefix pragma problem in previous
4033 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4034 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4035 # pragma __extern_prefix save
4036 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4037 # define gmtime decc$__utctz_gmtime
4038 # define localtime decc$__utctz_localtime
4039 # define time decc$__utc_time
4040 # pragma __extern_prefix restore
4042 struct tm *gmtime(), *localtime();
4048 static time_t toutc_dst(time_t loc) {
4051 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4052 loc -= utc_offset_secs;
4053 if (rsltmp->tm_isdst) loc -= 3600;
4056 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4057 ((gmtime_emulation_type || my_time(NULL)), \
4058 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4059 ((secs) - utc_offset_secs))))
4061 static time_t toloc_dst(time_t utc) {
4064 utc += utc_offset_secs;
4065 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4066 if (rsltmp->tm_isdst) utc += 3600;
4069 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4070 ((gmtime_emulation_type || my_time(NULL)), \
4071 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4072 ((secs) + utc_offset_secs))))
4075 /* my_time(), my_localtime(), my_gmtime()
4076 * By default traffic in UTC time values, using CRTL gmtime() or
4077 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4078 * Note: We need to use these functions even when the CRTL has working
4079 * UTC support, since they also handle C<use vmsish qw(times);>
4081 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4082 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4085 /*{{{time_t my_time(time_t *timep)*/
4086 time_t my_time(time_t *timep)
4092 if (gmtime_emulation_type == 0) {
4094 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4095 /* results of calls to gmtime() and localtime() */
4096 /* for same &base */
4098 gmtime_emulation_type++;
4099 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4100 char off[LNM$C_NAMLENGTH+1];;
4102 gmtime_emulation_type++;
4103 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4104 gmtime_emulation_type++;
4105 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4107 else { utc_offset_secs = atol(off); }
4109 else { /* We've got a working gmtime() */
4110 struct tm gmt, local;
4113 tm_p = localtime(&base);
4115 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4116 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4117 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4118 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4124 # ifdef RTL_USES_UTC
4125 if (VMSISH_TIME) when = _toloc(when);
4127 if (!VMSISH_TIME) when = _toutc(when);
4130 if (timep != NULL) *timep = when;
4133 } /* end of my_time() */
4137 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4139 my_gmtime(const time_t *timep)
4146 if (timep == NULL) {
4147 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4150 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4154 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4156 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4157 return gmtime(&when);
4159 /* CRTL localtime() wants local time as input, so does no tz correction */
4160 rsltmp = localtime(&when);
4161 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4164 } /* end of my_gmtime() */
4168 /*{{{struct tm *my_localtime(const time_t *timep)*/
4170 my_localtime(const time_t *timep)
4176 if (timep == NULL) {
4177 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4180 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4181 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4184 # ifdef RTL_USES_UTC
4186 if (VMSISH_TIME) when = _toutc(when);
4188 /* CRTL localtime() wants UTC as input, does tz correction itself */
4189 return localtime(&when);
4192 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4195 /* CRTL localtime() wants local time as input, so does no tz correction */
4196 rsltmp = localtime(&when);
4197 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4200 } /* end of my_localtime() */
4203 /* Reset definitions for later calls */
4204 #define gmtime(t) my_gmtime(t)
4205 #define localtime(t) my_localtime(t)
4206 #define time(t) my_time(t)
4209 /* my_utime - update modification time of a file
4210 * calling sequence is identical to POSIX utime(), but under
4211 * VMS only the modification time is changed; ODS-2 does not
4212 * maintain access times. Restrictions differ from the POSIX
4213 * definition in that the time can be changed as long as the
4214 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4215 * no separate checks are made to insure that the caller is the
4216 * owner of the file or has special privs enabled.
4217 * Code here is based on Joe Meadows' FILE utility.
4220 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4221 * to VMS epoch (01-JAN-1858 00:00:00.00)
4222 * in 100 ns intervals.
4224 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4226 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4227 int my_utime(char *file, struct utimbuf *utimes)
4231 long int bintime[2], len = 2, lowbit, unixtime,
4232 secscale = 10000000; /* seconds --> 100 ns intervals */
4233 unsigned long int chan, iosb[2], retsts;
4234 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4235 struct FAB myfab = cc$rms_fab;
4236 struct NAM mynam = cc$rms_nam;
4237 #if defined (__DECC) && defined (__VAX)
4238 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4239 * at least through VMS V6.1, which causes a type-conversion warning.
4241 # pragma message save
4242 # pragma message disable cvtdiftypes
4244 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4245 struct fibdef myfib;
4246 #if defined (__DECC) && defined (__VAX)
4247 /* This should be right after the declaration of myatr, but due
4248 * to a bug in VAX DEC C, this takes effect a statement early.
4250 # pragma message restore
4252 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4253 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4254 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4256 if (file == NULL || *file == '\0') {
4258 set_vaxc_errno(LIB$_INVARG);
4261 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4263 if (utimes != NULL) {
4264 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4265 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4266 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4267 * as input, we force the sign bit to be clear by shifting unixtime right
4268 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4270 lowbit = (utimes->modtime & 1) ? secscale : 0;
4271 unixtime = (long int) utimes->modtime;
4273 /* If input was UTC; convert to local for sys svc */
4274 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4276 unixtime >>= 1; secscale <<= 1;
4277 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4278 if (!(retsts & 1)) {
4280 set_vaxc_errno(retsts);
4283 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4284 if (!(retsts & 1)) {
4286 set_vaxc_errno(retsts);
4291 /* Just get the current time in VMS format directly */
4292 retsts = sys$gettim(bintime);
4293 if (!(retsts & 1)) {
4295 set_vaxc_errno(retsts);
4300 myfab.fab$l_fna = vmsspec;
4301 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4302 myfab.fab$l_nam = &mynam;
4303 mynam.nam$l_esa = esa;
4304 mynam.nam$b_ess = (unsigned char) sizeof esa;
4305 mynam.nam$l_rsa = rsa;
4306 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4308 /* Look for the file to be affected, letting RMS parse the file
4309 * specification for us as well. I have set errno using only
4310 * values documented in the utime() man page for VMS POSIX.
4312 retsts = sys$parse(&myfab,0,0);
4313 if (!(retsts & 1)) {
4314 set_vaxc_errno(retsts);
4315 if (retsts == RMS$_PRV) set_errno(EACCES);
4316 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4317 else set_errno(EVMSERR);
4320 retsts = sys$search(&myfab,0,0);
4321 if (!(retsts & 1)) {
4322 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4323 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4324 set_vaxc_errno(retsts);
4325 if (retsts == RMS$_PRV) set_errno(EACCES);
4326 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4327 else set_errno(EVMSERR);
4331 devdsc.dsc$w_length = mynam.nam$b_dev;
4332 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4334 retsts = sys$assign(&devdsc,&chan,0,0);
4335 if (!(retsts & 1)) {
4336 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4337 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4338 set_vaxc_errno(retsts);
4339 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4340 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4341 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4342 else set_errno(EVMSERR);
4346 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4347 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4349 memset((void *) &myfib, 0, sizeof myfib);
4351 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4352 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4353 /* This prevents the revision time of the file being reset to the current
4354 * time as a result of our IO$_MODIFY $QIO. */
4355 myfib.fib$l_acctl = FIB$M_NORECORD;
4357 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4358 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4359 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4361 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4362 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4363 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4364 _ckvmssts(sys$dassgn(chan));
4365 if (retsts & 1) retsts = iosb[0];
4366 if (!(retsts & 1)) {
4367 set_vaxc_errno(retsts);
4368 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4369 else set_errno(EVMSERR);
4374 } /* end of my_utime() */
4378 * flex_stat, flex_fstat
4379 * basic stat, but gets it right when asked to stat
4380 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4383 /* encode_dev packs a VMS device name string into an integer to allow
4384 * simple comparisons. This can be used, for example, to check whether two
4385 * files are located on the same device, by comparing their encoded device
4386 * names. Even a string comparison would not do, because stat() reuses the
4387 * device name buffer for each call; so without encode_dev, it would be
4388 * necessary to save the buffer and use strcmp (this would mean a number of
4389 * changes to the standard Perl code, to say nothing of what a Perl script
4392 * The device lock id, if it exists, should be unique (unless perhaps compared
4393 * with lock ids transferred from other nodes). We have a lock id if the disk is
4394 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4395 * device names. Thus we use the lock id in preference, and only if that isn't
4396 * available, do we try to pack the device name into an integer (flagged by
4397 * the sign bit (LOCKID_MASK) being set).
4399 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4400 * name and its encoded form, but it seems very unlikely that we will find
4401 * two files on different disks that share the same encoded device names,
4402 * and even more remote that they will share the same file id (if the test
4403 * is to check for the same file).
4405 * A better method might be to use sys$device_scan on the first call, and to
4406 * search for the device, returning an index into the cached array.
4407 * The number returned would be more intelligable.
4408 * This is probably not worth it, and anyway would take quite a bit longer
4409 * on the first call.
4411 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4412 static mydev_t encode_dev (const char *dev)
4415 unsigned long int f;
4421 if (!dev || !dev[0]) return 0;
4425 struct dsc$descriptor_s dev_desc;
4426 unsigned long int status, lockid, item = DVI$_LOCKID;
4428 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4429 can try that first. */
4430 dev_desc.dsc$w_length = strlen (dev);
4431 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4432 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4433 dev_desc.dsc$a_pointer = (char *) dev;
4434 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4435 if (lockid) return (lockid & ~LOCKID_MASK);
4439 /* Otherwise we try to encode the device name */
4443 for (q = dev + strlen(dev); q--; q >= dev) {
4446 else if (isalpha (toupper (*q)))
4447 c= toupper (*q) - 'A' + (char)10;
4449 continue; /* Skip '$'s */
4451 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4453 enc += f * (unsigned long int) c;
4455 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4457 } /* end of encode_dev() */
4459 static char namecache[NAM$C_MAXRSS+1];
4462 is_null_device(name)
4466 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4467 The underscore prefix, controller letter, and unit number are
4468 independently optional; for our purposes, the colon punctuation
4469 is not. The colon can be trailed by optional directory and/or
4470 filename, but two consecutive colons indicates a nodename rather
4471 than a device. [pr] */
4472 if (*name == '_') ++name;
4473 if (tolower(*name++) != 'n') return 0;
4474 if (tolower(*name++) != 'l') return 0;
4475 if (tolower(*name) == 'a') ++name;
4476 if (*name == '0') ++name;
4477 return (*name++ == ':') && (*name != ':');
4480 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4481 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4482 * subset of the applicable information.
4485 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4487 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4489 char fname[NAM$C_MAXRSS+1];
4490 unsigned long int retsts;
4491 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4492 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4494 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4495 device name on successive calls */
4496 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4497 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4498 namdsc.dsc$a_pointer = fname;
4499 namdsc.dsc$w_length = sizeof fname - 1;
4501 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4502 &namdsc,&namdsc.dsc$w_length,0,0);
4504 fname[namdsc.dsc$w_length] = '\0';
4505 return cando_by_name(bit,effective,fname);
4507 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4508 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4512 return FALSE; /* Should never get to here */
4514 } /* end of cando() */
4518 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4520 cando_by_name(I32 bit, Uid_t effective, char *fname)
4522 static char usrname[L_cuserid];
4523 static struct dsc$descriptor_s usrdsc =
4524 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4525 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4526 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4527 unsigned short int retlen;
4529 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4530 union prvdef curprv;
4531 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4532 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4533 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4536 if (!fname || !*fname) return FALSE;
4537 /* Make sure we expand logical names, since sys$check_access doesn't */
4538 if (!strpbrk(fname,"/]>:")) {
4539 strcpy(fileified,fname);
4540 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4543 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4544 retlen = namdsc.dsc$w_length = strlen(vmsname);
4545 namdsc.dsc$a_pointer = vmsname;
4546 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4547 vmsname[retlen-1] == ':') {
4548 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4549 namdsc.dsc$w_length = strlen(fileified);
4550 namdsc.dsc$a_pointer = fileified;
4553 if (!usrdsc.dsc$w_length) {
4555 usrdsc.dsc$w_length = strlen(usrname);
4562 access = ARM$M_EXECUTE;
4567 access = ARM$M_READ;
4572 access = ARM$M_WRITE;
4577 access = ARM$M_DELETE;
4583 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4584 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4585 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4586 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4587 set_vaxc_errno(retsts);
4588 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4589 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4590 else set_errno(ENOENT);
4593 if (retsts == SS$_NORMAL) {
4594 if (!privused) return TRUE;
4595 /* We can get access, but only by using privs. Do we have the
4596 necessary privs currently enabled? */
4597 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4598 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4599 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4600 !curprv.prv$v_bypass) return FALSE;
4601 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4602 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4603 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4606 if (retsts == SS$_ACCONFLICT) {
4611 return FALSE; /* Should never get here */
4613 } /* end of cando_by_name() */
4617 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4619 flex_fstat(int fd, Stat_t *statbufp)
4622 if (!fstat(fd,(stat_t *) statbufp)) {
4623 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4624 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4625 # ifdef RTL_USES_UTC
4628 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4629 statbufp->st_atime = _toloc(statbufp->st_atime);
4630 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4635 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4639 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4640 statbufp->st_atime = _toutc(statbufp->st_atime);
4641 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4648 } /* end of flex_fstat() */
4651 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4653 flex_stat(const char *fspec, Stat_t *statbufp)
4656 char fileified[NAM$C_MAXRSS+1];
4657 char temp_fspec[NAM$C_MAXRSS+300];
4660 strcpy(temp_fspec, fspec);
4661 if (statbufp == (Stat_t *) &PL_statcache)
4662 do_tovmsspec(temp_fspec,namecache,0);
4663 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4664 memset(statbufp,0,sizeof *statbufp);
4665 statbufp->st_dev = encode_dev("_NLA0:");
4666 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4667 statbufp->st_uid = 0x00010001;
4668 statbufp->st_gid = 0x0001;
4669 time((time_t *)&statbufp->st_mtime);
4670 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4674 /* Try for a directory name first. If fspec contains a filename without
4675 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4676 * and sea:[wine.dark]water. exist, we prefer the directory here.
4677 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4678 * not sea:[wine.dark]., if the latter exists. If the intended target is
4679 * the file with null type, specify this by calling flex_stat() with
4680 * a '.' at the end of fspec.
4682 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4683 retval = stat(fileified,(stat_t *) statbufp);
4684 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4685 strcpy(namecache,fileified);
4687 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4689 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4690 # ifdef RTL_USES_UTC
4693 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4694 statbufp->st_atime = _toloc(statbufp->st_atime);
4695 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4700 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4704 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4705 statbufp->st_atime = _toutc(statbufp->st_atime);
4706 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4712 } /* end of flex_stat() */
4716 /*{{{char *my_getlogin()*/
4717 /* VMS cuserid == Unix getlogin, except calling sequence */
4721 static char user[L_cuserid];
4722 return cuserid(user);
4727 /* rmscopy - copy a file using VMS RMS routines
4729 * Copies contents and attributes of spec_in to spec_out, except owner
4730 * and protection information. Name and type of spec_in are used as
4731 * defaults for spec_out. The third parameter specifies whether rmscopy()
4732 * should try to propagate timestamps from the input file to the output file.
4733 * If it is less than 0, no timestamps are preserved. If it is 0, then
4734 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4735 * propagated to the output file at creation iff the output file specification
4736 * did not contain an explicit name or type, and the revision date is always
4737 * updated at the end of the copy operation. If it is greater than 0, then
4738 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4739 * other than the revision date should be propagated, and bit 1 indicates
4740 * that the revision date should be propagated.
4742 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4744 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4745 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4746 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4747 * as part of the Perl standard distribution under the terms of the
4748 * GNU General Public License or the Perl Artistic License. Copies
4749 * of each may be found in the Perl standard distribution.
4751 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4753 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4755 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4756 rsa[NAM$C_MAXRSS], ubf[32256];
4757 unsigned long int i, sts, sts2;
4758 struct FAB fab_in, fab_out;
4759 struct RAB rab_in, rab_out;
4761 struct XABDAT xabdat;
4762 struct XABFHC xabfhc;
4763 struct XABRDT xabrdt;
4764 struct XABSUM xabsum;
4766 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4767 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4768 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4772 fab_in = cc$rms_fab;
4773 fab_in.fab$l_fna = vmsin;
4774 fab_in.fab$b_fns = strlen(vmsin);
4775 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4776 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4777 fab_in.fab$l_fop = FAB$M_SQO;
4778 fab_in.fab$l_nam = &nam;
4779 fab_in.fab$l_xab = (void *) &xabdat;
4782 nam.nam$l_rsa = rsa;
4783 nam.nam$b_rss = sizeof(rsa);
4784 nam.nam$l_esa = esa;
4785 nam.nam$b_ess = sizeof (esa);
4786 nam.nam$b_esl = nam.nam$b_rsl = 0;
4788 xabdat = cc$rms_xabdat; /* To get creation date */
4789 xabdat.xab$l_nxt = (void *) &xabfhc;
4791 xabfhc = cc$rms_xabfhc; /* To get record length */
4792 xabfhc.xab$l_nxt = (void *) &xabsum;
4794 xabsum = cc$rms_xabsum; /* To get key and area information */
4796 if (!((sts = sys$open(&fab_in)) & 1)) {
4797 set_vaxc_errno(sts);
4801 set_errno(ENOENT); break;
4803 set_errno(ENODEV); break;
4805 set_errno(EINVAL); break;
4807 set_errno(EACCES); break;
4815 fab_out.fab$w_ifi = 0;
4816 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4817 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4818 fab_out.fab$l_fop = FAB$M_SQO;
4819 fab_out.fab$l_fna = vmsout;
4820 fab_out.fab$b_fns = strlen(vmsout);
4821 fab_out.fab$l_dna = nam.nam$l_name;
4822 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4824 if (preserve_dates == 0) { /* Act like DCL COPY */
4825 nam.nam$b_nop = NAM$M_SYNCHK;
4826 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4827 if (!((sts = sys$parse(&fab_out)) & 1)) {
4828 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4829 set_vaxc_errno(sts);
4832 fab_out.fab$l_xab = (void *) &xabdat;
4833 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4835 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4836 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4837 preserve_dates =0; /* bitmask from this point forward */
4839 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4840 if (!((sts = sys$create(&fab_out)) & 1)) {
4841 set_vaxc_errno(sts);
4844 set_errno(ENOENT); break;
4846 set_errno(ENODEV); break;
4848 set_errno(EINVAL); break;
4850 set_errno(EACCES); break;
4856 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4857 if (preserve_dates & 2) {
4858 /* sys$close() will process xabrdt, not xabdat */
4859 xabrdt = cc$rms_xabrdt;
4861 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4863 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4864 * is unsigned long[2], while DECC & VAXC use a struct */
4865 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4867 fab_out.fab$l_xab = (void *) &xabrdt;
4870 rab_in = cc$rms_rab;
4871 rab_in.rab$l_fab = &fab_in;
4872 rab_in.rab$l_rop = RAB$M_BIO;
4873 rab_in.rab$l_ubf = ubf;
4874 rab_in.rab$w_usz = sizeof ubf;
4875 if (!((sts = sys$connect(&rab_in)) & 1)) {
4876 sys$close(&fab_in); sys$close(&fab_out);
4877 set_errno(EVMSERR); set_vaxc_errno(sts);
4881 rab_out = cc$rms_rab;
4882 rab_out.rab$l_fab = &fab_out;
4883 rab_out.rab$l_rbf = ubf;
4884 if (!((sts = sys$connect(&rab_out)) & 1)) {
4885 sys$close(&fab_in); sys$close(&fab_out);
4886 set_errno(EVMSERR); set_vaxc_errno(sts);
4890 while ((sts = sys$read(&rab_in))) { /* always true */
4891 if (sts == RMS$_EOF) break;
4892 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4893 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4894 sys$close(&fab_in); sys$close(&fab_out);
4895 set_errno(EVMSERR); set_vaxc_errno(sts);
4900 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4901 sys$close(&fab_in); sys$close(&fab_out);
4902 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4904 set_errno(EVMSERR); set_vaxc_errno(sts);
4910 } /* end of rmscopy() */
4914 /*** The following glue provides 'hooks' to make some of the routines
4915 * from this file available from Perl. These routines are sufficiently
4916 * basic, and are required sufficiently early in the build process,
4917 * that's it's nice to have them available to miniperl as well as the
4918 * full Perl, so they're set up here instead of in an extension. The
4919 * Perl code which handles importation of these names into a given
4920 * package lives in [.VMS]Filespec.pm in @INC.
4924 rmsexpand_fromperl(pTHX_ CV *cv)
4927 char *fspec, *defspec = NULL, *rslt;
4930 if (!items || items > 2)
4931 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4932 fspec = SvPV(ST(0),n_a);
4933 if (!fspec || !*fspec) XSRETURN_UNDEF;
4934 if (items == 2) defspec = SvPV(ST(1),n_a);
4936 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4937 ST(0) = sv_newmortal();
4938 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4943 vmsify_fromperl(pTHX_ CV *cv)
4949 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4950 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4951 ST(0) = sv_newmortal();
4952 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4957 unixify_fromperl(pTHX_ CV *cv)
4963 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
4964 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4965 ST(0) = sv_newmortal();
4966 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4971 fileify_fromperl(pTHX_ CV *cv)
4977 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
4978 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4979 ST(0) = sv_newmortal();
4980 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4985 pathify_fromperl(pTHX_ CV *cv)
4991 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
4992 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4993 ST(0) = sv_newmortal();
4994 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4999 vmspath_fromperl(pTHX_ CV *cv)
5005 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5006 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5007 ST(0) = sv_newmortal();
5008 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5013 unixpath_fromperl(pTHX_ CV *cv)
5019 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5020 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5021 ST(0) = sv_newmortal();
5022 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5027 candelete_fromperl(pTHX_ CV *cv)
5030 char fspec[NAM$C_MAXRSS+1], *fsp;
5035 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5037 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5038 if (SvTYPE(mysv) == SVt_PVGV) {
5039 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5040 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5047 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5048 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5054 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5059 rmscopy_fromperl(pTHX_ CV *cv)
5062 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5064 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5065 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5066 unsigned long int sts;
5071 if (items < 2 || items > 3)
5072 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5074 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5075 if (SvTYPE(mysv) == SVt_PVGV) {
5076 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5077 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5084 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5085 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5090 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5091 if (SvTYPE(mysv) == SVt_PVGV) {
5092 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5093 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5100 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5101 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5106 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5108 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5115 char* file = __FILE__;
5117 char temp_buff[512];
5118 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5119 no_translate_barewords = TRUE;
5121 no_translate_barewords = FALSE;
5124 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5125 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5126 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5127 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5128 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5129 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5130 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5131 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5132 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);