3 * VMS-specific routines for perl5
5 * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
24 #include <libclidef.h>
26 #include <lib$routines.h>
35 #include <str$routines.h>
40 /* Older versions of ssdef.h don't have these */
41 #ifndef SS$_INVFILFOROP
42 # define SS$_INVFILFOROP 3930
44 #ifndef SS$_NOSUCHOBJECT
45 # define SS$_NOSUCHOBJECT 2696
48 /* Don't replace system definitions of vfork, getenv, and stat,
49 * code below needs to get to the underlying CRTL routines. */
50 #define DONT_MASK_RTL_CALLS
54 /* Anticipating future expansion in lexical warnings . . . */
56 # define WARN_INTERNAL WARN_MISC
59 /* gcc's header files don't #define direct access macros
60 * corresponding to VAXC's variant structs */
62 # define uic$v_format uic$r_uic_form.uic$v_format
63 # define uic$v_group uic$r_uic_form.uic$v_group
64 # define uic$v_member uic$r_uic_form.uic$v_member
65 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
66 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
67 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
68 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
71 #if defined(NEED_AN_H_ERRNO)
76 unsigned short int buflen;
77 unsigned short int itmcode;
79 unsigned short int *retlen;
82 static char *__mystrtolower(char *str)
84 if (str) for (; *str; ++str) *str= tolower(*str);
88 static struct dsc$descriptor_s fildevdsc =
89 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
90 static struct dsc$descriptor_s crtlenvdsc =
91 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
92 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
93 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
94 static struct dsc$descriptor_s **env_tables = defenv;
95 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
97 /* True if we shouldn't treat barewords as logicals during directory */
99 static int no_translate_barewords;
101 /* Temp for subprocess commands */
102 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
104 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
106 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
107 struct dsc$descriptor_s **tabvec, unsigned long int flags)
109 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
110 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
111 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
112 unsigned char acmode;
113 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
114 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
115 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
116 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
118 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
119 #if defined(USE_THREADS)
120 /* We jump through these hoops because we can be called at */
121 /* platform-specific initialization time, which is before anything is */
122 /* set up--we can't even do a plain dTHX since that relies on the */
123 /* interpreter structure to be initialized */
124 struct perl_thread *thr;
126 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
132 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
133 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
135 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
136 *cp2 = _toupper(*cp1);
137 if (cp1 - lnm > LNM$C_NAMLENGTH) {
138 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
142 lnmdsc.dsc$w_length = cp1 - lnm;
143 lnmdsc.dsc$a_pointer = uplnm;
144 secure = flags & PERL__TRNENV_SECURE;
145 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
146 if (!tabvec || !*tabvec) tabvec = env_tables;
148 for (curtab = 0; tabvec[curtab]; curtab++) {
149 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
150 if (!ivenv && !secure) {
155 Perl_warn(aTHX_ "Can't read CRTL environ\n");
158 retsts = SS$_NOLOGNAM;
159 for (i = 0; environ[i]; i++) {
160 if ((eq = strchr(environ[i],'=')) &&
161 !strncmp(environ[i],uplnm,eq - environ[i])) {
163 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
164 if (!eqvlen) continue;
169 if (retsts != SS$_NOLOGNAM) break;
172 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
173 !str$case_blind_compare(&tmpdsc,&clisym)) {
174 if (!ivsym && !secure) {
175 unsigned short int deflen = LNM$C_NAMLENGTH;
176 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
177 /* dynamic dsc to accomodate possible long value */
178 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
179 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
182 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
184 /* Special hack--we might be called before the interpreter's */
185 /* fully initialized, in which case either thr or PL_curcop */
186 /* might be bogus. We have to check, since ckWARN needs them */
187 /* both to be valid if running threaded */
188 #if defined(USE_THREADS)
189 if (thr && PL_curcop) {
191 if (ckWARN(WARN_MISC)) {
192 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
194 #if defined(USE_THREADS)
196 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
201 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
203 _ckvmssts(lib$sfree1_dd(&eqvdsc));
204 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
205 if (retsts == LIB$_NOSUCHSYM) continue;
210 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
211 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
212 if (retsts == SS$_NOLOGNAM) continue;
216 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
217 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
218 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
219 retsts == SS$_NOLOGNAM) {
220 set_errno(EINVAL); set_vaxc_errno(retsts);
222 else _ckvmssts(retsts);
224 } /* end of vmstrnenv */
227 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
228 /* Define as a function so we can access statics. */
229 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
231 return vmstrnenv(lnm,eqv,idx,fildev,
232 #ifdef SECURE_INTERNAL_GETENV
233 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
242 * Note: Uses Perl temp to store result so char * can be returned to
243 * caller; this pointer will be invalidated at next Perl statement
245 * We define this as a function rather than a macro in terms of my_getenv_len()
246 * so that it'll work when PL_curinterp is undefined (and we therefore can't
249 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
251 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
253 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
254 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
255 unsigned long int idx = 0;
259 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
260 /* Set up a temporary buffer for the return value; Perl will
261 * clean it up at the next statement transition */
262 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
263 if (!tmpsv) return NULL;
266 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
267 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
268 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
269 getcwd(eqv,LNM$C_NAMLENGTH);
273 if ((cp2 = strchr(lnm,';')) != NULL) {
275 uplnm[cp2-lnm] = '\0';
276 idx = strtoul(cp2+1,NULL,0);
279 /* Impose security constraints only if tainting */
280 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
281 if (vmstrnenv(lnm,eqv,idx,
283 #ifdef SECURE_INTERNAL_GETENV
284 sys ? PERL__TRNENV_SECURE : 0
292 } /* end of my_getenv() */
296 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
298 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
301 char *buf, *cp1, *cp2;
302 unsigned long idx = 0;
303 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
306 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
307 /* Set up a temporary buffer for the return value; Perl will
308 * clean it up at the next statement transition */
309 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
310 if (!tmpsv) return NULL;
313 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
314 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
315 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
316 getcwd(buf,LNM$C_NAMLENGTH);
321 if ((cp2 = strchr(lnm,';')) != NULL) {
324 idx = strtoul(cp2+1,NULL,0);
327 /* Impose security constraints only if tainting */
328 if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
329 if ((*len = vmstrnenv(lnm,buf,idx,
331 #ifdef SECURE_INTERNAL_GETENV
332 sys ? PERL__TRNENV_SECURE : 0
342 } /* end of my_getenv_len() */
345 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
347 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
349 /*{{{ void prime_env_iter() */
352 /* Fill the %ENV associative array with all logical names we can
353 * find, in preparation for iterating over it.
357 static int primed = 0;
358 HV *seenhv = NULL, *envhv;
359 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
360 unsigned short int chan;
361 #ifndef CLI$M_TRUSTED
362 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
364 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
365 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
367 bool have_sym = FALSE, have_lnm = FALSE;
368 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
369 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
370 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
371 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
372 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
374 static perl_mutex primenv_mutex;
375 MUTEX_INIT(&primenv_mutex);
378 if (primed || !PL_envgv) return;
379 MUTEX_LOCK(&primenv_mutex);
380 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
381 envhv = GvHVn(PL_envgv);
382 /* Perform a dummy fetch as an lval to insure that the hash table is
383 * set up. Otherwise, the hv_store() will turn into a nullop. */
384 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
386 for (i = 0; env_tables[i]; i++) {
387 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
388 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
389 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
391 if (have_sym || have_lnm) {
392 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
393 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
394 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
395 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
398 for (i--; i >= 0; i--) {
399 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
402 for (j = 0; environ[j]; j++) {
403 if (!(start = strchr(environ[j],'='))) {
404 if (ckWARN(WARN_INTERNAL))
405 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
409 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
415 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
416 !str$case_blind_compare(&tmpdsc,&clisym)) {
417 strcpy(cmd,"Show Symbol/Global *");
418 cmddsc.dsc$w_length = 20;
419 if (env_tables[i]->dsc$w_length == 12 &&
420 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
421 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
422 flags = defflags | CLI$M_NOLOGNAM;
425 strcpy(cmd,"Show Logical *");
426 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
427 strcat(cmd," /Table=");
428 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
429 cmddsc.dsc$w_length = strlen(cmd);
431 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
432 flags = defflags | CLI$M_NOCLISYM;
435 /* Create a new subprocess to execute each command, to exclude the
436 * remote possibility that someone could subvert a mbx or file used
437 * to write multiple commands to a single subprocess.
440 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
441 0,&riseandshine,0,0,&clidsc,&clitabdsc);
442 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
443 defflags &= ~CLI$M_TRUSTED;
444 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
446 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
447 if (seenhv) SvREFCNT_dec(seenhv);
450 char *cp1, *cp2, *key;
451 unsigned long int sts, iosb[2], retlen, keylen;
454 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
455 if (sts & 1) sts = iosb[0] & 0xffff;
456 if (sts == SS$_ENDOFFILE) {
458 while (substs == 0) { sys$hiber(); wakect++;}
459 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
464 retlen = iosb[0] >> 16;
465 if (!retlen) continue; /* blank line */
467 if (iosb[1] != subpid) {
469 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
473 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
474 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
476 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
477 if (*cp1 == '(' || /* Logical name table name */
478 *cp1 == '=' /* Next eqv of searchlist */) continue;
479 if (*cp1 == '"') cp1++;
480 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
481 key = cp1; keylen = cp2 - cp1;
482 if (keylen && hv_exists(seenhv,key,keylen)) continue;
483 while (*cp2 && *cp2 != '=') cp2++;
484 while (*cp2 && *cp2 == '=') cp2++;
485 while (*cp2 && *cp2 == ' ') cp2++;
486 if (*cp2 == '"') { /* String translation; may embed "" */
487 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
488 cp2++; cp1--; /* Skip "" surrounding translation */
490 else { /* Numeric translation */
491 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
492 cp1--; /* stop on last non-space char */
494 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
495 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
498 PERL_HASH(hash,key,keylen);
499 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
500 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
502 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
503 /* get the PPFs for this process, not the subprocess */
504 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
505 char eqv[LNM$C_NAMLENGTH+1];
507 for (i = 0; ppfs[i]; i++) {
508 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
509 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
514 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
515 if (buf) Safefree(buf);
516 if (seenhv) SvREFCNT_dec(seenhv);
517 MUTEX_UNLOCK(&primenv_mutex);
520 } /* end of prime_env_iter */
524 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
525 /* Define or delete an element in the same "environment" as
526 * vmstrnenv(). If an element is to be deleted, it's removed from
527 * the first place it's found. If it's to be set, it's set in the
528 * place designated by the first element of the table vector.
529 * Like setenv() returns 0 for success, non-zero on error.
532 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
534 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
535 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
536 unsigned long int retsts, usermode = PSL$C_USER;
537 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
538 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
539 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
540 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
541 $DESCRIPTOR(local,"_LOCAL");
544 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
545 *cp2 = _toupper(*cp1);
546 if (cp1 - lnm > LNM$C_NAMLENGTH) {
547 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
551 lnmdsc.dsc$w_length = cp1 - lnm;
552 if (!tabvec || !*tabvec) tabvec = env_tables;
554 if (!eqv) { /* we're deleting n element */
555 for (curtab = 0; tabvec[curtab]; curtab++) {
556 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
558 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
559 if ((cp1 = strchr(environ[i],'=')) &&
560 !strncmp(environ[i],lnm,cp1 - environ[i])) {
562 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
565 ivenv = 1; retsts = SS$_NOLOGNAM;
567 if (ckWARN(WARN_INTERNAL))
568 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
569 ivenv = 1; retsts = SS$_NOSUCHPGM;
575 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
576 !str$case_blind_compare(&tmpdsc,&clisym)) {
577 unsigned int symtype;
578 if (tabvec[curtab]->dsc$w_length == 12 &&
579 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
580 !str$case_blind_compare(&tmpdsc,&local))
581 symtype = LIB$K_CLI_LOCAL_SYM;
582 else symtype = LIB$K_CLI_GLOBAL_SYM;
583 retsts = lib$delete_symbol(&lnmdsc,&symtype);
584 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
585 if (retsts == LIB$_NOSUCHSYM) continue;
589 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
590 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
591 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
592 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
593 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
597 else { /* we're defining a value */
598 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
600 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
602 if (ckWARN(WARN_INTERNAL))
603 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
604 retsts = SS$_NOSUCHPGM;
608 eqvdsc.dsc$a_pointer = eqv;
609 eqvdsc.dsc$w_length = strlen(eqv);
610 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
611 !str$case_blind_compare(&tmpdsc,&clisym)) {
612 unsigned int symtype;
613 if (tabvec[0]->dsc$w_length == 12 &&
614 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
615 !str$case_blind_compare(&tmpdsc,&local))
616 symtype = LIB$K_CLI_LOCAL_SYM;
617 else symtype = LIB$K_CLI_GLOBAL_SYM;
618 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
621 if (!*eqv) eqvdsc.dsc$w_length = 1;
622 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
623 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
624 if (ckWARN(WARN_MISC)) {
625 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
628 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
634 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
635 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
636 set_errno(EVMSERR); break;
637 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
638 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
639 set_errno(EINVAL); break;
646 set_vaxc_errno(retsts);
647 return (int) retsts || 44; /* retsts should never be 0, but just in case */
650 /* We reset error values on success because Perl does an hv_fetch()
651 * before each hv_store(), and if the thing we're setting didn't
652 * previously exist, we've got a leftover error message. (Of course,
653 * this fails in the face of
654 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
655 * in that the error reported in $! isn't spurious,
656 * but it's right more often than not.)
658 set_errno(0); set_vaxc_errno(retsts);
662 } /* end of vmssetenv() */
665 /*{{{ void my_setenv(char *lnm, char *eqv)*/
666 /* This has to be a function since there's a prototype for it in proto.h */
668 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
670 if (lnm && *lnm && strlen(lnm) == 7) {
673 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
674 if (!strcmp(uplnm,"DEFAULT")) {
675 if (eqv && *eqv) chdir(eqv);
679 (void) vmssetenv(lnm,eqv,NULL);
685 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
686 /* my_crypt - VMS password hashing
687 * my_crypt() provides an interface compatible with the Unix crypt()
688 * C library function, and uses sys$hash_password() to perform VMS
689 * password hashing. The quadword hashed password value is returned
690 * as a NUL-terminated 8 character string. my_crypt() does not change
691 * the case of its string arguments; in order to match the behavior
692 * of LOGINOUT et al., alphabetic characters in both arguments must
693 * be upcased by the caller.
696 my_crypt(const char *textpasswd, const char *usrname)
698 # ifndef UAI$C_PREFERRED_ALGORITHM
699 # define UAI$C_PREFERRED_ALGORITHM 127
701 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
702 unsigned short int salt = 0;
703 unsigned long int sts;
705 unsigned short int dsc$w_length;
706 unsigned char dsc$b_type;
707 unsigned char dsc$b_class;
708 const char * dsc$a_pointer;
709 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
710 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
711 struct itmlst_3 uailst[3] = {
712 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
713 { sizeof salt, UAI$_SALT, &salt, 0},
714 { 0, 0, NULL, NULL}};
717 usrdsc.dsc$w_length = strlen(usrname);
718 usrdsc.dsc$a_pointer = usrname;
719 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
726 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
732 if (sts != RMS$_RNF) return NULL;
735 txtdsc.dsc$w_length = strlen(textpasswd);
736 txtdsc.dsc$a_pointer = textpasswd;
737 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
738 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
741 return (char *) hash;
743 } /* end of my_crypt() */
747 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
748 static char *do_fileify_dirspec(char *, char *, int);
749 static char *do_tovmsspec(char *, char *, int);
751 /*{{{int do_rmdir(char *name)*/
755 char dirfile[NAM$C_MAXRSS+1];
759 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
760 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
761 else retval = kill_file(dirfile);
764 } /* end of do_rmdir */
768 * Delete any file to which user has control access, regardless of whether
769 * delete access is explicitly allowed.
770 * Limitations: User must have write access to parent directory.
771 * Does not block signals or ASTs; if interrupted in midstream
772 * may leave file with an altered ACL.
775 /*{{{int kill_file(char *name)*/
777 kill_file(char *name)
779 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
780 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
781 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
783 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
785 unsigned char myace$b_length;
786 unsigned char myace$b_type;
787 unsigned short int myace$w_flags;
788 unsigned long int myace$l_access;
789 unsigned long int myace$l_ident;
790 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
791 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
792 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
794 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
795 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
796 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
797 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
798 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
799 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
801 /* Expand the input spec using RMS, since the CRTL remove() and
802 * system services won't do this by themselves, so we may miss
803 * a file "hiding" behind a logical name or search list. */
804 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
805 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
806 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
807 /* If not, can changing protections help? */
808 if (vaxc$errno != RMS$_PRV) return -1;
810 /* No, so we get our own UIC to use as a rights identifier,
811 * and the insert an ACE at the head of the ACL which allows us
812 * to delete the file.
814 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
815 fildsc.dsc$w_length = strlen(rspec);
816 fildsc.dsc$a_pointer = rspec;
818 newace.myace$l_ident = oldace.myace$l_ident;
819 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
824 case SS$_NOSUCHOBJECT:
825 set_errno(ENOENT); break;
827 set_errno(ENODEV); break;
829 case SS$_INVFILFOROP:
830 set_errno(EINVAL); break;
832 set_errno(EACCES); break;
836 set_vaxc_errno(aclsts);
839 /* Grab any existing ACEs with this identifier in case we fail */
840 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
841 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
842 || fndsts == SS$_NOMOREACE ) {
843 /* Add the new ACE . . . */
844 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
846 if ((rmsts = remove(name))) {
847 /* We blew it - dir with files in it, no write priv for
848 * parent directory, etc. Put things back the way they were. */
849 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
852 addlst[0].bufadr = &oldace;
853 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
860 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
861 /* We just deleted it, so of course it's not there. Some versions of
862 * VMS seem to return success on the unlock operation anyhow (after all
863 * the unlock is successful), but others don't.
865 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
866 if (aclsts & 1) aclsts = fndsts;
869 set_vaxc_errno(aclsts);
875 } /* end of kill_file() */
879 /*{{{int my_mkdir(char *,Mode_t)*/
881 my_mkdir(char *dir, Mode_t mode)
883 STRLEN dirlen = strlen(dir);
886 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
887 * null file name/type. However, it's commonplace under Unix,
888 * so we'll allow it for a gain in portability.
890 if (dir[dirlen-1] == '/') {
891 char *newdir = savepvn(dir,dirlen-1);
892 int ret = mkdir(newdir,mode);
896 else return mkdir(dir,mode);
897 } /* end of my_mkdir */
902 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
904 static unsigned long int mbxbufsiz;
905 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
910 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
911 * preprocessor consant BUFSIZ from stdio.h as the size of the
914 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
915 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
917 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
919 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
920 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
922 } /* end of create_mbx() */
924 /*{{{ my_popen and my_pclose*/
927 struct pipe_details *next;
928 PerlIO *fp; /* stdio file pointer to pipe mailbox */
929 int pid; /* PID of subprocess */
930 int mode; /* == 'r' if pipe open for reading */
931 int done; /* subprocess has completed */
932 unsigned long int completion; /* termination status of subprocess */
935 struct exit_control_block
937 struct exit_control_block *flink;
938 unsigned long int (*exit_routine)();
939 unsigned long int arg_count;
940 unsigned long int *status_address;
941 unsigned long int exit_status;
944 static struct pipe_details *open_pipes = NULL;
945 static $DESCRIPTOR(nl_desc, "NL:");
946 static int waitpid_asleep = 0;
948 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
949 * to a mbx; that's the caller's responsibility.
951 static unsigned long int
952 pipe_eof(FILE *fp, int immediate)
954 char devnam[NAM$C_MAXRSS+1], *cp;
955 unsigned long int chan, iosb[2], retsts, retsts2;
956 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
959 if (fgetname(fp,devnam,1)) {
960 /* It oughta be a mailbox, so fgetname should give just the device
961 * name, but just in case . . . */
962 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
963 devdsc.dsc$w_length = strlen(devnam);
964 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
965 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
966 iosb,0,0,0,0,0,0,0,0);
967 if (retsts & 1) retsts = iosb[0];
968 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
969 if (retsts & 1) retsts = retsts2;
973 else _ckvmssts(vaxc$errno); /* Should never happen */
974 return (unsigned long int) vaxc$errno;
977 static unsigned long int
980 struct pipe_details *info;
981 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
986 first we try sending an EOF...ignore if doesn't work, make sure we
994 _ckvmssts(sys$setast(0));
995 need_eof = info->mode != 'r' && !info->done;
996 _ckvmssts(sys$setast(1));
998 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
1002 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1007 _ckvmssts(sys$setast(0));
1008 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1009 sts = sys$forcex(&info->pid,0,&abort);
1010 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1013 _ckvmssts(sys$setast(1));
1016 if (did_stuff) sleep(1); /* wait for them to respond */
1020 _ckvmssts(sys$setast(0));
1021 if (!info->done) { /* We tried to be nice . . . */
1022 sts = sys$delprc(&info->pid,0);
1023 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1024 info->done = 1; /* so my_pclose doesn't try to write EOF */
1026 _ckvmssts(sys$setast(1));
1031 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1032 else if (!(sts & 1)) retsts = sts;
1037 static struct exit_control_block pipe_exitblock =
1038 {(struct exit_control_block *) 0,
1039 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1043 popen_completion_ast(struct pipe_details *thispipe)
1045 thispipe->done = TRUE;
1046 if (waitpid_asleep) {
1052 static unsigned long int setup_cmddsc(char *cmd, int check_img);
1053 static void vms_execfree();
1056 safe_popen(char *cmd, char *mode)
1058 static int handler_set_up = FALSE;
1060 unsigned short int chan;
1061 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1063 struct pipe_details *info;
1064 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1065 DSC$K_CLASS_S, mbxname},
1066 cmddsc = {0, DSC$K_DTYPE_T,
1070 if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
1071 New(1301,info,1,struct pipe_details);
1073 /* create mailbox */
1074 create_mbx(&chan,&namdsc);
1076 /* open a FILE* onto it */
1077 info->fp = PerlIO_open(mbxname, mode);
1079 /* give up other channel onto it */
1080 _ckvmssts(sys$dassgn(chan));
1090 _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags,
1091 0 /* name */, &info->pid, &info->completion,
1092 0, popen_completion_ast,info,0,0,0));
1095 _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags,
1096 0 /* name */, &info->pid, &info->completion,
1097 0, popen_completion_ast,info,0,0,0));
1101 if (!handler_set_up) {
1102 _ckvmssts(sys$dclexh(&pipe_exitblock));
1103 handler_set_up = TRUE;
1105 info->next=open_pipes; /* prepend to list */
1108 PL_forkprocess = info->pid;
1110 } /* end of safe_popen */
1113 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1115 Perl_my_popen(pTHX_ char *cmd, char *mode)
1118 TAINT_PROPER("popen");
1119 PERL_FLUSHALL_FOR_CHILD;
1120 return safe_popen(cmd,mode);
1125 /*{{{ I32 my_pclose(FILE *fp)*/
1126 I32 Perl_my_pclose(pTHX_ FILE *fp)
1128 struct pipe_details *info, *last = NULL;
1129 unsigned long int retsts;
1132 for (info = open_pipes; info != NULL; last = info, info = info->next)
1133 if (info->fp == fp) break;
1135 if (info == NULL) { /* no such pipe open */
1136 set_errno(ECHILD); /* quoth POSIX */
1137 set_vaxc_errno(SS$_NONEXPR);
1141 /* If we were writing to a subprocess, insure that someone reading from
1142 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1143 * produce an EOF record in the mailbox. */
1144 _ckvmssts(sys$setast(0));
1145 need_eof = info->mode != 'r' && !info->done;
1146 _ckvmssts(sys$setast(1));
1147 if (need_eof) pipe_eof(info->fp,0);
1148 PerlIO_close(info->fp);
1150 if (info->done) retsts = info->completion;
1151 else waitpid(info->pid,(int *) &retsts,0);
1153 /* remove from list of open pipes */
1154 _ckvmssts(sys$setast(0));
1155 if (last) last->next = info->next;
1156 else open_pipes = info->next;
1157 _ckvmssts(sys$setast(1));
1162 } /* end of my_pclose() */
1164 /* sort-of waitpid; use only with popen() */
1165 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1167 my_waitpid(Pid_t pid, int *statusp, int flags)
1169 struct pipe_details *info;
1172 for (info = open_pipes; info != NULL; info = info->next)
1173 if (info->pid == pid) break;
1175 if (info != NULL) { /* we know about this child */
1176 while (!info->done) {
1181 *statusp = info->completion;
1184 else { /* we haven't heard of this child */
1185 $DESCRIPTOR(intdsc,"0 00:00:01");
1186 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1187 unsigned long int interval[2],sts;
1189 if (ckWARN(WARN_EXEC)) {
1190 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1191 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1192 if (ownerpid != mypid)
1193 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1196 _ckvmssts(sys$bintim(&intdsc,interval));
1197 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1198 _ckvmssts(sys$schdwk(0,0,interval,0));
1199 _ckvmssts(sys$hiber());
1203 /* There's no easy way to find the termination status a child we're
1204 * not aware of beforehand. If we're really interested in the future,
1205 * we can go looking for a termination mailbox, or chase after the
1206 * accounting record for the process.
1212 } /* end of waitpid() */
1217 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1219 my_gconvert(double val, int ndig, int trail, char *buf)
1221 static char __gcvtbuf[DBL_DIG+1];
1224 loc = buf ? buf : __gcvtbuf;
1226 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1228 sprintf(loc,"%.*g",ndig,val);
1234 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1235 return gcvt(val,ndig,loc);
1238 loc[0] = '0'; loc[1] = '\0';
1246 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1247 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1248 * to expand file specification. Allows for a single default file
1249 * specification and a simple mask of options. If outbuf is non-NULL,
1250 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1251 * the resultant file specification is placed. If outbuf is NULL, the
1252 * resultant file specification is placed into a static buffer.
1253 * The third argument, if non-NULL, is taken to be a default file
1254 * specification string. The fourth argument is unused at present.
1255 * rmesexpand() returns the address of the resultant string if
1256 * successful, and NULL on error.
1258 static char *do_tounixspec(char *, char *, int);
1261 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1263 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1264 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1265 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1266 struct FAB myfab = cc$rms_fab;
1267 struct NAM mynam = cc$rms_nam;
1269 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1271 if (!filespec || !*filespec) {
1272 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1276 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1277 else outbuf = __rmsexpand_retbuf;
1279 if ((isunix = (strchr(filespec,'/') != NULL))) {
1280 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1281 filespec = vmsfspec;
1284 myfab.fab$l_fna = filespec;
1285 myfab.fab$b_fns = strlen(filespec);
1286 myfab.fab$l_nam = &mynam;
1288 if (defspec && *defspec) {
1289 if (strchr(defspec,'/') != NULL) {
1290 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1293 myfab.fab$l_dna = defspec;
1294 myfab.fab$b_dns = strlen(defspec);
1297 mynam.nam$l_esa = esa;
1298 mynam.nam$b_ess = sizeof esa;
1299 mynam.nam$l_rsa = outbuf;
1300 mynam.nam$b_rss = NAM$C_MAXRSS;
1302 retsts = sys$parse(&myfab,0,0);
1303 if (!(retsts & 1)) {
1304 mynam.nam$b_nop |= NAM$M_SYNCHK;
1305 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1306 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1307 retsts = sys$parse(&myfab,0,0);
1308 if (retsts & 1) goto expanded;
1310 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1311 (void) sys$parse(&myfab,0,0); /* Free search context */
1312 if (out) Safefree(out);
1313 set_vaxc_errno(retsts);
1314 if (retsts == RMS$_PRV) set_errno(EACCES);
1315 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1316 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1317 else set_errno(EVMSERR);
1320 retsts = sys$search(&myfab,0,0);
1321 if (!(retsts & 1) && retsts != RMS$_FNF) {
1322 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1323 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1324 if (out) Safefree(out);
1325 set_vaxc_errno(retsts);
1326 if (retsts == RMS$_PRV) set_errno(EACCES);
1327 else set_errno(EVMSERR);
1331 /* If the input filespec contained any lowercase characters,
1332 * downcase the result for compatibility with Unix-minded code. */
1334 for (out = myfab.fab$l_fna; *out; out++)
1335 if (islower(*out)) { haslower = 1; break; }
1336 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1337 else { out = esa; speclen = mynam.nam$b_esl; }
1338 /* Trim off null fields added by $PARSE
1339 * If type > 1 char, must have been specified in original or default spec
1340 * (not true for version; $SEARCH may have added version of existing file).
1342 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1343 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1344 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1345 if (trimver || trimtype) {
1346 if (defspec && *defspec) {
1347 char defesa[NAM$C_MAXRSS];
1348 struct FAB deffab = cc$rms_fab;
1349 struct NAM defnam = cc$rms_nam;
1351 deffab.fab$l_nam = &defnam;
1352 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1353 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1354 defnam.nam$b_nop = NAM$M_SYNCHK;
1355 if (sys$parse(&deffab,0,0) & 1) {
1356 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1357 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1360 if (trimver) speclen = mynam.nam$l_ver - out;
1362 /* If we didn't already trim version, copy down */
1363 if (speclen > mynam.nam$l_ver - out)
1364 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1365 speclen - (mynam.nam$l_ver - out));
1366 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1369 /* If we just had a directory spec on input, $PARSE "helpfully"
1370 * adds an empty name and type for us */
1371 if (mynam.nam$l_name == mynam.nam$l_type &&
1372 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1373 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1374 speclen = mynam.nam$l_name - out;
1375 out[speclen] = '\0';
1376 if (haslower) __mystrtolower(out);
1378 /* Have we been working with an expanded, but not resultant, spec? */
1379 /* Also, convert back to Unix syntax if necessary. */
1380 if (!mynam.nam$b_rsl) {
1382 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1384 else strcpy(outbuf,esa);
1387 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1388 strcpy(outbuf,tmpfspec);
1390 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1391 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1392 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1396 /* External entry points */
1397 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1398 { return do_rmsexpand(spec,buf,0,def,opt); }
1399 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1400 { return do_rmsexpand(spec,buf,1,def,opt); }
1404 ** The following routines are provided to make life easier when
1405 ** converting among VMS-style and Unix-style directory specifications.
1406 ** All will take input specifications in either VMS or Unix syntax. On
1407 ** failure, all return NULL. If successful, the routines listed below
1408 ** return a pointer to a buffer containing the appropriately
1409 ** reformatted spec (and, therefore, subsequent calls to that routine
1410 ** will clobber the result), while the routines of the same names with
1411 ** a _ts suffix appended will return a pointer to a mallocd string
1412 ** containing the appropriately reformatted spec.
1413 ** In all cases, only explicit syntax is altered; no check is made that
1414 ** the resulting string is valid or that the directory in question
1417 ** fileify_dirspec() - convert a directory spec into the name of the
1418 ** directory file (i.e. what you can stat() to see if it's a dir).
1419 ** The style (VMS or Unix) of the result is the same as the style
1420 ** of the parameter passed in.
1421 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1422 ** what you prepend to a filename to indicate what directory it's in).
1423 ** The style (VMS or Unix) of the result is the same as the style
1424 ** of the parameter passed in.
1425 ** tounixpath() - convert a directory spec into a Unix-style path.
1426 ** tovmspath() - convert a directory spec into a VMS-style path.
1427 ** tounixspec() - convert any file spec into a Unix-style file spec.
1428 ** tovmsspec() - convert any file spec into a VMS-style spec.
1430 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1431 ** Permission is given to distribute this code as part of the Perl
1432 ** standard distribution under the terms of the GNU General Public
1433 ** License or the Perl Artistic License. Copies of each may be
1434 ** found in the Perl standard distribution.
1437 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1438 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1440 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1441 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1442 char *retspec, *cp1, *cp2, *lastdir;
1443 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1445 if (!dir || !*dir) {
1446 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1448 dirlen = strlen(dir);
1449 while (dir[dirlen-1] == '/') --dirlen;
1450 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1451 strcpy(trndir,"/sys$disk/000000");
1455 if (dirlen > NAM$C_MAXRSS) {
1456 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1458 if (!strpbrk(dir+1,"/]>:")) {
1459 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1460 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1462 dirlen = strlen(dir);
1465 strncpy(trndir,dir,dirlen);
1466 trndir[dirlen] = '\0';
1469 /* If we were handed a rooted logical name or spec, treat it like a
1470 * simple directory, so that
1471 * $ Define myroot dev:[dir.]
1472 * ... do_fileify_dirspec("myroot",buf,1) ...
1473 * does something useful.
1475 if (!strcmp(dir+dirlen-2,".]")) {
1476 dir[--dirlen] = '\0';
1477 dir[dirlen-1] = ']';
1480 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1481 /* If we've got an explicit filename, we can just shuffle the string. */
1482 if (*(cp1+1)) hasfilename = 1;
1483 /* Similarly, we can just back up a level if we've got multiple levels
1484 of explicit directories in a VMS spec which ends with directories. */
1486 for (cp2 = cp1; cp2 > dir; cp2--) {
1488 *cp2 = *cp1; *cp1 = '\0';
1492 if (*cp2 == '[' || *cp2 == '<') break;
1497 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1498 if (dir[0] == '.') {
1499 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1500 return do_fileify_dirspec("[]",buf,ts);
1501 else if (dir[1] == '.' &&
1502 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1503 return do_fileify_dirspec("[-]",buf,ts);
1505 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1506 dirlen -= 1; /* to last element */
1507 lastdir = strrchr(dir,'/');
1509 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1510 /* If we have "/." or "/..", VMSify it and let the VMS code
1511 * below expand it, rather than repeating the code to handle
1512 * relative components of a filespec here */
1514 if (*(cp1+2) == '.') cp1++;
1515 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1516 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1517 if (strchr(vmsdir,'/') != NULL) {
1518 /* If do_tovmsspec() returned it, it must have VMS syntax
1519 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1520 * the time to check this here only so we avoid a recursion
1521 * loop; otherwise, gigo.
1523 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1525 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1526 return do_tounixspec(trndir,buf,ts);
1529 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1530 lastdir = strrchr(dir,'/');
1532 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1533 /* Ditto for specs that end in an MFD -- let the VMS code
1534 * figure out whether it's a real device or a rooted logical. */
1535 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1536 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1537 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1538 return do_tounixspec(trndir,buf,ts);
1541 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1542 !(lastdir = cp1 = strrchr(dir,']')) &&
1543 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1544 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1546 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1547 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1548 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1549 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1550 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1551 (ver || *cp3)))))) {
1553 set_vaxc_errno(RMS$_DIR);
1559 /* If we lead off with a device or rooted logical, add the MFD
1560 if we're specifying a top-level directory. */
1561 if (lastdir && *dir == '/') {
1563 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1570 retlen = dirlen + (addmfd ? 13 : 6);
1571 if (buf) retspec = buf;
1572 else if (ts) New(1309,retspec,retlen+1,char);
1573 else retspec = __fileify_retbuf;
1575 dirlen = lastdir - dir;
1576 memcpy(retspec,dir,dirlen);
1577 strcpy(&retspec[dirlen],"/000000");
1578 strcpy(&retspec[dirlen+7],lastdir);
1581 memcpy(retspec,dir,dirlen);
1582 retspec[dirlen] = '\0';
1584 /* We've picked up everything up to the directory file name.
1585 Now just add the type and version, and we're set. */
1586 strcat(retspec,".dir;1");
1589 else { /* VMS-style directory spec */
1590 char esa[NAM$C_MAXRSS+1], term, *cp;
1591 unsigned long int sts, cmplen, haslower = 0;
1592 struct FAB dirfab = cc$rms_fab;
1593 struct NAM savnam, dirnam = cc$rms_nam;
1595 dirfab.fab$b_fns = strlen(dir);
1596 dirfab.fab$l_fna = dir;
1597 dirfab.fab$l_nam = &dirnam;
1598 dirfab.fab$l_dna = ".DIR;1";
1599 dirfab.fab$b_dns = 6;
1600 dirnam.nam$b_ess = NAM$C_MAXRSS;
1601 dirnam.nam$l_esa = esa;
1603 for (cp = dir; *cp; cp++)
1604 if (islower(*cp)) { haslower = 1; break; }
1605 if (!((sts = sys$parse(&dirfab))&1)) {
1606 if (dirfab.fab$l_sts == RMS$_DIR) {
1607 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1608 sts = sys$parse(&dirfab) & 1;
1612 set_vaxc_errno(dirfab.fab$l_sts);
1618 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1619 /* Yes; fake the fnb bits so we'll check type below */
1620 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1622 else { /* No; just work with potential name */
1623 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
1625 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
1626 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1627 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1632 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1633 cp1 = strchr(esa,']');
1634 if (!cp1) cp1 = strchr(esa,'>');
1635 if (cp1) { /* Should always be true */
1636 dirnam.nam$b_esl -= cp1 - esa - 1;
1637 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1640 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1641 /* Yep; check version while we're at it, if it's there. */
1642 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1643 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1644 /* Something other than .DIR[;1]. Bzzt. */
1645 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1646 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1648 set_vaxc_errno(RMS$_DIR);
1652 esa[dirnam.nam$b_esl] = '\0';
1653 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1654 /* They provided at least the name; we added the type, if necessary, */
1655 if (buf) retspec = buf; /* in sys$parse() */
1656 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1657 else retspec = __fileify_retbuf;
1658 strcpy(retspec,esa);
1659 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1660 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1663 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1664 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1666 dirnam.nam$b_esl -= 9;
1668 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1669 if (cp1 == NULL) { /* should never happen */
1670 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1671 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1676 retlen = strlen(esa);
1677 if ((cp1 = strrchr(esa,'.')) != NULL) {
1678 /* There's more than one directory in the path. Just roll back. */
1680 if (buf) retspec = buf;
1681 else if (ts) New(1311,retspec,retlen+7,char);
1682 else retspec = __fileify_retbuf;
1683 strcpy(retspec,esa);
1686 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1687 /* Go back and expand rooted logical name */
1688 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1689 if (!(sys$parse(&dirfab) & 1)) {
1690 dirnam.nam$l_rlf = NULL;
1691 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1693 set_vaxc_errno(dirfab.fab$l_sts);
1696 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1697 if (buf) retspec = buf;
1698 else if (ts) New(1312,retspec,retlen+16,char);
1699 else retspec = __fileify_retbuf;
1700 cp1 = strstr(esa,"][");
1702 memcpy(retspec,esa,dirlen);
1703 if (!strncmp(cp1+2,"000000]",7)) {
1704 retspec[dirlen-1] = '\0';
1705 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1706 if (*cp1 == '.') *cp1 = ']';
1708 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1709 memcpy(cp1+1,"000000]",7);
1713 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1714 retspec[retlen] = '\0';
1715 /* Convert last '.' to ']' */
1716 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1717 if (*cp1 == '.') *cp1 = ']';
1719 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1720 memcpy(cp1+1,"000000]",7);
1724 else { /* This is a top-level dir. Add the MFD to the path. */
1725 if (buf) retspec = buf;
1726 else if (ts) New(1312,retspec,retlen+16,char);
1727 else retspec = __fileify_retbuf;
1730 while (*cp1 != ':') *(cp2++) = *(cp1++);
1731 strcpy(cp2,":[000000]");
1736 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1737 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1738 /* We've set up the string up through the filename. Add the
1739 type and version, and we're done. */
1740 strcat(retspec,".DIR;1");
1742 /* $PARSE may have upcased filespec, so convert output to lower
1743 * case if input contained any lowercase characters. */
1744 if (haslower) __mystrtolower(retspec);
1747 } /* end of do_fileify_dirspec() */
1749 /* External entry points */
1750 char *fileify_dirspec(char *dir, char *buf)
1751 { return do_fileify_dirspec(dir,buf,0); }
1752 char *fileify_dirspec_ts(char *dir, char *buf)
1753 { return do_fileify_dirspec(dir,buf,1); }
1755 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1756 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1758 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1759 unsigned long int retlen;
1760 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1762 if (!dir || !*dir) {
1763 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1766 if (*dir) strcpy(trndir,dir);
1767 else getcwd(trndir,sizeof trndir - 1);
1769 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1770 && my_trnlnm(trndir,trndir,0)) {
1771 STRLEN trnlen = strlen(trndir);
1773 /* Trap simple rooted lnms, and return lnm:[000000] */
1774 if (!strcmp(trndir+trnlen-2,".]")) {
1775 if (buf) retpath = buf;
1776 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1777 else retpath = __pathify_retbuf;
1778 strcpy(retpath,dir);
1779 strcat(retpath,":[000000]");
1785 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1786 if (*dir == '.' && (*(dir+1) == '\0' ||
1787 (*(dir+1) == '.' && *(dir+2) == '\0')))
1788 retlen = 2 + (*(dir+1) != '\0');
1790 if ( !(cp1 = strrchr(dir,'/')) &&
1791 !(cp1 = strrchr(dir,']')) &&
1792 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1793 if ((cp2 = strchr(cp1,'.')) != NULL &&
1794 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1795 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1796 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1797 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1799 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1800 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1801 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1802 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1803 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1804 (ver || *cp3)))))) {
1806 set_vaxc_errno(RMS$_DIR);
1809 retlen = cp2 - dir + 1;
1811 else { /* No file type present. Treat the filename as a directory. */
1812 retlen = strlen(dir) + 1;
1815 if (buf) retpath = buf;
1816 else if (ts) New(1313,retpath,retlen+1,char);
1817 else retpath = __pathify_retbuf;
1818 strncpy(retpath,dir,retlen-1);
1819 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1820 retpath[retlen-1] = '/'; /* with '/', add it. */
1821 retpath[retlen] = '\0';
1823 else retpath[retlen-1] = '\0';
1825 else { /* VMS-style directory spec */
1826 char esa[NAM$C_MAXRSS+1], *cp;
1827 unsigned long int sts, cmplen, haslower;
1828 struct FAB dirfab = cc$rms_fab;
1829 struct NAM savnam, dirnam = cc$rms_nam;
1831 /* If we've got an explicit filename, we can just shuffle the string. */
1832 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1833 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1834 if ((cp2 = strchr(cp1,'.')) != NULL) {
1836 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1837 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1838 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1839 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1840 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1841 (ver || *cp3)))))) {
1843 set_vaxc_errno(RMS$_DIR);
1847 else { /* No file type, so just draw name into directory part */
1848 for (cp2 = cp1; *cp2; cp2++) ;
1851 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1853 /* We've now got a VMS 'path'; fall through */
1855 dirfab.fab$b_fns = strlen(dir);
1856 dirfab.fab$l_fna = dir;
1857 if (dir[dirfab.fab$b_fns-1] == ']' ||
1858 dir[dirfab.fab$b_fns-1] == '>' ||
1859 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1860 if (buf) retpath = buf;
1861 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1862 else retpath = __pathify_retbuf;
1863 strcpy(retpath,dir);
1866 dirfab.fab$l_dna = ".DIR;1";
1867 dirfab.fab$b_dns = 6;
1868 dirfab.fab$l_nam = &dirnam;
1869 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1870 dirnam.nam$l_esa = esa;
1872 for (cp = dir; *cp; cp++)
1873 if (islower(*cp)) { haslower = 1; break; }
1875 if (!(sts = (sys$parse(&dirfab)&1))) {
1876 if (dirfab.fab$l_sts == RMS$_DIR) {
1877 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1878 sts = sys$parse(&dirfab) & 1;
1882 set_vaxc_errno(dirfab.fab$l_sts);
1888 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1889 if (dirfab.fab$l_sts != RMS$_FNF) {
1890 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1891 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1893 set_vaxc_errno(dirfab.fab$l_sts);
1896 dirnam = savnam; /* No; just work with potential name */
1899 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1900 /* Yep; check version while we're at it, if it's there. */
1901 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1902 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1903 /* Something other than .DIR[;1]. Bzzt. */
1904 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1905 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1907 set_vaxc_errno(RMS$_DIR);
1911 /* OK, the type was fine. Now pull any file name into the
1913 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1915 cp1 = strrchr(esa,'>');
1916 *dirnam.nam$l_type = '>';
1919 *(dirnam.nam$l_type + 1) = '\0';
1920 retlen = dirnam.nam$l_type - esa + 2;
1921 if (buf) retpath = buf;
1922 else if (ts) New(1314,retpath,retlen,char);
1923 else retpath = __pathify_retbuf;
1924 strcpy(retpath,esa);
1925 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
1926 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
1927 /* $PARSE may have upcased filespec, so convert output to lower
1928 * case if input contained any lowercase characters. */
1929 if (haslower) __mystrtolower(retpath);
1933 } /* end of do_pathify_dirspec() */
1935 /* External entry points */
1936 char *pathify_dirspec(char *dir, char *buf)
1937 { return do_pathify_dirspec(dir,buf,0); }
1938 char *pathify_dirspec_ts(char *dir, char *buf)
1939 { return do_pathify_dirspec(dir,buf,1); }
1941 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1942 static char *do_tounixspec(char *spec, char *buf, int ts)
1944 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1945 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1946 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1948 if (spec == NULL) return NULL;
1949 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1950 if (buf) rslt = buf;
1952 retlen = strlen(spec);
1953 cp1 = strchr(spec,'[');
1954 if (!cp1) cp1 = strchr(spec,'<');
1956 for (cp1++; *cp1; cp1++) {
1957 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1958 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1959 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1962 New(1315,rslt,retlen+2+2*expand,char);
1964 else rslt = __tounixspec_retbuf;
1965 if (strchr(spec,'/') != NULL) {
1972 dirend = strrchr(spec,']');
1973 if (dirend == NULL) dirend = strrchr(spec,'>');
1974 if (dirend == NULL) dirend = strchr(spec,':');
1975 if (dirend == NULL) {
1979 if (*cp2 != '[' && *cp2 != '<') {
1982 else { /* the VMS spec begins with directories */
1984 if (*cp2 == ']' || *cp2 == '>') {
1985 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1988 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1989 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1990 if (ts) Safefree(rslt);
1995 while (*cp3 != ':' && *cp3) cp3++;
1997 if (strchr(cp3,']') != NULL) break;
1998 } while (vmstrnenv(tmp,tmp,0,fildev,0));
2000 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
2001 retlen = devlen + dirlen;
2002 Renew(rslt,retlen+1+2*expand,char);
2008 *(cp1++) = *(cp3++);
2009 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
2013 else if ( *cp2 == '.') {
2014 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
2015 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2021 for (; cp2 <= dirend; cp2++) {
2024 if (*(cp2+1) == '[') cp2++;
2026 else if (*cp2 == ']' || *cp2 == '>') {
2027 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
2029 else if (*cp2 == '.') {
2031 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
2032 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
2033 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
2034 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
2035 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
2037 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
2038 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
2042 else if (*cp2 == '-') {
2043 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2044 while (*cp2 == '-') {
2046 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2048 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2049 if (ts) Safefree(rslt); /* filespecs like */
2050 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2054 else *(cp1++) = *cp2;
2056 else *(cp1++) = *cp2;
2058 while (*cp2) *(cp1++) = *(cp2++);
2063 } /* end of do_tounixspec() */
2065 /* External entry points */
2066 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2067 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2069 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2070 static char *do_tovmsspec(char *path, char *buf, int ts) {
2071 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2072 char *rslt, *dirend;
2073 register char *cp1, *cp2;
2074 unsigned long int infront = 0, hasdir = 1;
2076 if (path == NULL) return NULL;
2077 if (buf) rslt = buf;
2078 else if (ts) New(1316,rslt,strlen(path)+9,char);
2079 else rslt = __tovmsspec_retbuf;
2080 if (strpbrk(path,"]:>") ||
2081 (dirend = strrchr(path,'/')) == NULL) {
2082 if (path[0] == '.') {
2083 if (path[1] == '\0') strcpy(rslt,"[]");
2084 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2085 else strcpy(rslt,path); /* probably garbage */
2087 else strcpy(rslt,path);
2090 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2091 if (!*(dirend+2)) dirend +=2;
2092 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2093 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2098 char trndev[NAM$C_MAXRSS+1];
2102 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2104 if (!buf & ts) Renew(rslt,18,char);
2105 strcpy(rslt,"sys$disk:[000000]");
2108 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2110 islnm = my_trnlnm(rslt,trndev,0);
2111 trnend = islnm ? strlen(trndev) - 1 : 0;
2112 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2113 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2114 /* If the first element of the path is a logical name, determine
2115 * whether it has to be translated so we can add more directories. */
2116 if (!islnm || rooted) {
2119 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2123 if (cp2 != dirend) {
2124 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2125 strcpy(rslt,trndev);
2126 cp1 = rslt + trnend;
2139 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2140 cp2 += 2; /* skip over "./" - it's redundant */
2141 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2143 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2144 *(cp1++) = '-'; /* "../" --> "-" */
2147 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2148 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2149 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2150 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2153 if (cp2 > dirend) cp2 = dirend;
2155 else *(cp1++) = '.';
2157 for (; cp2 < dirend; cp2++) {
2159 if (*(cp2-1) == '/') continue;
2160 if (*(cp1-1) != '.') *(cp1++) = '.';
2163 else if (!infront && *cp2 == '.') {
2164 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2165 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2166 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) { /* handle "../" */
2167 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-';
2168 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2170 /* if (*(cp1-1) != '.') *(cp1++) = '.'; */
2174 if (cp2 == dirend) break;
2176 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2177 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2178 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2179 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2181 *(cp1++) = '.'; /* Simulate trailing '/' */
2182 cp2 += 2; /* for loop will incr this to == dirend */
2184 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2186 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2189 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2190 if (*cp2 == '.') *(cp1++) = '_';
2191 else *(cp1++) = *cp2;
2195 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2196 if (hasdir) *(cp1++) = ']';
2197 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2198 while (*cp2) *(cp1++) = *(cp2++);
2203 } /* end of do_tovmsspec() */
2205 /* External entry points */
2206 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2207 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2209 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2210 static char *do_tovmspath(char *path, char *buf, int ts) {
2211 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2213 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2215 if (path == NULL) return NULL;
2216 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2217 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2218 if (buf) return buf;
2220 vmslen = strlen(vmsified);
2221 New(1317,cp,vmslen+1,char);
2222 memcpy(cp,vmsified,vmslen);
2227 strcpy(__tovmspath_retbuf,vmsified);
2228 return __tovmspath_retbuf;
2231 } /* end of do_tovmspath() */
2233 /* External entry points */
2234 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2235 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2238 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2239 static char *do_tounixpath(char *path, char *buf, int ts) {
2240 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2242 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2244 if (path == NULL) return NULL;
2245 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2246 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2247 if (buf) return buf;
2249 unixlen = strlen(unixified);
2250 New(1317,cp,unixlen+1,char);
2251 memcpy(cp,unixified,unixlen);
2256 strcpy(__tounixpath_retbuf,unixified);
2257 return __tounixpath_retbuf;
2260 } /* end of do_tounixpath() */
2262 /* External entry points */
2263 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2264 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2267 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2269 *****************************************************************************
2271 * Copyright (C) 1989-1994 by *
2272 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2274 * Permission is hereby granted for the reproduction of this software, *
2275 * on condition that this copyright notice is included in the reproduction, *
2276 * and that such reproduction is not for purposes of profit or material *
2279 * 27-Aug-1994 Modified for inclusion in perl5 *
2280 * by Charles Bailey bailey@newman.upenn.edu *
2281 *****************************************************************************
2285 * getredirection() is intended to aid in porting C programs
2286 * to VMS (Vax-11 C). The native VMS environment does not support
2287 * '>' and '<' I/O redirection, or command line wild card expansion,
2288 * or a command line pipe mechanism using the '|' AND background
2289 * command execution '&'. All of these capabilities are provided to any
2290 * C program which calls this procedure as the first thing in the
2292 * The piping mechanism will probably work with almost any 'filter' type
2293 * of program. With suitable modification, it may useful for other
2294 * portability problems as well.
2296 * Author: Mark Pizzolato mark@infocomm.com
2300 struct list_item *next;
2304 static void add_item(struct list_item **head,
2305 struct list_item **tail,
2309 static void expand_wild_cards(char *item,
2310 struct list_item **head,
2311 struct list_item **tail,
2314 static int background_process(int argc, char **argv);
2316 static void pipe_and_fork(char **cmargv);
2318 /*{{{ void getredirection(int *ac, char ***av)*/
2320 getredirection(int *ac, char ***av)
2322 * Process vms redirection arg's. Exit if any error is seen.
2323 * If getredirection() processes an argument, it is erased
2324 * from the vector. getredirection() returns a new argc and argv value.
2325 * In the event that a background command is requested (by a trailing "&"),
2326 * this routine creates a background subprocess, and simply exits the program.
2328 * Warning: do not try to simplify the code for vms. The code
2329 * presupposes that getredirection() is called before any data is
2330 * read from stdin or written to stdout.
2332 * Normal usage is as follows:
2338 * getredirection(&argc, &argv);
2342 int argc = *ac; /* Argument Count */
2343 char **argv = *av; /* Argument Vector */
2344 char *ap; /* Argument pointer */
2345 int j; /* argv[] index */
2346 int item_count = 0; /* Count of Items in List */
2347 struct list_item *list_head = 0; /* First Item in List */
2348 struct list_item *list_tail; /* Last Item in List */
2349 char *in = NULL; /* Input File Name */
2350 char *out = NULL; /* Output File Name */
2351 char *outmode = "w"; /* Mode to Open Output File */
2352 char *err = NULL; /* Error File Name */
2353 char *errmode = "w"; /* Mode to Open Error File */
2354 int cmargc = 0; /* Piped Command Arg Count */
2355 char **cmargv = NULL;/* Piped Command Arg Vector */
2358 * First handle the case where the last thing on the line ends with
2359 * a '&'. This indicates the desire for the command to be run in a
2360 * subprocess, so we satisfy that desire.
2363 if (0 == strcmp("&", ap))
2364 exit(background_process(--argc, argv));
2365 if (*ap && '&' == ap[strlen(ap)-1])
2367 ap[strlen(ap)-1] = '\0';
2368 exit(background_process(argc, argv));
2371 * Now we handle the general redirection cases that involve '>', '>>',
2372 * '<', and pipes '|'.
2374 for (j = 0; j < argc; ++j)
2376 if (0 == strcmp("<", argv[j]))
2380 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2381 exit(LIB$_WRONUMARG);
2386 if ('<' == *(ap = argv[j]))
2391 if (0 == strcmp(">", ap))
2395 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2396 exit(LIB$_WRONUMARG);
2415 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2416 exit(LIB$_WRONUMARG);
2420 if (('2' == *ap) && ('>' == ap[1]))
2437 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2438 exit(LIB$_WRONUMARG);
2442 if (0 == strcmp("|", argv[j]))
2446 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2447 exit(LIB$_WRONUMARG);
2449 cmargc = argc-(j+1);
2450 cmargv = &argv[j+1];
2454 if ('|' == *(ap = argv[j]))
2462 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2465 * Allocate and fill in the new argument vector, Some Unix's terminate
2466 * the list with an extra null pointer.
2468 New(1302, argv, item_count+1, char *);
2470 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2471 argv[j] = list_head->value;
2477 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2478 exit(LIB$_INVARGORD);
2480 pipe_and_fork(cmargv);
2483 /* Check for input from a pipe (mailbox) */
2485 if (in == NULL && 1 == isapipe(0))
2487 char mbxname[L_tmpnam];
2489 long int dvi_item = DVI$_DEVBUFSIZ;
2490 $DESCRIPTOR(mbxnam, "");
2491 $DESCRIPTOR(mbxdevnam, "");
2493 /* Input from a pipe, reopen it in binary mode to disable */
2494 /* carriage control processing. */
2496 PerlIO_getname(stdin, mbxname);
2497 mbxnam.dsc$a_pointer = mbxname;
2498 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2499 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2500 mbxdevnam.dsc$a_pointer = mbxname;
2501 mbxdevnam.dsc$w_length = sizeof(mbxname);
2502 dvi_item = DVI$_DEVNAM;
2503 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2504 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2507 freopen(mbxname, "rb", stdin);
2510 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2514 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2516 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2519 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2521 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2525 if (strcmp(err,"&1") == 0) {
2526 dup2(fileno(stdout), fileno(Perl_debug_log));
2529 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2531 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2535 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2541 #ifdef ARGPROC_DEBUG
2542 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2543 for (j = 0; j < *ac; ++j)
2544 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2546 /* Clear errors we may have hit expanding wildcards, so they don't
2547 show up in Perl's $! later */
2548 set_errno(0); set_vaxc_errno(1);
2549 } /* end of getredirection() */
2552 static void add_item(struct list_item **head,
2553 struct list_item **tail,
2559 New(1303,*head,1,struct list_item);
2563 New(1304,(*tail)->next,1,struct list_item);
2564 *tail = (*tail)->next;
2566 (*tail)->value = value;
2570 static void expand_wild_cards(char *item,
2571 struct list_item **head,
2572 struct list_item **tail,
2576 unsigned long int context = 0;
2582 char vmsspec[NAM$C_MAXRSS+1];
2583 $DESCRIPTOR(filespec, "");
2584 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2585 $DESCRIPTOR(resultspec, "");
2586 unsigned long int zero = 0, sts;
2588 for (cp = item; *cp; cp++) {
2589 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2590 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2592 if (!*cp || isspace(*cp))
2594 add_item(head, tail, item, count);
2597 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2598 resultspec.dsc$b_class = DSC$K_CLASS_D;
2599 resultspec.dsc$a_pointer = NULL;
2600 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2601 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2602 if (!isunix || !filespec.dsc$a_pointer)
2603 filespec.dsc$a_pointer = item;
2604 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2606 * Only return version specs, if the caller specified a version
2608 had_version = strchr(item, ';');
2610 * Only return device and directory specs, if the caller specifed either.
2612 had_device = strchr(item, ':');
2613 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2615 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2616 &defaultspec, 0, 0, &zero))))
2621 New(1305,string,resultspec.dsc$w_length+1,char);
2622 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2623 string[resultspec.dsc$w_length] = '\0';
2624 if (NULL == had_version)
2625 *((char *)strrchr(string, ';')) = '\0';
2626 if ((!had_directory) && (had_device == NULL))
2628 if (NULL == (devdir = strrchr(string, ']')))
2629 devdir = strrchr(string, '>');
2630 strcpy(string, devdir + 1);
2633 * Be consistent with what the C RTL has already done to the rest of
2634 * the argv items and lowercase all of these names.
2636 for (c = string; *c; ++c)
2639 if (isunix) trim_unixpath(string,item,1);
2640 add_item(head, tail, string, count);
2643 if (sts != RMS$_NMF)
2645 set_vaxc_errno(sts);
2651 set_errno(ENOENT); break;
2653 set_errno(ENODEV); break;
2656 set_errno(EINVAL); break;
2658 set_errno(EACCES); break;
2660 _ckvmssts_noperl(sts);
2664 add_item(head, tail, item, count);
2665 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2666 _ckvmssts_noperl(lib$find_file_end(&context));
2669 static int child_st[2];/* Event Flag set when child process completes */
2671 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2673 static unsigned long int exit_handler(int *status)
2677 if (0 == child_st[0])
2679 #ifdef ARGPROC_DEBUG
2680 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2682 fflush(stdout); /* Have to flush pipe for binary data to */
2683 /* terminate properly -- <tp@mccall.com> */
2684 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2685 sys$dassgn(child_chan);
2687 sys$synch(0, child_st);
2692 static void sig_child(int chan)
2694 #ifdef ARGPROC_DEBUG
2695 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2697 if (child_st[0] == 0)
2701 static struct exit_control_block exit_block =
2706 &exit_block.exit_status,
2710 static void pipe_and_fork(char **cmargv)
2713 $DESCRIPTOR(cmddsc, "");
2714 static char mbxname[64];
2715 $DESCRIPTOR(mbxdsc, mbxname);
2717 unsigned long int zero = 0, one = 1;
2719 strcpy(subcmd, cmargv[0]);
2720 for (j = 1; NULL != cmargv[j]; ++j)
2722 strcat(subcmd, " \"");
2723 strcat(subcmd, cmargv[j]);
2724 strcat(subcmd, "\"");
2726 cmddsc.dsc$a_pointer = subcmd;
2727 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2729 create_mbx(&child_chan,&mbxdsc);
2730 #ifdef ARGPROC_DEBUG
2731 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2732 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2734 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2735 0, &pid, child_st, &zero, sig_child,
2737 #ifdef ARGPROC_DEBUG
2738 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2740 sys$dclexh(&exit_block);
2741 if (NULL == freopen(mbxname, "wb", stdout))
2743 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2747 static int background_process(int argc, char **argv)
2749 char command[2048] = "$";
2750 $DESCRIPTOR(value, "");
2751 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2752 static $DESCRIPTOR(null, "NLA0:");
2753 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2755 $DESCRIPTOR(pidstr, "");
2757 unsigned long int flags = 17, one = 1, retsts;
2759 strcat(command, argv[0]);
2762 strcat(command, " \"");
2763 strcat(command, *(++argv));
2764 strcat(command, "\"");
2766 value.dsc$a_pointer = command;
2767 value.dsc$w_length = strlen(value.dsc$a_pointer);
2768 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2769 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2770 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2771 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2774 _ckvmssts_noperl(retsts);
2776 #ifdef ARGPROC_DEBUG
2777 PerlIO_printf(Perl_debug_log, "%s\n", command);
2779 sprintf(pidstring, "%08X", pid);
2780 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2781 pidstr.dsc$a_pointer = pidstring;
2782 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2783 lib$set_symbol(&pidsymbol, &pidstr);
2787 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2790 /* OS-specific initialization at image activation (not thread startup) */
2791 /* Older VAXC header files lack these constants */
2792 #ifndef JPI$_RIGHTS_SIZE
2793 # define JPI$_RIGHTS_SIZE 817
2795 #ifndef KGB$M_SUBSYSTEM
2796 # define KGB$M_SUBSYSTEM 0x8
2799 /*{{{void vms_image_init(int *, char ***)*/
2801 vms_image_init(int *argcp, char ***argvp)
2803 char eqv[LNM$C_NAMLENGTH+1] = "";
2804 unsigned int len, tabct = 8, tabidx = 0;
2805 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2806 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2807 unsigned short int dummy, rlen;
2808 struct dsc$descriptor_s **tabvec;
2810 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2811 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2812 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2815 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2817 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2818 if (iprv[i]) { /* Running image installed with privs? */
2819 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2824 /* Rights identifiers might trigger tainting as well. */
2825 if (!will_taint && (rlen || rsz)) {
2826 while (rlen < rsz) {
2827 /* We didn't get all the identifiers on the first pass. Allocate a
2828 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2829 * were needed to hold all identifiers at time of last call; we'll
2830 * allocate that many unsigned long ints), and go back and get 'em.
2832 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2833 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2834 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2835 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2838 mask = jpilist[1].bufadr;
2839 /* Check attribute flags for each identifier (2nd longword); protected
2840 * subsystem identifiers trigger tainting.
2842 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2843 if (mask[i] & KGB$M_SUBSYSTEM) {
2848 if (mask != rlst) Safefree(mask);
2850 /* We need to use this hack to tell Perl it should run with tainting,
2851 * since its tainting flag may be part of the PL_curinterp struct, which
2852 * hasn't been allocated when vms_image_init() is called.
2856 New(1320,newap,*argcp+2,char **);
2857 newap[0] = argvp[0];
2859 Copy(argvp[1],newap[2],*argcp-1,char **);
2860 /* We orphan the old argv, since we don't know where it's come from,
2861 * so we don't know how to free it.
2863 *argcp++; argvp = newap;
2865 else { /* Did user explicitly request tainting? */
2867 char *cp, **av = *argvp;
2868 for (i = 1; i < *argcp; i++) {
2869 if (*av[i] != '-') break;
2870 for (cp = av[i]+1; *cp; cp++) {
2871 if (*cp == 'T') { will_taint = 1; break; }
2872 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2873 strchr("DFIiMmx",*cp)) break;
2875 if (will_taint) break;
2880 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2882 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2883 else if (tabidx >= tabct) {
2885 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2887 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2888 tabvec[tabidx]->dsc$w_length = 0;
2889 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2890 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2891 tabvec[tabidx]->dsc$a_pointer = NULL;
2892 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2894 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2896 getredirection(argcp,argvp);
2897 #if defined(USE_THREADS) && defined(__DECC)
2899 # include <reentrancy.h>
2900 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2909 * Trim Unix-style prefix off filespec, so it looks like what a shell
2910 * glob expansion would return (i.e. from specified prefix on, not
2911 * full path). Note that returned filespec is Unix-style, regardless
2912 * of whether input filespec was VMS-style or Unix-style.
2914 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2915 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2916 * vector of options; at present, only bit 0 is used, and if set tells
2917 * trim unixpath to try the current default directory as a prefix when
2918 * presented with a possibly ambiguous ... wildcard.
2920 * Returns !=0 on success, with trimmed filespec replacing contents of
2921 * fspec, and 0 on failure, with contents of fpsec unchanged.
2923 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2925 trim_unixpath(char *fspec, char *wildspec, int opts)
2927 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2928 *template, *base, *end, *cp1, *cp2;
2929 register int tmplen, reslen = 0, dirs = 0;
2931 if (!wildspec || !fspec) return 0;
2932 if (strpbrk(wildspec,"]>:") != NULL) {
2933 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2934 else template = unixwild;
2936 else template = wildspec;
2937 if (strpbrk(fspec,"]>:") != NULL) {
2938 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2939 else base = unixified;
2940 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2941 * check to see that final result fits into (isn't longer than) fspec */
2942 reslen = strlen(fspec);
2946 /* No prefix or absolute path on wildcard, so nothing to remove */
2947 if (!*template || *template == '/') {
2948 if (base == fspec) return 1;
2949 tmplen = strlen(unixified);
2950 if (tmplen > reslen) return 0; /* not enough space */
2951 /* Copy unixified resultant, including trailing NUL */
2952 memmove(fspec,unixified,tmplen+1);
2956 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2957 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2958 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2959 for (cp1 = end ;cp1 >= base; cp1--)
2960 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2962 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2966 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2967 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2968 int ells = 1, totells, segdirs, match;
2969 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2970 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2972 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2974 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2975 if (ellipsis == template && opts & 1) {
2976 /* Template begins with an ellipsis. Since we can't tell how many
2977 * directory names at the front of the resultant to keep for an
2978 * arbitrary starting point, we arbitrarily choose the current
2979 * default directory as a starting point. If it's there as a prefix,
2980 * clip it off. If not, fall through and act as if the leading
2981 * ellipsis weren't there (i.e. return shortest possible path that
2982 * could match template).
2984 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2985 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2986 if (_tolower(*cp1) != _tolower(*cp2)) break;
2987 segdirs = dirs - totells; /* Min # of dirs we must have left */
2988 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2989 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2990 memcpy(fspec,cp2+1,end - cp2);
2994 /* First off, back up over constant elements at end of path */
2996 for (front = end ; front >= base; front--)
2997 if (*front == '/' && !dirs--) { front++; break; }
2999 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
3000 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
3001 if (cp1 != '\0') return 0; /* Path too long. */
3003 *cp2 = '\0'; /* Pick up with memcpy later */
3004 lcfront = lcres + (front - base);
3005 /* Now skip over each ellipsis and try to match the path in front of it. */
3007 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
3008 if (*(cp1) == '.' && *(cp1+1) == '.' &&
3009 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
3010 if (cp1 < template) break; /* template started with an ellipsis */
3011 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
3012 ellipsis = cp1; continue;
3014 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
3016 for (segdirs = 0, cp2 = tpl;
3017 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
3019 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
3020 else *cp2 = _tolower(*cp1); /* else lowercase for match */
3021 if (*cp2 == '/') segdirs++;
3023 if (cp1 != ellipsis - 1) return 0; /* Path too long */
3024 /* Back up at least as many dirs as in template before matching */
3025 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
3026 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
3027 for (match = 0; cp1 > lcres;) {
3028 resdsc.dsc$a_pointer = cp1;
3029 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
3031 if (match == 1) lcfront = cp1;
3033 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
3035 if (!match) return 0; /* Can't find prefix ??? */
3036 if (match > 1 && opts & 1) {
3037 /* This ... wildcard could cover more than one set of dirs (i.e.
3038 * a set of similar dir names is repeated). If the template
3039 * contains more than 1 ..., upstream elements could resolve the
3040 * ambiguity, but it's not worth a full backtracking setup here.
3041 * As a quick heuristic, clip off the current default directory
3042 * if it's present to find the trimmed spec, else use the
3043 * shortest string that this ... could cover.
3045 char def[NAM$C_MAXRSS+1], *st;
3047 if (getcwd(def, sizeof def,0) == NULL) return 0;
3048 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3049 if (_tolower(*cp1) != _tolower(*cp2)) break;
3050 segdirs = dirs - totells; /* Min # of dirs we must have left */
3051 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3052 if (*cp1 == '\0' && *cp2 == '/') {
3053 memcpy(fspec,cp2+1,end - cp2);
3056 /* Nope -- stick with lcfront from above and keep going. */
3059 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3064 } /* end of trim_unixpath() */
3069 * VMS readdir() routines.
3070 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3072 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3073 * Minor modifications to original routines.
3076 /* Number of elements in vms_versions array */
3077 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3080 * Open a directory, return a handle for later use.
3082 /*{{{ DIR *opendir(char*name) */
3087 char dir[NAM$C_MAXRSS+1];
3090 if (do_tovmspath(name,dir,0) == NULL) {
3093 if (flex_stat(dir,&sb) == -1) return NULL;
3094 if (!S_ISDIR(sb.st_mode)) {
3095 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3098 if (!cando_by_name(S_IRUSR,0,dir)) {
3099 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3102 /* Get memory for the handle, and the pattern. */
3104 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3106 /* Fill in the fields; mainly playing with the descriptor. */
3107 (void)sprintf(dd->pattern, "%s*.*",dir);
3110 dd->vms_wantversions = 0;
3111 dd->pat.dsc$a_pointer = dd->pattern;
3112 dd->pat.dsc$w_length = strlen(dd->pattern);
3113 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3114 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3117 } /* end of opendir() */
3121 * Set the flag to indicate we want versions or not.
3123 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3125 vmsreaddirversions(DIR *dd, int flag)
3127 dd->vms_wantversions = flag;
3132 * Free up an opened directory.
3134 /*{{{ void closedir(DIR *dd)*/
3138 (void)lib$find_file_end(&dd->context);
3139 Safefree(dd->pattern);
3140 Safefree((char *)dd);
3145 * Collect all the version numbers for the current file.
3151 struct dsc$descriptor_s pat;
3152 struct dsc$descriptor_s res;
3154 char *p, *text, buff[sizeof dd->entry.d_name];
3156 unsigned long context, tmpsts;
3159 /* Convenient shorthand. */
3162 /* Add the version wildcard, ignoring the "*.*" put on before */
3163 i = strlen(dd->pattern);
3164 New(1308,text,i + e->d_namlen + 3,char);
3165 (void)strcpy(text, dd->pattern);
3166 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3168 /* Set up the pattern descriptor. */
3169 pat.dsc$a_pointer = text;
3170 pat.dsc$w_length = i + e->d_namlen - 1;
3171 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3172 pat.dsc$b_class = DSC$K_CLASS_S;
3174 /* Set up result descriptor. */
3175 res.dsc$a_pointer = buff;
3176 res.dsc$w_length = sizeof buff - 2;
3177 res.dsc$b_dtype = DSC$K_DTYPE_T;
3178 res.dsc$b_class = DSC$K_CLASS_S;
3180 /* Read files, collecting versions. */
3181 for (context = 0, e->vms_verscount = 0;
3182 e->vms_verscount < VERSIZE(e);
3183 e->vms_verscount++) {
3184 tmpsts = lib$find_file(&pat, &res, &context);
3185 if (tmpsts == RMS$_NMF || context == 0) break;
3187 buff[sizeof buff - 1] = '\0';
3188 if ((p = strchr(buff, ';')))
3189 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3191 e->vms_versions[e->vms_verscount] = -1;
3194 _ckvmssts(lib$find_file_end(&context));
3197 } /* end of collectversions() */
3200 * Read the next entry from the directory.
3202 /*{{{ struct dirent *readdir(DIR *dd)*/
3206 struct dsc$descriptor_s res;
3207 char *p, buff[sizeof dd->entry.d_name];
3208 unsigned long int tmpsts;
3210 /* Set up result descriptor, and get next file. */
3211 res.dsc$a_pointer = buff;
3212 res.dsc$w_length = sizeof buff - 2;
3213 res.dsc$b_dtype = DSC$K_DTYPE_T;
3214 res.dsc$b_class = DSC$K_CLASS_S;
3215 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3216 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3217 if (!(tmpsts & 1)) {
3218 set_vaxc_errno(tmpsts);
3221 set_errno(EACCES); break;
3223 set_errno(ENODEV); break;
3226 set_errno(ENOENT); break;
3233 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3234 buff[sizeof buff - 1] = '\0';
3235 for (p = buff; *p; p++) *p = _tolower(*p);
3236 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3239 /* Skip any directory component and just copy the name. */
3240 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3241 else (void)strcpy(dd->entry.d_name, buff);
3243 /* Clobber the version. */
3244 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3246 dd->entry.d_namlen = strlen(dd->entry.d_name);
3247 dd->entry.vms_verscount = 0;
3248 if (dd->vms_wantversions) collectversions(dd);
3251 } /* end of readdir() */
3255 * Return something that can be used in a seekdir later.
3257 /*{{{ long telldir(DIR *dd)*/
3266 * Return to a spot where we used to be. Brute force.
3268 /*{{{ void seekdir(DIR *dd,long count)*/
3270 seekdir(DIR *dd, long count)
3272 int vms_wantversions;
3275 /* If we haven't done anything yet... */
3279 /* Remember some state, and clear it. */
3280 vms_wantversions = dd->vms_wantversions;
3281 dd->vms_wantversions = 0;
3282 _ckvmssts(lib$find_file_end(&dd->context));
3285 /* The increment is in readdir(). */
3286 for (dd->count = 0; dd->count < count; )
3289 dd->vms_wantversions = vms_wantversions;
3291 } /* end of seekdir() */
3294 /* VMS subprocess management
3296 * my_vfork() - just a vfork(), after setting a flag to record that
3297 * the current script is trying a Unix-style fork/exec.
3299 * vms_do_aexec() and vms_do_exec() are called in response to the
3300 * perl 'exec' function. If this follows a vfork call, then they
3301 * call out the the regular perl routines in doio.c which do an
3302 * execvp (for those who really want to try this under VMS).
3303 * Otherwise, they do exactly what the perl docs say exec should
3304 * do - terminate the current script and invoke a new command
3305 * (See below for notes on command syntax.)
3307 * do_aspawn() and do_spawn() implement the VMS side of the perl
3308 * 'system' function.
3310 * Note on command arguments to perl 'exec' and 'system': When handled
3311 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3312 * are concatenated to form a DCL command string. If the first arg
3313 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3314 * the the command string is handed off to DCL directly. Otherwise,
3315 * the first token of the command is taken as the filespec of an image
3316 * to run. The filespec is expanded using a default type of '.EXE' and
3317 * the process defaults for device, directory, etc., and if found, the resultant
3318 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3319 * the command string as parameters. This is perhaps a bit complicated,
3320 * but I hope it will form a happy medium between what VMS folks expect
3321 * from lib$spawn and what Unix folks expect from exec.
3324 static int vfork_called;
3326 /*{{{int my_vfork()*/
3339 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
3342 if (VMScmd.dsc$a_pointer) {
3343 Safefree(VMScmd.dsc$a_pointer);
3344 VMScmd.dsc$w_length = 0;
3345 VMScmd.dsc$a_pointer = Nullch;
3350 setup_argstr(SV *really, SV **mark, SV **sp)
3353 char *junk, *tmps = Nullch;
3354 register size_t cmdlen = 0;
3361 tmps = SvPV(really,rlen);
3368 for (idx++; idx <= sp; idx++) {
3370 junk = SvPVx(*idx,rlen);
3371 cmdlen += rlen ? rlen + 1 : 0;
3374 New(401,PL_Cmd,cmdlen+1,char);
3376 if (tmps && *tmps) {
3377 strcpy(PL_Cmd,tmps);
3380 else *PL_Cmd = '\0';
3381 while (++mark <= sp) {
3383 char *s = SvPVx(*mark,n_a);
3385 if (*PL_Cmd) strcat(PL_Cmd," ");
3391 } /* end of setup_argstr() */
3394 static unsigned long int
3395 setup_cmddsc(char *cmd, int check_img)
3397 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
3398 $DESCRIPTOR(defdsc,".EXE");
3399 $DESCRIPTOR(defdsc2,".");
3400 $DESCRIPTOR(resdsc,resspec);
3401 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3402 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3403 register char *s, *rest, *cp, *wordbreak;
3408 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
3411 while (*s && isspace(*s)) s++;
3413 if (*s == '@' || *s == '$') {
3414 vmsspec[0] = *s; rest = s + 1;
3415 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
3417 else { cp = vmsspec; rest = s; }
3418 if (*rest == '.' || *rest == '/') {
3421 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
3422 rest++, cp2++) *cp2 = *rest;
3424 if (do_tovmsspec(resspec,cp,0)) {
3427 for (cp2 = vmsspec + strlen(vmsspec);
3428 *rest && cp2 - vmsspec < sizeof vmsspec;
3429 rest++, cp2++) *cp2 = *rest;
3434 /* Intuit whether verb (first word of cmd) is a DCL command:
3435 * - if first nonspace char is '@', it's a DCL indirection
3437 * - if verb contains a filespec separator, it's not a DCL command
3438 * - if it doesn't, caller tells us whether to default to a DCL
3439 * command, or to a local image unless told it's DCL (by leading '$')
3441 if (*s == '@') isdcl = 1;
3443 register char *filespec = strpbrk(s,":<[.;");
3444 rest = wordbreak = strpbrk(s," \"\t/");
3445 if (!wordbreak) wordbreak = s + strlen(s);
3446 if (*s == '$') check_img = 0;
3447 if (filespec && (filespec < wordbreak)) isdcl = 0;
3448 else isdcl = !check_img;
3452 imgdsc.dsc$a_pointer = s;
3453 imgdsc.dsc$w_length = wordbreak - s;
3454 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3456 _ckvmssts(lib$find_file_end(&cxt));
3457 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3458 if (!(retsts & 1) && *s == '$') {
3459 _ckvmssts(lib$find_file_end(&cxt));
3460 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
3461 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3463 _ckvmssts(lib$find_file_end(&cxt));
3464 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
3468 _ckvmssts(lib$find_file_end(&cxt));
3473 while (*s && !isspace(*s)) s++;
3476 /* check that it's really not DCL with no file extension */
3477 fp = fopen(resspec,"r","ctx=bin,shr=get");
3479 char b[4] = {0,0,0,0};
3480 read(fileno(fp),b,4);
3481 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
3484 if (check_img && isdcl) return RMS$_FNF;
3486 if (cando_by_name(S_IXUSR,0,resspec)) {
3487 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3489 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3491 strcpy(VMScmd.dsc$a_pointer,"@");
3493 strcat(VMScmd.dsc$a_pointer,resspec);
3494 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3495 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3498 else retsts = RMS$_PRV;
3501 /* It's either a DCL command or we couldn't find a suitable image */
3502 VMScmd.dsc$w_length = strlen(cmd);
3503 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
3504 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3505 if (!(retsts & 1)) {
3506 /* just hand off status values likely to be due to user error */
3507 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3508 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3509 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3510 else { _ckvmssts(retsts); }
3513 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3515 } /* end of setup_cmddsc() */
3518 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3520 vms_do_aexec(SV *really,SV **mark,SV **sp)
3524 if (vfork_called) { /* this follows a vfork - act Unixish */
3526 if (vfork_called < 0) {
3527 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3530 else return do_aexec(really,mark,sp);
3532 /* no vfork - act VMSish */
3533 return vms_do_exec(setup_argstr(really,mark,sp));
3538 } /* end of vms_do_aexec() */
3541 /* {{{bool vms_do_exec(char *cmd) */
3543 vms_do_exec(char *cmd)
3547 if (vfork_called) { /* this follows a vfork - act Unixish */
3549 if (vfork_called < 0) {
3550 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3553 else return do_exec(cmd);
3556 { /* no vfork - act VMSish */
3557 unsigned long int retsts;
3560 TAINT_PROPER("exec");
3561 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3562 retsts = lib$do_command(&VMScmd);
3566 set_errno(ENOENT); break;
3567 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3568 set_errno(ENOTDIR); break;
3570 set_errno(EACCES); break;
3572 set_errno(EINVAL); break;
3574 set_errno(E2BIG); break;
3575 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3576 _ckvmssts(retsts); /* fall through */
3577 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3580 set_vaxc_errno(retsts);
3581 if (ckWARN(WARN_EXEC)) {
3582 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3583 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3590 } /* end of vms_do_exec() */
3593 unsigned long int do_spawn(char *);
3595 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3597 do_aspawn(void *really,void **mark,void **sp)
3600 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3603 } /* end of do_aspawn() */
3606 /* {{{unsigned long int do_spawn(char *cmd) */
3610 unsigned long int sts, substs, hadcmd = 1;
3614 TAINT_PROPER("spawn");
3615 if (!cmd || !*cmd) {
3617 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3619 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3620 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3626 set_errno(ENOENT); break;
3627 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3628 set_errno(ENOTDIR); break;
3630 set_errno(EACCES); break;
3632 set_errno(EINVAL); break;
3634 set_errno(E2BIG); break;
3635 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3636 _ckvmssts(sts); /* fall through */
3637 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3640 set_vaxc_errno(sts);
3641 if (ckWARN(WARN_EXEC)) {
3642 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3643 hadcmd ? VMScmd.dsc$w_length : 0,
3644 hadcmd ? VMScmd.dsc$a_pointer : "",
3651 } /* end of do_spawn() */
3655 * A simple fwrite replacement which outputs itmsz*nitm chars without
3656 * introducing record boundaries every itmsz chars.
3658 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3660 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3662 register char *cp, *end;
3664 end = (char *)src + itmsz * nitm;
3666 while ((char *)src <= end) {
3667 for (cp = src; cp <= end; cp++) if (!*cp) break;
3668 if (fputs(src,dest) == EOF) return EOF;
3670 if (fputc('\0',dest) == EOF) return EOF;
3676 } /* end of my_fwrite() */
3679 /*{{{ int my_flush(FILE *fp)*/
3684 if ((res = fflush(fp)) == 0 && fp) {
3685 #ifdef VMS_DO_SOCKETS
3687 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3689 res = fsync(fileno(fp));
3696 * Here are replacements for the following Unix routines in the VMS environment:
3697 * getpwuid Get information for a particular UIC or UID
3698 * getpwnam Get information for a named user
3699 * getpwent Get information for each user in the rights database
3700 * setpwent Reset search to the start of the rights database
3701 * endpwent Finish searching for users in the rights database
3703 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3704 * (defined in pwd.h), which contains the following fields:-
3706 * char *pw_name; Username (in lower case)
3707 * char *pw_passwd; Hashed password
3708 * unsigned int pw_uid; UIC
3709 * unsigned int pw_gid; UIC group number
3710 * char *pw_unixdir; Default device/directory (VMS-style)
3711 * char *pw_gecos; Owner name
3712 * char *pw_dir; Default device/directory (Unix-style)
3713 * char *pw_shell; Default CLI name (eg. DCL)
3715 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3717 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3718 * not the UIC member number (eg. what's returned by getuid()),
3719 * getpwuid() can accept either as input (if uid is specified, the caller's
3720 * UIC group is used), though it won't recognise gid=0.
3722 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3723 * information about other users in your group or in other groups, respectively.
3724 * If the required privilege is not available, then these routines fill only
3725 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3728 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3731 /* sizes of various UAF record fields */
3732 #define UAI$S_USERNAME 12
3733 #define UAI$S_IDENT 31
3734 #define UAI$S_OWNER 31
3735 #define UAI$S_DEFDEV 31
3736 #define UAI$S_DEFDIR 63
3737 #define UAI$S_DEFCLI 31
3740 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3741 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3742 (uic).uic$v_group != UIC$K_WILD_GROUP)
3744 static char __empty[]= "";
3745 static struct passwd __passwd_empty=
3746 {(char *) __empty, (char *) __empty, 0, 0,
3747 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3748 static int contxt= 0;
3749 static struct passwd __pwdcache;
3750 static char __pw_namecache[UAI$S_IDENT+1];
3753 * This routine does most of the work extracting the user information.
3755 static int fillpasswd (const char *name, struct passwd *pwd)
3759 unsigned char length;
3760 char pw_gecos[UAI$S_OWNER+1];
3762 static union uicdef uic;
3764 unsigned char length;
3765 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3768 unsigned char length;
3769 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3772 unsigned char length;
3773 char pw_shell[UAI$S_DEFCLI+1];
3775 static char pw_passwd[UAI$S_PWD+1];
3777 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3778 struct dsc$descriptor_s name_desc;
3779 unsigned long int sts;
3781 static struct itmlst_3 itmlst[]= {
3782 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3783 {sizeof(uic), UAI$_UIC, &uic, &luic},
3784 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3785 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3786 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3787 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3788 {0, 0, NULL, NULL}};
3790 name_desc.dsc$w_length= strlen(name);
3791 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3792 name_desc.dsc$b_class= DSC$K_CLASS_S;
3793 name_desc.dsc$a_pointer= (char *) name;
3795 /* Note that sys$getuai returns many fields as counted strings. */
3796 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3797 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3798 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3800 else { _ckvmssts(sts); }
3801 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3803 if ((int) owner.length < lowner) lowner= (int) owner.length;
3804 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3805 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3806 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3807 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3808 owner.pw_gecos[lowner]= '\0';
3809 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3810 defcli.pw_shell[ldefcli]= '\0';
3811 if (valid_uic(uic)) {
3812 pwd->pw_uid= uic.uic$l_uic;
3813 pwd->pw_gid= uic.uic$v_group;
3816 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3817 pwd->pw_passwd= pw_passwd;
3818 pwd->pw_gecos= owner.pw_gecos;
3819 pwd->pw_dir= defdev.pw_dir;
3820 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3821 pwd->pw_shell= defcli.pw_shell;
3822 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3824 ldir= strlen(pwd->pw_unixdir) - 1;
3825 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3828 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3829 __mystrtolower(pwd->pw_unixdir);
3834 * Get information for a named user.
3836 /*{{{struct passwd *getpwnam(char *name)*/
3837 struct passwd *my_getpwnam(char *name)
3839 struct dsc$descriptor_s name_desc;
3841 unsigned long int status, sts;
3844 __pwdcache = __passwd_empty;
3845 if (!fillpasswd(name, &__pwdcache)) {
3846 /* We still may be able to determine pw_uid and pw_gid */
3847 name_desc.dsc$w_length= strlen(name);
3848 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3849 name_desc.dsc$b_class= DSC$K_CLASS_S;
3850 name_desc.dsc$a_pointer= (char *) name;
3851 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3852 __pwdcache.pw_uid= uic.uic$l_uic;
3853 __pwdcache.pw_gid= uic.uic$v_group;
3856 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3857 set_vaxc_errno(sts);
3858 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3861 else { _ckvmssts(sts); }
3864 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3865 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3866 __pwdcache.pw_name= __pw_namecache;
3868 } /* end of my_getpwnam() */
3872 * Get information for a particular UIC or UID.
3873 * Called by my_getpwent with uid=-1 to list all users.
3875 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3876 struct passwd *my_getpwuid(Uid_t uid)
3878 const $DESCRIPTOR(name_desc,__pw_namecache);
3879 unsigned short lname;
3881 unsigned long int status;
3884 if (uid == (unsigned int) -1) {
3886 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3887 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3888 set_vaxc_errno(status);
3889 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3893 else { _ckvmssts(status); }
3894 } while (!valid_uic (uic));
3898 if (!uic.uic$v_group)
3899 uic.uic$v_group= PerlProc_getgid();
3901 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3902 else status = SS$_IVIDENT;
3903 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3904 status == RMS$_PRV) {
3905 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3908 else { _ckvmssts(status); }
3910 __pw_namecache[lname]= '\0';
3911 __mystrtolower(__pw_namecache);
3913 __pwdcache = __passwd_empty;
3914 __pwdcache.pw_name = __pw_namecache;
3916 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3917 The identifier's value is usually the UIC, but it doesn't have to be,
3918 so if we can, we let fillpasswd update this. */
3919 __pwdcache.pw_uid = uic.uic$l_uic;
3920 __pwdcache.pw_gid = uic.uic$v_group;
3922 fillpasswd(__pw_namecache, &__pwdcache);
3925 } /* end of my_getpwuid() */
3929 * Get information for next user.
3931 /*{{{struct passwd *my_getpwent()*/
3932 struct passwd *my_getpwent()
3934 return (my_getpwuid((unsigned int) -1));
3939 * Finish searching rights database for users.
3941 /*{{{void my_endpwent()*/
3946 _ckvmssts(sys$finish_rdb(&contxt));
3952 #ifdef HOMEGROWN_POSIX_SIGNALS
3953 /* Signal handling routines, pulled into the core from POSIX.xs.
3955 * We need these for threads, so they've been rolled into the core,
3956 * rather than left in POSIX.xs.
3958 * (DRS, Oct 23, 1997)
3961 /* sigset_t is atomic under VMS, so these routines are easy */
3962 /*{{{int my_sigemptyset(sigset_t *) */
3963 int my_sigemptyset(sigset_t *set) {
3964 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3970 /*{{{int my_sigfillset(sigset_t *)*/
3971 int my_sigfillset(sigset_t *set) {
3973 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3974 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3980 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3981 int my_sigaddset(sigset_t *set, int sig) {
3982 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3983 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3984 *set |= (1 << (sig - 1));
3990 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3991 int my_sigdelset(sigset_t *set, int sig) {
3992 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3993 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3994 *set &= ~(1 << (sig - 1));
4000 /*{{{int my_sigismember(sigset_t *set, int sig)*/
4001 int my_sigismember(sigset_t *set, int sig) {
4002 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
4003 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
4004 *set & (1 << (sig - 1));
4009 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
4010 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
4013 /* If set and oset are both null, then things are badly wrong. Bail out. */
4014 if ((oset == NULL) && (set == NULL)) {
4015 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
4019 /* If set's null, then we're just handling a fetch. */
4021 tempmask = sigblock(0);
4026 tempmask = sigsetmask(*set);
4029 tempmask = sigblock(*set);
4032 tempmask = sigblock(0);
4033 sigsetmask(*oset & ~tempmask);
4036 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4041 /* Did they pass us an oset? If so, stick our holding mask into it */
4048 #endif /* HOMEGROWN_POSIX_SIGNALS */
4051 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
4052 * my_utime(), and flex_stat(), all of which operate on UTC unless
4053 * VMSISH_TIMES is true.
4055 /* method used to handle UTC conversions:
4056 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
4058 static int gmtime_emulation_type;
4059 /* number of secs to add to UTC POSIX-style time to get local time */
4060 static long int utc_offset_secs;
4062 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
4063 * in vmsish.h. #undef them here so we can call the CRTL routines
4070 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
4071 # define RTL_USES_UTC 1
4075 * DEC C previous to 6.0 corrupts the behavior of the /prefix
4076 * qualifier with the extern prefix pragma. This provisional
4077 * hack circumvents this prefix pragma problem in previous
4080 #if defined(__VMS_VER) && __VMS_VER >= 70000000
4081 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
4082 # pragma __extern_prefix save
4083 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
4084 # define gmtime decc$__utctz_gmtime
4085 # define localtime decc$__utctz_localtime
4086 # define time decc$__utc_time
4087 # pragma __extern_prefix restore
4089 struct tm *gmtime(), *localtime();
4095 static time_t toutc_dst(time_t loc) {
4098 if ((rsltmp = localtime(&loc)) == NULL) return -1;
4099 loc -= utc_offset_secs;
4100 if (rsltmp->tm_isdst) loc -= 3600;
4103 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4104 ((gmtime_emulation_type || my_time(NULL)), \
4105 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
4106 ((secs) - utc_offset_secs))))
4108 static time_t toloc_dst(time_t utc) {
4111 utc += utc_offset_secs;
4112 if ((rsltmp = localtime(&utc)) == NULL) return -1;
4113 if (rsltmp->tm_isdst) utc += 3600;
4116 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
4117 ((gmtime_emulation_type || my_time(NULL)), \
4118 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4119 ((secs) + utc_offset_secs))))
4122 /* my_time(), my_localtime(), my_gmtime()
4123 * By default traffic in UTC time values, using CRTL gmtime() or
4124 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4125 * Note: We need to use these functions even when the CRTL has working
4126 * UTC support, since they also handle C<use vmsish qw(times);>
4128 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4129 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4132 /*{{{time_t my_time(time_t *timep)*/
4133 time_t my_time(time_t *timep)
4139 if (gmtime_emulation_type == 0) {
4141 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4142 /* results of calls to gmtime() and localtime() */
4143 /* for same &base */
4145 gmtime_emulation_type++;
4146 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4147 char off[LNM$C_NAMLENGTH+1];;
4149 gmtime_emulation_type++;
4150 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4151 gmtime_emulation_type++;
4152 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4154 else { utc_offset_secs = atol(off); }
4156 else { /* We've got a working gmtime() */
4157 struct tm gmt, local;
4160 tm_p = localtime(&base);
4162 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4163 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4164 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4165 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4171 # ifdef RTL_USES_UTC
4172 if (VMSISH_TIME) when = _toloc(when);
4174 if (!VMSISH_TIME) when = _toutc(when);
4177 if (timep != NULL) *timep = when;
4180 } /* end of my_time() */
4184 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4186 my_gmtime(const time_t *timep)
4193 if (timep == NULL) {
4194 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4197 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4201 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4203 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4204 return gmtime(&when);
4206 /* CRTL localtime() wants local time as input, so does no tz correction */
4207 rsltmp = localtime(&when);
4208 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4211 } /* end of my_gmtime() */
4215 /*{{{struct tm *my_localtime(const time_t *timep)*/
4217 my_localtime(const time_t *timep)
4223 if (timep == NULL) {
4224 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4227 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4228 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4231 # ifdef RTL_USES_UTC
4233 if (VMSISH_TIME) when = _toutc(when);
4235 /* CRTL localtime() wants UTC as input, does tz correction itself */
4236 return localtime(&when);
4239 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4242 /* CRTL localtime() wants local time as input, so does no tz correction */
4243 rsltmp = localtime(&when);
4244 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4247 } /* end of my_localtime() */
4250 /* Reset definitions for later calls */
4251 #define gmtime(t) my_gmtime(t)
4252 #define localtime(t) my_localtime(t)
4253 #define time(t) my_time(t)
4256 /* my_utime - update modification time of a file
4257 * calling sequence is identical to POSIX utime(), but under
4258 * VMS only the modification time is changed; ODS-2 does not
4259 * maintain access times. Restrictions differ from the POSIX
4260 * definition in that the time can be changed as long as the
4261 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4262 * no separate checks are made to insure that the caller is the
4263 * owner of the file or has special privs enabled.
4264 * Code here is based on Joe Meadows' FILE utility.
4267 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4268 * to VMS epoch (01-JAN-1858 00:00:00.00)
4269 * in 100 ns intervals.
4271 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4273 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4274 int my_utime(char *file, struct utimbuf *utimes)
4278 long int bintime[2], len = 2, lowbit, unixtime,
4279 secscale = 10000000; /* seconds --> 100 ns intervals */
4280 unsigned long int chan, iosb[2], retsts;
4281 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4282 struct FAB myfab = cc$rms_fab;
4283 struct NAM mynam = cc$rms_nam;
4284 #if defined (__DECC) && defined (__VAX)
4285 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4286 * at least through VMS V6.1, which causes a type-conversion warning.
4288 # pragma message save
4289 # pragma message disable cvtdiftypes
4291 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4292 struct fibdef myfib;
4293 #if defined (__DECC) && defined (__VAX)
4294 /* This should be right after the declaration of myatr, but due
4295 * to a bug in VAX DEC C, this takes effect a statement early.
4297 # pragma message restore
4299 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4300 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4301 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4303 if (file == NULL || *file == '\0') {
4305 set_vaxc_errno(LIB$_INVARG);
4308 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4310 if (utimes != NULL) {
4311 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4312 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4313 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4314 * as input, we force the sign bit to be clear by shifting unixtime right
4315 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4317 lowbit = (utimes->modtime & 1) ? secscale : 0;
4318 unixtime = (long int) utimes->modtime;
4320 /* If input was UTC; convert to local for sys svc */
4321 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4323 unixtime >>= 1; secscale <<= 1;
4324 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4325 if (!(retsts & 1)) {
4327 set_vaxc_errno(retsts);
4330 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4331 if (!(retsts & 1)) {
4333 set_vaxc_errno(retsts);
4338 /* Just get the current time in VMS format directly */
4339 retsts = sys$gettim(bintime);
4340 if (!(retsts & 1)) {
4342 set_vaxc_errno(retsts);
4347 myfab.fab$l_fna = vmsspec;
4348 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4349 myfab.fab$l_nam = &mynam;
4350 mynam.nam$l_esa = esa;
4351 mynam.nam$b_ess = (unsigned char) sizeof esa;
4352 mynam.nam$l_rsa = rsa;
4353 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4355 /* Look for the file to be affected, letting RMS parse the file
4356 * specification for us as well. I have set errno using only
4357 * values documented in the utime() man page for VMS POSIX.
4359 retsts = sys$parse(&myfab,0,0);
4360 if (!(retsts & 1)) {
4361 set_vaxc_errno(retsts);
4362 if (retsts == RMS$_PRV) set_errno(EACCES);
4363 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4364 else set_errno(EVMSERR);
4367 retsts = sys$search(&myfab,0,0);
4368 if (!(retsts & 1)) {
4369 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4370 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4371 set_vaxc_errno(retsts);
4372 if (retsts == RMS$_PRV) set_errno(EACCES);
4373 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4374 else set_errno(EVMSERR);
4378 devdsc.dsc$w_length = mynam.nam$b_dev;
4379 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4381 retsts = sys$assign(&devdsc,&chan,0,0);
4382 if (!(retsts & 1)) {
4383 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4384 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4385 set_vaxc_errno(retsts);
4386 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4387 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4388 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4389 else set_errno(EVMSERR);
4393 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4394 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4396 memset((void *) &myfib, 0, sizeof myfib);
4398 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4399 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4400 /* This prevents the revision time of the file being reset to the current
4401 * time as a result of our IO$_MODIFY $QIO. */
4402 myfib.fib$l_acctl = FIB$M_NORECORD;
4404 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4405 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4406 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4408 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4409 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4410 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
4411 _ckvmssts(sys$dassgn(chan));
4412 if (retsts & 1) retsts = iosb[0];
4413 if (!(retsts & 1)) {
4414 set_vaxc_errno(retsts);
4415 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4416 else set_errno(EVMSERR);
4421 } /* end of my_utime() */
4425 * flex_stat, flex_fstat
4426 * basic stat, but gets it right when asked to stat
4427 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4430 /* encode_dev packs a VMS device name string into an integer to allow
4431 * simple comparisons. This can be used, for example, to check whether two
4432 * files are located on the same device, by comparing their encoded device
4433 * names. Even a string comparison would not do, because stat() reuses the
4434 * device name buffer for each call; so without encode_dev, it would be
4435 * necessary to save the buffer and use strcmp (this would mean a number of
4436 * changes to the standard Perl code, to say nothing of what a Perl script
4439 * The device lock id, if it exists, should be unique (unless perhaps compared
4440 * with lock ids transferred from other nodes). We have a lock id if the disk is
4441 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4442 * device names. Thus we use the lock id in preference, and only if that isn't
4443 * available, do we try to pack the device name into an integer (flagged by
4444 * the sign bit (LOCKID_MASK) being set).
4446 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4447 * name and its encoded form, but it seems very unlikely that we will find
4448 * two files on different disks that share the same encoded device names,
4449 * and even more remote that they will share the same file id (if the test
4450 * is to check for the same file).
4452 * A better method might be to use sys$device_scan on the first call, and to
4453 * search for the device, returning an index into the cached array.
4454 * The number returned would be more intelligable.
4455 * This is probably not worth it, and anyway would take quite a bit longer
4456 * on the first call.
4458 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4459 static mydev_t encode_dev (const char *dev)
4462 unsigned long int f;
4468 if (!dev || !dev[0]) return 0;
4472 struct dsc$descriptor_s dev_desc;
4473 unsigned long int status, lockid, item = DVI$_LOCKID;
4475 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4476 can try that first. */
4477 dev_desc.dsc$w_length = strlen (dev);
4478 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4479 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4480 dev_desc.dsc$a_pointer = (char *) dev;
4481 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4482 if (lockid) return (lockid & ~LOCKID_MASK);
4486 /* Otherwise we try to encode the device name */
4490 for (q = dev + strlen(dev); q--; q >= dev) {
4493 else if (isalpha (toupper (*q)))
4494 c= toupper (*q) - 'A' + (char)10;
4496 continue; /* Skip '$'s */
4498 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4500 enc += f * (unsigned long int) c;
4502 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4504 } /* end of encode_dev() */
4506 static char namecache[NAM$C_MAXRSS+1];
4509 is_null_device(name)
4513 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4514 The underscore prefix, controller letter, and unit number are
4515 independently optional; for our purposes, the colon punctuation
4516 is not. The colon can be trailed by optional directory and/or
4517 filename, but two consecutive colons indicates a nodename rather
4518 than a device. [pr] */
4519 if (*name == '_') ++name;
4520 if (tolower(*name++) != 'n') return 0;
4521 if (tolower(*name++) != 'l') return 0;
4522 if (tolower(*name) == 'a') ++name;
4523 if (*name == '0') ++name;
4524 return (*name++ == ':') && (*name != ':');
4527 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4528 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4529 * subset of the applicable information.
4532 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
4534 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4536 char fname[NAM$C_MAXRSS+1];
4537 unsigned long int retsts;
4538 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4539 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4541 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4542 device name on successive calls */
4543 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4544 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4545 namdsc.dsc$a_pointer = fname;
4546 namdsc.dsc$w_length = sizeof fname - 1;
4548 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4549 &namdsc,&namdsc.dsc$w_length,0,0);
4551 fname[namdsc.dsc$w_length] = '\0';
4552 return cando_by_name(bit,effective,fname);
4554 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4555 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4559 return FALSE; /* Should never get to here */
4561 } /* end of cando() */
4565 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
4567 cando_by_name(I32 bit, Uid_t effective, char *fname)
4569 static char usrname[L_cuserid];
4570 static struct dsc$descriptor_s usrdsc =
4571 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4572 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4573 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4574 unsigned short int retlen;
4576 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4577 union prvdef curprv;
4578 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4579 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4580 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4583 if (!fname || !*fname) return FALSE;
4584 /* Make sure we expand logical names, since sys$check_access doesn't */
4585 if (!strpbrk(fname,"/]>:")) {
4586 strcpy(fileified,fname);
4587 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4590 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4591 retlen = namdsc.dsc$w_length = strlen(vmsname);
4592 namdsc.dsc$a_pointer = vmsname;
4593 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4594 vmsname[retlen-1] == ':') {
4595 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4596 namdsc.dsc$w_length = strlen(fileified);
4597 namdsc.dsc$a_pointer = fileified;
4600 if (!usrdsc.dsc$w_length) {
4602 usrdsc.dsc$w_length = strlen(usrname);
4609 access = ARM$M_EXECUTE;
4614 access = ARM$M_READ;
4619 access = ARM$M_WRITE;
4624 access = ARM$M_DELETE;
4630 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4631 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4632 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4633 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4634 set_vaxc_errno(retsts);
4635 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4636 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4637 else set_errno(ENOENT);
4640 if (retsts == SS$_NORMAL) {
4641 if (!privused) return TRUE;
4642 /* We can get access, but only by using privs. Do we have the
4643 necessary privs currently enabled? */
4644 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4645 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4646 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4647 !curprv.prv$v_bypass) return FALSE;
4648 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4649 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4650 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4653 if (retsts == SS$_ACCONFLICT) {
4658 return FALSE; /* Should never get here */
4660 } /* end of cando_by_name() */
4664 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4666 flex_fstat(int fd, Stat_t *statbufp)
4669 if (!fstat(fd,(stat_t *) statbufp)) {
4670 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4671 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4672 # ifdef RTL_USES_UTC
4675 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4676 statbufp->st_atime = _toloc(statbufp->st_atime);
4677 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4682 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4686 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4687 statbufp->st_atime = _toutc(statbufp->st_atime);
4688 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4695 } /* end of flex_fstat() */
4698 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4700 flex_stat(const char *fspec, Stat_t *statbufp)
4703 char fileified[NAM$C_MAXRSS+1];
4704 char temp_fspec[NAM$C_MAXRSS+300];
4707 strcpy(temp_fspec, fspec);
4708 if (statbufp == (Stat_t *) &PL_statcache)
4709 do_tovmsspec(temp_fspec,namecache,0);
4710 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4711 memset(statbufp,0,sizeof *statbufp);
4712 statbufp->st_dev = encode_dev("_NLA0:");
4713 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4714 statbufp->st_uid = 0x00010001;
4715 statbufp->st_gid = 0x0001;
4716 time((time_t *)&statbufp->st_mtime);
4717 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4721 /* Try for a directory name first. If fspec contains a filename without
4722 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4723 * and sea:[wine.dark]water. exist, we prefer the directory here.
4724 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4725 * not sea:[wine.dark]., if the latter exists. If the intended target is
4726 * the file with null type, specify this by calling flex_stat() with
4727 * a '.' at the end of fspec.
4729 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4730 retval = stat(fileified,(stat_t *) statbufp);
4731 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4732 strcpy(namecache,fileified);
4734 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4736 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4737 # ifdef RTL_USES_UTC
4740 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4741 statbufp->st_atime = _toloc(statbufp->st_atime);
4742 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4747 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4751 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4752 statbufp->st_atime = _toutc(statbufp->st_atime);
4753 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4759 } /* end of flex_stat() */
4763 /*{{{char *my_getlogin()*/
4764 /* VMS cuserid == Unix getlogin, except calling sequence */
4768 static char user[L_cuserid];
4769 return cuserid(user);
4774 /* rmscopy - copy a file using VMS RMS routines
4776 * Copies contents and attributes of spec_in to spec_out, except owner
4777 * and protection information. Name and type of spec_in are used as
4778 * defaults for spec_out. The third parameter specifies whether rmscopy()
4779 * should try to propagate timestamps from the input file to the output file.
4780 * If it is less than 0, no timestamps are preserved. If it is 0, then
4781 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4782 * propagated to the output file at creation iff the output file specification
4783 * did not contain an explicit name or type, and the revision date is always
4784 * updated at the end of the copy operation. If it is greater than 0, then
4785 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4786 * other than the revision date should be propagated, and bit 1 indicates
4787 * that the revision date should be propagated.
4789 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4791 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4792 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4793 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4794 * as part of the Perl standard distribution under the terms of the
4795 * GNU General Public License or the Perl Artistic License. Copies
4796 * of each may be found in the Perl standard distribution.
4798 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4800 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4802 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4803 rsa[NAM$C_MAXRSS], ubf[32256];
4804 unsigned long int i, sts, sts2;
4805 struct FAB fab_in, fab_out;
4806 struct RAB rab_in, rab_out;
4808 struct XABDAT xabdat;
4809 struct XABFHC xabfhc;
4810 struct XABRDT xabrdt;
4811 struct XABSUM xabsum;
4813 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4814 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4815 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4819 fab_in = cc$rms_fab;
4820 fab_in.fab$l_fna = vmsin;
4821 fab_in.fab$b_fns = strlen(vmsin);
4822 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4823 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4824 fab_in.fab$l_fop = FAB$M_SQO;
4825 fab_in.fab$l_nam = &nam;
4826 fab_in.fab$l_xab = (void *) &xabdat;
4829 nam.nam$l_rsa = rsa;
4830 nam.nam$b_rss = sizeof(rsa);
4831 nam.nam$l_esa = esa;
4832 nam.nam$b_ess = sizeof (esa);
4833 nam.nam$b_esl = nam.nam$b_rsl = 0;
4835 xabdat = cc$rms_xabdat; /* To get creation date */
4836 xabdat.xab$l_nxt = (void *) &xabfhc;
4838 xabfhc = cc$rms_xabfhc; /* To get record length */
4839 xabfhc.xab$l_nxt = (void *) &xabsum;
4841 xabsum = cc$rms_xabsum; /* To get key and area information */
4843 if (!((sts = sys$open(&fab_in)) & 1)) {
4844 set_vaxc_errno(sts);
4848 set_errno(ENOENT); break;
4850 set_errno(ENODEV); break;
4852 set_errno(EINVAL); break;
4854 set_errno(EACCES); break;
4862 fab_out.fab$w_ifi = 0;
4863 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4864 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4865 fab_out.fab$l_fop = FAB$M_SQO;
4866 fab_out.fab$l_fna = vmsout;
4867 fab_out.fab$b_fns = strlen(vmsout);
4868 fab_out.fab$l_dna = nam.nam$l_name;
4869 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4871 if (preserve_dates == 0) { /* Act like DCL COPY */
4872 nam.nam$b_nop = NAM$M_SYNCHK;
4873 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4874 if (!((sts = sys$parse(&fab_out)) & 1)) {
4875 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4876 set_vaxc_errno(sts);
4879 fab_out.fab$l_xab = (void *) &xabdat;
4880 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4882 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4883 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4884 preserve_dates =0; /* bitmask from this point forward */
4886 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4887 if (!((sts = sys$create(&fab_out)) & 1)) {
4888 set_vaxc_errno(sts);
4891 set_errno(ENOENT); break;
4893 set_errno(ENODEV); break;
4895 set_errno(EINVAL); break;
4897 set_errno(EACCES); break;
4903 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4904 if (preserve_dates & 2) {
4905 /* sys$close() will process xabrdt, not xabdat */
4906 xabrdt = cc$rms_xabrdt;
4908 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4910 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4911 * is unsigned long[2], while DECC & VAXC use a struct */
4912 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4914 fab_out.fab$l_xab = (void *) &xabrdt;
4917 rab_in = cc$rms_rab;
4918 rab_in.rab$l_fab = &fab_in;
4919 rab_in.rab$l_rop = RAB$M_BIO;
4920 rab_in.rab$l_ubf = ubf;
4921 rab_in.rab$w_usz = sizeof ubf;
4922 if (!((sts = sys$connect(&rab_in)) & 1)) {
4923 sys$close(&fab_in); sys$close(&fab_out);
4924 set_errno(EVMSERR); set_vaxc_errno(sts);
4928 rab_out = cc$rms_rab;
4929 rab_out.rab$l_fab = &fab_out;
4930 rab_out.rab$l_rbf = ubf;
4931 if (!((sts = sys$connect(&rab_out)) & 1)) {
4932 sys$close(&fab_in); sys$close(&fab_out);
4933 set_errno(EVMSERR); set_vaxc_errno(sts);
4937 while ((sts = sys$read(&rab_in))) { /* always true */
4938 if (sts == RMS$_EOF) break;
4939 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4940 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4941 sys$close(&fab_in); sys$close(&fab_out);
4942 set_errno(EVMSERR); set_vaxc_errno(sts);
4947 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4948 sys$close(&fab_in); sys$close(&fab_out);
4949 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4951 set_errno(EVMSERR); set_vaxc_errno(sts);
4957 } /* end of rmscopy() */
4961 /*** The following glue provides 'hooks' to make some of the routines
4962 * from this file available from Perl. These routines are sufficiently
4963 * basic, and are required sufficiently early in the build process,
4964 * that's it's nice to have them available to miniperl as well as the
4965 * full Perl, so they're set up here instead of in an extension. The
4966 * Perl code which handles importation of these names into a given
4967 * package lives in [.VMS]Filespec.pm in @INC.
4971 rmsexpand_fromperl(pTHX_ CV *cv)
4974 char *fspec, *defspec = NULL, *rslt;
4977 if (!items || items > 2)
4978 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4979 fspec = SvPV(ST(0),n_a);
4980 if (!fspec || !*fspec) XSRETURN_UNDEF;
4981 if (items == 2) defspec = SvPV(ST(1),n_a);
4983 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4984 ST(0) = sv_newmortal();
4985 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4990 vmsify_fromperl(pTHX_ CV *cv)
4996 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4997 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4998 ST(0) = sv_newmortal();
4999 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
5004 unixify_fromperl(pTHX_ CV *cv)
5010 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
5011 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
5012 ST(0) = sv_newmortal();
5013 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
5018 fileify_fromperl(pTHX_ CV *cv)
5024 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
5025 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
5026 ST(0) = sv_newmortal();
5027 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
5032 pathify_fromperl(pTHX_ CV *cv)
5038 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
5039 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
5040 ST(0) = sv_newmortal();
5041 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
5046 vmspath_fromperl(pTHX_ CV *cv)
5052 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
5053 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
5054 ST(0) = sv_newmortal();
5055 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
5060 unixpath_fromperl(pTHX_ CV *cv)
5066 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
5067 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
5068 ST(0) = sv_newmortal();
5069 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
5074 candelete_fromperl(pTHX_ CV *cv)
5077 char fspec[NAM$C_MAXRSS+1], *fsp;
5082 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
5084 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5085 if (SvTYPE(mysv) == SVt_PVGV) {
5086 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
5087 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5094 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
5095 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5101 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
5106 rmscopy_fromperl(pTHX_ CV *cv)
5109 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
5111 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
5112 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5113 unsigned long int sts;
5118 if (items < 2 || items > 3)
5119 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
5121 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5122 if (SvTYPE(mysv) == SVt_PVGV) {
5123 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5124 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5131 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5132 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5137 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5138 if (SvTYPE(mysv) == SVt_PVGV) {
5139 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5140 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5147 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5148 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5153 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5155 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5162 char* file = __FILE__;
5164 char temp_buff[512];
5165 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5166 no_translate_barewords = TRUE;
5168 no_translate_barewords = FALSE;
5171 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5172 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5173 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5174 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5175 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5176 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5177 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5178 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5179 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);