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 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
625 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
626 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
627 set_errno(EVMSERR); break;
628 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
629 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
630 set_errno(EINVAL); break;
637 set_vaxc_errno(retsts);
638 return (int) retsts || 44; /* retsts should never be 0, but just in case */
641 /* We reset error values on success because Perl does an hv_fetch()
642 * before each hv_store(), and if the thing we're setting didn't
643 * previously exist, we've got a leftover error message. (Of course,
644 * this fails in the face of
645 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
646 * in that the error reported in $! isn't spurious,
647 * but it's right more often than not.)
649 set_errno(0); set_vaxc_errno(retsts);
653 } /* end of vmssetenv() */
656 /*{{{ void my_setenv(char *lnm, char *eqv)*/
657 /* This has to be a function since there's a prototype for it in proto.h */
659 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
661 if (lnm && *lnm && strlen(lnm) == 7) {
664 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
665 if (!strcmp(uplnm,"DEFAULT")) {
666 if (eqv && *eqv) chdir(eqv);
670 (void) vmssetenv(lnm,eqv,NULL);
676 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
677 /* my_crypt - VMS password hashing
678 * my_crypt() provides an interface compatible with the Unix crypt()
679 * C library function, and uses sys$hash_password() to perform VMS
680 * password hashing. The quadword hashed password value is returned
681 * as a NUL-terminated 8 character string. my_crypt() does not change
682 * the case of its string arguments; in order to match the behavior
683 * of LOGINOUT et al., alphabetic characters in both arguments must
684 * be upcased by the caller.
687 my_crypt(const char *textpasswd, const char *usrname)
689 # ifndef UAI$C_PREFERRED_ALGORITHM
690 # define UAI$C_PREFERRED_ALGORITHM 127
692 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
693 unsigned short int salt = 0;
694 unsigned long int sts;
696 unsigned short int dsc$w_length;
697 unsigned char dsc$b_type;
698 unsigned char dsc$b_class;
699 const char * dsc$a_pointer;
700 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
701 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
702 struct itmlst_3 uailst[3] = {
703 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
704 { sizeof salt, UAI$_SALT, &salt, 0},
705 { 0, 0, NULL, NULL}};
708 usrdsc.dsc$w_length = strlen(usrname);
709 usrdsc.dsc$a_pointer = usrname;
710 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
717 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
723 if (sts != RMS$_RNF) return NULL;
726 txtdsc.dsc$w_length = strlen(textpasswd);
727 txtdsc.dsc$a_pointer = textpasswd;
728 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
729 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
732 return (char *) hash;
734 } /* end of my_crypt() */
738 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
739 static char *do_fileify_dirspec(char *, char *, int);
740 static char *do_tovmsspec(char *, char *, int);
742 /*{{{int do_rmdir(char *name)*/
746 char dirfile[NAM$C_MAXRSS+1];
750 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
751 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
752 else retval = kill_file(dirfile);
755 } /* end of do_rmdir */
759 * Delete any file to which user has control access, regardless of whether
760 * delete access is explicitly allowed.
761 * Limitations: User must have write access to parent directory.
762 * Does not block signals or ASTs; if interrupted in midstream
763 * may leave file with an altered ACL.
766 /*{{{int kill_file(char *name)*/
768 kill_file(char *name)
770 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
771 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
772 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
774 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
776 unsigned char myace$b_length;
777 unsigned char myace$b_type;
778 unsigned short int myace$w_flags;
779 unsigned long int myace$l_access;
780 unsigned long int myace$l_ident;
781 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
782 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
783 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
785 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
786 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
787 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
788 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
789 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
790 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
792 /* Expand the input spec using RMS, since the CRTL remove() and
793 * system services won't do this by themselves, so we may miss
794 * a file "hiding" behind a logical name or search list. */
795 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
796 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
797 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
798 /* If not, can changing protections help? */
799 if (vaxc$errno != RMS$_PRV) return -1;
801 /* No, so we get our own UIC to use as a rights identifier,
802 * and the insert an ACE at the head of the ACL which allows us
803 * to delete the file.
805 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
806 fildsc.dsc$w_length = strlen(rspec);
807 fildsc.dsc$a_pointer = rspec;
809 newace.myace$l_ident = oldace.myace$l_ident;
810 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
815 case SS$_NOSUCHOBJECT:
816 set_errno(ENOENT); break;
818 set_errno(ENODEV); break;
820 case SS$_INVFILFOROP:
821 set_errno(EINVAL); break;
823 set_errno(EACCES); break;
827 set_vaxc_errno(aclsts);
830 /* Grab any existing ACEs with this identifier in case we fail */
831 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
832 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
833 || fndsts == SS$_NOMOREACE ) {
834 /* Add the new ACE . . . */
835 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
837 if ((rmsts = remove(name))) {
838 /* We blew it - dir with files in it, no write priv for
839 * parent directory, etc. Put things back the way they were. */
840 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
843 addlst[0].bufadr = &oldace;
844 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
851 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
852 /* We just deleted it, so of course it's not there. Some versions of
853 * VMS seem to return success on the unlock operation anyhow (after all
854 * the unlock is successful), but others don't.
856 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
857 if (aclsts & 1) aclsts = fndsts;
860 set_vaxc_errno(aclsts);
866 } /* end of kill_file() */
870 /*{{{int my_mkdir(char *,Mode_t)*/
872 my_mkdir(char *dir, Mode_t mode)
874 STRLEN dirlen = strlen(dir);
877 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
878 * null file name/type. However, it's commonplace under Unix,
879 * so we'll allow it for a gain in portability.
881 if (dir[dirlen-1] == '/') {
882 char *newdir = savepvn(dir,dirlen-1);
883 int ret = mkdir(newdir,mode);
887 else return mkdir(dir,mode);
888 } /* end of my_mkdir */
893 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
895 static unsigned long int mbxbufsiz;
896 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
901 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
902 * preprocessor consant BUFSIZ from stdio.h as the size of the
905 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
906 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
908 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
910 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
911 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
913 } /* end of create_mbx() */
915 /*{{{ my_popen and my_pclose*/
918 struct pipe_details *next;
919 PerlIO *fp; /* stdio file pointer to pipe mailbox */
920 int pid; /* PID of subprocess */
921 int mode; /* == 'r' if pipe open for reading */
922 int done; /* subprocess has completed */
923 unsigned long int completion; /* termination status of subprocess */
926 struct exit_control_block
928 struct exit_control_block *flink;
929 unsigned long int (*exit_routine)();
930 unsigned long int arg_count;
931 unsigned long int *status_address;
932 unsigned long int exit_status;
935 static struct pipe_details *open_pipes = NULL;
936 static $DESCRIPTOR(nl_desc, "NL:");
937 static int waitpid_asleep = 0;
939 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
940 * to a mbx; that's the caller's responsibility.
942 static unsigned long int
943 pipe_eof(FILE *fp, int immediate)
945 char devnam[NAM$C_MAXRSS+1], *cp;
946 unsigned long int chan, iosb[2], retsts, retsts2;
947 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
950 if (fgetname(fp,devnam,1)) {
951 /* It oughta be a mailbox, so fgetname should give just the device
952 * name, but just in case . . . */
953 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
954 devdsc.dsc$w_length = strlen(devnam);
955 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
956 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
957 iosb,0,0,0,0,0,0,0,0);
958 if (retsts & 1) retsts = iosb[0];
959 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
960 if (retsts & 1) retsts = retsts2;
964 else _ckvmssts(vaxc$errno); /* Should never happen */
965 return (unsigned long int) vaxc$errno;
968 static unsigned long int
971 struct pipe_details *info;
972 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
977 first we try sending an EOF...ignore if doesn't work, make sure we
984 if (info->mode != 'r' && !info->done) {
985 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
989 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
994 if (!info->done) { /* Tap them gently on the shoulder . . .*/
995 sts = sys$forcex(&info->pid,0,&abort);
996 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1001 if (did_stuff) sleep(1); /* wait for them to respond */
1005 if (!info->done) { /* We tried to be nice . . . */
1006 sts = sys$delprc(&info->pid,0);
1007 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1008 info->done = 1; /* so my_pclose doesn't try to write EOF */
1014 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1015 else if (!(sts & 1)) retsts = sts;
1020 static struct exit_control_block pipe_exitblock =
1021 {(struct exit_control_block *) 0,
1022 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1026 popen_completion_ast(struct pipe_details *thispipe)
1028 thispipe->done = TRUE;
1029 if (waitpid_asleep) {
1035 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1036 static void vms_execfree();
1039 safe_popen(char *cmd, char *mode)
1041 static int handler_set_up = FALSE;
1043 unsigned short int chan;
1044 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1046 struct pipe_details *info;
1047 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1048 DSC$K_CLASS_S, mbxname},
1049 cmddsc = {0, DSC$K_DTYPE_T,
1053 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1054 New(1301,info,1,struct pipe_details);
1056 /* create mailbox */
1057 create_mbx(&chan,&namdsc);
1059 /* open a FILE* onto it */
1060 info->fp = PerlIO_open(mbxname, mode);
1062 /* give up other channel onto it */
1063 _ckvmssts(sys$dassgn(chan));
1073 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1074 0 /* name */, &info->pid, &info->completion,
1075 0, popen_completion_ast,info,0,0,0));
1078 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1079 0 /* name */, &info->pid, &info->completion,
1080 0, popen_completion_ast,info,0,0,0));
1084 if (!handler_set_up) {
1085 _ckvmssts(sys$dclexh(&pipe_exitblock));
1086 handler_set_up = TRUE;
1088 info->next=open_pipes; /* prepend to list */
1091 PL_forkprocess = info->pid;
1093 } /* end of safe_popen */
1096 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1098 Perl_my_popen(pTHX_ char *cmd, char *mode)
1101 TAINT_PROPER("popen");
1102 PERL_FLUSHALL_FOR_CHILD;
1103 return safe_popen(cmd,mode);
1108 /*{{{ I32 my_pclose(FILE *fp)*/
1109 I32 Perl_my_pclose(pTHX_ FILE *fp)
1111 struct pipe_details *info, *last = NULL;
1112 unsigned long int retsts;
1114 for (info = open_pipes; info != NULL; last = info, info = info->next)
1115 if (info->fp == fp) break;
1117 if (info == NULL) { /* no such pipe open */
1118 set_errno(ECHILD); /* quoth POSIX */
1119 set_vaxc_errno(SS$_NONEXPR);
1123 /* If we were writing to a subprocess, insure that someone reading from
1124 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1125 * produce an EOF record in the mailbox. */
1126 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,1);
1127 PerlIO_close(info->fp);
1129 if (info->done) retsts = info->completion;
1130 else waitpid(info->pid,(int *) &retsts,0);
1132 /* remove from list of open pipes */
1133 if (last) last->next = info->next;
1134 else open_pipes = info->next;
1139 } /* end of my_pclose() */
1141 /* sort-of waitpid; use only with popen() */
1142 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1144 my_waitpid(Pid_t pid, int *statusp, int flags)
1146 struct pipe_details *info;
1149 for (info = open_pipes; info != NULL; info = info->next)
1150 if (info->pid == pid) break;
1152 if (info != NULL) { /* we know about this child */
1153 while (!info->done) {
1158 *statusp = info->completion;
1161 else { /* we haven't heard of this child */
1162 $DESCRIPTOR(intdsc,"0 00:00:01");
1163 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1164 unsigned long int interval[2],sts;
1166 if (ckWARN(WARN_EXEC)) {
1167 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1168 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1169 if (ownerpid != mypid)
1170 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1173 _ckvmssts(sys$bintim(&intdsc,interval));
1174 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1175 _ckvmssts(sys$schdwk(0,0,interval,0));
1176 _ckvmssts(sys$hiber());
1180 /* There's no easy way to find the termination status a child we're
1181 * not aware of beforehand. If we're really interested in the future,
1182 * we can go looking for a termination mailbox, or chase after the
1183 * accounting record for the process.
1189 } /* end of waitpid() */
1194 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1196 my_gconvert(double val, int ndig, int trail, char *buf)
1198 static char __gcvtbuf[DBL_DIG+1];
1201 loc = buf ? buf : __gcvtbuf;
1203 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1205 sprintf(loc,"%.*g",ndig,val);
1211 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1212 return gcvt(val,ndig,loc);
1215 loc[0] = '0'; loc[1] = '\0';
1223 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1224 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1225 * to expand file specification. Allows for a single default file
1226 * specification and a simple mask of options. If outbuf is non-NULL,
1227 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1228 * the resultant file specification is placed. If outbuf is NULL, the
1229 * resultant file specification is placed into a static buffer.
1230 * The third argument, if non-NULL, is taken to be a default file
1231 * specification string. The fourth argument is unused at present.
1232 * rmesexpand() returns the address of the resultant string if
1233 * successful, and NULL on error.
1235 static char *do_tounixspec(char *, char *, int);
1238 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1240 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1241 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1242 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1243 struct FAB myfab = cc$rms_fab;
1244 struct NAM mynam = cc$rms_nam;
1246 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1248 if (!filespec || !*filespec) {
1249 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1253 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1254 else outbuf = __rmsexpand_retbuf;
1256 if ((isunix = (strchr(filespec,'/') != NULL))) {
1257 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1258 filespec = vmsfspec;
1261 myfab.fab$l_fna = filespec;
1262 myfab.fab$b_fns = strlen(filespec);
1263 myfab.fab$l_nam = &mynam;
1265 if (defspec && *defspec) {
1266 if (strchr(defspec,'/') != NULL) {
1267 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1270 myfab.fab$l_dna = defspec;
1271 myfab.fab$b_dns = strlen(defspec);
1274 mynam.nam$l_esa = esa;
1275 mynam.nam$b_ess = sizeof esa;
1276 mynam.nam$l_rsa = outbuf;
1277 mynam.nam$b_rss = NAM$C_MAXRSS;
1279 retsts = sys$parse(&myfab,0,0);
1280 if (!(retsts & 1)) {
1281 mynam.nam$b_nop |= NAM$M_SYNCHK;
1282 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1283 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1284 retsts = sys$parse(&myfab,0,0);
1285 if (retsts & 1) goto expanded;
1287 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1288 (void) sys$parse(&myfab,0,0); /* Free search context */
1289 if (out) Safefree(out);
1290 set_vaxc_errno(retsts);
1291 if (retsts == RMS$_PRV) set_errno(EACCES);
1292 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1293 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1294 else set_errno(EVMSERR);
1297 retsts = sys$search(&myfab,0,0);
1298 if (!(retsts & 1) && retsts != RMS$_FNF) {
1299 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1300 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1301 if (out) Safefree(out);
1302 set_vaxc_errno(retsts);
1303 if (retsts == RMS$_PRV) set_errno(EACCES);
1304 else set_errno(EVMSERR);
1308 /* If the input filespec contained any lowercase characters,
1309 * downcase the result for compatibility with Unix-minded code. */
1311 for (out = myfab.fab$l_fna; *out; out++)
1312 if (islower(*out)) { haslower = 1; break; }
1313 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1314 else { out = esa; speclen = mynam.nam$b_esl; }
1315 /* Trim off null fields added by $PARSE
1316 * If type > 1 char, must have been specified in original or default spec
1317 * (not true for version; $SEARCH may have added version of existing file).
1319 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1320 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1321 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1322 if (trimver || trimtype) {
1323 if (defspec && *defspec) {
1324 char defesa[NAM$C_MAXRSS];
1325 struct FAB deffab = cc$rms_fab;
1326 struct NAM defnam = cc$rms_nam;
1328 deffab.fab$l_nam = &defnam;
1329 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1330 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1331 defnam.nam$b_nop = NAM$M_SYNCHK;
1332 if (sys$parse(&deffab,0,0) & 1) {
1333 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1334 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1337 if (trimver) speclen = mynam.nam$l_ver - out;
1339 /* If we didn't already trim version, copy down */
1340 if (speclen > mynam.nam$l_ver - out)
1341 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1342 speclen - (mynam.nam$l_ver - out));
1343 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1346 /* If we just had a directory spec on input, $PARSE "helpfully"
1347 * adds an empty name and type for us */
1348 if (mynam.nam$l_name == mynam.nam$l_type &&
1349 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1350 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1351 speclen = mynam.nam$l_name - out;
1352 out[speclen] = '\0';
1353 if (haslower) __mystrtolower(out);
1355 /* Have we been working with an expanded, but not resultant, spec? */
1356 /* Also, convert back to Unix syntax if necessary. */
1357 if (!mynam.nam$b_rsl) {
1359 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1361 else strcpy(outbuf,esa);
1364 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1365 strcpy(outbuf,tmpfspec);
1367 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1368 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1369 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1373 /* External entry points */
1374 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1375 { return do_rmsexpand(spec,buf,0,def,opt); }
1376 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1377 { return do_rmsexpand(spec,buf,1,def,opt); }
1381 ** The following routines are provided to make life easier when
1382 ** converting among VMS-style and Unix-style directory specifications.
1383 ** All will take input specifications in either VMS or Unix syntax. On
1384 ** failure, all return NULL. If successful, the routines listed below
1385 ** return a pointer to a buffer containing the appropriately
1386 ** reformatted spec (and, therefore, subsequent calls to that routine
1387 ** will clobber the result), while the routines of the same names with
1388 ** a _ts suffix appended will return a pointer to a mallocd string
1389 ** containing the appropriately reformatted spec.
1390 ** In all cases, only explicit syntax is altered; no check is made that
1391 ** the resulting string is valid or that the directory in question
1394 ** fileify_dirspec() - convert a directory spec into the name of the
1395 ** directory file (i.e. what you can stat() to see if it's a dir).
1396 ** The style (VMS or Unix) of the result is the same as the style
1397 ** of the parameter passed in.
1398 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1399 ** what you prepend to a filename to indicate what directory it's in).
1400 ** The style (VMS or Unix) of the result is the same as the style
1401 ** of the parameter passed in.
1402 ** tounixpath() - convert a directory spec into a Unix-style path.
1403 ** tovmspath() - convert a directory spec into a VMS-style path.
1404 ** tounixspec() - convert any file spec into a Unix-style file spec.
1405 ** tovmsspec() - convert any file spec into a VMS-style spec.
1407 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1408 ** Permission is given to distribute this code as part of the Perl
1409 ** standard distribution under the terms of the GNU General Public
1410 ** License or the Perl Artistic License. Copies of each may be
1411 ** found in the Perl standard distribution.
1414 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1415 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1417 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1418 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1419 char *retspec, *cp1, *cp2, *lastdir;
1420 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1422 if (!dir || !*dir) {
1423 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1425 dirlen = strlen(dir);
1426 while (dir[dirlen-1] == '/') --dirlen;
1427 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1428 strcpy(trndir,"/sys$disk/000000");
1432 if (dirlen > NAM$C_MAXRSS) {
1433 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1435 if (!strpbrk(dir+1,"/]>:")) {
1436 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1437 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1439 dirlen = strlen(dir);
1442 strncpy(trndir,dir,dirlen);
1443 trndir[dirlen] = '\0';
1446 /* If we were handed a rooted logical name or spec, treat it like a
1447 * simple directory, so that
1448 * $ Define myroot dev:[dir.]
1449 * ... do_fileify_dirspec("myroot",buf,1) ...
1450 * does something useful.
1452 if (!strcmp(dir+dirlen-2,".]")) {
1453 dir[--dirlen] = '\0';
1454 dir[dirlen-1] = ']';
1457 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1458 /* If we've got an explicit filename, we can just shuffle the string. */
1459 if (*(cp1+1)) hasfilename = 1;
1460 /* Similarly, we can just back up a level if we've got multiple levels
1461 of explicit directories in a VMS spec which ends with directories. */
1463 for (cp2 = cp1; cp2 > dir; cp2--) {
1465 *cp2 = *cp1; *cp1 = '\0';
1469 if (*cp2 == '[' || *cp2 == '<') break;
1474 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1475 if (dir[0] == '.') {
1476 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1477 return do_fileify_dirspec("[]",buf,ts);
1478 else if (dir[1] == '.' &&
1479 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1480 return do_fileify_dirspec("[-]",buf,ts);
1482 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1483 dirlen -= 1; /* to last element */
1484 lastdir = strrchr(dir,'/');
1486 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1487 /* If we have "/." or "/..", VMSify it and let the VMS code
1488 * below expand it, rather than repeating the code to handle
1489 * relative components of a filespec here */
1491 if (*(cp1+2) == '.') cp1++;
1492 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1493 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1494 if (strchr(vmsdir,'/') != NULL) {
1495 /* If do_tovmsspec() returned it, it must have VMS syntax
1496 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1497 * the time to check this here only so we avoid a recursion
1498 * loop; otherwise, gigo.
1500 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1502 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1503 return do_tounixspec(trndir,buf,ts);
1506 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1507 lastdir = strrchr(dir,'/');
1509 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1510 /* Ditto for specs that end in an MFD -- let the VMS code
1511 * figure out whether it's a real device or a rooted logical. */
1512 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1513 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1514 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1515 return do_tounixspec(trndir,buf,ts);
1518 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1519 !(lastdir = cp1 = strrchr(dir,']')) &&
1520 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1521 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1523 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1524 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1525 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1526 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1527 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1528 (ver || *cp3)))))) {
1530 set_vaxc_errno(RMS$_DIR);
1536 /* If we lead off with a device or rooted logical, add the MFD
1537 if we're specifying a top-level directory. */
1538 if (lastdir && *dir == '/') {
1540 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1547 retlen = dirlen + (addmfd ? 13 : 6);
1548 if (buf) retspec = buf;
1549 else if (ts) New(1309,retspec,retlen+1,char);
1550 else retspec = __fileify_retbuf;
1552 dirlen = lastdir - dir;
1553 memcpy(retspec,dir,dirlen);
1554 strcpy(&retspec[dirlen],"/000000");
1555 strcpy(&retspec[dirlen+7],lastdir);
1558 memcpy(retspec,dir,dirlen);
1559 retspec[dirlen] = '\0';
1561 /* We've picked up everything up to the directory file name.
1562 Now just add the type and version, and we're set. */
1563 strcat(retspec,".dir;1");
1566 else { /* VMS-style directory spec */
1567 char esa[NAM$C_MAXRSS+1], term, *cp;
1568 unsigned long int sts, cmplen, haslower = 0;
1569 struct FAB dirfab = cc$rms_fab;
1570 struct NAM savnam, dirnam = cc$rms_nam;
1572 dirfab.fab$b_fns = strlen(dir);
1573 dirfab.fab$l_fna = dir;
1574 dirfab.fab$l_nam = &dirnam;
1575 dirfab.fab$l_dna = ".DIR;1";
1576 dirfab.fab$b_dns = 6;
1577 dirnam.nam$b_ess = NAM$C_MAXRSS;
1578 dirnam.nam$l_esa = esa;
1580 for (cp = dir; *cp; cp++)
1581 if (islower(*cp)) { haslower = 1; break; }
1582 if (!((sts = sys$parse(&dirfab))&1)) {
1583 if (dirfab.fab$l_sts == RMS$_DIR) {
1584 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1585 sts = sys$parse(&dirfab) & 1;
1589 set_vaxc_errno(dirfab.fab$l_sts);
1595 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1596 /* Yes; fake the fnb bits so we'll check type below */
1597 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1599 else { /* No; just work with potential name */
1600 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1602 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1603 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1604 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1609 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1610 cp1 = strchr(esa,']');
1611 if (!cp1) cp1 = strchr(esa,'>');
1612 if (cp1) { /* Should always be true */
1613 dirnam.nam$b_esl -= cp1 - esa - 1;
1614 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1617 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1618 /* Yep; check version while we're at it, if it's there. */
1619 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1620 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1621 /* Something other than .DIR[;1]. Bzzt. */
1622 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1623 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1625 set_vaxc_errno(RMS$_DIR);
1629 esa[dirnam.nam$b_esl] = '\0';
1630 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1631 /* They provided at least the name; we added the type, if necessary, */
1632 if (buf) retspec = buf; /* in sys$parse() */
1633 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1634 else retspec = __fileify_retbuf;
1635 strcpy(retspec,esa);
1636 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1637 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1640 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1641 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1643 dirnam.nam$b_esl -= 9;
1645 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1646 if (cp1 == NULL) { /* should never happen */
1647 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1648 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1653 retlen = strlen(esa);
1654 if ((cp1 = strrchr(esa,'.')) != NULL) {
1655 /* There's more than one directory in the path. Just roll back. */
1657 if (buf) retspec = buf;
1658 else if (ts) New(1311,retspec,retlen+7,char);
1659 else retspec = __fileify_retbuf;
1660 strcpy(retspec,esa);
1663 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1664 /* Go back and expand rooted logical name */
1665 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1666 if (!(sys$parse(&dirfab) & 1)) {
1667 dirnam.nam$l_rlf = NULL;
1668 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1670 set_vaxc_errno(dirfab.fab$l_sts);
1673 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1674 if (buf) retspec = buf;
1675 else if (ts) New(1312,retspec,retlen+16,char);
1676 else retspec = __fileify_retbuf;
1677 cp1 = strstr(esa,"][");
1679 memcpy(retspec,esa,dirlen);
1680 if (!strncmp(cp1+2,"000000]",7)) {
1681 retspec[dirlen-1] = '\0';
1682 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1683 if (*cp1 == '.') *cp1 = ']';
1685 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1686 memcpy(cp1+1,"000000]",7);
1690 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1691 retspec[retlen] = '\0';
1692 /* Convert last '.' to ']' */
1693 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1694 if (*cp1 == '.') *cp1 = ']';
1696 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1697 memcpy(cp1+1,"000000]",7);
1701 else { /* This is a top-level dir. Add the MFD to the path. */
1702 if (buf) retspec = buf;
1703 else if (ts) New(1312,retspec,retlen+16,char);
1704 else retspec = __fileify_retbuf;
1707 while (*cp1 != ':') *(cp2++) = *(cp1++);
1708 strcpy(cp2,":[000000]");
1713 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1714 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1715 /* We've set up the string up through the filename. Add the
1716 type and version, and we're done. */
1717 strcat(retspec,".DIR;1");
1719 /* $PARSE may have upcased filespec, so convert output to lower
1720 * case if input contained any lowercase characters. */
1721 if (haslower) __mystrtolower(retspec);
1724 } /* end of do_fileify_dirspec() */
1726 /* External entry points */
1727 char *fileify_dirspec(char *dir, char *buf)
1728 { return do_fileify_dirspec(dir,buf,0); }
1729 char *fileify_dirspec_ts(char *dir, char *buf)
1730 { return do_fileify_dirspec(dir,buf,1); }
1732 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1733 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1735 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1736 unsigned long int retlen;
1737 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1739 if (!dir || !*dir) {
1740 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1743 if (*dir) strcpy(trndir,dir);
1744 else getcwd(trndir,sizeof trndir - 1);
1746 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1747 && my_trnlnm(trndir,trndir,0)) {
1748 STRLEN trnlen = strlen(trndir);
1750 /* Trap simple rooted lnms, and return lnm:[000000] */
1751 if (!strcmp(trndir+trnlen-2,".]")) {
1752 if (buf) retpath = buf;
1753 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1754 else retpath = __pathify_retbuf;
1755 strcpy(retpath,dir);
1756 strcat(retpath,":[000000]");
1762 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1763 if (*dir == '.' && (*(dir+1) == '\0' ||
1764 (*(dir+1) == '.' && *(dir+2) == '\0')))
1765 retlen = 2 + (*(dir+1) != '\0');
1767 if ( !(cp1 = strrchr(dir,'/')) &&
1768 !(cp1 = strrchr(dir,']')) &&
1769 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1770 if ((cp2 = strchr(cp1,'.')) != NULL &&
1771 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1772 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1773 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1774 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1776 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1777 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1778 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1779 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1780 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1781 (ver || *cp3)))))) {
1783 set_vaxc_errno(RMS$_DIR);
1786 retlen = cp2 - dir + 1;
1788 else { /* No file type present. Treat the filename as a directory. */
1789 retlen = strlen(dir) + 1;
1792 if (buf) retpath = buf;
1793 else if (ts) New(1313,retpath,retlen+1,char);
1794 else retpath = __pathify_retbuf;
1795 strncpy(retpath,dir,retlen-1);
1796 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1797 retpath[retlen-1] = '/'; /* with '/', add it. */
1798 retpath[retlen] = '\0';
1800 else retpath[retlen-1] = '\0';
1802 else { /* VMS-style directory spec */
1803 char esa[NAM$C_MAXRSS+1], *cp;
1804 unsigned long int sts, cmplen, haslower;
1805 struct FAB dirfab = cc$rms_fab;
1806 struct NAM savnam, dirnam = cc$rms_nam;
1808 /* If we've got an explicit filename, we can just shuffle the string. */
1809 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1810 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1811 if ((cp2 = strchr(cp1,'.')) != NULL) {
1813 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1814 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1815 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1816 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1817 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1818 (ver || *cp3)))))) {
1820 set_vaxc_errno(RMS$_DIR);
1824 else { /* No file type, so just draw name into directory part */
1825 for (cp2 = cp1; *cp2; cp2++) ;
1828 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1830 /* We've now got a VMS 'path'; fall through */
1832 dirfab.fab$b_fns = strlen(dir);
1833 dirfab.fab$l_fna = dir;
1834 if (dir[dirfab.fab$b_fns-1] == ']' ||
1835 dir[dirfab.fab$b_fns-1] == '>' ||
1836 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1837 if (buf) retpath = buf;
1838 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1839 else retpath = __pathify_retbuf;
1840 strcpy(retpath,dir);
1843 dirfab.fab$l_dna = ".DIR;1";
1844 dirfab.fab$b_dns = 6;
1845 dirfab.fab$l_nam = &dirnam;
1846 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1847 dirnam.nam$l_esa = esa;
1849 for (cp = dir; *cp; cp++)
1850 if (islower(*cp)) { haslower = 1; break; }
1852 if (!(sts = (sys$parse(&dirfab)&1))) {
1853 if (dirfab.fab$l_sts == RMS$_DIR) {
1854 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1855 sts = sys$parse(&dirfab) & 1;
1859 set_vaxc_errno(dirfab.fab$l_sts);
1865 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1866 if (dirfab.fab$l_sts != RMS$_FNF) {
1867 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1868 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1870 set_vaxc_errno(dirfab.fab$l_sts);
1873 dirnam = savnam; /* No; just work with potential name */
1876 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1877 /* Yep; check version while we're at it, if it's there. */
1878 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1879 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1880 /* Something other than .DIR[;1]. Bzzt. */
1881 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1882 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1884 set_vaxc_errno(RMS$_DIR);
1888 /* OK, the type was fine. Now pull any file name into the
1890 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1892 cp1 = strrchr(esa,'>');
1893 *dirnam.nam$l_type = '>';
1896 *(dirnam.nam$l_type + 1) = '\0';
1897 retlen = dirnam.nam$l_type - esa + 2;
1898 if (buf) retpath = buf;
1899 else if (ts) New(1314,retpath,retlen,char);
1900 else retpath = __pathify_retbuf;
1901 strcpy(retpath,esa);
1902 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1903 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1904 /* $PARSE may have upcased filespec, so convert output to lower
1905 * case if input contained any lowercase characters. */
1906 if (haslower) __mystrtolower(retpath);
1910 } /* end of do_pathify_dirspec() */
1912 /* External entry points */
1913 char *pathify_dirspec(char *dir, char *buf)
1914 { return do_pathify_dirspec(dir,buf,0); }
1915 char *pathify_dirspec_ts(char *dir, char *buf)
1916 { return do_pathify_dirspec(dir,buf,1); }
1918 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1919 static char *do_tounixspec(char *spec, char *buf, int ts)
1921 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1922 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1923 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1925 if (spec == NULL) return NULL;
1926 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1927 if (buf) rslt = buf;
1929 retlen = strlen(spec);
1930 cp1 = strchr(spec,'[');
1931 if (!cp1) cp1 = strchr(spec,'<');
1933 for (cp1++; *cp1; cp1++) {
1934 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1935 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1936 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1939 New(1315,rslt,retlen+2+2*expand,char);
1941 else rslt = __tounixspec_retbuf;
1942 if (strchr(spec,'/') != NULL) {
1949 dirend = strrchr(spec,']');
1950 if (dirend == NULL) dirend = strrchr(spec,'>');
1951 if (dirend == NULL) dirend = strchr(spec,':');
1952 if (dirend == NULL) {
1956 if (*cp2 != '[' && *cp2 != '<') {
1959 else { /* the VMS spec begins with directories */
1961 if (*cp2 == ']' || *cp2 == '>') {
1962 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1965 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1966 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1967 if (ts) Safefree(rslt);
1972 while (*cp3 != ':' && *cp3) cp3++;
1974 if (strchr(cp3,']') != NULL) break;
1975 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1977 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1978 retlen = devlen + dirlen;
1979 Renew(rslt,retlen+1+2*expand,char);
1985 *(cp1++) = *(cp3++);
1986 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1990 else if ( *cp2 == '.') {
1991 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1992 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1998 for (; cp2 <= dirend; cp2++) {
2001 if (*(cp2+1) == '[') cp2++;
2003 else if (*cp2 == ']' || *cp2 == '>') {
2004 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2006 else if (*cp2 == '.') {
2008 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2009 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2010 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2011 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2012 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2014 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2015 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2019 else if (*cp2 == '-') {
2020 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2021 while (*cp2 == '-') {
2023 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2025 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2026 if (ts) Safefree(rslt); /* filespecs like */
2027 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2031 else *(cp1++) = *cp2;
2033 else *(cp1++) = *cp2;
2035 while (*cp2) *(cp1++) = *(cp2++);
2040 } /* end of do_tounixspec() */
2042 /* External entry points */
2043 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2044 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2046 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2047 static char *do_tovmsspec(char *path, char *buf, int ts) {
2048 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2049 char *rslt, *dirend;
2050 register char *cp1, *cp2;
2051 unsigned long int infront = 0, hasdir = 1;
2053 if (path == NULL) return NULL;
2054 if (buf) rslt = buf;
2055 else if (ts) New(1316,rslt,strlen(path)+9,char);
2056 else rslt = __tovmsspec_retbuf;
2057 if (strpbrk(path,"]:>") ||
2058 (dirend = strrchr(path,'/')) == NULL) {
2059 if (path[0] == '.') {
2060 if (path[1] == '\0') strcpy(rslt,"[]");
2061 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2062 else strcpy(rslt,path); /* probably garbage */
2064 else strcpy(rslt,path);
2067 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2068 if (!*(dirend+2)) dirend +=2;
2069 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2070 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2075 char trndev[NAM$C_MAXRSS+1];
2079 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2081 if (!buf & ts) Renew(rslt,18,char);
2082 strcpy(rslt,"sys$disk:[000000]");
2085 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2087 islnm = my_trnlnm(rslt,trndev,0);
2088 trnend = islnm ? strlen(trndev) - 1 : 0;
2089 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2090 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2091 /* If the first element of the path is a logical name, determine
2092 * whether it has to be translated so we can add more directories. */
2093 if (!islnm || rooted) {
2096 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2100 if (cp2 != dirend) {
2101 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2102 strcpy(rslt,trndev);
2103 cp1 = rslt + trnend;
2116 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2117 cp2 += 2; /* skip over "./" - it's redundant */
2118 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2120 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2121 *(cp1++) = '-'; /* "../" --> "-" */
2124 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2125 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2126 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2127 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2130 if (cp2 > dirend) cp2 = dirend;
2132 else *(cp1++) = '.';
2134 for (; cp2 < dirend; cp2++) {
2136 if (*(cp2-1) == '/') continue;
2137 if (*(cp1-1) != '.') *(cp1++) = '.';
2140 else if (!infront && *cp2 == '.') {
2141 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2142 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2143 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
2144 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-';
2145 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2147 /* if (*(cp1-1) != '.') *(cp1++) = '.'; */
2151 if (cp2 == dirend) break;
2153 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2154 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2155 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2156 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2158 *(cp1++) = '.'; /* Simulate trailing '/' */
2159 cp2 += 2; /* for loop will incr this to == dirend */
2161 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2163 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2166 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2167 if (*cp2 == '.') *(cp1++) = '_';
2168 else *(cp1++) = *cp2;
2172 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2173 if (hasdir) *(cp1++) = ']';
2174 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2175 while (*cp2) *(cp1++) = *(cp2++);
2180 } /* end of do_tovmsspec() */
2182 /* External entry points */
2183 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2184 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2186 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2187 static char *do_tovmspath(char *path, char *buf, int ts) {
2188 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2190 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2192 if (path == NULL) return NULL;
2193 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2194 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2195 if (buf) return buf;
2197 vmslen = strlen(vmsified);
2198 New(1317,cp,vmslen+1,char);
2199 memcpy(cp,vmsified,vmslen);
2204 strcpy(__tovmspath_retbuf,vmsified);
2205 return __tovmspath_retbuf;
2208 } /* end of do_tovmspath() */
2210 /* External entry points */
2211 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2212 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2215 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2216 static char *do_tounixpath(char *path, char *buf, int ts) {
2217 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2219 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2221 if (path == NULL) return NULL;
2222 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2223 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2224 if (buf) return buf;
2226 unixlen = strlen(unixified);
2227 New(1317,cp,unixlen+1,char);
2228 memcpy(cp,unixified,unixlen);
2233 strcpy(__tounixpath_retbuf,unixified);
2234 return __tounixpath_retbuf;
2237 } /* end of do_tounixpath() */
2239 /* External entry points */
2240 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2241 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2244 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2246 *****************************************************************************
2248 * Copyright (C) 1989-1994 by *
2249 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2251 * Permission is hereby granted for the reproduction of this software, *
2252 * on condition that this copyright notice is included in the reproduction, *
2253 * and that such reproduction is not for purposes of profit or material *
2256 * 27-Aug-1994 Modified for inclusion in perl5 *
2257 * by Charles Bailey bailey@newman.upenn.edu *
2258 *****************************************************************************
2262 * getredirection() is intended to aid in porting C programs
2263 * to VMS (Vax-11 C). The native VMS environment does not support
2264 * '>' and '<' I/O redirection, or command line wild card expansion,
2265 * or a command line pipe mechanism using the '|' AND background
2266 * command execution '&'. All of these capabilities are provided to any
2267 * C program which calls this procedure as the first thing in the
2269 * The piping mechanism will probably work with almost any 'filter' type
2270 * of program. With suitable modification, it may useful for other
2271 * portability problems as well.
2273 * Author: Mark Pizzolato mark@infocomm.com
2277 struct list_item *next;
2281 static void add_item(struct list_item **head,
2282 struct list_item **tail,
2286 static void expand_wild_cards(char *item,
2287 struct list_item **head,
2288 struct list_item **tail,
2291 static int background_process(int argc, char **argv);
2293 static void pipe_and_fork(char **cmargv);
2295 /*{{{ void getredirection(int *ac, char ***av)*/
2297 getredirection(int *ac, char ***av)
2299 * Process vms redirection arg's. Exit if any error is seen.
2300 * If getredirection() processes an argument, it is erased
2301 * from the vector. getredirection() returns a new argc and argv value.
2302 * In the event that a background command is requested (by a trailing "&"),
2303 * this routine creates a background subprocess, and simply exits the program.
2305 * Warning: do not try to simplify the code for vms. The code
2306 * presupposes that getredirection() is called before any data is
2307 * read from stdin or written to stdout.
2309 * Normal usage is as follows:
2315 * getredirection(&argc, &argv);
2319 int argc = *ac; /* Argument Count */
2320 char **argv = *av; /* Argument Vector */
2321 char *ap; /* Argument pointer */
2322 int j; /* argv[] index */
2323 int item_count = 0; /* Count of Items in List */
2324 struct list_item *list_head = 0; /* First Item in List */
2325 struct list_item *list_tail; /* Last Item in List */
2326 char *in = NULL; /* Input File Name */
2327 char *out = NULL; /* Output File Name */
2328 char *outmode = "w"; /* Mode to Open Output File */
2329 char *err = NULL; /* Error File Name */
2330 char *errmode = "w"; /* Mode to Open Error File */
2331 int cmargc = 0; /* Piped Command Arg Count */
2332 char **cmargv = NULL;/* Piped Command Arg Vector */
2335 * First handle the case where the last thing on the line ends with
2336 * a '&'. This indicates the desire for the command to be run in a
2337 * subprocess, so we satisfy that desire.
2340 if (0 == strcmp("&", ap))
2341 exit(background_process(--argc, argv));
2342 if (*ap && '&' == ap[strlen(ap)-1])
2344 ap[strlen(ap)-1] = '\0';
2345 exit(background_process(argc, argv));
2348 * Now we handle the general redirection cases that involve '>', '>>',
2349 * '<', and pipes '|'.
2351 for (j = 0; j < argc; ++j)
2353 if (0 == strcmp("<", argv[j]))
2357 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2358 exit(LIB$_WRONUMARG);
2363 if ('<' == *(ap = argv[j]))
2368 if (0 == strcmp(">", ap))
2372 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2373 exit(LIB$_WRONUMARG);
2392 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2393 exit(LIB$_WRONUMARG);
2397 if (('2' == *ap) && ('>' == ap[1]))
2414 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2415 exit(LIB$_WRONUMARG);
2419 if (0 == strcmp("|", argv[j]))
2423 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2424 exit(LIB$_WRONUMARG);
2426 cmargc = argc-(j+1);
2427 cmargv = &argv[j+1];
2431 if ('|' == *(ap = argv[j]))
2439 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2442 * Allocate and fill in the new argument vector, Some Unix's terminate
2443 * the list with an extra null pointer.
2445 New(1302, argv, item_count+1, char *);
2447 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2448 argv[j] = list_head->value;
2454 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2455 exit(LIB$_INVARGORD);
2457 pipe_and_fork(cmargv);
2460 /* Check for input from a pipe (mailbox) */
2462 if (in == NULL && 1 == isapipe(0))
2464 char mbxname[L_tmpnam];
2466 long int dvi_item = DVI$_DEVBUFSIZ;
2467 $DESCRIPTOR(mbxnam, "");
2468 $DESCRIPTOR(mbxdevnam, "");
2470 /* Input from a pipe, reopen it in binary mode to disable */
2471 /* carriage control processing. */
2473 PerlIO_getname(stdin, mbxname);
2474 mbxnam.dsc$a_pointer = mbxname;
2475 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2476 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2477 mbxdevnam.dsc$a_pointer = mbxname;
2478 mbxdevnam.dsc$w_length = sizeof(mbxname);
2479 dvi_item = DVI$_DEVNAM;
2480 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2481 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2484 freopen(mbxname, "rb", stdin);
2487 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2491 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2493 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2496 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2498 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2503 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2505 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2509 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2514 #ifdef ARGPROC_DEBUG
2515 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2516 for (j = 0; j < *ac; ++j)
2517 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2519 /* Clear errors we may have hit expanding wildcards, so they don't
2520 show up in Perl's $! later */
2521 set_errno(0); set_vaxc_errno(1);
2522 } /* end of getredirection() */
2525 static void add_item(struct list_item **head,
2526 struct list_item **tail,
2532 New(1303,*head,1,struct list_item);
2536 New(1304,(*tail)->next,1,struct list_item);
2537 *tail = (*tail)->next;
2539 (*tail)->value = value;
2543 static void expand_wild_cards(char *item,
2544 struct list_item **head,
2545 struct list_item **tail,
2549 unsigned long int context = 0;
2555 char vmsspec[NAM$C_MAXRSS+1];
2556 $DESCRIPTOR(filespec, "");
2557 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2558 $DESCRIPTOR(resultspec, "");
2559 unsigned long int zero = 0, sts;
2561 for (cp = item; *cp; cp++) {
2562 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2563 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2565 if (!*cp || isspace(*cp))
2567 add_item(head, tail, item, count);
2570 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2571 resultspec.dsc$b_class = DSC$K_CLASS_D;
2572 resultspec.dsc$a_pointer = NULL;
2573 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2574 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2575 if (!isunix || !filespec.dsc$a_pointer)
2576 filespec.dsc$a_pointer = item;
2577 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2579 * Only return version specs, if the caller specified a version
2581 had_version = strchr(item, ';');
2583 * Only return device and directory specs, if the caller specifed either.
2585 had_device = strchr(item, ':');
2586 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2588 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2589 &defaultspec, 0, 0, &zero))))
2594 New(1305,string,resultspec.dsc$w_length+1,char);
2595 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2596 string[resultspec.dsc$w_length] = '\0';
2597 if (NULL == had_version)
2598 *((char *)strrchr(string, ';')) = '\0';
2599 if ((!had_directory) && (had_device == NULL))
2601 if (NULL == (devdir = strrchr(string, ']')))
2602 devdir = strrchr(string, '>');
2603 strcpy(string, devdir + 1);
2606 * Be consistent with what the C RTL has already done to the rest of
2607 * the argv items and lowercase all of these names.
2609 for (c = string; *c; ++c)
2612 if (isunix) trim_unixpath(string,item,1);
2613 add_item(head, tail, string, count);
2616 if (sts != RMS$_NMF)
2618 set_vaxc_errno(sts);
2624 set_errno(ENOENT); break;
2626 set_errno(ENODEV); break;
2629 set_errno(EINVAL); break;
2631 set_errno(EACCES); break;
2633 _ckvmssts_noperl(sts);
2637 add_item(head, tail, item, count);
2638 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2639 _ckvmssts_noperl(lib$find_file_end(&context));
2642 static int child_st[2];/* Event Flag set when child process completes */
2644 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2646 static unsigned long int exit_handler(int *status)
2650 if (0 == child_st[0])
2652 #ifdef ARGPROC_DEBUG
2653 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2655 fflush(stdout); /* Have to flush pipe for binary data to */
2656 /* terminate properly -- <tp@mccall.com> */
2657 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2658 sys$dassgn(child_chan);
2660 sys$synch(0, child_st);
2665 static void sig_child(int chan)
2667 #ifdef ARGPROC_DEBUG
2668 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2670 if (child_st[0] == 0)
2674 static struct exit_control_block exit_block =
2679 &exit_block.exit_status,
2683 static void pipe_and_fork(char **cmargv)
2686 $DESCRIPTOR(cmddsc, "");
2687 static char mbxname[64];
2688 $DESCRIPTOR(mbxdsc, mbxname);
2690 unsigned long int zero = 0, one = 1;
2692 strcpy(subcmd, cmargv[0]);
2693 for (j = 1; NULL != cmargv[j]; ++j)
2695 strcat(subcmd, " \"");
2696 strcat(subcmd, cmargv[j]);
2697 strcat(subcmd, "\"");
2699 cmddsc.dsc$a_pointer = subcmd;
2700 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2702 create_mbx(&child_chan,&mbxdsc);
2703 #ifdef ARGPROC_DEBUG
2704 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2705 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2707 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2708 0, &pid, child_st, &zero, sig_child,
2710 #ifdef ARGPROC_DEBUG
2711 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2713 sys$dclexh(&exit_block);
2714 if (NULL == freopen(mbxname, "wb", stdout))
2716 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2720 static int background_process(int argc, char **argv)
2722 char command[2048] = "$";
2723 $DESCRIPTOR(value, "");
2724 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2725 static $DESCRIPTOR(null, "NLA0:");
2726 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2728 $DESCRIPTOR(pidstr, "");
2730 unsigned long int flags = 17, one = 1, retsts;
2732 strcat(command, argv[0]);
2735 strcat(command, " \"");
2736 strcat(command, *(++argv));
2737 strcat(command, "\"");
2739 value.dsc$a_pointer = command;
2740 value.dsc$w_length = strlen(value.dsc$a_pointer);
2741 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2742 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2743 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2744 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2747 _ckvmssts_noperl(retsts);
2749 #ifdef ARGPROC_DEBUG
2750 PerlIO_printf(Perl_debug_log, "%s\n", command);
2752 sprintf(pidstring, "%08X", pid);
2753 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2754 pidstr.dsc$a_pointer = pidstring;
2755 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2756 lib$set_symbol(&pidsymbol, &pidstr);
2760 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2763 /* OS-specific initialization at image activation (not thread startup) */
2764 /* Older VAXC header files lack these constants */
2765 #ifndef JPI$_RIGHTS_SIZE
2766 # define JPI$_RIGHTS_SIZE 817
2768 #ifndef KGB$M_SUBSYSTEM
2769 # define KGB$M_SUBSYSTEM 0x8
2772 /*{{{void vms_image_init(int *, char ***)*/
2774 vms_image_init(int *argcp, char ***argvp)
2776 char eqv[LNM$C_NAMLENGTH+1] = "";
2777 unsigned int len, tabct = 8, tabidx = 0;
2778 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2779 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2780 unsigned short int dummy, rlen;
2781 struct dsc$descriptor_s **tabvec;
2783 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2784 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2785 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2788 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2790 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2791 if (iprv[i]) { /* Running image installed with privs? */
2792 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2797 /* Rights identifiers might trigger tainting as well. */
2798 if (!will_taint && (rlen || rsz)) {
2799 while (rlen < rsz) {
2800 /* We didn't get all the identifiers on the first pass. Allocate a
2801 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2802 * were needed to hold all identifiers at time of last call; we'll
2803 * allocate that many unsigned long ints), and go back and get 'em.
2805 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2806 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2807 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2808 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2811 mask = jpilist[1].bufadr;
2812 /* Check attribute flags for each identifier (2nd longword); protected
2813 * subsystem identifiers trigger tainting.
2815 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2816 if (mask[i] & KGB$M_SUBSYSTEM) {
2821 if (mask != rlst) Safefree(mask);
2823 /* We need to use this hack to tell Perl it should run with tainting,
2824 * since its tainting flag may be part of the PL_curinterp struct, which
2825 * hasn't been allocated when vms_image_init() is called.
2829 New(1320,newap,*argcp+2,char **);
2830 newap[0] = argvp[0];
2832 Copy(argvp[1],newap[2],*argcp-1,char **);
2833 /* We orphan the old argv, since we don't know where it's come from,
2834 * so we don't know how to free it.
2836 *argcp++; argvp = newap;
2838 else { /* Did user explicitly request tainting? */
2840 char *cp, **av = *argvp;
2841 for (i = 1; i < *argcp; i++) {
2842 if (*av[i] != '-') break;
2843 for (cp = av[i]+1; *cp; cp++) {
2844 if (*cp == 'T') { will_taint = 1; break; }
2845 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2846 strchr("DFIiMmx",*cp)) break;
2848 if (will_taint) break;
2853 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2855 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2856 else if (tabidx >= tabct) {
2858 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2860 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2861 tabvec[tabidx]->dsc$w_length = 0;
2862 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2863 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2864 tabvec[tabidx]->dsc$a_pointer = NULL;
2865 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2867 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2869 getredirection(argcp,argvp);
2870 #if defined(USE_THREADS) && defined(__DECC)
2872 # include <reentrancy.h>
2873 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2882 * Trim Unix-style prefix off filespec, so it looks like what a shell
2883 * glob expansion would return (i.e. from specified prefix on, not
2884 * full path). Note that returned filespec is Unix-style, regardless
2885 * of whether input filespec was VMS-style or Unix-style.
2887 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2888 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2889 * vector of options; at present, only bit 0 is used, and if set tells
2890 * trim unixpath to try the current default directory as a prefix when
2891 * presented with a possibly ambiguous ... wildcard.
2893 * Returns !=0 on success, with trimmed filespec replacing contents of
2894 * fspec, and 0 on failure, with contents of fpsec unchanged.
2896 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2898 trim_unixpath(char *fspec, char *wildspec, int opts)
2900 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2901 *template, *base, *end, *cp1, *cp2;
2902 register int tmplen, reslen = 0, dirs = 0;
2904 if (!wildspec || !fspec) return 0;
2905 if (strpbrk(wildspec,"]>:") != NULL) {
2906 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2907 else template = unixwild;
2909 else template = wildspec;
2910 if (strpbrk(fspec,"]>:") != NULL) {
2911 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2912 else base = unixified;
2913 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2914 * check to see that final result fits into (isn't longer than) fspec */
2915 reslen = strlen(fspec);
2919 /* No prefix or absolute path on wildcard, so nothing to remove */
2920 if (!*template || *template == '/') {
2921 if (base == fspec) return 1;
2922 tmplen = strlen(unixified);
2923 if (tmplen > reslen) return 0; /* not enough space */
2924 /* Copy unixified resultant, including trailing NUL */
2925 memmove(fspec,unixified,tmplen+1);
2929 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2930 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2931 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2932 for (cp1 = end ;cp1 >= base; cp1--)
2933 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2935 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2939 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2940 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2941 int ells = 1, totells, segdirs, match;
2942 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2943 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2945 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2947 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2948 if (ellipsis == template && opts & 1) {
2949 /* Template begins with an ellipsis. Since we can't tell how many
2950 * directory names at the front of the resultant to keep for an
2951 * arbitrary starting point, we arbitrarily choose the current
2952 * default directory as a starting point. If it's there as a prefix,
2953 * clip it off. If not, fall through and act as if the leading
2954 * ellipsis weren't there (i.e. return shortest possible path that
2955 * could match template).
2957 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2958 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2959 if (_tolower(*cp1) != _tolower(*cp2)) break;
2960 segdirs = dirs - totells; /* Min # of dirs we must have left */
2961 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2962 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2963 memcpy(fspec,cp2+1,end - cp2);
2967 /* First off, back up over constant elements at end of path */
2969 for (front = end ; front >= base; front--)
2970 if (*front == '/' && !dirs--) { front++; break; }
2972 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2973 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2974 if (cp1 != '\0') return 0; /* Path too long. */
2976 *cp2 = '\0'; /* Pick up with memcpy later */
2977 lcfront = lcres + (front - base);
2978 /* Now skip over each ellipsis and try to match the path in front of it. */
2980 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2981 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2982 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2983 if (cp1 < template) break; /* template started with an ellipsis */
2984 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2985 ellipsis = cp1; continue;
2987 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2989 for (segdirs = 0, cp2 = tpl;
2990 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2992 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2993 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2994 if (*cp2 == '/') segdirs++;
2996 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2997 /* Back up at least as many dirs as in template before matching */
2998 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2999 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3000 for (match = 0; cp1 > lcres;) {
3001 resdsc.dsc$a_pointer = cp1;
3002 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3004 if (match == 1) lcfront = cp1;
3006 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3008 if (!match) return 0; /* Can't find prefix ??? */
3009 if (match > 1 && opts & 1) {
3010 /* This ... wildcard could cover more than one set of dirs (i.e.
3011 * a set of similar dir names is repeated). If the template
3012 * contains more than 1 ..., upstream elements could resolve the
3013 * ambiguity, but it's not worth a full backtracking setup here.
3014 * As a quick heuristic, clip off the current default directory
3015 * if it's present to find the trimmed spec, else use the
3016 * shortest string that this ... could cover.
3018 char def[NAM$C_MAXRSS+1], *st;
3020 if (getcwd(def, sizeof def,0) == NULL) return 0;
3021 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3022 if (_tolower(*cp1) != _tolower(*cp2)) break;
3023 segdirs = dirs - totells; /* Min # of dirs we must have left */
3024 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3025 if (*cp1 == '\0' && *cp2 == '/') {
3026 memcpy(fspec,cp2+1,end - cp2);
3029 /* Nope -- stick with lcfront from above and keep going. */
3032 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3037 } /* end of trim_unixpath() */
3042 * VMS readdir() routines.
3043 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3045 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3046 * Minor modifications to original routines.
3049 /* Number of elements in vms_versions array */
3050 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3053 * Open a directory, return a handle for later use.
3055 /*{{{ DIR *opendir(char*name) */
3060 char dir[NAM$C_MAXRSS+1];
3063 if (do_tovmspath(name,dir,0) == NULL) {
3066 if (flex_stat(dir,&sb) == -1) return NULL;
3067 if (!S_ISDIR(sb.st_mode)) {
3068 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3071 if (!cando_by_name(S_IRUSR,0,dir)) {
3072 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3075 /* Get memory for the handle, and the pattern. */
3077 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3079 /* Fill in the fields; mainly playing with the descriptor. */
3080 (void)sprintf(dd->pattern, "%s*.*",dir);
3083 dd->vms_wantversions = 0;
3084 dd->pat.dsc$a_pointer = dd->pattern;
3085 dd->pat.dsc$w_length = strlen(dd->pattern);
3086 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3087 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3090 } /* end of opendir() */
3094 * Set the flag to indicate we want versions or not.
3096 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3098 vmsreaddirversions(DIR *dd, int flag)
3100 dd->vms_wantversions = flag;
3105 * Free up an opened directory.
3107 /*{{{ void closedir(DIR *dd)*/
3111 (void)lib$find_file_end(&dd->context);
3112 Safefree(dd->pattern);
3113 Safefree((char *)dd);
3118 * Collect all the version numbers for the current file.
3124 struct dsc$descriptor_s pat;
3125 struct dsc$descriptor_s res;
3127 char *p, *text, buff[sizeof dd->entry.d_name];
3129 unsigned long context, tmpsts;
3132 /* Convenient shorthand. */
3135 /* Add the version wildcard, ignoring the "*.*" put on before */
3136 i = strlen(dd->pattern);
3137 New(1308,text,i + e->d_namlen + 3,char);
3138 (void)strcpy(text, dd->pattern);
3139 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3141 /* Set up the pattern descriptor. */
3142 pat.dsc$a_pointer = text;
3143 pat.dsc$w_length = i + e->d_namlen - 1;
3144 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3145 pat.dsc$b_class = DSC$K_CLASS_S;
3147 /* Set up result descriptor. */
3148 res.dsc$a_pointer = buff;
3149 res.dsc$w_length = sizeof buff - 2;
3150 res.dsc$b_dtype = DSC$K_DTYPE_T;
3151 res.dsc$b_class = DSC$K_CLASS_S;
3153 /* Read files, collecting versions. */
3154 for (context = 0, e->vms_verscount = 0;
3155 e->vms_verscount < VERSIZE(e);
3156 e->vms_verscount++) {
3157 tmpsts = lib$find_file(&pat, &res, &context);
3158 if (tmpsts == RMS$_NMF || context == 0) break;
3160 buff[sizeof buff - 1] = '\0';
3161 if ((p = strchr(buff, ';')))
3162 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3164 e->vms_versions[e->vms_verscount] = -1;
3167 _ckvmssts(lib$find_file_end(&context));
3170 } /* end of collectversions() */
3173 * Read the next entry from the directory.
3175 /*{{{ struct dirent *readdir(DIR *dd)*/
3179 struct dsc$descriptor_s res;
3180 char *p, buff[sizeof dd->entry.d_name];
3181 unsigned long int tmpsts;
3183 /* Set up result descriptor, and get next file. */
3184 res.dsc$a_pointer = buff;
3185 res.dsc$w_length = sizeof buff - 2;
3186 res.dsc$b_dtype = DSC$K_DTYPE_T;
3187 res.dsc$b_class = DSC$K_CLASS_S;
3188 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3189 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3190 if (!(tmpsts & 1)) {
3191 set_vaxc_errno(tmpsts);
3194 set_errno(EACCES); break;
3196 set_errno(ENODEV); break;
3199 set_errno(ENOENT); break;
3206 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3207 buff[sizeof buff - 1] = '\0';
3208 for (p = buff; *p; p++) *p = _tolower(*p);
3209 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3212 /* Skip any directory component and just copy the name. */
3213 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3214 else (void)strcpy(dd->entry.d_name, buff);
3216 /* Clobber the version. */
3217 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3219 dd->entry.d_namlen = strlen(dd->entry.d_name);
3220 dd->entry.vms_verscount = 0;
3221 if (dd->vms_wantversions) collectversions(dd);
3224 } /* end of readdir() */
3228 * Return something that can be used in a seekdir later.
3230 /*{{{ long telldir(DIR *dd)*/
3239 * Return to a spot where we used to be. Brute force.
3241 /*{{{ void seekdir(DIR *dd,long count)*/
3243 seekdir(DIR *dd, long count)
3245 int vms_wantversions;
3248 /* If we haven't done anything yet... */
3252 /* Remember some state, and clear it. */
3253 vms_wantversions = dd->vms_wantversions;
3254 dd->vms_wantversions = 0;
3255 _ckvmssts(lib$find_file_end(&dd->context));
3258 /* The increment is in readdir(). */
3259 for (dd->count = 0; dd->count < count; )
3262 dd->vms_wantversions = vms_wantversions;
3264 } /* end of seekdir() */
3267 /* VMS subprocess management
3269 * my_vfork() - just a vfork(), after setting a flag to record that
3270 * the current script is trying a Unix-style fork/exec.
3272 * vms_do_aexec() and vms_do_exec() are called in response to the
3273 * perl 'exec' function. If this follows a vfork call, then they
3274 * call out the the regular perl routines in doio.c which do an
3275 * execvp (for those who really want to try this under VMS).
3276 * Otherwise, they do exactly what the perl docs say exec should
3277 * do - terminate the current script and invoke a new command
3278 * (See below for notes on command syntax.)
3280 * do_aspawn() and do_spawn() implement the VMS side of the perl
3281 * 'system' function.
3283 * Note on command arguments to perl 'exec' and 'system': When handled
3284 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3285 * are concatenated to form a DCL command string. If the first arg
3286 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3287 * the the command string is handed off to DCL directly. Otherwise,
3288 * the first token of the command is taken as the filespec of an image
3289 * to run. The filespec is expanded using a default type of '.EXE' and
3290 * the process defaults for device, directory, etc., and if found, the resultant
3291 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3292 * the command string as parameters. This is perhaps a bit complicated,
3293 * but I hope it will form a happy medium between what VMS folks expect
3294 * from lib$spawn and what Unix folks expect from exec.
3297 static int vfork_called;
3299 /*{{{int my_vfork()*/
3312 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3315 if (VMScmd.dsc$a_pointer) {
3316 Safefree(VMScmd.dsc$a_pointer);
3317 VMScmd.dsc$w_length = 0;
3318 VMScmd.dsc$a_pointer = Nullch;
3323 setup_argstr(SV *really, SV **mark, SV **sp)
3326 char *junk, *tmps = Nullch;
3327 register size_t cmdlen = 0;
3334 tmps = SvPV(really,rlen);
3341 for (idx++; idx <= sp; idx++) {
3343 junk = SvPVx(*idx,rlen);
3344 cmdlen += rlen ? rlen + 1 : 0;
3347 New(401,PL_Cmd,cmdlen+1,char);
3349 if (tmps && *tmps) {
3350 strcpy(PL_Cmd,tmps);
3353 else *PL_Cmd = '\0';
3354 while (++mark <= sp) {
3356 char *s = SvPVx(*mark,n_a);
3358 if (*PL_Cmd) strcat(PL_Cmd," ");
3364 } /* end of setup_argstr() */
3367 static unsigned long int
3368 setup_cmddsc(char *cmd, int check_img)
3370 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3371 $DESCRIPTOR(defdsc,".EXE");
3372 $DESCRIPTOR(resdsc,resspec);
3373 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3374 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3375 register char *s, *rest, *cp, *wordbreak;
3380 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3383 while (*s && isspace(*s)) s++;
3385 if (*s == '@' || *s == '$') {
3386 vmsspec[0] = *s; rest = s + 1;
3387 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3389 else { cp = vmsspec; rest = s; }
3390 if (*rest == '.' || *rest == '/') {
3393 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3394 rest++, cp2++) *cp2 = *rest;
3396 if (do_tovmsspec(resspec,cp,0)) {
3399 for (cp2 = vmsspec + strlen(vmsspec);
3400 *rest && cp2 - vmsspec < sizeof vmsspec;
3401 rest++, cp2++) *cp2 = *rest;
3406 /* Intuit whether verb (first word of cmd) is a DCL command:
3407 * - if first nonspace char is '@', it's a DCL indirection
3409 * - if verb contains a filespec separator, it's not a DCL command
3410 * - if it doesn't, caller tells us whether to default to a DCL
3411 * command, or to a local image unless told it's DCL (by leading '$')
3413 if (*s == '@') isdcl = 1;
3415 register char *filespec = strpbrk(s,":<[.;");
3416 rest = wordbreak = strpbrk(s," \"\t/");
3417 if (!wordbreak) wordbreak = s + strlen(s);
3418 if (*s == '$') check_img = 0;
3419 if (filespec && (filespec < wordbreak)) isdcl = 0;
3420 else isdcl = !check_img;
3424 imgdsc.dsc$a_pointer = s;
3425 imgdsc.dsc$w_length = wordbreak - s;
3426 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3427 if (!(retsts & 1) && *s == '$') {
3428 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3429 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3430 _ckvmssts(lib$find_file_end(&cxt));
3434 while (*s && !isspace(*s)) s++;
3436 if (cando_by_name(S_IXUSR,0,resspec)) {
3437 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3438 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3439 strcat(VMScmd.dsc$a_pointer,resspec);
3440 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3441 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3444 else retsts = RMS$_PRV;
3447 /* It's either a DCL command or we couldn't find a suitable image */
3448 VMScmd.dsc$w_length = strlen(cmd);
3449 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3450 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3451 if (!(retsts & 1)) {
3452 /* just hand off status values likely to be due to user error */
3453 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3454 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3455 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3456 else { _ckvmssts(retsts); }
3459 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3461 } /* end of setup_cmddsc() */
3464 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3466 vms_do_aexec(SV *really,SV **mark,SV **sp)
3470 if (vfork_called) { /* this follows a vfork - act Unixish */
3472 if (vfork_called < 0) {
3473 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3476 else return do_aexec(really,mark,sp);
3478 /* no vfork - act VMSish */
3479 return vms_do_exec(setup_argstr(really,mark,sp));
3484 } /* end of vms_do_aexec() */
3487 /* {{{bool vms_do_exec(char *cmd) */
3489 vms_do_exec(char *cmd)
3493 if (vfork_called) { /* this follows a vfork - act Unixish */
3495 if (vfork_called < 0) {
3496 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3499 else return do_exec(cmd);
3502 { /* no vfork - act VMSish */
3503 unsigned long int retsts;
3506 TAINT_PROPER("exec");
3507 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3508 retsts = lib$do_command(&VMScmd);
3512 set_errno(ENOENT); break;
3513 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3514 set_errno(ENOTDIR); break;
3516 set_errno(EACCES); break;
3518 set_errno(EINVAL); break;
3520 set_errno(E2BIG); break;
3521 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3522 _ckvmssts(retsts); /* fall through */
3523 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3526 set_vaxc_errno(retsts);
3527 if (ckWARN(WARN_EXEC)) {
3528 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3529 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3536 } /* end of vms_do_exec() */
3539 unsigned long int do_spawn(char *);
3541 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3543 do_aspawn(void *really,void **mark,void **sp)
3546 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3549 } /* end of do_aspawn() */
3552 /* {{{unsigned long int do_spawn(char *cmd) */
3556 unsigned long int sts, substs, hadcmd = 1;
3560 TAINT_PROPER("spawn");
3561 if (!cmd || !*cmd) {
3563 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3565 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3566 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3572 set_errno(ENOENT); break;
3573 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3574 set_errno(ENOTDIR); break;
3576 set_errno(EACCES); break;
3578 set_errno(EINVAL); break;
3580 set_errno(E2BIG); break;
3581 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3582 _ckvmssts(sts); /* fall through */
3583 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3586 set_vaxc_errno(sts);
3587 if (ckWARN(WARN_EXEC)) {
3588 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3589 hadcmd ? VMScmd.dsc$w_length : 0,
3590 hadcmd ? VMScmd.dsc$a_pointer : "",
3597 } /* end of do_spawn() */
3601 * A simple fwrite replacement which outputs itmsz*nitm chars without
3602 * introducing record boundaries every itmsz chars.
3604 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3606 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3608 register char *cp, *end;
3610 end = (char *)src + itmsz * nitm;
3612 while ((char *)src <= end) {
3613 for (cp = src; cp <= end; cp++) if (!*cp) break;
3614 if (fputs(src,dest) == EOF) return EOF;
3616 if (fputc('\0',dest) == EOF) return EOF;
3622 } /* end of my_fwrite() */
3625 /*{{{ int my_flush(FILE *fp)*/
3630 if ((res = fflush(fp)) == 0 && fp) {
3631 #ifdef VMS_DO_SOCKETS
3633 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3635 res = fsync(fileno(fp));
3642 * Here are replacements for the following Unix routines in the VMS environment:
3643 * getpwuid Get information for a particular UIC or UID
3644 * getpwnam Get information for a named user
3645 * getpwent Get information for each user in the rights database
3646 * setpwent Reset search to the start of the rights database
3647 * endpwent Finish searching for users in the rights database
3649 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3650 * (defined in pwd.h), which contains the following fields:-
3652 * char *pw_name; Username (in lower case)
3653 * char *pw_passwd; Hashed password
3654 * unsigned int pw_uid; UIC
3655 * unsigned int pw_gid; UIC group number
3656 * char *pw_unixdir; Default device/directory (VMS-style)
3657 * char *pw_gecos; Owner name
3658 * char *pw_dir; Default device/directory (Unix-style)
3659 * char *pw_shell; Default CLI name (eg. DCL)
3661 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3663 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3664 * not the UIC member number (eg. what's returned by getuid()),
3665 * getpwuid() can accept either as input (if uid is specified, the caller's
3666 * UIC group is used), though it won't recognise gid=0.
3668 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3669 * information about other users in your group or in other groups, respectively.
3670 * If the required privilege is not available, then these routines fill only
3671 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3674 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3677 /* sizes of various UAF record fields */
3678 #define UAI$S_USERNAME 12
3679 #define UAI$S_IDENT 31
3680 #define UAI$S_OWNER 31
3681 #define UAI$S_DEFDEV 31
3682 #define UAI$S_DEFDIR 63
3683 #define UAI$S_DEFCLI 31
3686 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3687 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3688 (uic).uic$v_group != UIC$K_WILD_GROUP)
3690 static char __empty[]= "";
3691 static struct passwd __passwd_empty=
3692 {(char *) __empty, (char *) __empty, 0, 0,
3693 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3694 static int contxt= 0;
3695 static struct passwd __pwdcache;
3696 static char __pw_namecache[UAI$S_IDENT+1];
3699 * This routine does most of the work extracting the user information.
3701 static int fillpasswd (const char *name, struct passwd *pwd)
3705 unsigned char length;
3706 char pw_gecos[UAI$S_OWNER+1];
3708 static union uicdef uic;
3710 unsigned char length;
3711 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3714 unsigned char length;
3715 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3718 unsigned char length;
3719 char pw_shell[UAI$S_DEFCLI+1];
3721 static char pw_passwd[UAI$S_PWD+1];
3723 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3724 struct dsc$descriptor_s name_desc;
3725 unsigned long int sts;
3727 static struct itmlst_3 itmlst[]= {
3728 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3729 {sizeof(uic), UAI$_UIC, &uic, &luic},
3730 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3731 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3732 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3733 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3734 {0, 0, NULL, NULL}};
3736 name_desc.dsc$w_length= strlen(name);
3737 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3738 name_desc.dsc$b_class= DSC$K_CLASS_S;
3739 name_desc.dsc$a_pointer= (char *) name;
3741 /* Note that sys$getuai returns many fields as counted strings. */
3742 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3743 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3744 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3746 else { _ckvmssts(sts); }
3747 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3749 if ((int) owner.length < lowner) lowner= (int) owner.length;
3750 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3751 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3752 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3753 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3754 owner.pw_gecos[lowner]= '\0';
3755 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3756 defcli.pw_shell[ldefcli]= '\0';
3757 if (valid_uic(uic)) {
3758 pwd->pw_uid= uic.uic$l_uic;
3759 pwd->pw_gid= uic.uic$v_group;
3762 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3763 pwd->pw_passwd= pw_passwd;
3764 pwd->pw_gecos= owner.pw_gecos;
3765 pwd->pw_dir= defdev.pw_dir;
3766 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3767 pwd->pw_shell= defcli.pw_shell;
3768 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3770 ldir= strlen(pwd->pw_unixdir) - 1;
3771 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3774 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3775 __mystrtolower(pwd->pw_unixdir);
3780 * Get information for a named user.
3782 /*{{{struct passwd *getpwnam(char *name)*/
3783 struct passwd *my_getpwnam(char *name)
3785 struct dsc$descriptor_s name_desc;
3787 unsigned long int status, sts;
3790 __pwdcache = __passwd_empty;
3791 if (!fillpasswd(name, &__pwdcache)) {
3792 /* We still may be able to determine pw_uid and pw_gid */
3793 name_desc.dsc$w_length= strlen(name);
3794 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3795 name_desc.dsc$b_class= DSC$K_CLASS_S;
3796 name_desc.dsc$a_pointer= (char *) name;
3797 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3798 __pwdcache.pw_uid= uic.uic$l_uic;
3799 __pwdcache.pw_gid= uic.uic$v_group;
3802 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3803 set_vaxc_errno(sts);
3804 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3807 else { _ckvmssts(sts); }
3810 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3811 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3812 __pwdcache.pw_name= __pw_namecache;
3814 } /* end of my_getpwnam() */
3818 * Get information for a particular UIC or UID.
3819 * Called by my_getpwent with uid=-1 to list all users.
3821 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3822 struct passwd *my_getpwuid(Uid_t uid)
3824 const $DESCRIPTOR(name_desc,__pw_namecache);
3825 unsigned short lname;
3827 unsigned long int status;
3830 if (uid == (unsigned int) -1) {
3832 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3833 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3834 set_vaxc_errno(status);
3835 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3839 else { _ckvmssts(status); }
3840 } while (!valid_uic (uic));
3844 if (!uic.uic$v_group)
3845 uic.uic$v_group= PerlProc_getgid();
3847 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3848 else status = SS$_IVIDENT;
3849 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3850 status == RMS$_PRV) {
3851 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3854 else { _ckvmssts(status); }
3856 __pw_namecache[lname]= '\0';
3857 __mystrtolower(__pw_namecache);
3859 __pwdcache = __passwd_empty;
3860 __pwdcache.pw_name = __pw_namecache;
3862 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3863 The identifier's value is usually the UIC, but it doesn't have to be,
3864 so if we can, we let fillpasswd update this. */
3865 __pwdcache.pw_uid = uic.uic$l_uic;
3866 __pwdcache.pw_gid = uic.uic$v_group;
3868 fillpasswd(__pw_namecache, &__pwdcache);
3871 } /* end of my_getpwuid() */
3875 * Get information for next user.
3877 /*{{{struct passwd *my_getpwent()*/
3878 struct passwd *my_getpwent()
3880 return (my_getpwuid((unsigned int) -1));
3885 * Finish searching rights database for users.
3887 /*{{{void my_endpwent()*/
3892 _ckvmssts(sys$finish_rdb(&contxt));
3898 #ifdef HOMEGROWN_POSIX_SIGNALS
3899 /* Signal handling routines, pulled into the core from POSIX.xs.
3901 * We need these for threads, so they've been rolled into the core,
3902 * rather than left in POSIX.xs.
3904 * (DRS, Oct 23, 1997)
3907 /* sigset_t is atomic under VMS, so these routines are easy */
3908 /*{{{int my_sigemptyset(sigset_t *) */
3909 int my_sigemptyset(sigset_t *set) {
3910 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3916 /*{{{int my_sigfillset(sigset_t *)*/
3917 int my_sigfillset(sigset_t *set) {
3919 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3920 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3926 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3927 int my_sigaddset(sigset_t *set, int sig) {
3928 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3929 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3930 *set |= (1 << (sig - 1));
3936 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3937 int my_sigdelset(sigset_t *set, int sig) {
3938 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3939 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3940 *set &= ~(1 << (sig - 1));
3946 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3947 int my_sigismember(sigset_t *set, int sig) {
3948 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3949 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3950 *set & (1 << (sig - 1));
3955 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3956 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3959 /* If set and oset are both null, then things are badly wrong. Bail out. */
3960 if ((oset == NULL) && (set == NULL)) {
3961 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3965 /* If set's null, then we're just handling a fetch. */
3967 tempmask = sigblock(0);
3972 tempmask = sigsetmask(*set);
3975 tempmask = sigblock(*set);
3978 tempmask = sigblock(0);
3979 sigsetmask(*oset & ~tempmask);
3982 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3987 /* Did they pass us an oset? If so, stick our holding mask into it */
3994 #endif /* HOMEGROWN_POSIX_SIGNALS */
3997 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3998 * my_utime(), and flex_stat(), all of which operate on UTC unless
3999 * VMSISH_TIMES is true.
4001 /* method used to handle UTC conversions:
4002 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4004 static int gmtime_emulation_type;
4005 /* number of secs to add to UTC POSIX-style time to get local time */
4006 static long int utc_offset_secs;
4008 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4009 * in vmsish.h. #undef them here so we can call the CRTL routines
4016 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4017 # define RTL_USES_UTC 1
4021 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4022 * qualifier with the extern prefix pragma. This provisional
4023 * hack circumvents this prefix pragma problem in previous
4026 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4027 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4028 # pragma __extern_prefix save
4029 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4030 # define gmtime decc$__utctz_gmtime
4031 # define localtime decc$__utctz_localtime
4032 # define time decc$__utc_time
4033 # pragma __extern_prefix restore
4035 struct tm *gmtime(), *localtime();
4041 static time_t toutc_dst(time_t loc) {
4044 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4045 loc -= utc_offset_secs;
4046 if (rsltmp->tm_isdst) loc -= 3600;
4049 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4050 ((gmtime_emulation_type || my_time(NULL)), \
4051 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4052 ((secs) - utc_offset_secs))))
4054 static time_t toloc_dst(time_t utc) {
4057 utc += utc_offset_secs;
4058 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4059 if (rsltmp->tm_isdst) utc += 3600;
4062 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4063 ((gmtime_emulation_type || my_time(NULL)), \
4064 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4065 ((secs) + utc_offset_secs))))
4068 /* my_time(), my_localtime(), my_gmtime()
4069 * By default traffic in UTC time values, using CRTL gmtime() or
4070 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4071 * Note: We need to use these functions even when the CRTL has working
4072 * UTC support, since they also handle C<use vmsish qw(times);>
4074 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4075 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4078 /*{{{time_t my_time(time_t *timep)*/
4079 time_t my_time(time_t *timep)
4085 if (gmtime_emulation_type == 0) {
4087 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4088 /* results of calls to gmtime() and localtime() */
4089 /* for same &base */
4091 gmtime_emulation_type++;
4092 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4093 char off[LNM$C_NAMLENGTH+1];;
4095 gmtime_emulation_type++;
4096 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4097 gmtime_emulation_type++;
4098 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4100 else { utc_offset_secs = atol(off); }
4102 else { /* We've got a working gmtime() */
4103 struct tm gmt, local;
4106 tm_p = localtime(&base);
4108 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4109 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4110 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4111 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4117 # ifdef RTL_USES_UTC
4118 if (VMSISH_TIME) when = _toloc(when);
4120 if (!VMSISH_TIME) when = _toutc(when);
4123 if (timep != NULL) *timep = when;
4126 } /* end of my_time() */
4130 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4132 my_gmtime(const time_t *timep)
4139 if (timep == NULL) {
4140 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4143 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4147 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4149 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4150 return gmtime(&when);
4152 /* CRTL localtime() wants local time as input, so does no tz correction */
4153 rsltmp = localtime(&when);
4154 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4157 } /* end of my_gmtime() */
4161 /*{{{struct tm *my_localtime(const time_t *timep)*/
4163 my_localtime(const time_t *timep)
4169 if (timep == NULL) {
4170 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4173 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4174 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4177 # ifdef RTL_USES_UTC
4179 if (VMSISH_TIME) when = _toutc(when);
4181 /* CRTL localtime() wants UTC as input, does tz correction itself */
4182 return localtime(&when);
4185 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4188 /* CRTL localtime() wants local time as input, so does no tz correction */
4189 rsltmp = localtime(&when);
4190 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4193 } /* end of my_localtime() */
4196 /* Reset definitions for later calls */
4197 #define gmtime(t) my_gmtime(t)
4198 #define localtime(t) my_localtime(t)
4199 #define time(t) my_time(t)
4202 /* my_utime - update modification time of a file
4203 * calling sequence is identical to POSIX utime(), but under
4204 * VMS only the modification time is changed; ODS-2 does not
4205 * maintain access times. Restrictions differ from the POSIX
4206 * definition in that the time can be changed as long as the
4207 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4208 * no separate checks are made to insure that the caller is the
4209 * owner of the file or has special privs enabled.
4210 * Code here is based on Joe Meadows' FILE utility.
4213 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4214 * to VMS epoch (01-JAN-1858 00:00:00.00)
4215 * in 100 ns intervals.
4217 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4219 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4220 int my_utime(char *file, struct utimbuf *utimes)
4224 long int bintime[2], len = 2, lowbit, unixtime,
4225 secscale = 10000000; /* seconds --> 100 ns intervals */
4226 unsigned long int chan, iosb[2], retsts;
4227 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4228 struct FAB myfab = cc$rms_fab;
4229 struct NAM mynam = cc$rms_nam;
4230 #if defined (__DECC) && defined (__VAX)
4231 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4232 * at least through VMS V6.1, which causes a type-conversion warning.
4234 # pragma message save
4235 # pragma message disable cvtdiftypes
4237 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4238 struct fibdef myfib;
4239 #if defined (__DECC) && defined (__VAX)
4240 /* This should be right after the declaration of myatr, but due
4241 * to a bug in VAX DEC C, this takes effect a statement early.
4243 # pragma message restore
4245 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4246 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4247 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4249 if (file == NULL || *file == '\0') {
4251 set_vaxc_errno(LIB$_INVARG);
4254 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4256 if (utimes != NULL) {
4257 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4258 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4259 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4260 * as input, we force the sign bit to be clear by shifting unixtime right
4261 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4263 lowbit = (utimes->modtime & 1) ? secscale : 0;
4264 unixtime = (long int) utimes->modtime;
4266 /* If input was UTC; convert to local for sys svc */
4267 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4269 unixtime >> 1; secscale << 1;
4270 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4271 if (!(retsts & 1)) {
4273 set_vaxc_errno(retsts);
4276 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4277 if (!(retsts & 1)) {
4279 set_vaxc_errno(retsts);
4284 /* Just get the current time in VMS format directly */
4285 retsts = sys$gettim(bintime);
4286 if (!(retsts & 1)) {
4288 set_vaxc_errno(retsts);
4293 myfab.fab$l_fna = vmsspec;
4294 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4295 myfab.fab$l_nam = &mynam;
4296 mynam.nam$l_esa = esa;
4297 mynam.nam$b_ess = (unsigned char) sizeof esa;
4298 mynam.nam$l_rsa = rsa;
4299 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4301 /* Look for the file to be affected, letting RMS parse the file
4302 * specification for us as well. I have set errno using only
4303 * values documented in the utime() man page for VMS POSIX.
4305 retsts = sys$parse(&myfab,0,0);
4306 if (!(retsts & 1)) {
4307 set_vaxc_errno(retsts);
4308 if (retsts == RMS$_PRV) set_errno(EACCES);
4309 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4310 else set_errno(EVMSERR);
4313 retsts = sys$search(&myfab,0,0);
4314 if (!(retsts & 1)) {
4315 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4316 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4317 set_vaxc_errno(retsts);
4318 if (retsts == RMS$_PRV) set_errno(EACCES);
4319 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4320 else set_errno(EVMSERR);
4324 devdsc.dsc$w_length = mynam.nam$b_dev;
4325 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4327 retsts = sys$assign(&devdsc,&chan,0,0);
4328 if (!(retsts & 1)) {
4329 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4330 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4331 set_vaxc_errno(retsts);
4332 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4333 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4334 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4335 else set_errno(EVMSERR);
4339 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4340 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4342 memset((void *) &myfib, 0, sizeof myfib);
4344 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4345 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4346 /* This prevents the revision time of the file being reset to the current
4347 * time as a result of our IO$_MODIFY $QIO. */
4348 myfib.fib$l_acctl = FIB$M_NORECORD;
4350 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4351 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4352 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4354 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4355 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4356 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4357 _ckvmssts(sys$dassgn(chan));
4358 if (retsts & 1) retsts = iosb[0];
4359 if (!(retsts & 1)) {
4360 set_vaxc_errno(retsts);
4361 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4362 else set_errno(EVMSERR);
4367 } /* end of my_utime() */
4371 * flex_stat, flex_fstat
4372 * basic stat, but gets it right when asked to stat
4373 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4376 /* encode_dev packs a VMS device name string into an integer to allow
4377 * simple comparisons. This can be used, for example, to check whether two
4378 * files are located on the same device, by comparing their encoded device
4379 * names. Even a string comparison would not do, because stat() reuses the
4380 * device name buffer for each call; so without encode_dev, it would be
4381 * necessary to save the buffer and use strcmp (this would mean a number of
4382 * changes to the standard Perl code, to say nothing of what a Perl script
4385 * The device lock id, if it exists, should be unique (unless perhaps compared
4386 * with lock ids transferred from other nodes). We have a lock id if the disk is
4387 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4388 * device names. Thus we use the lock id in preference, and only if that isn't
4389 * available, do we try to pack the device name into an integer (flagged by
4390 * the sign bit (LOCKID_MASK) being set).
4392 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4393 * name and its encoded form, but it seems very unlikely that we will find
4394 * two files on different disks that share the same encoded device names,
4395 * and even more remote that they will share the same file id (if the test
4396 * is to check for the same file).
4398 * A better method might be to use sys$device_scan on the first call, and to
4399 * search for the device, returning an index into the cached array.
4400 * The number returned would be more intelligable.
4401 * This is probably not worth it, and anyway would take quite a bit longer
4402 * on the first call.
4404 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4405 static mydev_t encode_dev (const char *dev)
4408 unsigned long int f;
4414 if (!dev || !dev[0]) return 0;
4418 struct dsc$descriptor_s dev_desc;
4419 unsigned long int status, lockid, item = DVI$_LOCKID;
4421 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4422 can try that first. */
4423 dev_desc.dsc$w_length = strlen (dev);
4424 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4425 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4426 dev_desc.dsc$a_pointer = (char *) dev;
4427 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4428 if (lockid) return (lockid & ~LOCKID_MASK);
4432 /* Otherwise we try to encode the device name */
4436 for (q = dev + strlen(dev); q--; q >= dev) {
4439 else if (isalpha (toupper (*q)))
4440 c= toupper (*q) - 'A' + (char)10;
4442 continue; /* Skip '$'s */
4444 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4446 enc += f * (unsigned long int) c;
4448 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4450 } /* end of encode_dev() */
4452 static char namecache[NAM$C_MAXRSS+1];
4455 is_null_device(name)
4459 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4460 The underscore prefix, controller letter, and unit number are
4461 independently optional; for our purposes, the colon punctuation
4462 is not. The colon can be trailed by optional directory and/or
4463 filename, but two consecutive colons indicates a nodename rather
4464 than a device. [pr] */
4465 if (*name == '_') ++name;
4466 if (tolower(*name++) != 'n') return 0;
4467 if (tolower(*name++) != 'l') return 0;
4468 if (tolower(*name) == 'a') ++name;
4469 if (*name == '0') ++name;
4470 return (*name++ == ':') && (*name != ':');
4473 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4474 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4475 * subset of the applicable information.
4478 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4480 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4482 char fname[NAM$C_MAXRSS+1];
4483 unsigned long int retsts;
4484 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4485 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4487 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4488 device name on successive calls */
4489 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4490 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4491 namdsc.dsc$a_pointer = fname;
4492 namdsc.dsc$w_length = sizeof fname - 1;
4494 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4495 &namdsc,&namdsc.dsc$w_length,0,0);
4497 fname[namdsc.dsc$w_length] = '\0';
4498 return cando_by_name(bit,effective,fname);
4500 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4501 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4505 return FALSE; /* Should never get to here */
4507 } /* end of cando() */
4511 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4513 cando_by_name(I32 bit, Uid_t effective, char *fname)
4515 static char usrname[L_cuserid];
4516 static struct dsc$descriptor_s usrdsc =
4517 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4518 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4519 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4520 unsigned short int retlen;
4522 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4523 union prvdef curprv;
4524 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4525 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4526 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4529 if (!fname || !*fname) return FALSE;
4530 /* Make sure we expand logical names, since sys$check_access doesn't */
4531 if (!strpbrk(fname,"/]>:")) {
4532 strcpy(fileified,fname);
4533 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4536 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4537 retlen = namdsc.dsc$w_length = strlen(vmsname);
4538 namdsc.dsc$a_pointer = vmsname;
4539 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4540 vmsname[retlen-1] == ':') {
4541 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4542 namdsc.dsc$w_length = strlen(fileified);
4543 namdsc.dsc$a_pointer = fileified;
4546 if (!usrdsc.dsc$w_length) {
4548 usrdsc.dsc$w_length = strlen(usrname);
4555 access = ARM$M_EXECUTE;
4560 access = ARM$M_READ;
4565 access = ARM$M_WRITE;
4570 access = ARM$M_DELETE;
4576 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4577 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4578 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4579 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4580 set_vaxc_errno(retsts);
4581 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4582 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4583 else set_errno(ENOENT);
4586 if (retsts == SS$_NORMAL) {
4587 if (!privused) return TRUE;
4588 /* We can get access, but only by using privs. Do we have the
4589 necessary privs currently enabled? */
4590 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4591 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4592 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4593 !curprv.prv$v_bypass) return FALSE;
4594 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4595 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4596 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4599 if (retsts == SS$_ACCONFLICT) {
4604 return FALSE; /* Should never get here */
4606 } /* end of cando_by_name() */
4610 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4612 flex_fstat(int fd, Stat_t *statbufp)
4615 if (!fstat(fd,(stat_t *) statbufp)) {
4616 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4617 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4618 # ifdef RTL_USES_UTC
4621 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4622 statbufp->st_atime = _toloc(statbufp->st_atime);
4623 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4628 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4632 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4633 statbufp->st_atime = _toutc(statbufp->st_atime);
4634 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4641 } /* end of flex_fstat() */
4644 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4646 flex_stat(const char *fspec, Stat_t *statbufp)
4649 char fileified[NAM$C_MAXRSS+1];
4650 char temp_fspec[NAM$C_MAXRSS+300];
4653 strcpy(temp_fspec, fspec);
4654 if (statbufp == (Stat_t *) &PL_statcache)
4655 do_tovmsspec(temp_fspec,namecache,0);
4656 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4657 memset(statbufp,0,sizeof *statbufp);
4658 statbufp->st_dev = encode_dev("_NLA0:");
4659 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4660 statbufp->st_uid = 0x00010001;
4661 statbufp->st_gid = 0x0001;
4662 time((time_t *)&statbufp->st_mtime);
4663 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4667 /* Try for a directory name first. If fspec contains a filename without
4668 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4669 * and sea:[wine.dark]water. exist, we prefer the directory here.
4670 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4671 * not sea:[wine.dark]., if the latter exists. If the intended target is
4672 * the file with null type, specify this by calling flex_stat() with
4673 * a '.' at the end of fspec.
4675 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4676 retval = stat(fileified,(stat_t *) statbufp);
4677 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4678 strcpy(namecache,fileified);
4680 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4682 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4683 # ifdef RTL_USES_UTC
4686 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4687 statbufp->st_atime = _toloc(statbufp->st_atime);
4688 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4693 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4697 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4698 statbufp->st_atime = _toutc(statbufp->st_atime);
4699 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4705 } /* end of flex_stat() */
4709 /*{{{char *my_getlogin()*/
4710 /* VMS cuserid == Unix getlogin, except calling sequence */
4714 static char user[L_cuserid];
4715 return cuserid(user);
4720 /* rmscopy - copy a file using VMS RMS routines
4722 * Copies contents and attributes of spec_in to spec_out, except owner
4723 * and protection information. Name and type of spec_in are used as
4724 * defaults for spec_out. The third parameter specifies whether rmscopy()
4725 * should try to propagate timestamps from the input file to the output file.
4726 * If it is less than 0, no timestamps are preserved. If it is 0, then
4727 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4728 * propagated to the output file at creation iff the output file specification
4729 * did not contain an explicit name or type, and the revision date is always
4730 * updated at the end of the copy operation. If it is greater than 0, then
4731 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4732 * other than the revision date should be propagated, and bit 1 indicates
4733 * that the revision date should be propagated.
4735 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4737 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4738 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4739 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4740 * as part of the Perl standard distribution under the terms of the
4741 * GNU General Public License or the Perl Artistic License. Copies
4742 * of each may be found in the Perl standard distribution.
4744 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4746 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4748 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4749 rsa[NAM$C_MAXRSS], ubf[32256];
4750 unsigned long int i, sts, sts2;
4751 struct FAB fab_in, fab_out;
4752 struct RAB rab_in, rab_out;
4754 struct XABDAT xabdat;
4755 struct XABFHC xabfhc;
4756 struct XABRDT xabrdt;
4757 struct XABSUM xabsum;
4759 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4760 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4761 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4765 fab_in = cc$rms_fab;
4766 fab_in.fab$l_fna = vmsin;
4767 fab_in.fab$b_fns = strlen(vmsin);
4768 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4769 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4770 fab_in.fab$l_fop = FAB$M_SQO;
4771 fab_in.fab$l_nam = &nam;
4772 fab_in.fab$l_xab = (void *) &xabdat;
4775 nam.nam$l_rsa = rsa;
4776 nam.nam$b_rss = sizeof(rsa);
4777 nam.nam$l_esa = esa;
4778 nam.nam$b_ess = sizeof (esa);
4779 nam.nam$b_esl = nam.nam$b_rsl = 0;
4781 xabdat = cc$rms_xabdat; /* To get creation date */
4782 xabdat.xab$l_nxt = (void *) &xabfhc;
4784 xabfhc = cc$rms_xabfhc; /* To get record length */
4785 xabfhc.xab$l_nxt = (void *) &xabsum;
4787 xabsum = cc$rms_xabsum; /* To get key and area information */
4789 if (!((sts = sys$open(&fab_in)) & 1)) {
4790 set_vaxc_errno(sts);
4794 set_errno(ENOENT); break;
4796 set_errno(ENODEV); break;
4798 set_errno(EINVAL); break;
4800 set_errno(EACCES); break;
4808 fab_out.fab$w_ifi = 0;
4809 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4810 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4811 fab_out.fab$l_fop = FAB$M_SQO;
4812 fab_out.fab$l_fna = vmsout;
4813 fab_out.fab$b_fns = strlen(vmsout);
4814 fab_out.fab$l_dna = nam.nam$l_name;
4815 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4817 if (preserve_dates == 0) { /* Act like DCL COPY */
4818 nam.nam$b_nop = NAM$M_SYNCHK;
4819 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4820 if (!((sts = sys$parse(&fab_out)) & 1)) {
4821 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4822 set_vaxc_errno(sts);
4825 fab_out.fab$l_xab = (void *) &xabdat;
4826 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4828 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4829 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4830 preserve_dates =0; /* bitmask from this point forward */
4832 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4833 if (!((sts = sys$create(&fab_out)) & 1)) {
4834 set_vaxc_errno(sts);
4837 set_errno(ENOENT); break;
4839 set_errno(ENODEV); break;
4841 set_errno(EINVAL); break;
4843 set_errno(EACCES); break;
4849 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4850 if (preserve_dates & 2) {
4851 /* sys$close() will process xabrdt, not xabdat */
4852 xabrdt = cc$rms_xabrdt;
4854 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4856 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4857 * is unsigned long[2], while DECC & VAXC use a struct */
4858 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4860 fab_out.fab$l_xab = (void *) &xabrdt;
4863 rab_in = cc$rms_rab;
4864 rab_in.rab$l_fab = &fab_in;
4865 rab_in.rab$l_rop = RAB$M_BIO;
4866 rab_in.rab$l_ubf = ubf;
4867 rab_in.rab$w_usz = sizeof ubf;
4868 if (!((sts = sys$connect(&rab_in)) & 1)) {
4869 sys$close(&fab_in); sys$close(&fab_out);
4870 set_errno(EVMSERR); set_vaxc_errno(sts);
4874 rab_out = cc$rms_rab;
4875 rab_out.rab$l_fab = &fab_out;
4876 rab_out.rab$l_rbf = ubf;
4877 if (!((sts = sys$connect(&rab_out)) & 1)) {
4878 sys$close(&fab_in); sys$close(&fab_out);
4879 set_errno(EVMSERR); set_vaxc_errno(sts);
4883 while ((sts = sys$read(&rab_in))) { /* always true */
4884 if (sts == RMS$_EOF) break;
4885 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4886 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4887 sys$close(&fab_in); sys$close(&fab_out);
4888 set_errno(EVMSERR); set_vaxc_errno(sts);
4893 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4894 sys$close(&fab_in); sys$close(&fab_out);
4895 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4897 set_errno(EVMSERR); set_vaxc_errno(sts);
4903 } /* end of rmscopy() */
4907 /*** The following glue provides 'hooks' to make some of the routines
4908 * from this file available from Perl. These routines are sufficiently
4909 * basic, and are required sufficiently early in the build process,
4910 * that's it's nice to have them available to miniperl as well as the
4911 * full Perl, so they're set up here instead of in an extension. The
4912 * Perl code which handles importation of these names into a given
4913 * package lives in [.VMS]Filespec.pm in @INC.
4917 rmsexpand_fromperl(pTHX_ CV *cv)
4920 char *fspec, *defspec = NULL, *rslt;
4923 if (!items || items > 2)
4924 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4925 fspec = SvPV(ST(0),n_a);
4926 if (!fspec || !*fspec) XSRETURN_UNDEF;
4927 if (items == 2) defspec = SvPV(ST(1),n_a);
4929 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4930 ST(0) = sv_newmortal();
4931 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4936 vmsify_fromperl(pTHX_ CV *cv)
4942 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4943 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4944 ST(0) = sv_newmortal();
4945 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4950 unixify_fromperl(pTHX_ CV *cv)
4956 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
4957 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4958 ST(0) = sv_newmortal();
4959 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4964 fileify_fromperl(pTHX_ CV *cv)
4970 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
4971 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4972 ST(0) = sv_newmortal();
4973 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4978 pathify_fromperl(pTHX_ CV *cv)
4984 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
4985 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4986 ST(0) = sv_newmortal();
4987 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4992 vmspath_fromperl(pTHX_ CV *cv)
4998 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
4999 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5000 ST(0) = sv_newmortal();
5001 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5006 unixpath_fromperl(pTHX_ CV *cv)
5012 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5013 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5014 ST(0) = sv_newmortal();
5015 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5020 candelete_fromperl(pTHX_ CV *cv)
5023 char fspec[NAM$C_MAXRSS+1], *fsp;
5028 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5030 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5031 if (SvTYPE(mysv) == SVt_PVGV) {
5032 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5033 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5040 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5041 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5047 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5052 rmscopy_fromperl(pTHX_ CV *cv)
5055 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5057 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5058 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5059 unsigned long int sts;
5064 if (items < 2 || items > 3)
5065 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5067 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5068 if (SvTYPE(mysv) == SVt_PVGV) {
5069 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5070 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5077 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5078 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5083 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5084 if (SvTYPE(mysv) == SVt_PVGV) {
5085 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5086 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5093 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5094 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5099 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5101 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5108 char* file = __FILE__;
5110 char temp_buff[512];
5111 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5112 no_translate_barewords = TRUE;
5114 no_translate_barewords = FALSE;
5117 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5118 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5119 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5120 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5121 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5122 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5123 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5124 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5125 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);