3 * VMS-specific routines for perl5
5 * Last revised: 15-Aug-1999 by Charles Bailey bailey@newman.upenn.edu
15 #include <climsgdef.h>
24 #include <libclidef.h>
26 #include <lib$routines.h>
35 #include <str$routines.h>
40 /* Older versions of ssdef.h don't have these */
41 #ifndef SS$_INVFILFOROP
42 # define SS$_INVFILFOROP 3930
44 #ifndef SS$_NOSUCHOBJECT
45 # define SS$_NOSUCHOBJECT 2696
48 /* Don't replace system definitions of vfork, getenv, and stat,
49 * code below needs to get to the underlying CRTL routines. */
50 #define DONT_MASK_RTL_CALLS
54 /* Anticipating future expansion in lexical warnings . . . */
56 # define WARN_INTERNAL WARN_MISC
59 /* gcc's header files don't #define direct access macros
60 * corresponding to VAXC's variant structs */
62 # define uic$v_format uic$r_uic_form.uic$v_format
63 # define uic$v_group uic$r_uic_form.uic$v_group
64 # define uic$v_member uic$r_uic_form.uic$v_member
65 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
66 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
67 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
68 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
73 unsigned short int buflen;
74 unsigned short int itmcode;
76 unsigned short int *retlen;
79 static char *__mystrtolower(char *str)
81 if (str) for (; *str; ++str) *str= tolower(*str);
85 static struct dsc$descriptor_s fildevdsc =
86 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
87 static struct dsc$descriptor_s crtlenvdsc =
88 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
89 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
90 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
91 static struct dsc$descriptor_s **env_tables = defenv;
92 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
94 /* True if we shouldn't treat barewords as logicals during directory */
96 static int no_translate_barewords;
98 /* True if we shouldn't treat barewords as logicals during directory */
100 static int no_translate_barewords;
102 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
104 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
105 struct dsc$descriptor_s **tabvec, unsigned long int flags)
107 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
108 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
109 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
110 unsigned char acmode;
111 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
112 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
113 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
114 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
116 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
117 #if defined(USE_THREADS)
118 /* We jump through these hoops because we can be called at */
119 /* platform-specific initialization time, which is before anything is */
120 /* set up--we can't even do a plain dTHX since that relies on the */
121 /* interpreter structure to be initialized */
122 struct perl_thread *thr;
124 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
130 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
131 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
133 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
134 *cp2 = _toupper(*cp1);
135 if (cp1 - lnm > LNM$C_NAMLENGTH) {
136 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
140 lnmdsc.dsc$w_length = cp1 - lnm;
141 lnmdsc.dsc$a_pointer = uplnm;
142 secure = flags & PERL__TRNENV_SECURE;
143 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
144 if (!tabvec || !*tabvec) tabvec = env_tables;
146 for (curtab = 0; tabvec[curtab]; curtab++) {
147 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
148 if (!ivenv && !secure) {
153 Perl_warn(aTHX_ "Can't read CRTL environ\n");
156 retsts = SS$_NOLOGNAM;
157 for (i = 0; environ[i]; i++) {
158 if ((eq = strchr(environ[i],'=')) &&
159 !strncmp(environ[i],uplnm,eq - environ[i])) {
161 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
162 if (!eqvlen) continue;
167 if (retsts != SS$_NOLOGNAM) break;
170 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
171 !str$case_blind_compare(&tmpdsc,&clisym)) {
172 if (!ivsym && !secure) {
173 unsigned short int deflen = LNM$C_NAMLENGTH;
174 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
175 /* dynamic dsc to accomodate possible long value */
176 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
177 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
180 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
182 /* Special hack--we might be called before the interpreter's */
183 /* fully initialized, in which case either thr or PL_curcop */
184 /* might be bogus. We have to check, since ckWARN needs them */
185 /* both to be valid if running threaded */
186 #if defined(USE_THREADS)
187 if (thr && PL_curcop) {
189 if (ckWARN(WARN_MISC)) {
190 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
192 #if defined(USE_THREADS)
194 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
199 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
201 _ckvmssts(lib$sfree1_dd(&eqvdsc));
202 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
203 if (retsts == LIB$_NOSUCHSYM) continue;
208 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
209 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
210 if (retsts == SS$_NOLOGNAM) continue;
214 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
215 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
216 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
217 retsts == SS$_NOLOGNAM) {
218 set_errno(EINVAL); set_vaxc_errno(retsts);
220 else _ckvmssts(retsts);
222 } /* end of vmstrnenv */
225 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
226 /* Define as a function so we can access statics. */
227 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
229 return vmstrnenv(lnm,eqv,idx,fildev,
230 #ifdef SECURE_INTERNAL_GETENV
231 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
240 * Note: Uses Perl temp to store result so char * can be returned to
241 * caller; this pointer will be invalidated at next Perl statement
243 * We define this as a function rather than a macro in terms of my_getenv_len()
244 * so that it'll work when PL_curinterp is undefined (and we therefore can't
247 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
249 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
251 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
252 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
253 unsigned long int idx = 0;
257 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
258 /* Set up a temporary buffer for the return value; Perl will
259 * clean it up at the next statement transition */
260 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
261 if (!tmpsv) return NULL;
264 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
265 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
266 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
267 getcwd(eqv,LNM$C_NAMLENGTH);
271 if ((cp2 = strchr(lnm,';')) != NULL) {
273 uplnm[cp2-lnm] = '\0';
274 idx = strtoul(cp2+1,NULL,0);
277 if (vmstrnenv(lnm,eqv,idx,
279 #ifdef SECURE_INTERNAL_GETENV
280 sys ? PERL__TRNENV_SECURE : 0
288 } /* end of my_getenv() */
292 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
294 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
297 char *buf, *cp1, *cp2;
298 unsigned long idx = 0;
299 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
302 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
303 /* Set up a temporary buffer for the return value; Perl will
304 * clean it up at the next statement transition */
305 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
306 if (!tmpsv) return NULL;
309 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
310 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
311 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
312 getcwd(buf,LNM$C_NAMLENGTH);
317 if ((cp2 = strchr(lnm,';')) != NULL) {
320 idx = strtoul(cp2+1,NULL,0);
323 if ((*len = vmstrnenv(lnm,buf,idx,
325 #ifdef SECURE_INTERNAL_GETENV
326 sys ? PERL__TRNENV_SECURE : 0
336 } /* end of my_getenv_len() */
339 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
341 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
343 /*{{{ void prime_env_iter() */
346 /* Fill the %ENV associative array with all logical names we can
347 * find, in preparation for iterating over it.
351 static int primed = 0;
352 HV *seenhv = NULL, *envhv;
353 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
354 unsigned short int chan;
355 #ifndef CLI$M_TRUSTED
356 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
358 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
359 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
361 bool have_sym = FALSE, have_lnm = FALSE;
362 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
363 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
364 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
365 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
366 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
368 static perl_mutex primenv_mutex;
369 MUTEX_INIT(&primenv_mutex);
372 if (primed || !PL_envgv) return;
373 MUTEX_LOCK(&primenv_mutex);
374 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
375 envhv = GvHVn(PL_envgv);
376 /* Perform a dummy fetch as an lval to insure that the hash table is
377 * set up. Otherwise, the hv_store() will turn into a nullop. */
378 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
380 for (i = 0; env_tables[i]; i++) {
381 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
382 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
383 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
385 if (have_sym || have_lnm) {
386 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
387 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
388 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
389 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
392 for (i--; i >= 0; i--) {
393 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
396 for (j = 0; environ[j]; j++) {
397 if (!(start = strchr(environ[j],'='))) {
398 if (ckWARN(WARN_INTERNAL))
399 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
403 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
409 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
410 !str$case_blind_compare(&tmpdsc,&clisym)) {
411 strcpy(cmd,"Show Symbol/Global *");
412 cmddsc.dsc$w_length = 20;
413 if (env_tables[i]->dsc$w_length == 12 &&
414 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
415 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
416 flags = defflags | CLI$M_NOLOGNAM;
419 strcpy(cmd,"Show Logical *");
420 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
421 strcat(cmd," /Table=");
422 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
423 cmddsc.dsc$w_length = strlen(cmd);
425 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
426 flags = defflags | CLI$M_NOCLISYM;
429 /* Create a new subprocess to execute each command, to exclude the
430 * remote possibility that someone could subvert a mbx or file used
431 * to write multiple commands to a single subprocess.
434 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
435 0,&riseandshine,0,0,&clidsc,&clitabdsc);
436 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
437 defflags &= ~CLI$M_TRUSTED;
438 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
440 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
441 if (seenhv) SvREFCNT_dec(seenhv);
444 char *cp1, *cp2, *key;
445 unsigned long int sts, iosb[2], retlen, keylen;
448 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
449 if (sts & 1) sts = iosb[0] & 0xffff;
450 if (sts == SS$_ENDOFFILE) {
452 while (substs == 0) { sys$hiber(); wakect++;}
453 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
458 retlen = iosb[0] >> 16;
459 if (!retlen) continue; /* blank line */
461 if (iosb[1] != subpid) {
463 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
467 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
468 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
470 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
471 if (*cp1 == '(' || /* Logical name table name */
472 *cp1 == '=' /* Next eqv of searchlist */) continue;
473 if (*cp1 == '"') cp1++;
474 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
475 key = cp1; keylen = cp2 - cp1;
476 if (keylen && hv_exists(seenhv,key,keylen)) continue;
477 while (*cp2 && *cp2 != '=') cp2++;
478 while (*cp2 && *cp2 == '=') cp2++;
479 while (*cp2 && *cp2 == ' ') cp2++;
480 if (*cp2 == '"') { /* String translation; may embed "" */
481 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
482 cp2++; cp1--; /* Skip "" surrounding translation */
484 else { /* Numeric translation */
485 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
486 cp1--; /* stop on last non-space char */
488 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
489 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
492 PERL_HASH(hash,key,keylen);
493 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
494 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
496 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
497 /* get the PPFs for this process, not the subprocess */
498 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
499 char eqv[LNM$C_NAMLENGTH+1];
501 for (i = 0; ppfs[i]; i++) {
502 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
503 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
508 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
509 if (buf) Safefree(buf);
510 if (seenhv) SvREFCNT_dec(seenhv);
511 MUTEX_UNLOCK(&primenv_mutex);
514 } /* end of prime_env_iter */
518 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
519 /* Define or delete an element in the same "environment" as
520 * vmstrnenv(). If an element is to be deleted, it's removed from
521 * the first place it's found. If it's to be set, it's set in the
522 * place designated by the first element of the table vector.
523 * Like setenv() returns 0 for success, non-zero on error.
526 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
528 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
529 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
530 unsigned long int retsts, usermode = PSL$C_USER;
531 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
532 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
533 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
534 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
535 $DESCRIPTOR(local,"_LOCAL");
538 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
539 *cp2 = _toupper(*cp1);
540 if (cp1 - lnm > LNM$C_NAMLENGTH) {
541 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
545 lnmdsc.dsc$w_length = cp1 - lnm;
546 if (!tabvec || !*tabvec) tabvec = env_tables;
548 if (!eqv) { /* we're deleting n element */
549 for (curtab = 0; tabvec[curtab]; curtab++) {
550 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
552 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
553 if ((cp1 = strchr(environ[i],'=')) &&
554 !strncmp(environ[i],lnm,cp1 - environ[i])) {
556 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
559 ivenv = 1; retsts = SS$_NOLOGNAM;
561 if (ckWARN(WARN_INTERNAL))
562 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
563 ivenv = 1; retsts = SS$_NOSUCHPGM;
569 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
570 !str$case_blind_compare(&tmpdsc,&clisym)) {
571 unsigned int symtype;
572 if (tabvec[curtab]->dsc$w_length == 12 &&
573 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
574 !str$case_blind_compare(&tmpdsc,&local))
575 symtype = LIB$K_CLI_LOCAL_SYM;
576 else symtype = LIB$K_CLI_GLOBAL_SYM;
577 retsts = lib$delete_symbol(&lnmdsc,&symtype);
578 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
579 if (retsts == LIB$_NOSUCHSYM) continue;
583 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
584 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
585 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
586 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
587 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
591 else { /* we're defining a value */
592 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
594 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
596 if (ckWARN(WARN_INTERNAL))
597 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
598 retsts = SS$_NOSUCHPGM;
602 eqvdsc.dsc$a_pointer = eqv;
603 eqvdsc.dsc$w_length = strlen(eqv);
604 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
605 !str$case_blind_compare(&tmpdsc,&clisym)) {
606 unsigned int symtype;
607 if (tabvec[0]->dsc$w_length == 12 &&
608 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
609 !str$case_blind_compare(&tmpdsc,&local))
610 symtype = LIB$K_CLI_LOCAL_SYM;
611 else symtype = LIB$K_CLI_GLOBAL_SYM;
612 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
615 if (!*eqv) eqvdsc.dsc$w_length = 1;
616 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
622 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
623 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
624 set_errno(EVMSERR); break;
625 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
626 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
627 set_errno(EINVAL); break;
634 set_vaxc_errno(retsts);
635 return (int) retsts || 44; /* retsts should never be 0, but just in case */
638 /* We reset error values on success because Perl does an hv_fetch()
639 * before each hv_store(), and if the thing we're setting didn't
640 * previously exist, we've got a leftover error message. (Of course,
641 * this fails in the face of
642 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
643 * in that the error reported in $! isn't spurious,
644 * but it's right more often than not.)
646 set_errno(0); set_vaxc_errno(retsts);
650 } /* end of vmssetenv() */
653 /*{{{ void my_setenv(char *lnm, char *eqv)*/
654 /* This has to be a function since there's a prototype for it in proto.h */
656 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
658 if (lnm && *lnm && strlen(lnm) == 7) {
661 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
662 if (!strcmp(uplnm,"DEFAULT")) {
663 if (eqv && *eqv) chdir(eqv);
667 (void) vmssetenv(lnm,eqv,NULL);
673 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
674 /* my_crypt - VMS password hashing
675 * my_crypt() provides an interface compatible with the Unix crypt()
676 * C library function, and uses sys$hash_password() to perform VMS
677 * password hashing. The quadword hashed password value is returned
678 * as a NUL-terminated 8 character string. my_crypt() does not change
679 * the case of its string arguments; in order to match the behavior
680 * of LOGINOUT et al., alphabetic characters in both arguments must
681 * be upcased by the caller.
684 my_crypt(const char *textpasswd, const char *usrname)
686 # ifndef UAI$C_PREFERRED_ALGORITHM
687 # define UAI$C_PREFERRED_ALGORITHM 127
689 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
690 unsigned short int salt = 0;
691 unsigned long int sts;
693 unsigned short int dsc$w_length;
694 unsigned char dsc$b_type;
695 unsigned char dsc$b_class;
696 const char * dsc$a_pointer;
697 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
698 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
699 struct itmlst_3 uailst[3] = {
700 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
701 { sizeof salt, UAI$_SALT, &salt, 0},
702 { 0, 0, NULL, NULL}};
705 usrdsc.dsc$w_length = strlen(usrname);
706 usrdsc.dsc$a_pointer = usrname;
707 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
714 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
720 if (sts != RMS$_RNF) return NULL;
723 txtdsc.dsc$w_length = strlen(textpasswd);
724 txtdsc.dsc$a_pointer = textpasswd;
725 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
726 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
729 return (char *) hash;
731 } /* end of my_crypt() */
735 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
736 static char *do_fileify_dirspec(char *, char *, int);
737 static char *do_tovmsspec(char *, char *, int);
739 /*{{{int do_rmdir(char *name)*/
743 char dirfile[NAM$C_MAXRSS+1];
747 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
748 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
749 else retval = kill_file(dirfile);
752 } /* end of do_rmdir */
756 * Delete any file to which user has control access, regardless of whether
757 * delete access is explicitly allowed.
758 * Limitations: User must have write access to parent directory.
759 * Does not block signals or ASTs; if interrupted in midstream
760 * may leave file with an altered ACL.
763 /*{{{int kill_file(char *name)*/
765 kill_file(char *name)
767 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
768 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
769 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
771 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
773 unsigned char myace$b_length;
774 unsigned char myace$b_type;
775 unsigned short int myace$w_flags;
776 unsigned long int myace$l_access;
777 unsigned long int myace$l_ident;
778 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
779 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
780 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
782 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
783 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
784 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
785 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
786 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
787 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
789 /* Expand the input spec using RMS, since the CRTL remove() and
790 * system services won't do this by themselves, so we may miss
791 * a file "hiding" behind a logical name or search list. */
792 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
793 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
794 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
795 /* If not, can changing protections help? */
796 if (vaxc$errno != RMS$_PRV) return -1;
798 /* No, so we get our own UIC to use as a rights identifier,
799 * and the insert an ACE at the head of the ACL which allows us
800 * to delete the file.
802 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
803 fildsc.dsc$w_length = strlen(rspec);
804 fildsc.dsc$a_pointer = rspec;
806 newace.myace$l_ident = oldace.myace$l_ident;
807 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
812 case SS$_NOSUCHOBJECT:
813 set_errno(ENOENT); break;
815 set_errno(ENODEV); break;
817 case SS$_INVFILFOROP:
818 set_errno(EINVAL); break;
820 set_errno(EACCES); break;
824 set_vaxc_errno(aclsts);
827 /* Grab any existing ACEs with this identifier in case we fail */
828 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
829 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
830 || fndsts == SS$_NOMOREACE ) {
831 /* Add the new ACE . . . */
832 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
834 if ((rmsts = remove(name))) {
835 /* We blew it - dir with files in it, no write priv for
836 * parent directory, etc. Put things back the way they were. */
837 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
840 addlst[0].bufadr = &oldace;
841 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
848 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
849 /* We just deleted it, so of course it's not there. Some versions of
850 * VMS seem to return success on the unlock operation anyhow (after all
851 * the unlock is successful), but others don't.
853 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
854 if (aclsts & 1) aclsts = fndsts;
857 set_vaxc_errno(aclsts);
863 } /* end of kill_file() */
867 /*{{{int my_mkdir(char *,Mode_t)*/
869 my_mkdir(char *dir, Mode_t mode)
871 STRLEN dirlen = strlen(dir);
874 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
875 * null file name/type. However, it's commonplace under Unix,
876 * so we'll allow it for a gain in portability.
878 if (dir[dirlen-1] == '/') {
879 char *newdir = savepvn(dir,dirlen-1);
880 int ret = mkdir(newdir,mode);
884 else return mkdir(dir,mode);
885 } /* end of my_mkdir */
890 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
892 static unsigned long int mbxbufsiz;
893 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
898 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
899 * preprocessor consant BUFSIZ from stdio.h as the size of the
902 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
903 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
905 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
907 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
908 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
910 } /* end of create_mbx() */
912 /*{{{ my_popen and my_pclose*/
915 struct pipe_details *next;
916 PerlIO *fp; /* stdio file pointer to pipe mailbox */
917 int pid; /* PID of subprocess */
918 int mode; /* == 'r' if pipe open for reading */
919 int done; /* subprocess has completed */
920 unsigned long int completion; /* termination status of subprocess */
923 struct exit_control_block
925 struct exit_control_block *flink;
926 unsigned long int (*exit_routine)();
927 unsigned long int arg_count;
928 unsigned long int *status_address;
929 unsigned long int exit_status;
932 static struct pipe_details *open_pipes = NULL;
933 static $DESCRIPTOR(nl_desc, "NL:");
934 static int waitpid_asleep = 0;
936 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
937 * to a mbx; that's the caller's responsibility.
939 static unsigned long int
940 pipe_eof(FILE *fp, int immediate)
942 char devnam[NAM$C_MAXRSS+1], *cp;
943 unsigned long int chan, iosb[2], retsts, retsts2;
944 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
947 if (fgetname(fp,devnam,1)) {
948 /* It oughta be a mailbox, so fgetname should give just the device
949 * name, but just in case . . . */
950 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
951 devdsc.dsc$w_length = strlen(devnam);
952 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
953 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
954 iosb,0,0,0,0,0,0,0,0);
955 if (retsts & 1) retsts = iosb[0];
956 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
957 if (retsts & 1) retsts = retsts2;
961 else _ckvmssts(vaxc$errno); /* Should never happen */
962 return (unsigned long int) vaxc$errno;
965 static unsigned long int
968 struct pipe_details *info;
969 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
974 first we try sending an EOF...ignore if doesn't work, make sure we
981 if (info->mode != 'r' && !info->done) {
982 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
986 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
991 if (!info->done) { /* Tap them gently on the shoulder . . .*/
992 sts = sys$forcex(&info->pid,0,&abort);
993 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
998 if (did_stuff) sleep(1); /* wait for them to respond */
1002 if (!info->done) { /* We tried to be nice . . . */
1003 sts = sys$delprc(&info->pid,0);
1004 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1005 info->done = 1; /* so my_pclose doesn't try to write EOF */
1011 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1012 else if (!(sts & 1)) retsts = sts;
1017 static struct exit_control_block pipe_exitblock =
1018 {(struct exit_control_block *) 0,
1019 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1023 popen_completion_ast(struct pipe_details *thispipe)
1025 thispipe->done = TRUE;
1026 if (waitpid_asleep) {
1033 safe_popen(char *cmd, char *mode)
1035 static int handler_set_up = FALSE;
1037 unsigned short int chan;
1038 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
1040 struct pipe_details *info;
1041 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1042 DSC$K_CLASS_S, mbxname},
1043 cmddsc = {0, DSC$K_DTYPE_T,
1047 cmddsc.dsc$w_length=strlen(cmd);
1048 cmddsc.dsc$a_pointer=cmd;
1049 if (cmddsc.dsc$w_length > 255) {
1050 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
1054 New(1301,info,1,struct pipe_details);
1056 /* create mailbox */
1057 create_mbx(&chan,&namdsc);
1059 /* open a FILE* onto it */
1060 info->fp = PerlIO_open(mbxname, mode);
1062 /* give up other channel onto it */
1063 _ckvmssts(sys$dassgn(chan));
1073 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1074 0 /* name */, &info->pid, &info->completion,
1075 0, popen_completion_ast,info,0,0,0));
1078 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1079 0 /* name */, &info->pid, &info->completion,
1080 0, popen_completion_ast,info,0,0,0));
1083 if (!handler_set_up) {
1084 _ckvmssts(sys$dclexh(&pipe_exitblock));
1085 handler_set_up = TRUE;
1087 info->next=open_pipes; /* prepend to list */
1090 PL_forkprocess = info->pid;
1092 } /* end of safe_popen */
1095 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1097 Perl_my_popen(pTHX_ char *cmd, char *mode)
1100 TAINT_PROPER("popen");
1101 PERL_FLUSHALL_FOR_CHILD;
1102 return safe_popen(cmd,mode);
1107 /*{{{ I32 my_pclose(FILE *fp)*/
1108 I32 Perl_my_pclose(pTHX_ FILE *fp)
1110 struct pipe_details *info, *last = NULL;
1111 unsigned long int retsts;
1113 for (info = open_pipes; info != NULL; last = info, info = info->next)
1114 if (info->fp == fp) break;
1116 if (info == NULL) { /* no such pipe open */
1117 set_errno(ECHILD); /* quoth POSIX */
1118 set_vaxc_errno(SS$_NONEXPR);
1122 /* If we were writing to a subprocess, insure that someone reading from
1123 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1124 * produce an EOF record in the mailbox. */
1125 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
1126 PerlIO_close(info->fp);
1128 if (info->done) retsts = info->completion;
1129 else waitpid(info->pid,(int *) &retsts,0);
1131 /* remove from list of open pipes */
1132 if (last) last->next = info->next;
1133 else open_pipes = info->next;
1138 } /* end of my_pclose() */
1140 /* sort-of waitpid; use only with popen() */
1141 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1143 my_waitpid(Pid_t pid, int *statusp, int flags)
1145 struct pipe_details *info;
1148 for (info = open_pipes; info != NULL; info = info->next)
1149 if (info->pid == pid) break;
1151 if (info != NULL) { /* we know about this child */
1152 while (!info->done) {
1157 *statusp = info->completion;
1160 else { /* we haven't heard of this child */
1161 $DESCRIPTOR(intdsc,"0 00:00:01");
1162 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1163 unsigned long int interval[2],sts;
1165 if (ckWARN(WARN_EXEC)) {
1166 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1167 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1168 if (ownerpid != mypid)
1169 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1172 _ckvmssts(sys$bintim(&intdsc,interval));
1173 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1174 _ckvmssts(sys$schdwk(0,0,interval,0));
1175 _ckvmssts(sys$hiber());
1179 /* There's no easy way to find the termination status a child we're
1180 * not aware of beforehand. If we're really interested in the future,
1181 * we can go looking for a termination mailbox, or chase after the
1182 * accounting record for the process.
1188 } /* end of waitpid() */
1193 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1195 my_gconvert(double val, int ndig, int trail, char *buf)
1197 static char __gcvtbuf[DBL_DIG+1];
1200 loc = buf ? buf : __gcvtbuf;
1202 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1204 sprintf(loc,"%.*g",ndig,val);
1210 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1211 return gcvt(val,ndig,loc);
1214 loc[0] = '0'; loc[1] = '\0';
1222 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1223 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1224 * to expand file specification. Allows for a single default file
1225 * specification and a simple mask of options. If outbuf is non-NULL,
1226 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1227 * the resultant file specification is placed. If outbuf is NULL, the
1228 * resultant file specification is placed into a static buffer.
1229 * The third argument, if non-NULL, is taken to be a default file
1230 * specification string. The fourth argument is unused at present.
1231 * rmesexpand() returns the address of the resultant string if
1232 * successful, and NULL on error.
1234 static char *do_tounixspec(char *, char *, int);
1237 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1239 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1240 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1241 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1242 struct FAB myfab = cc$rms_fab;
1243 struct NAM mynam = cc$rms_nam;
1245 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1247 if (!filespec || !*filespec) {
1248 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1252 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1253 else outbuf = __rmsexpand_retbuf;
1255 if ((isunix = (strchr(filespec,'/') != NULL))) {
1256 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1257 filespec = vmsfspec;
1260 myfab.fab$l_fna = filespec;
1261 myfab.fab$b_fns = strlen(filespec);
1262 myfab.fab$l_nam = &mynam;
1264 if (defspec && *defspec) {
1265 if (strchr(defspec,'/') != NULL) {
1266 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1269 myfab.fab$l_dna = defspec;
1270 myfab.fab$b_dns = strlen(defspec);
1273 mynam.nam$l_esa = esa;
1274 mynam.nam$b_ess = sizeof esa;
1275 mynam.nam$l_rsa = outbuf;
1276 mynam.nam$b_rss = NAM$C_MAXRSS;
1278 retsts = sys$parse(&myfab,0,0);
1279 if (!(retsts & 1)) {
1280 mynam.nam$b_nop |= NAM$M_SYNCHK;
1281 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1282 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1283 retsts = sys$parse(&myfab,0,0);
1284 if (retsts & 1) goto expanded;
1286 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1287 (void) sys$parse(&myfab,0,0); /* Free search context */
1288 if (out) Safefree(out);
1289 set_vaxc_errno(retsts);
1290 if (retsts == RMS$_PRV) set_errno(EACCES);
1291 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1292 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1293 else set_errno(EVMSERR);
1296 retsts = sys$search(&myfab,0,0);
1297 if (!(retsts & 1) && retsts != RMS$_FNF) {
1298 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1299 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1300 if (out) Safefree(out);
1301 set_vaxc_errno(retsts);
1302 if (retsts == RMS$_PRV) set_errno(EACCES);
1303 else set_errno(EVMSERR);
1307 /* If the input filespec contained any lowercase characters,
1308 * downcase the result for compatibility with Unix-minded code. */
1310 for (out = myfab.fab$l_fna; *out; out++)
1311 if (islower(*out)) { haslower = 1; break; }
1312 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1313 else { out = esa; speclen = mynam.nam$b_esl; }
1314 /* Trim off null fields added by $PARSE
1315 * If type > 1 char, must have been specified in original or default spec
1316 * (not true for version; $SEARCH may have added version of existing file).
1318 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1319 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1320 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1321 if (trimver || trimtype) {
1322 if (defspec && *defspec) {
1323 char defesa[NAM$C_MAXRSS];
1324 struct FAB deffab = cc$rms_fab;
1325 struct NAM defnam = cc$rms_nam;
1327 deffab.fab$l_nam = &defnam;
1328 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1329 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1330 defnam.nam$b_nop = NAM$M_SYNCHK;
1331 if (sys$parse(&deffab,0,0) & 1) {
1332 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1333 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1336 if (trimver) speclen = mynam.nam$l_ver - out;
1338 /* If we didn't already trim version, copy down */
1339 if (speclen > mynam.nam$l_ver - out)
1340 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1341 speclen - (mynam.nam$l_ver - out));
1342 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1345 /* If we just had a directory spec on input, $PARSE "helpfully"
1346 * adds an empty name and type for us */
1347 if (mynam.nam$l_name == mynam.nam$l_type &&
1348 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1349 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1350 speclen = mynam.nam$l_name - out;
1351 out[speclen] = '\0';
1352 if (haslower) __mystrtolower(out);
1354 /* Have we been working with an expanded, but not resultant, spec? */
1355 /* Also, convert back to Unix syntax if necessary. */
1356 if (!mynam.nam$b_rsl) {
1358 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1360 else strcpy(outbuf,esa);
1363 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1364 strcpy(outbuf,tmpfspec);
1366 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1367 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1368 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1372 /* External entry points */
1373 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1374 { return do_rmsexpand(spec,buf,0,def,opt); }
1375 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1376 { return do_rmsexpand(spec,buf,1,def,opt); }
1380 ** The following routines are provided to make life easier when
1381 ** converting among VMS-style and Unix-style directory specifications.
1382 ** All will take input specifications in either VMS or Unix syntax. On
1383 ** failure, all return NULL. If successful, the routines listed below
1384 ** return a pointer to a buffer containing the appropriately
1385 ** reformatted spec (and, therefore, subsequent calls to that routine
1386 ** will clobber the result), while the routines of the same names with
1387 ** a _ts suffix appended will return a pointer to a mallocd string
1388 ** containing the appropriately reformatted spec.
1389 ** In all cases, only explicit syntax is altered; no check is made that
1390 ** the resulting string is valid or that the directory in question
1393 ** fileify_dirspec() - convert a directory spec into the name of the
1394 ** directory file (i.e. what you can stat() to see if it's a dir).
1395 ** The style (VMS or Unix) of the result is the same as the style
1396 ** of the parameter passed in.
1397 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1398 ** what you prepend to a filename to indicate what directory it's in).
1399 ** The style (VMS or Unix) of the result is the same as the style
1400 ** of the parameter passed in.
1401 ** tounixpath() - convert a directory spec into a Unix-style path.
1402 ** tovmspath() - convert a directory spec into a VMS-style path.
1403 ** tounixspec() - convert any file spec into a Unix-style file spec.
1404 ** tovmsspec() - convert any file spec into a VMS-style spec.
1406 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1407 ** Permission is given to distribute this code as part of the Perl
1408 ** standard distribution under the terms of the GNU General Public
1409 ** License or the Perl Artistic License. Copies of each may be
1410 ** found in the Perl standard distribution.
1413 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1414 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1416 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1417 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1418 char *retspec, *cp1, *cp2, *lastdir;
1419 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1421 if (!dir || !*dir) {
1422 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1424 dirlen = strlen(dir);
1425 while (dir[dirlen-1] == '/') --dirlen;
1426 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1427 strcpy(trndir,"/sys$disk/000000");
1431 if (dirlen > NAM$C_MAXRSS) {
1432 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1434 if (!strpbrk(dir+1,"/]>:")) {
1435 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1436 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1438 dirlen = strlen(dir);
1441 strncpy(trndir,dir,dirlen);
1442 trndir[dirlen] = '\0';
1445 /* If we were handed a rooted logical name or spec, treat it like a
1446 * simple directory, so that
1447 * $ Define myroot dev:[dir.]
1448 * ... do_fileify_dirspec("myroot",buf,1) ...
1449 * does something useful.
1451 if (!strcmp(dir+dirlen-2,".]")) {
1452 dir[--dirlen] = '\0';
1453 dir[dirlen-1] = ']';
1456 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1457 /* If we've got an explicit filename, we can just shuffle the string. */
1458 if (*(cp1+1)) hasfilename = 1;
1459 /* Similarly, we can just back up a level if we've got multiple levels
1460 of explicit directories in a VMS spec which ends with directories. */
1462 for (cp2 = cp1; cp2 > dir; cp2--) {
1464 *cp2 = *cp1; *cp1 = '\0';
1468 if (*cp2 == '[' || *cp2 == '<') break;
1473 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1474 if (dir[0] == '.') {
1475 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1476 return do_fileify_dirspec("[]",buf,ts);
1477 else if (dir[1] == '.' &&
1478 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1479 return do_fileify_dirspec("[-]",buf,ts);
1481 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1482 dirlen -= 1; /* to last element */
1483 lastdir = strrchr(dir,'/');
1485 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1486 /* If we have "/." or "/..", VMSify it and let the VMS code
1487 * below expand it, rather than repeating the code to handle
1488 * relative components of a filespec here */
1490 if (*(cp1+2) == '.') cp1++;
1491 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1492 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1493 if (strchr(vmsdir,'/') != NULL) {
1494 /* If do_tovmsspec() returned it, it must have VMS syntax
1495 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1496 * the time to check this here only so we avoid a recursion
1497 * loop; otherwise, gigo.
1499 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1501 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1502 return do_tounixspec(trndir,buf,ts);
1505 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1506 lastdir = strrchr(dir,'/');
1508 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1509 /* Ditto for specs that end in an MFD -- let the VMS code
1510 * figure out whether it's a real device or a rooted logical. */
1511 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1512 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1513 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1514 return do_tounixspec(trndir,buf,ts);
1517 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1518 !(lastdir = cp1 = strrchr(dir,']')) &&
1519 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1520 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1522 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1523 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1524 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1525 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1526 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1527 (ver || *cp3)))))) {
1529 set_vaxc_errno(RMS$_DIR);
1535 /* If we lead off with a device or rooted logical, add the MFD
1536 if we're specifying a top-level directory. */
1537 if (lastdir && *dir == '/') {
1539 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1546 retlen = dirlen + (addmfd ? 13 : 6);
1547 if (buf) retspec = buf;
1548 else if (ts) New(1309,retspec,retlen+1,char);
1549 else retspec = __fileify_retbuf;
1551 dirlen = lastdir - dir;
1552 memcpy(retspec,dir,dirlen);
1553 strcpy(&retspec[dirlen],"/000000");
1554 strcpy(&retspec[dirlen+7],lastdir);
1557 memcpy(retspec,dir,dirlen);
1558 retspec[dirlen] = '\0';
1560 /* We've picked up everything up to the directory file name.
1561 Now just add the type and version, and we're set. */
1562 strcat(retspec,".dir;1");
1565 else { /* VMS-style directory spec */
1566 char esa[NAM$C_MAXRSS+1], term, *cp;
1567 unsigned long int sts, cmplen, haslower = 0;
1568 struct FAB dirfab = cc$rms_fab;
1569 struct NAM savnam, dirnam = cc$rms_nam;
1571 dirfab.fab$b_fns = strlen(dir);
1572 dirfab.fab$l_fna = dir;
1573 dirfab.fab$l_nam = &dirnam;
1574 dirfab.fab$l_dna = ".DIR;1";
1575 dirfab.fab$b_dns = 6;
1576 dirnam.nam$b_ess = NAM$C_MAXRSS;
1577 dirnam.nam$l_esa = esa;
1579 for (cp = dir; *cp; cp++)
1580 if (islower(*cp)) { haslower = 1; break; }
1581 if (!((sts = sys$parse(&dirfab))&1)) {
1582 if (dirfab.fab$l_sts == RMS$_DIR) {
1583 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1584 sts = sys$parse(&dirfab) & 1;
1588 set_vaxc_errno(dirfab.fab$l_sts);
1594 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1595 /* Yes; fake the fnb bits so we'll check type below */
1596 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1599 if (dirfab.fab$l_sts != RMS$_FNF) {
1601 set_vaxc_errno(dirfab.fab$l_sts);
1604 dirnam = savnam; /* No; just work with potential name */
1607 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1608 cp1 = strchr(esa,']');
1609 if (!cp1) cp1 = strchr(esa,'>');
1610 if (cp1) { /* Should always be true */
1611 dirnam.nam$b_esl -= cp1 - esa - 1;
1612 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1615 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1616 /* Yep; check version while we're at it, if it's there. */
1617 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1618 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1619 /* Something other than .DIR[;1]. Bzzt. */
1621 set_vaxc_errno(RMS$_DIR);
1625 esa[dirnam.nam$b_esl] = '\0';
1626 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1627 /* They provided at least the name; we added the type, if necessary, */
1628 if (buf) retspec = buf; /* in sys$parse() */
1629 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1630 else retspec = __fileify_retbuf;
1631 strcpy(retspec,esa);
1634 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1635 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1637 dirnam.nam$b_esl -= 9;
1639 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1640 if (cp1 == NULL) return NULL; /* should never happen */
1643 retlen = strlen(esa);
1644 if ((cp1 = strrchr(esa,'.')) != NULL) {
1645 /* There's more than one directory in the path. Just roll back. */
1647 if (buf) retspec = buf;
1648 else if (ts) New(1311,retspec,retlen+7,char);
1649 else retspec = __fileify_retbuf;
1650 strcpy(retspec,esa);
1653 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1654 /* Go back and expand rooted logical name */
1655 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1656 if (!(sys$parse(&dirfab) & 1)) {
1658 set_vaxc_errno(dirfab.fab$l_sts);
1661 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1662 if (buf) retspec = buf;
1663 else if (ts) New(1312,retspec,retlen+16,char);
1664 else retspec = __fileify_retbuf;
1665 cp1 = strstr(esa,"][");
1667 memcpy(retspec,esa,dirlen);
1668 if (!strncmp(cp1+2,"000000]",7)) {
1669 retspec[dirlen-1] = '\0';
1670 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1671 if (*cp1 == '.') *cp1 = ']';
1673 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1674 memcpy(cp1+1,"000000]",7);
1678 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1679 retspec[retlen] = '\0';
1680 /* Convert last '.' to ']' */
1681 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1682 if (*cp1 == '.') *cp1 = ']';
1684 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1685 memcpy(cp1+1,"000000]",7);
1689 else { /* This is a top-level dir. Add the MFD to the path. */
1690 if (buf) retspec = buf;
1691 else if (ts) New(1312,retspec,retlen+16,char);
1692 else retspec = __fileify_retbuf;
1695 while (*cp1 != ':') *(cp2++) = *(cp1++);
1696 strcpy(cp2,":[000000]");
1701 /* We've set up the string up through the filename. Add the
1702 type and version, and we're done. */
1703 strcat(retspec,".DIR;1");
1705 /* $PARSE may have upcased filespec, so convert output to lower
1706 * case if input contained any lowercase characters. */
1707 if (haslower) __mystrtolower(retspec);
1710 } /* end of do_fileify_dirspec() */
1712 /* External entry points */
1713 char *fileify_dirspec(char *dir, char *buf)
1714 { return do_fileify_dirspec(dir,buf,0); }
1715 char *fileify_dirspec_ts(char *dir, char *buf)
1716 { return do_fileify_dirspec(dir,buf,1); }
1718 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1719 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1721 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1722 unsigned long int retlen;
1723 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1725 if (!dir || !*dir) {
1726 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1729 if (*dir) strcpy(trndir,dir);
1730 else getcwd(trndir,sizeof trndir - 1);
1732 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
1733 && my_trnlnm(trndir,trndir,0)) {
1734 STRLEN trnlen = strlen(trndir);
1736 /* Trap simple rooted lnms, and return lnm:[000000] */
1737 if (!strcmp(trndir+trnlen-2,".]")) {
1738 if (buf) retpath = buf;
1739 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1740 else retpath = __pathify_retbuf;
1741 strcpy(retpath,dir);
1742 strcat(retpath,":[000000]");
1748 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1749 if (*dir == '.' && (*(dir+1) == '\0' ||
1750 (*(dir+1) == '.' && *(dir+2) == '\0')))
1751 retlen = 2 + (*(dir+1) != '\0');
1753 if ( !(cp1 = strrchr(dir,'/')) &&
1754 !(cp1 = strrchr(dir,']')) &&
1755 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1756 if ((cp2 = strchr(cp1,'.')) != NULL &&
1757 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1758 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1759 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1760 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1762 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1763 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1764 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1765 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1766 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1767 (ver || *cp3)))))) {
1769 set_vaxc_errno(RMS$_DIR);
1772 retlen = cp2 - dir + 1;
1774 else { /* No file type present. Treat the filename as a directory. */
1775 retlen = strlen(dir) + 1;
1778 if (buf) retpath = buf;
1779 else if (ts) New(1313,retpath,retlen+1,char);
1780 else retpath = __pathify_retbuf;
1781 strncpy(retpath,dir,retlen-1);
1782 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1783 retpath[retlen-1] = '/'; /* with '/', add it. */
1784 retpath[retlen] = '\0';
1786 else retpath[retlen-1] = '\0';
1788 else { /* VMS-style directory spec */
1789 char esa[NAM$C_MAXRSS+1], *cp;
1790 unsigned long int sts, cmplen, haslower;
1791 struct FAB dirfab = cc$rms_fab;
1792 struct NAM savnam, dirnam = cc$rms_nam;
1794 /* If we've got an explicit filename, we can just shuffle the string. */
1795 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1796 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1797 if ((cp2 = strchr(cp1,'.')) != NULL) {
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);
1810 else { /* No file type, so just draw name into directory part */
1811 for (cp2 = cp1; *cp2; cp2++) ;
1814 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1816 /* We've now got a VMS 'path'; fall through */
1818 dirfab.fab$b_fns = strlen(dir);
1819 dirfab.fab$l_fna = dir;
1820 if (dir[dirfab.fab$b_fns-1] == ']' ||
1821 dir[dirfab.fab$b_fns-1] == '>' ||
1822 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1823 if (buf) retpath = buf;
1824 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1825 else retpath = __pathify_retbuf;
1826 strcpy(retpath,dir);
1829 dirfab.fab$l_dna = ".DIR;1";
1830 dirfab.fab$b_dns = 6;
1831 dirfab.fab$l_nam = &dirnam;
1832 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1833 dirnam.nam$l_esa = esa;
1835 for (cp = dir; *cp; cp++)
1836 if (islower(*cp)) { haslower = 1; break; }
1838 if (!(sts = (sys$parse(&dirfab)&1))) {
1839 if (dirfab.fab$l_sts == RMS$_DIR) {
1840 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1841 sts = sys$parse(&dirfab) & 1;
1845 set_vaxc_errno(dirfab.fab$l_sts);
1851 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1852 if (dirfab.fab$l_sts != RMS$_FNF) {
1854 set_vaxc_errno(dirfab.fab$l_sts);
1857 dirnam = savnam; /* No; just work with potential name */
1860 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1861 /* Yep; check version while we're at it, if it's there. */
1862 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1863 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1864 /* Something other than .DIR[;1]. Bzzt. */
1866 set_vaxc_errno(RMS$_DIR);
1870 /* OK, the type was fine. Now pull any file name into the
1872 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1874 cp1 = strrchr(esa,'>');
1875 *dirnam.nam$l_type = '>';
1878 *(dirnam.nam$l_type + 1) = '\0';
1879 retlen = dirnam.nam$l_type - esa + 2;
1880 if (buf) retpath = buf;
1881 else if (ts) New(1314,retpath,retlen,char);
1882 else retpath = __pathify_retbuf;
1883 strcpy(retpath,esa);
1884 /* $PARSE may have upcased filespec, so convert output to lower
1885 * case if input contained any lowercase characters. */
1886 if (haslower) __mystrtolower(retpath);
1890 } /* end of do_pathify_dirspec() */
1892 /* External entry points */
1893 char *pathify_dirspec(char *dir, char *buf)
1894 { return do_pathify_dirspec(dir,buf,0); }
1895 char *pathify_dirspec_ts(char *dir, char *buf)
1896 { return do_pathify_dirspec(dir,buf,1); }
1898 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1899 static char *do_tounixspec(char *spec, char *buf, int ts)
1901 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1902 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1903 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1905 if (spec == NULL) return NULL;
1906 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1907 if (buf) rslt = buf;
1909 retlen = strlen(spec);
1910 cp1 = strchr(spec,'[');
1911 if (!cp1) cp1 = strchr(spec,'<');
1913 for (cp1++; *cp1; cp1++) {
1914 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1915 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1916 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1919 New(1315,rslt,retlen+2+2*expand,char);
1921 else rslt = __tounixspec_retbuf;
1922 if (strchr(spec,'/') != NULL) {
1929 dirend = strrchr(spec,']');
1930 if (dirend == NULL) dirend = strrchr(spec,'>');
1931 if (dirend == NULL) dirend = strchr(spec,':');
1932 if (dirend == NULL) {
1936 if (*cp2 != '[' && *cp2 != '<') {
1939 else { /* the VMS spec begins with directories */
1941 if (*cp2 == ']' || *cp2 == '>') {
1942 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1945 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1946 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1947 if (ts) Safefree(rslt);
1952 while (*cp3 != ':' && *cp3) cp3++;
1954 if (strchr(cp3,']') != NULL) break;
1955 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1957 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1958 retlen = devlen + dirlen;
1959 Renew(rslt,retlen+1+2*expand,char);
1965 *(cp1++) = *(cp3++);
1966 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1970 else if ( *cp2 == '.') {
1971 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1972 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1978 for (; cp2 <= dirend; cp2++) {
1981 if (*(cp2+1) == '[') cp2++;
1983 else if (*cp2 == ']' || *cp2 == '>') {
1984 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1986 else if (*cp2 == '.') {
1988 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1989 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1990 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1991 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1992 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1994 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1995 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1999 else if (*cp2 == '-') {
2000 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
2001 while (*cp2 == '-') {
2003 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
2005 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
2006 if (ts) Safefree(rslt); /* filespecs like */
2007 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2011 else *(cp1++) = *cp2;
2013 else *(cp1++) = *cp2;
2015 while (*cp2) *(cp1++) = *(cp2++);
2020 } /* end of do_tounixspec() */
2022 /* External entry points */
2023 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2024 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2026 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2027 static char *do_tovmsspec(char *path, char *buf, int ts) {
2028 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2029 char *rslt, *dirend;
2030 register char *cp1, *cp2;
2031 unsigned long int infront = 0, hasdir = 1;
2033 if (path == NULL) return NULL;
2034 if (buf) rslt = buf;
2035 else if (ts) New(1316,rslt,strlen(path)+9,char);
2036 else rslt = __tovmsspec_retbuf;
2037 if (strpbrk(path,"]:>") ||
2038 (dirend = strrchr(path,'/')) == NULL) {
2039 if (path[0] == '.') {
2040 if (path[1] == '\0') strcpy(rslt,"[]");
2041 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2042 else strcpy(rslt,path); /* probably garbage */
2044 else strcpy(rslt,path);
2047 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2048 if (!*(dirend+2)) dirend +=2;
2049 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2050 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2055 char trndev[NAM$C_MAXRSS+1];
2059 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2061 if (!buf & ts) Renew(rslt,18,char);
2062 strcpy(rslt,"sys$disk:[000000]");
2065 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2067 islnm = my_trnlnm(rslt,trndev,0);
2068 trnend = islnm ? strlen(trndev) - 1 : 0;
2069 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2070 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2071 /* If the first element of the path is a logical name, determine
2072 * whether it has to be translated so we can add more directories. */
2073 if (!islnm || rooted) {
2076 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2080 if (cp2 != dirend) {
2081 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2082 strcpy(rslt,trndev);
2083 cp1 = rslt + trnend;
2096 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2097 cp2 += 2; /* skip over "./" - it's redundant */
2098 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2100 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2101 *(cp1++) = '-'; /* "../" --> "-" */
2104 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2105 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2106 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2107 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2110 if (cp2 > dirend) cp2 = dirend;
2112 else *(cp1++) = '.';
2114 for (; cp2 < dirend; cp2++) {
2116 if (*(cp2-1) == '/') continue;
2117 if (*(cp1-1) != '.') *(cp1++) = '.';
2120 else if (!infront && *cp2 == '.') {
2121 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2122 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2123 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2124 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2125 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2126 else { /* back up over previous directory name */
2128 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2129 if (*(cp1-1) == '[') {
2130 memcpy(cp1,"000000.",7);
2135 if (cp2 == dirend) break;
2137 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2138 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2139 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2140 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2142 *(cp1++) = '.'; /* Simulate trailing '/' */
2143 cp2 += 2; /* for loop will incr this to == dirend */
2145 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2147 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2150 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2151 if (*cp2 == '.') *(cp1++) = '_';
2152 else *(cp1++) = *cp2;
2156 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2157 if (hasdir) *(cp1++) = ']';
2158 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2159 while (*cp2) *(cp1++) = *(cp2++);
2164 } /* end of do_tovmsspec() */
2166 /* External entry points */
2167 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2168 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2170 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2171 static char *do_tovmspath(char *path, char *buf, int ts) {
2172 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2174 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2176 if (path == NULL) return NULL;
2177 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2178 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2179 if (buf) return buf;
2181 vmslen = strlen(vmsified);
2182 New(1317,cp,vmslen+1,char);
2183 memcpy(cp,vmsified,vmslen);
2188 strcpy(__tovmspath_retbuf,vmsified);
2189 return __tovmspath_retbuf;
2192 } /* end of do_tovmspath() */
2194 /* External entry points */
2195 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2196 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2199 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2200 static char *do_tounixpath(char *path, char *buf, int ts) {
2201 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2203 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2205 if (path == NULL) return NULL;
2206 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2207 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2208 if (buf) return buf;
2210 unixlen = strlen(unixified);
2211 New(1317,cp,unixlen+1,char);
2212 memcpy(cp,unixified,unixlen);
2217 strcpy(__tounixpath_retbuf,unixified);
2218 return __tounixpath_retbuf;
2221 } /* end of do_tounixpath() */
2223 /* External entry points */
2224 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2225 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2228 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2230 *****************************************************************************
2232 * Copyright (C) 1989-1994 by *
2233 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2235 * Permission is hereby granted for the reproduction of this software, *
2236 * on condition that this copyright notice is included in the reproduction, *
2237 * and that such reproduction is not for purposes of profit or material *
2240 * 27-Aug-1994 Modified for inclusion in perl5 *
2241 * by Charles Bailey bailey@newman.upenn.edu *
2242 *****************************************************************************
2246 * getredirection() is intended to aid in porting C programs
2247 * to VMS (Vax-11 C). The native VMS environment does not support
2248 * '>' and '<' I/O redirection, or command line wild card expansion,
2249 * or a command line pipe mechanism using the '|' AND background
2250 * command execution '&'. All of these capabilities are provided to any
2251 * C program which calls this procedure as the first thing in the
2253 * The piping mechanism will probably work with almost any 'filter' type
2254 * of program. With suitable modification, it may useful for other
2255 * portability problems as well.
2257 * Author: Mark Pizzolato mark@infocomm.com
2261 struct list_item *next;
2265 static void add_item(struct list_item **head,
2266 struct list_item **tail,
2270 static void expand_wild_cards(char *item,
2271 struct list_item **head,
2272 struct list_item **tail,
2275 static int background_process(int argc, char **argv);
2277 static void pipe_and_fork(char **cmargv);
2279 /*{{{ void getredirection(int *ac, char ***av)*/
2281 getredirection(int *ac, char ***av)
2283 * Process vms redirection arg's. Exit if any error is seen.
2284 * If getredirection() processes an argument, it is erased
2285 * from the vector. getredirection() returns a new argc and argv value.
2286 * In the event that a background command is requested (by a trailing "&"),
2287 * this routine creates a background subprocess, and simply exits the program.
2289 * Warning: do not try to simplify the code for vms. The code
2290 * presupposes that getredirection() is called before any data is
2291 * read from stdin or written to stdout.
2293 * Normal usage is as follows:
2299 * getredirection(&argc, &argv);
2303 int argc = *ac; /* Argument Count */
2304 char **argv = *av; /* Argument Vector */
2305 char *ap; /* Argument pointer */
2306 int j; /* argv[] index */
2307 int item_count = 0; /* Count of Items in List */
2308 struct list_item *list_head = 0; /* First Item in List */
2309 struct list_item *list_tail; /* Last Item in List */
2310 char *in = NULL; /* Input File Name */
2311 char *out = NULL; /* Output File Name */
2312 char *outmode = "w"; /* Mode to Open Output File */
2313 char *err = NULL; /* Error File Name */
2314 char *errmode = "w"; /* Mode to Open Error File */
2315 int cmargc = 0; /* Piped Command Arg Count */
2316 char **cmargv = NULL;/* Piped Command Arg Vector */
2319 * First handle the case where the last thing on the line ends with
2320 * a '&'. This indicates the desire for the command to be run in a
2321 * subprocess, so we satisfy that desire.
2324 if (0 == strcmp("&", ap))
2325 exit(background_process(--argc, argv));
2326 if (*ap && '&' == ap[strlen(ap)-1])
2328 ap[strlen(ap)-1] = '\0';
2329 exit(background_process(argc, argv));
2332 * Now we handle the general redirection cases that involve '>', '>>',
2333 * '<', and pipes '|'.
2335 for (j = 0; j < argc; ++j)
2337 if (0 == strcmp("<", argv[j]))
2341 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2342 exit(LIB$_WRONUMARG);
2347 if ('<' == *(ap = argv[j]))
2352 if (0 == strcmp(">", ap))
2356 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2357 exit(LIB$_WRONUMARG);
2376 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2377 exit(LIB$_WRONUMARG);
2381 if (('2' == *ap) && ('>' == ap[1]))
2398 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2399 exit(LIB$_WRONUMARG);
2403 if (0 == strcmp("|", argv[j]))
2407 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2408 exit(LIB$_WRONUMARG);
2410 cmargc = argc-(j+1);
2411 cmargv = &argv[j+1];
2415 if ('|' == *(ap = argv[j]))
2423 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2426 * Allocate and fill in the new argument vector, Some Unix's terminate
2427 * the list with an extra null pointer.
2429 New(1302, argv, item_count+1, char *);
2431 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2432 argv[j] = list_head->value;
2438 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2439 exit(LIB$_INVARGORD);
2441 pipe_and_fork(cmargv);
2444 /* Check for input from a pipe (mailbox) */
2446 if (in == NULL && 1 == isapipe(0))
2448 char mbxname[L_tmpnam];
2450 long int dvi_item = DVI$_DEVBUFSIZ;
2451 $DESCRIPTOR(mbxnam, "");
2452 $DESCRIPTOR(mbxdevnam, "");
2454 /* Input from a pipe, reopen it in binary mode to disable */
2455 /* carriage control processing. */
2457 PerlIO_getname(stdin, mbxname);
2458 mbxnam.dsc$a_pointer = mbxname;
2459 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2460 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2461 mbxdevnam.dsc$a_pointer = mbxname;
2462 mbxdevnam.dsc$w_length = sizeof(mbxname);
2463 dvi_item = DVI$_DEVNAM;
2464 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2465 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2468 freopen(mbxname, "rb", stdin);
2471 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2475 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2477 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2480 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2482 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2487 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2489 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2493 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2498 #ifdef ARGPROC_DEBUG
2499 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2500 for (j = 0; j < *ac; ++j)
2501 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2503 /* Clear errors we may have hit expanding wildcards, so they don't
2504 show up in Perl's $! later */
2505 set_errno(0); set_vaxc_errno(1);
2506 } /* end of getredirection() */
2509 static void add_item(struct list_item **head,
2510 struct list_item **tail,
2516 New(1303,*head,1,struct list_item);
2520 New(1304,(*tail)->next,1,struct list_item);
2521 *tail = (*tail)->next;
2523 (*tail)->value = value;
2527 static void expand_wild_cards(char *item,
2528 struct list_item **head,
2529 struct list_item **tail,
2533 unsigned long int context = 0;
2539 char vmsspec[NAM$C_MAXRSS+1];
2540 $DESCRIPTOR(filespec, "");
2541 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2542 $DESCRIPTOR(resultspec, "");
2543 unsigned long int zero = 0, sts;
2545 for (cp = item; *cp; cp++) {
2546 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2547 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2549 if (!*cp || isspace(*cp))
2551 add_item(head, tail, item, count);
2554 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2555 resultspec.dsc$b_class = DSC$K_CLASS_D;
2556 resultspec.dsc$a_pointer = NULL;
2557 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2558 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2559 if (!isunix || !filespec.dsc$a_pointer)
2560 filespec.dsc$a_pointer = item;
2561 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2563 * Only return version specs, if the caller specified a version
2565 had_version = strchr(item, ';');
2567 * Only return device and directory specs, if the caller specifed either.
2569 had_device = strchr(item, ':');
2570 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2572 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2573 &defaultspec, 0, 0, &zero))))
2578 New(1305,string,resultspec.dsc$w_length+1,char);
2579 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2580 string[resultspec.dsc$w_length] = '\0';
2581 if (NULL == had_version)
2582 *((char *)strrchr(string, ';')) = '\0';
2583 if ((!had_directory) && (had_device == NULL))
2585 if (NULL == (devdir = strrchr(string, ']')))
2586 devdir = strrchr(string, '>');
2587 strcpy(string, devdir + 1);
2590 * Be consistent with what the C RTL has already done to the rest of
2591 * the argv items and lowercase all of these names.
2593 for (c = string; *c; ++c)
2596 if (isunix) trim_unixpath(string,item,1);
2597 add_item(head, tail, string, count);
2600 if (sts != RMS$_NMF)
2602 set_vaxc_errno(sts);
2608 set_errno(ENOENT); break;
2610 set_errno(ENODEV); break;
2613 set_errno(EINVAL); break;
2615 set_errno(EACCES); break;
2617 _ckvmssts_noperl(sts);
2621 add_item(head, tail, item, count);
2622 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2623 _ckvmssts_noperl(lib$find_file_end(&context));
2626 static int child_st[2];/* Event Flag set when child process completes */
2628 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2630 static unsigned long int exit_handler(int *status)
2634 if (0 == child_st[0])
2636 #ifdef ARGPROC_DEBUG
2637 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2639 fflush(stdout); /* Have to flush pipe for binary data to */
2640 /* terminate properly -- <tp@mccall.com> */
2641 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2642 sys$dassgn(child_chan);
2644 sys$synch(0, child_st);
2649 static void sig_child(int chan)
2651 #ifdef ARGPROC_DEBUG
2652 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2654 if (child_st[0] == 0)
2658 static struct exit_control_block exit_block =
2663 &exit_block.exit_status,
2667 static void pipe_and_fork(char **cmargv)
2670 $DESCRIPTOR(cmddsc, "");
2671 static char mbxname[64];
2672 $DESCRIPTOR(mbxdsc, mbxname);
2674 unsigned long int zero = 0, one = 1;
2676 strcpy(subcmd, cmargv[0]);
2677 for (j = 1; NULL != cmargv[j]; ++j)
2679 strcat(subcmd, " \"");
2680 strcat(subcmd, cmargv[j]);
2681 strcat(subcmd, "\"");
2683 cmddsc.dsc$a_pointer = subcmd;
2684 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2686 create_mbx(&child_chan,&mbxdsc);
2687 #ifdef ARGPROC_DEBUG
2688 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2689 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2691 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2692 0, &pid, child_st, &zero, sig_child,
2694 #ifdef ARGPROC_DEBUG
2695 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2697 sys$dclexh(&exit_block);
2698 if (NULL == freopen(mbxname, "wb", stdout))
2700 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2704 static int background_process(int argc, char **argv)
2706 char command[2048] = "$";
2707 $DESCRIPTOR(value, "");
2708 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2709 static $DESCRIPTOR(null, "NLA0:");
2710 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2712 $DESCRIPTOR(pidstr, "");
2714 unsigned long int flags = 17, one = 1, retsts;
2716 strcat(command, argv[0]);
2719 strcat(command, " \"");
2720 strcat(command, *(++argv));
2721 strcat(command, "\"");
2723 value.dsc$a_pointer = command;
2724 value.dsc$w_length = strlen(value.dsc$a_pointer);
2725 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2726 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2727 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2728 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2731 _ckvmssts_noperl(retsts);
2733 #ifdef ARGPROC_DEBUG
2734 PerlIO_printf(Perl_debug_log, "%s\n", command);
2736 sprintf(pidstring, "%08X", pid);
2737 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2738 pidstr.dsc$a_pointer = pidstring;
2739 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2740 lib$set_symbol(&pidsymbol, &pidstr);
2744 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2747 /* OS-specific initialization at image activation (not thread startup) */
2748 /* Older VAXC header files lack these constants */
2749 #ifndef JPI$_RIGHTS_SIZE
2750 # define JPI$_RIGHTS_SIZE 817
2752 #ifndef KGB$M_SUBSYSTEM
2753 # define KGB$M_SUBSYSTEM 0x8
2756 /*{{{void vms_image_init(int *, char ***)*/
2758 vms_image_init(int *argcp, char ***argvp)
2760 char eqv[LNM$C_NAMLENGTH+1] = "";
2761 unsigned int len, tabct = 8, tabidx = 0;
2762 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2763 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2764 unsigned short int dummy, rlen;
2765 struct dsc$descriptor_s **tabvec;
2767 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2768 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2769 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2772 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2774 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2775 if (iprv[i]) { /* Running image installed with privs? */
2776 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2781 /* Rights identifiers might trigger tainting as well. */
2782 if (!will_taint && (rlen || rsz)) {
2783 while (rlen < rsz) {
2784 /* We didn't get all the identifiers on the first pass. Allocate a
2785 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2786 * were needed to hold all identifiers at time of last call; we'll
2787 * allocate that many unsigned long ints), and go back and get 'em.
2789 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2790 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2791 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2792 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2795 mask = jpilist[1].bufadr;
2796 /* Check attribute flags for each identifier (2nd longword); protected
2797 * subsystem identifiers trigger tainting.
2799 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2800 if (mask[i] & KGB$M_SUBSYSTEM) {
2805 if (mask != rlst) Safefree(mask);
2807 /* We need to use this hack to tell Perl it should run with tainting,
2808 * since its tainting flag may be part of the PL_curinterp struct, which
2809 * hasn't been allocated when vms_image_init() is called.
2813 New(1320,newap,*argcp+2,char **);
2814 newap[0] = argvp[0];
2816 Copy(argvp[1],newap[2],*argcp-1,char **);
2817 /* We orphan the old argv, since we don't know where it's come from,
2818 * so we don't know how to free it.
2820 *argcp++; argvp = newap;
2822 else { /* Did user explicitly request tainting? */
2824 char *cp, **av = *argvp;
2825 for (i = 1; i < *argcp; i++) {
2826 if (*av[i] != '-') break;
2827 for (cp = av[i]+1; *cp; cp++) {
2828 if (*cp == 'T') { will_taint = 1; break; }
2829 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2830 strchr("DFIiMmx",*cp)) break;
2832 if (will_taint) break;
2837 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2839 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2840 else if (tabidx >= tabct) {
2842 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2844 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2845 tabvec[tabidx]->dsc$w_length = 0;
2846 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2847 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2848 tabvec[tabidx]->dsc$a_pointer = NULL;
2849 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2851 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2853 getredirection(argcp,argvp);
2854 #if defined(USE_THREADS) && defined(__DECC)
2856 # include <reentrancy.h>
2857 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2866 * Trim Unix-style prefix off filespec, so it looks like what a shell
2867 * glob expansion would return (i.e. from specified prefix on, not
2868 * full path). Note that returned filespec is Unix-style, regardless
2869 * of whether input filespec was VMS-style or Unix-style.
2871 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2872 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2873 * vector of options; at present, only bit 0 is used, and if set tells
2874 * trim unixpath to try the current default directory as a prefix when
2875 * presented with a possibly ambiguous ... wildcard.
2877 * Returns !=0 on success, with trimmed filespec replacing contents of
2878 * fspec, and 0 on failure, with contents of fpsec unchanged.
2880 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2882 trim_unixpath(char *fspec, char *wildspec, int opts)
2884 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2885 *template, *base, *end, *cp1, *cp2;
2886 register int tmplen, reslen = 0, dirs = 0;
2888 if (!wildspec || !fspec) return 0;
2889 if (strpbrk(wildspec,"]>:") != NULL) {
2890 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2891 else template = unixwild;
2893 else template = wildspec;
2894 if (strpbrk(fspec,"]>:") != NULL) {
2895 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2896 else base = unixified;
2897 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2898 * check to see that final result fits into (isn't longer than) fspec */
2899 reslen = strlen(fspec);
2903 /* No prefix or absolute path on wildcard, so nothing to remove */
2904 if (!*template || *template == '/') {
2905 if (base == fspec) return 1;
2906 tmplen = strlen(unixified);
2907 if (tmplen > reslen) return 0; /* not enough space */
2908 /* Copy unixified resultant, including trailing NUL */
2909 memmove(fspec,unixified,tmplen+1);
2913 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2914 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2915 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2916 for (cp1 = end ;cp1 >= base; cp1--)
2917 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2919 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2923 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2924 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2925 int ells = 1, totells, segdirs, match;
2926 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2927 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2929 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2931 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2932 if (ellipsis == template && opts & 1) {
2933 /* Template begins with an ellipsis. Since we can't tell how many
2934 * directory names at the front of the resultant to keep for an
2935 * arbitrary starting point, we arbitrarily choose the current
2936 * default directory as a starting point. If it's there as a prefix,
2937 * clip it off. If not, fall through and act as if the leading
2938 * ellipsis weren't there (i.e. return shortest possible path that
2939 * could match template).
2941 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2942 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2943 if (_tolower(*cp1) != _tolower(*cp2)) break;
2944 segdirs = dirs - totells; /* Min # of dirs we must have left */
2945 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2946 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2947 memcpy(fspec,cp2+1,end - cp2);
2951 /* First off, back up over constant elements at end of path */
2953 for (front = end ; front >= base; front--)
2954 if (*front == '/' && !dirs--) { front++; break; }
2956 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2957 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2958 if (cp1 != '\0') return 0; /* Path too long. */
2960 *cp2 = '\0'; /* Pick up with memcpy later */
2961 lcfront = lcres + (front - base);
2962 /* Now skip over each ellipsis and try to match the path in front of it. */
2964 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2965 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2966 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2967 if (cp1 < template) break; /* template started with an ellipsis */
2968 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2969 ellipsis = cp1; continue;
2971 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2973 for (segdirs = 0, cp2 = tpl;
2974 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2976 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2977 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2978 if (*cp2 == '/') segdirs++;
2980 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2981 /* Back up at least as many dirs as in template before matching */
2982 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2983 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2984 for (match = 0; cp1 > lcres;) {
2985 resdsc.dsc$a_pointer = cp1;
2986 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2988 if (match == 1) lcfront = cp1;
2990 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2992 if (!match) return 0; /* Can't find prefix ??? */
2993 if (match > 1 && opts & 1) {
2994 /* This ... wildcard could cover more than one set of dirs (i.e.
2995 * a set of similar dir names is repeated). If the template
2996 * contains more than 1 ..., upstream elements could resolve the
2997 * ambiguity, but it's not worth a full backtracking setup here.
2998 * As a quick heuristic, clip off the current default directory
2999 * if it's present to find the trimmed spec, else use the
3000 * shortest string that this ... could cover.
3002 char def[NAM$C_MAXRSS+1], *st;
3004 if (getcwd(def, sizeof def,0) == NULL) return 0;
3005 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
3006 if (_tolower(*cp1) != _tolower(*cp2)) break;
3007 segdirs = dirs - totells; /* Min # of dirs we must have left */
3008 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3009 if (*cp1 == '\0' && *cp2 == '/') {
3010 memcpy(fspec,cp2+1,end - cp2);
3013 /* Nope -- stick with lcfront from above and keep going. */
3016 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3021 } /* end of trim_unixpath() */
3026 * VMS readdir() routines.
3027 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3029 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3030 * Minor modifications to original routines.
3033 /* Number of elements in vms_versions array */
3034 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3037 * Open a directory, return a handle for later use.
3039 /*{{{ DIR *opendir(char*name) */
3044 char dir[NAM$C_MAXRSS+1];
3047 if (do_tovmspath(name,dir,0) == NULL) {
3050 if (flex_stat(dir,&sb) == -1) return NULL;
3051 if (!S_ISDIR(sb.st_mode)) {
3052 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3055 if (!cando_by_name(S_IRUSR,0,dir)) {
3056 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3059 /* Get memory for the handle, and the pattern. */
3061 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3063 /* Fill in the fields; mainly playing with the descriptor. */
3064 (void)sprintf(dd->pattern, "%s*.*",dir);
3067 dd->vms_wantversions = 0;
3068 dd->pat.dsc$a_pointer = dd->pattern;
3069 dd->pat.dsc$w_length = strlen(dd->pattern);
3070 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3071 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3074 } /* end of opendir() */
3078 * Set the flag to indicate we want versions or not.
3080 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3082 vmsreaddirversions(DIR *dd, int flag)
3084 dd->vms_wantversions = flag;
3089 * Free up an opened directory.
3091 /*{{{ void closedir(DIR *dd)*/
3095 (void)lib$find_file_end(&dd->context);
3096 Safefree(dd->pattern);
3097 Safefree((char *)dd);
3102 * Collect all the version numbers for the current file.
3108 struct dsc$descriptor_s pat;
3109 struct dsc$descriptor_s res;
3111 char *p, *text, buff[sizeof dd->entry.d_name];
3113 unsigned long context, tmpsts;
3116 /* Convenient shorthand. */
3119 /* Add the version wildcard, ignoring the "*.*" put on before */
3120 i = strlen(dd->pattern);
3121 New(1308,text,i + e->d_namlen + 3,char);
3122 (void)strcpy(text, dd->pattern);
3123 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3125 /* Set up the pattern descriptor. */
3126 pat.dsc$a_pointer = text;
3127 pat.dsc$w_length = i + e->d_namlen - 1;
3128 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3129 pat.dsc$b_class = DSC$K_CLASS_S;
3131 /* Set up result descriptor. */
3132 res.dsc$a_pointer = buff;
3133 res.dsc$w_length = sizeof buff - 2;
3134 res.dsc$b_dtype = DSC$K_DTYPE_T;
3135 res.dsc$b_class = DSC$K_CLASS_S;
3137 /* Read files, collecting versions. */
3138 for (context = 0, e->vms_verscount = 0;
3139 e->vms_verscount < VERSIZE(e);
3140 e->vms_verscount++) {
3141 tmpsts = lib$find_file(&pat, &res, &context);
3142 if (tmpsts == RMS$_NMF || context == 0) break;
3144 buff[sizeof buff - 1] = '\0';
3145 if ((p = strchr(buff, ';')))
3146 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3148 e->vms_versions[e->vms_verscount] = -1;
3151 _ckvmssts(lib$find_file_end(&context));
3154 } /* end of collectversions() */
3157 * Read the next entry from the directory.
3159 /*{{{ struct dirent *readdir(DIR *dd)*/
3163 struct dsc$descriptor_s res;
3164 char *p, buff[sizeof dd->entry.d_name];
3165 unsigned long int tmpsts;
3167 /* Set up result descriptor, and get next file. */
3168 res.dsc$a_pointer = buff;
3169 res.dsc$w_length = sizeof buff - 2;
3170 res.dsc$b_dtype = DSC$K_DTYPE_T;
3171 res.dsc$b_class = DSC$K_CLASS_S;
3172 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3173 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3174 if (!(tmpsts & 1)) {
3175 set_vaxc_errno(tmpsts);
3178 set_errno(EACCES); break;
3180 set_errno(ENODEV); break;
3183 set_errno(ENOENT); break;
3190 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3191 buff[sizeof buff - 1] = '\0';
3192 for (p = buff; *p; p++) *p = _tolower(*p);
3193 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3196 /* Skip any directory component and just copy the name. */
3197 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3198 else (void)strcpy(dd->entry.d_name, buff);
3200 /* Clobber the version. */
3201 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3203 dd->entry.d_namlen = strlen(dd->entry.d_name);
3204 dd->entry.vms_verscount = 0;
3205 if (dd->vms_wantversions) collectversions(dd);
3208 } /* end of readdir() */
3212 * Return something that can be used in a seekdir later.
3214 /*{{{ long telldir(DIR *dd)*/
3223 * Return to a spot where we used to be. Brute force.
3225 /*{{{ void seekdir(DIR *dd,long count)*/
3227 seekdir(DIR *dd, long count)
3229 int vms_wantversions;
3232 /* If we haven't done anything yet... */
3236 /* Remember some state, and clear it. */
3237 vms_wantversions = dd->vms_wantversions;
3238 dd->vms_wantversions = 0;
3239 _ckvmssts(lib$find_file_end(&dd->context));
3242 /* The increment is in readdir(). */
3243 for (dd->count = 0; dd->count < count; )
3246 dd->vms_wantversions = vms_wantversions;
3248 } /* end of seekdir() */
3251 /* VMS subprocess management
3253 * my_vfork() - just a vfork(), after setting a flag to record that
3254 * the current script is trying a Unix-style fork/exec.
3256 * vms_do_aexec() and vms_do_exec() are called in response to the
3257 * perl 'exec' function. If this follows a vfork call, then they
3258 * call out the the regular perl routines in doio.c which do an
3259 * execvp (for those who really want to try this under VMS).
3260 * Otherwise, they do exactly what the perl docs say exec should
3261 * do - terminate the current script and invoke a new command
3262 * (See below for notes on command syntax.)
3264 * do_aspawn() and do_spawn() implement the VMS side of the perl
3265 * 'system' function.
3267 * Note on command arguments to perl 'exec' and 'system': When handled
3268 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3269 * are concatenated to form a DCL command string. If the first arg
3270 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3271 * the the command string is handed off to DCL directly. Otherwise,
3272 * the first token of the command is taken as the filespec of an image
3273 * to run. The filespec is expanded using a default type of '.EXE' and
3274 * the process defaults for device, directory, etc., and if found, the resultant
3275 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3276 * the command string as parameters. This is perhaps a bit complicated,
3277 * but I hope it will form a happy medium between what VMS folks expect
3278 * from lib$spawn and what Unix folks expect from exec.
3281 static int vfork_called;
3283 /*{{{int my_vfork()*/
3293 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3301 if (VMScmd.dsc$a_pointer) {
3302 Safefree(VMScmd.dsc$a_pointer);
3303 VMScmd.dsc$w_length = 0;
3304 VMScmd.dsc$a_pointer = Nullch;
3309 setup_argstr(SV *really, SV **mark, SV **sp)
3312 char *junk, *tmps = Nullch;
3313 register size_t cmdlen = 0;
3320 tmps = SvPV(really,rlen);
3327 for (idx++; idx <= sp; idx++) {
3329 junk = SvPVx(*idx,rlen);
3330 cmdlen += rlen ? rlen + 1 : 0;
3333 New(401,PL_Cmd,cmdlen+1,char);
3335 if (tmps && *tmps) {
3336 strcpy(PL_Cmd,tmps);
3339 else *PL_Cmd = '\0';
3340 while (++mark <= sp) {
3342 char *s = SvPVx(*mark,n_a);
3344 if (*PL_Cmd) strcat(PL_Cmd," ");
3350 } /* end of setup_argstr() */
3353 static unsigned long int
3354 setup_cmddsc(char *cmd, int check_img)
3356 char resspec[NAM$C_MAXRSS+1];
3357 $DESCRIPTOR(defdsc,".EXE");
3358 $DESCRIPTOR(resdsc,resspec);
3359 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3360 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3361 register char *s, *rest, *cp;
3362 register int isdcl = 0;
3366 while (*s && isspace(*s)) s++;
3368 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3369 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3370 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3371 if (*cp == ':' || *cp == '[' || *cp == '<') {
3381 while (*s && !isspace(*s)) s++;
3383 imgdsc.dsc$a_pointer = cmd;
3384 imgdsc.dsc$w_length = s - cmd;
3385 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3387 _ckvmssts(lib$find_file_end(&cxt));
3389 while (*s && !isspace(*s)) s++;
3391 if (cando_by_name(S_IXUSR,0,resspec)) {
3392 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3393 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3394 strcat(VMScmd.dsc$a_pointer,resspec);
3395 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3396 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3399 else retsts = RMS$_PRV;
3402 /* It's either a DCL command or we couldn't find a suitable image */
3403 VMScmd.dsc$w_length = strlen(cmd);
3404 if (cmd == PL_Cmd) {
3405 VMScmd.dsc$a_pointer = PL_Cmd;
3406 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3408 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3409 if (!(retsts & 1)) {
3410 /* just hand off status values likely to be due to user error */
3411 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3412 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3413 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3414 else { _ckvmssts(retsts); }
3417 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3419 } /* end of setup_cmddsc() */
3422 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3424 vms_do_aexec(SV *really,SV **mark,SV **sp)
3428 if (vfork_called) { /* this follows a vfork - act Unixish */
3430 if (vfork_called < 0) {
3431 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3434 else return do_aexec(really,mark,sp);
3436 /* no vfork - act VMSish */
3437 return vms_do_exec(setup_argstr(really,mark,sp));
3442 } /* end of vms_do_aexec() */
3445 /* {{{bool vms_do_exec(char *cmd) */
3447 vms_do_exec(char *cmd)
3451 if (vfork_called) { /* this follows a vfork - act Unixish */
3453 if (vfork_called < 0) {
3454 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3457 else return do_exec(cmd);
3460 { /* no vfork - act VMSish */
3461 unsigned long int retsts;
3464 TAINT_PROPER("exec");
3465 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3466 retsts = lib$do_command(&VMScmd);
3470 set_errno(ENOENT); break;
3471 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3472 set_errno(ENOTDIR); break;
3474 set_errno(EACCES); break;
3476 set_errno(EINVAL); break;
3478 set_errno(E2BIG); break;
3479 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3480 _ckvmssts(retsts); /* fall through */
3481 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3484 set_vaxc_errno(retsts);
3485 if (ckWARN(WARN_EXEC)) {
3486 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3487 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3494 } /* end of vms_do_exec() */
3497 unsigned long int do_spawn(char *);
3499 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3501 do_aspawn(void *really,void **mark,void **sp)
3504 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3507 } /* end of do_aspawn() */
3510 /* {{{unsigned long int do_spawn(char *cmd) */
3514 unsigned long int sts, substs, hadcmd = 1;
3518 TAINT_PROPER("spawn");
3519 if (!cmd || !*cmd) {
3521 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3523 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3524 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3530 set_errno(ENOENT); break;
3531 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3532 set_errno(ENOTDIR); break;
3534 set_errno(EACCES); break;
3536 set_errno(EINVAL); break;
3538 set_errno(E2BIG); break;
3539 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3540 _ckvmssts(sts); /* fall through */
3541 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3544 set_vaxc_errno(sts);
3545 if (ckWARN(WARN_EXEC)) {
3546 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3547 hadcmd ? VMScmd.dsc$w_length : 0,
3548 hadcmd ? VMScmd.dsc$a_pointer : "",
3555 } /* end of do_spawn() */
3559 * A simple fwrite replacement which outputs itmsz*nitm chars without
3560 * introducing record boundaries every itmsz chars.
3562 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3564 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3566 register char *cp, *end;
3568 end = (char *)src + itmsz * nitm;
3570 while ((char *)src <= end) {
3571 for (cp = src; cp <= end; cp++) if (!*cp) break;
3572 if (fputs(src,dest) == EOF) return EOF;
3574 if (fputc('\0',dest) == EOF) return EOF;
3580 } /* end of my_fwrite() */
3583 /*{{{ int my_flush(FILE *fp)*/
3588 if ((res = fflush(fp)) == 0 && fp) {
3589 #ifdef VMS_DO_SOCKETS
3591 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3593 res = fsync(fileno(fp));
3600 * Here are replacements for the following Unix routines in the VMS environment:
3601 * getpwuid Get information for a particular UIC or UID
3602 * getpwnam Get information for a named user
3603 * getpwent Get information for each user in the rights database
3604 * setpwent Reset search to the start of the rights database
3605 * endpwent Finish searching for users in the rights database
3607 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3608 * (defined in pwd.h), which contains the following fields:-
3610 * char *pw_name; Username (in lower case)
3611 * char *pw_passwd; Hashed password
3612 * unsigned int pw_uid; UIC
3613 * unsigned int pw_gid; UIC group number
3614 * char *pw_unixdir; Default device/directory (VMS-style)
3615 * char *pw_gecos; Owner name
3616 * char *pw_dir; Default device/directory (Unix-style)
3617 * char *pw_shell; Default CLI name (eg. DCL)
3619 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3621 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3622 * not the UIC member number (eg. what's returned by getuid()),
3623 * getpwuid() can accept either as input (if uid is specified, the caller's
3624 * UIC group is used), though it won't recognise gid=0.
3626 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3627 * information about other users in your group or in other groups, respectively.
3628 * If the required privilege is not available, then these routines fill only
3629 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3632 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3635 /* sizes of various UAF record fields */
3636 #define UAI$S_USERNAME 12
3637 #define UAI$S_IDENT 31
3638 #define UAI$S_OWNER 31
3639 #define UAI$S_DEFDEV 31
3640 #define UAI$S_DEFDIR 63
3641 #define UAI$S_DEFCLI 31
3644 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3645 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3646 (uic).uic$v_group != UIC$K_WILD_GROUP)
3648 static char __empty[]= "";
3649 static struct passwd __passwd_empty=
3650 {(char *) __empty, (char *) __empty, 0, 0,
3651 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3652 static int contxt= 0;
3653 static struct passwd __pwdcache;
3654 static char __pw_namecache[UAI$S_IDENT+1];
3657 * This routine does most of the work extracting the user information.
3659 static int fillpasswd (const char *name, struct passwd *pwd)
3663 unsigned char length;
3664 char pw_gecos[UAI$S_OWNER+1];
3666 static union uicdef uic;
3668 unsigned char length;
3669 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3672 unsigned char length;
3673 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3676 unsigned char length;
3677 char pw_shell[UAI$S_DEFCLI+1];
3679 static char pw_passwd[UAI$S_PWD+1];
3681 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3682 struct dsc$descriptor_s name_desc;
3683 unsigned long int sts;
3685 static struct itmlst_3 itmlst[]= {
3686 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3687 {sizeof(uic), UAI$_UIC, &uic, &luic},
3688 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3689 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3690 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3691 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3692 {0, 0, NULL, NULL}};
3694 name_desc.dsc$w_length= strlen(name);
3695 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3696 name_desc.dsc$b_class= DSC$K_CLASS_S;
3697 name_desc.dsc$a_pointer= (char *) name;
3699 /* Note that sys$getuai returns many fields as counted strings. */
3700 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3701 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3702 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3704 else { _ckvmssts(sts); }
3705 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3707 if ((int) owner.length < lowner) lowner= (int) owner.length;
3708 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3709 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3710 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3711 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3712 owner.pw_gecos[lowner]= '\0';
3713 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3714 defcli.pw_shell[ldefcli]= '\0';
3715 if (valid_uic(uic)) {
3716 pwd->pw_uid= uic.uic$l_uic;
3717 pwd->pw_gid= uic.uic$v_group;
3720 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3721 pwd->pw_passwd= pw_passwd;
3722 pwd->pw_gecos= owner.pw_gecos;
3723 pwd->pw_dir= defdev.pw_dir;
3724 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3725 pwd->pw_shell= defcli.pw_shell;
3726 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3728 ldir= strlen(pwd->pw_unixdir) - 1;
3729 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3732 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3733 __mystrtolower(pwd->pw_unixdir);
3738 * Get information for a named user.
3740 /*{{{struct passwd *getpwnam(char *name)*/
3741 struct passwd *my_getpwnam(char *name)
3743 struct dsc$descriptor_s name_desc;
3745 unsigned long int status, sts;
3748 __pwdcache = __passwd_empty;
3749 if (!fillpasswd(name, &__pwdcache)) {
3750 /* We still may be able to determine pw_uid and pw_gid */
3751 name_desc.dsc$w_length= strlen(name);
3752 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3753 name_desc.dsc$b_class= DSC$K_CLASS_S;
3754 name_desc.dsc$a_pointer= (char *) name;
3755 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3756 __pwdcache.pw_uid= uic.uic$l_uic;
3757 __pwdcache.pw_gid= uic.uic$v_group;
3760 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3761 set_vaxc_errno(sts);
3762 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3765 else { _ckvmssts(sts); }
3768 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3769 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3770 __pwdcache.pw_name= __pw_namecache;
3772 } /* end of my_getpwnam() */
3776 * Get information for a particular UIC or UID.
3777 * Called by my_getpwent with uid=-1 to list all users.
3779 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3780 struct passwd *my_getpwuid(Uid_t uid)
3782 const $DESCRIPTOR(name_desc,__pw_namecache);
3783 unsigned short lname;
3785 unsigned long int status;
3788 if (uid == (unsigned int) -1) {
3790 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3791 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3792 set_vaxc_errno(status);
3793 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3797 else { _ckvmssts(status); }
3798 } while (!valid_uic (uic));
3802 if (!uic.uic$v_group)
3803 uic.uic$v_group= PerlProc_getgid();
3805 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3806 else status = SS$_IVIDENT;
3807 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3808 status == RMS$_PRV) {
3809 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3812 else { _ckvmssts(status); }
3814 __pw_namecache[lname]= '\0';
3815 __mystrtolower(__pw_namecache);
3817 __pwdcache = __passwd_empty;
3818 __pwdcache.pw_name = __pw_namecache;
3820 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3821 The identifier's value is usually the UIC, but it doesn't have to be,
3822 so if we can, we let fillpasswd update this. */
3823 __pwdcache.pw_uid = uic.uic$l_uic;
3824 __pwdcache.pw_gid = uic.uic$v_group;
3826 fillpasswd(__pw_namecache, &__pwdcache);
3829 } /* end of my_getpwuid() */
3833 * Get information for next user.
3835 /*{{{struct passwd *my_getpwent()*/
3836 struct passwd *my_getpwent()
3838 return (my_getpwuid((unsigned int) -1));
3843 * Finish searching rights database for users.
3845 /*{{{void my_endpwent()*/
3850 _ckvmssts(sys$finish_rdb(&contxt));
3856 #ifdef HOMEGROWN_POSIX_SIGNALS
3857 /* Signal handling routines, pulled into the core from POSIX.xs.
3859 * We need these for threads, so they've been rolled into the core,
3860 * rather than left in POSIX.xs.
3862 * (DRS, Oct 23, 1997)
3865 /* sigset_t is atomic under VMS, so these routines are easy */
3866 /*{{{int my_sigemptyset(sigset_t *) */
3867 int my_sigemptyset(sigset_t *set) {
3868 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3874 /*{{{int my_sigfillset(sigset_t *)*/
3875 int my_sigfillset(sigset_t *set) {
3877 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3878 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3884 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3885 int my_sigaddset(sigset_t *set, int sig) {
3886 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3887 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3888 *set |= (1 << (sig - 1));
3894 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3895 int my_sigdelset(sigset_t *set, int sig) {
3896 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3897 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3898 *set &= ~(1 << (sig - 1));
3904 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3905 int my_sigismember(sigset_t *set, int sig) {
3906 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3907 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3908 *set & (1 << (sig - 1));
3913 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3914 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3917 /* If set and oset are both null, then things are badly wrong. Bail out. */
3918 if ((oset == NULL) && (set == NULL)) {
3919 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3923 /* If set's null, then we're just handling a fetch. */
3925 tempmask = sigblock(0);
3930 tempmask = sigsetmask(*set);
3933 tempmask = sigblock(*set);
3936 tempmask = sigblock(0);
3937 sigsetmask(*oset & ~tempmask);
3940 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3945 /* Did they pass us an oset? If so, stick our holding mask into it */
3952 #endif /* HOMEGROWN_POSIX_SIGNALS */
3955 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3956 * my_utime(), and flex_stat(), all of which operate on UTC unless
3957 * VMSISH_TIMES is true.
3959 /* method used to handle UTC conversions:
3960 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3962 static int gmtime_emulation_type;
3963 /* number of secs to add to UTC POSIX-style time to get local time */
3964 static long int utc_offset_secs;
3966 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3967 * in vmsish.h. #undef them here so we can call the CRTL routines
3974 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3975 # define RTL_USES_UTC 1
3978 static time_t toutc_dst(time_t loc) {
3981 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3982 loc -= utc_offset_secs;
3983 if (rsltmp->tm_isdst) loc -= 3600;
3986 #define _toutc(secs) ((secs) == -1 ? -1 : \
3987 ((gmtime_emulation_type || my_time(NULL)), \
3988 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3989 ((secs) - utc_offset_secs))))
3991 static time_t toloc_dst(time_t utc) {
3994 utc += utc_offset_secs;
3995 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3996 if (rsltmp->tm_isdst) utc += 3600;
3999 #define _toloc(secs) ((secs) == -1 ? -1 : \
4000 ((gmtime_emulation_type || my_time(NULL)), \
4001 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
4002 ((secs) + utc_offset_secs))))
4005 /* my_time(), my_localtime(), my_gmtime()
4006 * By default traffic in UTC time values, using CRTL gmtime() or
4007 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
4008 * Note: We need to use these functions even when the CRTL has working
4009 * UTC support, since they also handle C<use vmsish qw(times);>
4011 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4012 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4015 /*{{{time_t my_time(time_t *timep)*/
4016 time_t my_time(time_t *timep)
4022 if (gmtime_emulation_type == 0) {
4024 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4025 /* results of calls to gmtime() and localtime() */
4026 /* for same &base */
4028 gmtime_emulation_type++;
4029 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4030 char off[LNM$C_NAMLENGTH+1];;
4032 gmtime_emulation_type++;
4033 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4034 gmtime_emulation_type++;
4035 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4037 else { utc_offset_secs = atol(off); }
4039 else { /* We've got a working gmtime() */
4040 struct tm gmt, local;
4043 tm_p = localtime(&base);
4045 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4046 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4047 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4048 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4054 # ifdef RTL_USES_UTC
4055 if (VMSISH_TIME) when = _toloc(when);
4057 if (!VMSISH_TIME) when = _toutc(when);
4060 if (timep != NULL) *timep = when;
4063 } /* end of my_time() */
4067 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4069 my_gmtime(const time_t *timep)
4076 if (timep == NULL) {
4077 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4080 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4084 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4086 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4087 return gmtime(&when);
4089 /* CRTL localtime() wants local time as input, so does no tz correction */
4090 rsltmp = localtime(&when);
4091 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4094 } /* end of my_gmtime() */
4098 /*{{{struct tm *my_localtime(const time_t *timep)*/
4100 my_localtime(const time_t *timep)
4106 if (timep == NULL) {
4107 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4110 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4111 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4114 # ifdef RTL_USES_UTC
4116 if (VMSISH_TIME) when = _toutc(when);
4118 /* CRTL localtime() wants UTC as input, does tz correction itself */
4119 return localtime(&when);
4122 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4125 /* CRTL localtime() wants local time as input, so does no tz correction */
4126 rsltmp = localtime(&when);
4127 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4130 } /* end of my_localtime() */
4133 /* Reset definitions for later calls */
4134 #define gmtime(t) my_gmtime(t)
4135 #define localtime(t) my_localtime(t)
4136 #define time(t) my_time(t)
4139 /* my_utime - update modification time of a file
4140 * calling sequence is identical to POSIX utime(), but under
4141 * VMS only the modification time is changed; ODS-2 does not
4142 * maintain access times. Restrictions differ from the POSIX
4143 * definition in that the time can be changed as long as the
4144 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4145 * no separate checks are made to insure that the caller is the
4146 * owner of the file or has special privs enabled.
4147 * Code here is based on Joe Meadows' FILE utility.
4150 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4151 * to VMS epoch (01-JAN-1858 00:00:00.00)
4152 * in 100 ns intervals.
4154 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4156 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4157 int my_utime(char *file, struct utimbuf *utimes)
4161 long int bintime[2], len = 2, lowbit, unixtime,
4162 secscale = 10000000; /* seconds --> 100 ns intervals */
4163 unsigned long int chan, iosb[2], retsts;
4164 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4165 struct FAB myfab = cc$rms_fab;
4166 struct NAM mynam = cc$rms_nam;
4167 #if defined (__DECC) && defined (__VAX)
4168 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4169 * at least through VMS V6.1, which causes a type-conversion warning.
4171 # pragma message save
4172 # pragma message disable cvtdiftypes
4174 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4175 struct fibdef myfib;
4176 #if defined (__DECC) && defined (__VAX)
4177 /* This should be right after the declaration of myatr, but due
4178 * to a bug in VAX DEC C, this takes effect a statement early.
4180 # pragma message restore
4182 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4183 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4184 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4186 if (file == NULL || *file == '\0') {
4188 set_vaxc_errno(LIB$_INVARG);
4191 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4193 if (utimes != NULL) {
4194 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4195 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4196 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4197 * as input, we force the sign bit to be clear by shifting unixtime right
4198 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4200 lowbit = (utimes->modtime & 1) ? secscale : 0;
4201 unixtime = (long int) utimes->modtime;
4203 /* If input was UTC; convert to local for sys svc */
4204 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4206 unixtime >> 1; secscale << 1;
4207 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4208 if (!(retsts & 1)) {
4210 set_vaxc_errno(retsts);
4213 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4214 if (!(retsts & 1)) {
4216 set_vaxc_errno(retsts);
4221 /* Just get the current time in VMS format directly */
4222 retsts = sys$gettim(bintime);
4223 if (!(retsts & 1)) {
4225 set_vaxc_errno(retsts);
4230 myfab.fab$l_fna = vmsspec;
4231 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4232 myfab.fab$l_nam = &mynam;
4233 mynam.nam$l_esa = esa;
4234 mynam.nam$b_ess = (unsigned char) sizeof esa;
4235 mynam.nam$l_rsa = rsa;
4236 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4238 /* Look for the file to be affected, letting RMS parse the file
4239 * specification for us as well. I have set errno using only
4240 * values documented in the utime() man page for VMS POSIX.
4242 retsts = sys$parse(&myfab,0,0);
4243 if (!(retsts & 1)) {
4244 set_vaxc_errno(retsts);
4245 if (retsts == RMS$_PRV) set_errno(EACCES);
4246 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4247 else set_errno(EVMSERR);
4250 retsts = sys$search(&myfab,0,0);
4251 if (!(retsts & 1)) {
4252 set_vaxc_errno(retsts);
4253 if (retsts == RMS$_PRV) set_errno(EACCES);
4254 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4255 else set_errno(EVMSERR);
4259 devdsc.dsc$w_length = mynam.nam$b_dev;
4260 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4262 retsts = sys$assign(&devdsc,&chan,0,0);
4263 if (!(retsts & 1)) {
4264 set_vaxc_errno(retsts);
4265 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4266 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4267 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4268 else set_errno(EVMSERR);
4272 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4273 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4275 memset((void *) &myfib, 0, sizeof myfib);
4277 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4278 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4279 /* This prevents the revision time of the file being reset to the current
4280 * time as a result of our IO$_MODIFY $QIO. */
4281 myfib.fib$l_acctl = FIB$M_NORECORD;
4283 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4284 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4285 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4287 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4288 _ckvmssts(sys$dassgn(chan));
4289 if (retsts & 1) retsts = iosb[0];
4290 if (!(retsts & 1)) {
4291 set_vaxc_errno(retsts);
4292 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4293 else set_errno(EVMSERR);
4298 } /* end of my_utime() */
4302 * flex_stat, flex_fstat
4303 * basic stat, but gets it right when asked to stat
4304 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4307 /* encode_dev packs a VMS device name string into an integer to allow
4308 * simple comparisons. This can be used, for example, to check whether two
4309 * files are located on the same device, by comparing their encoded device
4310 * names. Even a string comparison would not do, because stat() reuses the
4311 * device name buffer for each call; so without encode_dev, it would be
4312 * necessary to save the buffer and use strcmp (this would mean a number of
4313 * changes to the standard Perl code, to say nothing of what a Perl script
4316 * The device lock id, if it exists, should be unique (unless perhaps compared
4317 * with lock ids transferred from other nodes). We have a lock id if the disk is
4318 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4319 * device names. Thus we use the lock id in preference, and only if that isn't
4320 * available, do we try to pack the device name into an integer (flagged by
4321 * the sign bit (LOCKID_MASK) being set).
4323 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4324 * name and its encoded form, but it seems very unlikely that we will find
4325 * two files on different disks that share the same encoded device names,
4326 * and even more remote that they will share the same file id (if the test
4327 * is to check for the same file).
4329 * A better method might be to use sys$device_scan on the first call, and to
4330 * search for the device, returning an index into the cached array.
4331 * The number returned would be more intelligable.
4332 * This is probably not worth it, and anyway would take quite a bit longer
4333 * on the first call.
4335 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4336 static mydev_t encode_dev (const char *dev)
4339 unsigned long int f;
4345 if (!dev || !dev[0]) return 0;
4349 struct dsc$descriptor_s dev_desc;
4350 unsigned long int status, lockid, item = DVI$_LOCKID;
4352 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4353 can try that first. */
4354 dev_desc.dsc$w_length = strlen (dev);
4355 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4356 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4357 dev_desc.dsc$a_pointer = (char *) dev;
4358 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4359 if (lockid) return (lockid & ~LOCKID_MASK);
4363 /* Otherwise we try to encode the device name */
4367 for (q = dev + strlen(dev); q--; q >= dev) {
4370 else if (isalpha (toupper (*q)))
4371 c= toupper (*q) - 'A' + (char)10;
4373 continue; /* Skip '$'s */
4375 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4377 enc += f * (unsigned long int) c;
4379 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4381 } /* end of encode_dev() */
4383 static char namecache[NAM$C_MAXRSS+1];
4386 is_null_device(name)
4390 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4391 The underscore prefix, controller letter, and unit number are
4392 independently optional; for our purposes, the colon punctuation
4393 is not. The colon can be trailed by optional directory and/or
4394 filename, but two consecutive colons indicates a nodename rather
4395 than a device. [pr] */
4396 if (*name == '_') ++name;
4397 if (tolower(*name++) != 'n') return 0;
4398 if (tolower(*name++) != 'l') return 0;
4399 if (tolower(*name) == 'a') ++name;
4400 if (*name == '0') ++name;
4401 return (*name++ == ':') && (*name != ':');
4404 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4405 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4406 * subset of the applicable information.
4408 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
4410 Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
4412 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4414 char fname[NAM$C_MAXRSS+1];
4415 unsigned long int retsts;
4416 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4417 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4419 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4420 device name on successive calls */
4421 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4422 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4423 namdsc.dsc$a_pointer = fname;
4424 namdsc.dsc$w_length = sizeof fname - 1;
4426 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4427 &namdsc,&namdsc.dsc$w_length,0,0);
4429 fname[namdsc.dsc$w_length] = '\0';
4430 return cando_by_name(bit,effective,fname);
4432 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4433 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4437 return FALSE; /* Should never get to here */
4439 } /* end of cando() */
4443 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
4445 cando_by_name(I32 bit, I32 effective, char *fname)
4447 static char usrname[L_cuserid];
4448 static struct dsc$descriptor_s usrdsc =
4449 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4450 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4451 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4452 unsigned short int retlen;
4454 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4455 union prvdef curprv;
4456 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4457 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4458 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4461 if (!fname || !*fname) return FALSE;
4462 /* Make sure we expand logical names, since sys$check_access doesn't */
4463 if (!strpbrk(fname,"/]>:")) {
4464 strcpy(fileified,fname);
4465 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4468 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4469 retlen = namdsc.dsc$w_length = strlen(vmsname);
4470 namdsc.dsc$a_pointer = vmsname;
4471 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4472 vmsname[retlen-1] == ':') {
4473 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4474 namdsc.dsc$w_length = strlen(fileified);
4475 namdsc.dsc$a_pointer = fileified;
4478 if (!usrdsc.dsc$w_length) {
4480 usrdsc.dsc$w_length = strlen(usrname);
4487 access = ARM$M_EXECUTE;
4492 access = ARM$M_READ;
4497 access = ARM$M_WRITE;
4502 access = ARM$M_DELETE;
4508 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4509 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4510 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4511 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4512 set_vaxc_errno(retsts);
4513 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4514 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4515 else set_errno(ENOENT);
4518 if (retsts == SS$_NORMAL) {
4519 if (!privused) return TRUE;
4520 /* We can get access, but only by using privs. Do we have the
4521 necessary privs currently enabled? */
4522 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4523 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4524 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4525 !curprv.prv$v_bypass) return FALSE;
4526 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4527 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4528 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4531 if (retsts == SS$_ACCONFLICT) {
4536 return FALSE; /* Should never get here */
4538 } /* end of cando_by_name() */
4542 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4544 flex_fstat(int fd, Stat_t *statbufp)
4547 if (!fstat(fd,(stat_t *) statbufp)) {
4548 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4549 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4550 # ifdef RTL_USES_UTC
4553 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4554 statbufp->st_atime = _toloc(statbufp->st_atime);
4555 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4560 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4564 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4565 statbufp->st_atime = _toutc(statbufp->st_atime);
4566 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4573 } /* end of flex_fstat() */
4576 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4578 flex_stat(const char *fspec, Stat_t *statbufp)
4581 char fileified[NAM$C_MAXRSS+1];
4582 char temp_fspec[NAM$C_MAXRSS+300];
4585 strcpy(temp_fspec, fspec);
4586 if (statbufp == (Stat_t *) &PL_statcache)
4587 do_tovmsspec(temp_fspec,namecache,0);
4588 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4589 memset(statbufp,0,sizeof *statbufp);
4590 statbufp->st_dev = encode_dev("_NLA0:");
4591 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4592 statbufp->st_uid = 0x00010001;
4593 statbufp->st_gid = 0x0001;
4594 time((time_t *)&statbufp->st_mtime);
4595 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4599 /* Try for a directory name first. If fspec contains a filename without
4600 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4601 * and sea:[wine.dark]water. exist, we prefer the directory here.
4602 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4603 * not sea:[wine.dark]., if the latter exists. If the intended target is
4604 * the file with null type, specify this by calling flex_stat() with
4605 * a '.' at the end of fspec.
4607 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4608 retval = stat(fileified,(stat_t *) statbufp);
4609 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4610 strcpy(namecache,fileified);
4612 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4614 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4615 # ifdef RTL_USES_UTC
4618 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4619 statbufp->st_atime = _toloc(statbufp->st_atime);
4620 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4625 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4629 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4630 statbufp->st_atime = _toutc(statbufp->st_atime);
4631 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4637 } /* end of flex_stat() */
4641 /*{{{char *my_getlogin()*/
4642 /* VMS cuserid == Unix getlogin, except calling sequence */
4646 static char user[L_cuserid];
4647 return cuserid(user);
4652 /* rmscopy - copy a file using VMS RMS routines
4654 * Copies contents and attributes of spec_in to spec_out, except owner
4655 * and protection information. Name and type of spec_in are used as
4656 * defaults for spec_out. The third parameter specifies whether rmscopy()
4657 * should try to propagate timestamps from the input file to the output file.
4658 * If it is less than 0, no timestamps are preserved. If it is 0, then
4659 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4660 * propagated to the output file at creation iff the output file specification
4661 * did not contain an explicit name or type, and the revision date is always
4662 * updated at the end of the copy operation. If it is greater than 0, then
4663 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4664 * other than the revision date should be propagated, and bit 1 indicates
4665 * that the revision date should be propagated.
4667 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4669 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4670 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4671 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4672 * as part of the Perl standard distribution under the terms of the
4673 * GNU General Public License or the Perl Artistic License. Copies
4674 * of each may be found in the Perl standard distribution.
4676 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4678 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4680 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4681 rsa[NAM$C_MAXRSS], ubf[32256];
4682 unsigned long int i, sts, sts2;
4683 struct FAB fab_in, fab_out;
4684 struct RAB rab_in, rab_out;
4686 struct XABDAT xabdat;
4687 struct XABFHC xabfhc;
4688 struct XABRDT xabrdt;
4689 struct XABSUM xabsum;
4691 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4692 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4693 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4697 fab_in = cc$rms_fab;
4698 fab_in.fab$l_fna = vmsin;
4699 fab_in.fab$b_fns = strlen(vmsin);
4700 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4701 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4702 fab_in.fab$l_fop = FAB$M_SQO;
4703 fab_in.fab$l_nam = &nam;
4704 fab_in.fab$l_xab = (void *) &xabdat;
4707 nam.nam$l_rsa = rsa;
4708 nam.nam$b_rss = sizeof(rsa);
4709 nam.nam$l_esa = esa;
4710 nam.nam$b_ess = sizeof (esa);
4711 nam.nam$b_esl = nam.nam$b_rsl = 0;
4713 xabdat = cc$rms_xabdat; /* To get creation date */
4714 xabdat.xab$l_nxt = (void *) &xabfhc;
4716 xabfhc = cc$rms_xabfhc; /* To get record length */
4717 xabfhc.xab$l_nxt = (void *) &xabsum;
4719 xabsum = cc$rms_xabsum; /* To get key and area information */
4721 if (!((sts = sys$open(&fab_in)) & 1)) {
4722 set_vaxc_errno(sts);
4726 set_errno(ENOENT); break;
4728 set_errno(ENODEV); break;
4730 set_errno(EINVAL); break;
4732 set_errno(EACCES); break;
4740 fab_out.fab$w_ifi = 0;
4741 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4742 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4743 fab_out.fab$l_fop = FAB$M_SQO;
4744 fab_out.fab$l_fna = vmsout;
4745 fab_out.fab$b_fns = strlen(vmsout);
4746 fab_out.fab$l_dna = nam.nam$l_name;
4747 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4749 if (preserve_dates == 0) { /* Act like DCL COPY */
4750 nam.nam$b_nop = NAM$M_SYNCHK;
4751 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4752 if (!((sts = sys$parse(&fab_out)) & 1)) {
4753 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4754 set_vaxc_errno(sts);
4757 fab_out.fab$l_xab = (void *) &xabdat;
4758 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4760 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4761 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4762 preserve_dates =0; /* bitmask from this point forward */
4764 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4765 if (!((sts = sys$create(&fab_out)) & 1)) {
4766 set_vaxc_errno(sts);
4769 set_errno(ENOENT); break;
4771 set_errno(ENODEV); break;
4773 set_errno(EINVAL); break;
4775 set_errno(EACCES); break;
4781 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4782 if (preserve_dates & 2) {
4783 /* sys$close() will process xabrdt, not xabdat */
4784 xabrdt = cc$rms_xabrdt;
4786 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4788 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4789 * is unsigned long[2], while DECC & VAXC use a struct */
4790 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4792 fab_out.fab$l_xab = (void *) &xabrdt;
4795 rab_in = cc$rms_rab;
4796 rab_in.rab$l_fab = &fab_in;
4797 rab_in.rab$l_rop = RAB$M_BIO;
4798 rab_in.rab$l_ubf = ubf;
4799 rab_in.rab$w_usz = sizeof ubf;
4800 if (!((sts = sys$connect(&rab_in)) & 1)) {
4801 sys$close(&fab_in); sys$close(&fab_out);
4802 set_errno(EVMSERR); set_vaxc_errno(sts);
4806 rab_out = cc$rms_rab;
4807 rab_out.rab$l_fab = &fab_out;
4808 rab_out.rab$l_rbf = ubf;
4809 if (!((sts = sys$connect(&rab_out)) & 1)) {
4810 sys$close(&fab_in); sys$close(&fab_out);
4811 set_errno(EVMSERR); set_vaxc_errno(sts);
4815 while ((sts = sys$read(&rab_in))) { /* always true */
4816 if (sts == RMS$_EOF) break;
4817 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4818 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4819 sys$close(&fab_in); sys$close(&fab_out);
4820 set_errno(EVMSERR); set_vaxc_errno(sts);
4825 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4826 sys$close(&fab_in); sys$close(&fab_out);
4827 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4829 set_errno(EVMSERR); set_vaxc_errno(sts);
4835 } /* end of rmscopy() */
4839 /*** The following glue provides 'hooks' to make some of the routines
4840 * from this file available from Perl. These routines are sufficiently
4841 * basic, and are required sufficiently early in the build process,
4842 * that's it's nice to have them available to miniperl as well as the
4843 * full Perl, so they're set up here instead of in an extension. The
4844 * Perl code which handles importation of these names into a given
4845 * package lives in [.VMS]Filespec.pm in @INC.
4849 rmsexpand_fromperl(pTHX_ CV *cv)
4852 char *fspec, *defspec = NULL, *rslt;
4855 if (!items || items > 2)
4856 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4857 fspec = SvPV(ST(0),n_a);
4858 if (!fspec || !*fspec) XSRETURN_UNDEF;
4859 if (items == 2) defspec = SvPV(ST(1),n_a);
4861 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4862 ST(0) = sv_newmortal();
4863 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4868 vmsify_fromperl(pTHX_ CV *cv)
4874 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4875 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4876 ST(0) = sv_newmortal();
4877 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4882 unixify_fromperl(pTHX_ CV *cv)
4888 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
4889 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4890 ST(0) = sv_newmortal();
4891 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4896 fileify_fromperl(pTHX_ CV *cv)
4902 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
4903 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4904 ST(0) = sv_newmortal();
4905 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4910 pathify_fromperl(pTHX_ CV *cv)
4916 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
4917 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4918 ST(0) = sv_newmortal();
4919 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4924 vmspath_fromperl(pTHX_ CV *cv)
4930 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
4931 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4932 ST(0) = sv_newmortal();
4933 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4938 unixpath_fromperl(pTHX_ CV *cv)
4944 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
4945 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4946 ST(0) = sv_newmortal();
4947 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4952 candelete_fromperl(pTHX_ CV *cv)
4955 char fspec[NAM$C_MAXRSS+1], *fsp;
4960 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
4962 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4963 if (SvTYPE(mysv) == SVt_PVGV) {
4964 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4965 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4972 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4973 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4979 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4984 rmscopy_fromperl(pTHX_ CV *cv)
4987 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4989 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4990 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4991 unsigned long int sts;
4996 if (items < 2 || items > 3)
4997 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
4999 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
5000 if (SvTYPE(mysv) == SVt_PVGV) {
5001 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
5002 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5009 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5010 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5015 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5016 if (SvTYPE(mysv) == SVt_PVGV) {
5017 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5018 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5025 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5026 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5031 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5033 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5040 char* file = __FILE__;
5042 char temp_buff[512];
5043 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
5044 no_translate_barewords = TRUE;
5046 no_translate_barewords = FALSE;
5049 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5050 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5051 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5052 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5053 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5054 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5055 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5056 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5057 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);