3 * VMS-specific routines for perl5
5 * Last revised: 24-Apr-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 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
96 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
97 struct dsc$descriptor_s **tabvec, unsigned long int flags)
99 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
100 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
101 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
102 unsigned char acmode;
103 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
104 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
105 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
106 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
108 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
109 #if defined(USE_THREADS)
110 /* We jump through these hoops because we can be called at */
111 /* platform-specific initialization time, which is before anything is */
112 /* set up--we can't even do a plain dTHX since that relies on the */
113 /* interpreter structure to be initialized */
114 struct perl_thread *thr;
116 thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
122 if (!lnm || !eqv || idx > LNM$_MAX_INDEX) {
123 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
125 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
126 *cp2 = _toupper(*cp1);
127 if (cp1 - lnm > LNM$C_NAMLENGTH) {
128 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
132 lnmdsc.dsc$w_length = cp1 - lnm;
133 lnmdsc.dsc$a_pointer = uplnm;
134 secure = flags & PERL__TRNENV_SECURE;
135 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
136 if (!tabvec || !*tabvec) tabvec = env_tables;
138 for (curtab = 0; tabvec[curtab]; curtab++) {
139 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
140 if (!ivenv && !secure) {
145 Perl_warn(aTHX_ "Can't read CRTL environ\n");
148 retsts = SS$_NOLOGNAM;
149 for (i = 0; environ[i]; i++) {
150 if ((eq = strchr(environ[i],'=')) &&
151 !strncmp(environ[i],uplnm,eq - environ[i])) {
153 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
154 if (!eqvlen) continue;
159 if (retsts != SS$_NOLOGNAM) break;
162 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
163 !str$case_blind_compare(&tmpdsc,&clisym)) {
164 if (!ivsym && !secure) {
165 unsigned short int deflen = LNM$C_NAMLENGTH;
166 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
167 /* dynamic dsc to accomodate possible long value */
168 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
169 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
172 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
174 /* Special hack--we might be called before the interpreter's */
175 /* fully initialized, in which case either thr or PL_curcop */
176 /* might be bogus. We have to check, since ckWARN needs them */
177 /* both to be valid if running threaded */
178 #if defined(USE_THREADS)
179 if (thr && PL_curcop) {
181 if (ckWARN(WARN_MISC)) {
182 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
184 #if defined(USE_THREADS)
186 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
191 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
193 _ckvmssts(lib$sfree1_dd(&eqvdsc));
194 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
195 if (retsts == LIB$_NOSUCHSYM) continue;
200 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
201 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
202 if (retsts == SS$_NOLOGNAM) continue;
206 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
207 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
208 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
209 retsts == SS$_NOLOGNAM) {
210 set_errno(EINVAL); set_vaxc_errno(retsts);
212 else _ckvmssts(retsts);
214 } /* end of vmstrnenv */
217 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
218 /* Define as a function so we can access statics. */
219 int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
221 return vmstrnenv(lnm,eqv,idx,fildev,
222 #ifdef SECURE_INTERNAL_GETENV
223 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
232 * Note: Uses Perl temp to store result so char * can be returned to
233 * caller; this pointer will be invalidated at next Perl statement
235 * We define this as a function rather than a macro in terms of my_getenv_len()
236 * so that it'll work when PL_curinterp is undefined (and we therefore can't
239 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
241 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
243 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
244 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
245 unsigned long int idx = 0;
249 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
250 /* Set up a temporary buffer for the return value; Perl will
251 * clean it up at the next statement transition */
252 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
253 if (!tmpsv) return NULL;
256 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
257 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
258 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
259 getcwd(eqv,LNM$C_NAMLENGTH);
263 if ((cp2 = strchr(lnm,';')) != NULL) {
265 uplnm[cp2-lnm] = '\0';
266 idx = strtoul(cp2+1,NULL,0);
269 if (vmstrnenv(lnm,eqv,idx,
271 #ifdef SECURE_INTERNAL_GETENV
272 sys ? PERL__TRNENV_SECURE : 0
280 } /* end of my_getenv() */
284 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
286 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
289 char *buf, *cp1, *cp2;
290 unsigned long idx = 0;
291 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
294 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
295 /* Set up a temporary buffer for the return value; Perl will
296 * clean it up at the next statement transition */
297 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
298 if (!tmpsv) return NULL;
301 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
302 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
303 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
304 getcwd(buf,LNM$C_NAMLENGTH);
309 if ((cp2 = strchr(lnm,';')) != NULL) {
312 idx = strtoul(cp2+1,NULL,0);
315 if ((*len = vmstrnenv(lnm,buf,idx,
317 #ifdef SECURE_INTERNAL_GETENV
318 sys ? PERL__TRNENV_SECURE : 0
328 } /* end of my_getenv_len() */
331 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
333 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
335 /*{{{ void prime_env_iter() */
338 /* Fill the %ENV associative array with all logical names we can
339 * find, in preparation for iterating over it.
343 static int primed = 0;
344 HV *seenhv = NULL, *envhv;
345 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
346 unsigned short int chan;
347 #ifndef CLI$M_TRUSTED
348 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
350 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
351 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
353 bool have_sym = FALSE, have_lnm = FALSE;
354 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
355 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
356 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
357 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
358 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
360 static perl_mutex primenv_mutex;
361 MUTEX_INIT(&primenv_mutex);
364 if (primed || !PL_envgv) return;
365 MUTEX_LOCK(&primenv_mutex);
366 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
367 envhv = GvHVn(PL_envgv);
368 /* Perform a dummy fetch as an lval to insure that the hash table is
369 * set up. Otherwise, the hv_store() will turn into a nullop. */
370 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
372 for (i = 0; env_tables[i]; i++) {
373 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
374 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
375 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
377 if (have_sym || have_lnm) {
378 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
379 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
380 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
381 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
384 for (i--; i >= 0; i--) {
385 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
388 for (j = 0; environ[j]; j++) {
389 if (!(start = strchr(environ[j],'='))) {
390 if (ckWARN(WARN_INTERNAL))
391 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
395 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
401 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
402 !str$case_blind_compare(&tmpdsc,&clisym)) {
403 strcpy(cmd,"Show Symbol/Global *");
404 cmddsc.dsc$w_length = 20;
405 if (env_tables[i]->dsc$w_length == 12 &&
406 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
407 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
408 flags = defflags | CLI$M_NOLOGNAM;
411 strcpy(cmd,"Show Logical *");
412 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
413 strcat(cmd," /Table=");
414 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
415 cmddsc.dsc$w_length = strlen(cmd);
417 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
418 flags = defflags | CLI$M_NOCLISYM;
421 /* Create a new subprocess to execute each command, to exclude the
422 * remote possibility that someone could subvert a mbx or file used
423 * to write multiple commands to a single subprocess.
426 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
427 0,&riseandshine,0,0,&clidsc,&clitabdsc);
428 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
429 defflags &= ~CLI$M_TRUSTED;
430 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
432 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
433 if (seenhv) SvREFCNT_dec(seenhv);
436 char *cp1, *cp2, *key;
437 unsigned long int sts, iosb[2], retlen, keylen;
440 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
441 if (sts & 1) sts = iosb[0] & 0xffff;
442 if (sts == SS$_ENDOFFILE) {
444 while (substs == 0) { sys$hiber(); wakect++;}
445 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
450 retlen = iosb[0] >> 16;
451 if (!retlen) continue; /* blank line */
453 if (iosb[1] != subpid) {
455 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
459 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
460 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
462 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
463 if (*cp1 == '(' || /* Logical name table name */
464 *cp1 == '=' /* Next eqv of searchlist */) continue;
465 if (*cp1 == '"') cp1++;
466 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
467 key = cp1; keylen = cp2 - cp1;
468 if (keylen && hv_exists(seenhv,key,keylen)) continue;
469 while (*cp2 && *cp2 != '=') cp2++;
470 while (*cp2 && *cp2 == '=') cp2++;
471 while (*cp2 && *cp2 == ' ') cp2++;
472 if (*cp2 == '"') { /* String translation; may embed "" */
473 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
474 cp2++; cp1--; /* Skip "" surrounding translation */
476 else { /* Numeric translation */
477 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
478 cp1--; /* stop on last non-space char */
480 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
481 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
484 PERL_HASH(hash,key,keylen);
485 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
486 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
488 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
489 /* get the PPFs for this process, not the subprocess */
490 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
491 char eqv[LNM$C_NAMLENGTH+1];
493 for (i = 0; ppfs[i]; i++) {
494 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
495 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
500 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
501 if (buf) Safefree(buf);
502 if (seenhv) SvREFCNT_dec(seenhv);
503 MUTEX_UNLOCK(&primenv_mutex);
506 } /* end of prime_env_iter */
510 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
511 /* Define or delete an element in the same "environment" as
512 * vmstrnenv(). If an element is to be deleted, it's removed from
513 * the first place it's found. If it's to be set, it's set in the
514 * place designated by the first element of the table vector.
515 * Like setenv() returns 0 for success, non-zero on error.
518 vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
520 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
521 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
522 unsigned long int retsts, usermode = PSL$C_USER;
523 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
524 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
525 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
526 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
527 $DESCRIPTOR(local,"_LOCAL");
530 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
531 *cp2 = _toupper(*cp1);
532 if (cp1 - lnm > LNM$C_NAMLENGTH) {
533 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
537 lnmdsc.dsc$w_length = cp1 - lnm;
538 if (!tabvec || !*tabvec) tabvec = env_tables;
540 if (!eqv) { /* we're deleting n element */
541 for (curtab = 0; tabvec[curtab]; curtab++) {
542 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
544 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
545 if ((cp1 = strchr(environ[i],'=')) &&
546 !strncmp(environ[i],lnm,cp1 - environ[i])) {
548 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
551 ivenv = 1; retsts = SS$_NOLOGNAM;
553 if (ckWARN(WARN_INTERNAL))
554 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
555 ivenv = 1; retsts = SS$_NOSUCHPGM;
561 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
562 !str$case_blind_compare(&tmpdsc,&clisym)) {
563 unsigned int symtype;
564 if (tabvec[curtab]->dsc$w_length == 12 &&
565 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
566 !str$case_blind_compare(&tmpdsc,&local))
567 symtype = LIB$K_CLI_LOCAL_SYM;
568 else symtype = LIB$K_CLI_GLOBAL_SYM;
569 retsts = lib$delete_symbol(&lnmdsc,&symtype);
570 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
571 if (retsts == LIB$_NOSUCHSYM) continue;
575 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
576 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
577 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
578 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
579 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
583 else { /* we're defining a value */
584 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
586 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
588 if (ckWARN(WARN_INTERNAL))
589 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
590 retsts = SS$_NOSUCHPGM;
594 eqvdsc.dsc$a_pointer = eqv;
595 eqvdsc.dsc$w_length = strlen(eqv);
596 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
597 !str$case_blind_compare(&tmpdsc,&clisym)) {
598 unsigned int symtype;
599 if (tabvec[0]->dsc$w_length == 12 &&
600 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
601 !str$case_blind_compare(&tmpdsc,&local))
602 symtype = LIB$K_CLI_LOCAL_SYM;
603 else symtype = LIB$K_CLI_GLOBAL_SYM;
604 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
607 if (!*eqv) eqvdsc.dsc$w_length = 1;
608 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
614 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
615 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
616 set_errno(EVMSERR); break;
617 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
618 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
619 set_errno(EINVAL); break;
626 set_vaxc_errno(retsts);
627 return (int) retsts || 44; /* retsts should never be 0, but just in case */
630 /* We reset error values on success because Perl does an hv_fetch()
631 * before each hv_store(), and if the thing we're setting didn't
632 * previously exist, we've got a leftover error message. (Of course,
633 * this fails in the face of
634 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
635 * in that the error reported in $! isn't spurious,
636 * but it's right more often than not.)
638 set_errno(0); set_vaxc_errno(retsts);
642 } /* end of vmssetenv() */
645 /*{{{ void my_setenv(char *lnm, char *eqv)*/
646 /* This has to be a function since there's a prototype for it in proto.h */
648 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
650 if (lnm && *lnm && strlen(lnm) == 7) {
653 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
654 if (!strcmp(uplnm,"DEFAULT")) {
655 if (eqv && *eqv) chdir(eqv);
659 (void) vmssetenv(lnm,eqv,NULL);
665 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
666 /* my_crypt - VMS password hashing
667 * my_crypt() provides an interface compatible with the Unix crypt()
668 * C library function, and uses sys$hash_password() to perform VMS
669 * password hashing. The quadword hashed password value is returned
670 * as a NUL-terminated 8 character string. my_crypt() does not change
671 * the case of its string arguments; in order to match the behavior
672 * of LOGINOUT et al., alphabetic characters in both arguments must
673 * be upcased by the caller.
676 my_crypt(const char *textpasswd, const char *usrname)
678 # ifndef UAI$C_PREFERRED_ALGORITHM
679 # define UAI$C_PREFERRED_ALGORITHM 127
681 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
682 unsigned short int salt = 0;
683 unsigned long int sts;
685 unsigned short int dsc$w_length;
686 unsigned char dsc$b_type;
687 unsigned char dsc$b_class;
688 const char * dsc$a_pointer;
689 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
690 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
691 struct itmlst_3 uailst[3] = {
692 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
693 { sizeof salt, UAI$_SALT, &salt, 0},
694 { 0, 0, NULL, NULL}};
697 usrdsc.dsc$w_length = strlen(usrname);
698 usrdsc.dsc$a_pointer = usrname;
699 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
706 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
712 if (sts != RMS$_RNF) return NULL;
715 txtdsc.dsc$w_length = strlen(textpasswd);
716 txtdsc.dsc$a_pointer = textpasswd;
717 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
718 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
721 return (char *) hash;
723 } /* end of my_crypt() */
727 static char *do_rmsexpand(char *, char *, int, char *, unsigned);
728 static char *do_fileify_dirspec(char *, char *, int);
729 static char *do_tovmsspec(char *, char *, int);
731 /*{{{int do_rmdir(char *name)*/
735 char dirfile[NAM$C_MAXRSS+1];
739 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
740 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
741 else retval = kill_file(dirfile);
744 } /* end of do_rmdir */
748 * Delete any file to which user has control access, regardless of whether
749 * delete access is explicitly allowed.
750 * Limitations: User must have write access to parent directory.
751 * Does not block signals or ASTs; if interrupted in midstream
752 * may leave file with an altered ACL.
755 /*{{{int kill_file(char *name)*/
757 kill_file(char *name)
759 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
760 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
761 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
763 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
765 unsigned char myace$b_length;
766 unsigned char myace$b_type;
767 unsigned short int myace$w_flags;
768 unsigned long int myace$l_access;
769 unsigned long int myace$l_ident;
770 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
771 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
772 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
774 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
775 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
776 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
777 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
778 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
779 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
781 /* Expand the input spec using RMS, since the CRTL remove() and
782 * system services won't do this by themselves, so we may miss
783 * a file "hiding" behind a logical name or search list. */
784 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
785 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
786 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
787 /* If not, can changing protections help? */
788 if (vaxc$errno != RMS$_PRV) return -1;
790 /* No, so we get our own UIC to use as a rights identifier,
791 * and the insert an ACE at the head of the ACL which allows us
792 * to delete the file.
794 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
795 fildsc.dsc$w_length = strlen(rspec);
796 fildsc.dsc$a_pointer = rspec;
798 newace.myace$l_ident = oldace.myace$l_ident;
799 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
804 case SS$_NOSUCHOBJECT:
805 set_errno(ENOENT); break;
807 set_errno(ENODEV); break;
809 case SS$_INVFILFOROP:
810 set_errno(EINVAL); break;
812 set_errno(EACCES); break;
816 set_vaxc_errno(aclsts);
819 /* Grab any existing ACEs with this identifier in case we fail */
820 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
821 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
822 || fndsts == SS$_NOMOREACE ) {
823 /* Add the new ACE . . . */
824 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
826 if ((rmsts = remove(name))) {
827 /* We blew it - dir with files in it, no write priv for
828 * parent directory, etc. Put things back the way they were. */
829 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
832 addlst[0].bufadr = &oldace;
833 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
840 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
841 /* We just deleted it, so of course it's not there. Some versions of
842 * VMS seem to return success on the unlock operation anyhow (after all
843 * the unlock is successful), but others don't.
845 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
846 if (aclsts & 1) aclsts = fndsts;
849 set_vaxc_errno(aclsts);
855 } /* end of kill_file() */
859 /*{{{int my_mkdir(char *,Mode_t)*/
861 my_mkdir(char *dir, Mode_t mode)
863 STRLEN dirlen = strlen(dir);
866 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
867 * null file name/type. However, it's commonplace under Unix,
868 * so we'll allow it for a gain in portability.
870 if (dir[dirlen-1] == '/') {
871 char *newdir = savepvn(dir,dirlen-1);
872 int ret = mkdir(newdir,mode);
876 else return mkdir(dir,mode);
877 } /* end of my_mkdir */
882 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
884 static unsigned long int mbxbufsiz;
885 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
890 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
891 * preprocessor consant BUFSIZ from stdio.h as the size of the
894 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
895 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
897 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
899 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
900 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
902 } /* end of create_mbx() */
904 /*{{{ my_popen and my_pclose*/
907 struct pipe_details *next;
908 PerlIO *fp; /* stdio file pointer to pipe mailbox */
909 int pid; /* PID of subprocess */
910 int mode; /* == 'r' if pipe open for reading */
911 int done; /* subprocess has completed */
912 unsigned long int completion; /* termination status of subprocess */
915 struct exit_control_block
917 struct exit_control_block *flink;
918 unsigned long int (*exit_routine)();
919 unsigned long int arg_count;
920 unsigned long int *status_address;
921 unsigned long int exit_status;
924 static struct pipe_details *open_pipes = NULL;
925 static $DESCRIPTOR(nl_desc, "NL:");
926 static int waitpid_asleep = 0;
928 /* Send an EOF to a mbx. N.B. We don't check that fp actually points
929 * to a mbx; that's the caller's responsibility.
931 static unsigned long int
932 pipe_eof(FILE *fp, int immediate)
934 char devnam[NAM$C_MAXRSS+1], *cp;
935 unsigned long int chan, iosb[2], retsts, retsts2;
936 struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
939 if (fgetname(fp,devnam,1)) {
940 /* It oughta be a mailbox, so fgetname should give just the device
941 * name, but just in case . . . */
942 if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
943 devdsc.dsc$w_length = strlen(devnam);
944 _ckvmssts(sys$assign(&devdsc,&chan,0,0));
945 retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0),
946 iosb,0,0,0,0,0,0,0,0);
947 if (retsts & 1) retsts = iosb[0];
948 retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
949 if (retsts & 1) retsts = retsts2;
953 else _ckvmssts(vaxc$errno); /* Should never happen */
954 return (unsigned long int) vaxc$errno;
957 static unsigned long int
960 struct pipe_details *info;
961 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
966 first we try sending an EOF...ignore if doesn't work, make sure we
973 if (info->mode != 'r' && !info->done) {
974 if (pipe_eof(info->fp, 1) & 1) did_stuff = 1;
978 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
983 if (!info->done) { /* Tap them gently on the shoulder . . .*/
984 sts = sys$forcex(&info->pid,0,&abort);
985 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
990 if (did_stuff) sleep(1); /* wait for them to respond */
994 if (!info->done) { /* We tried to be nice . . . */
995 sts = sys$delprc(&info->pid,0);
996 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
997 info->done = 1; /* so my_pclose doesn't try to write EOF */
1003 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1004 else if (!(sts & 1)) retsts = sts;
1009 static struct exit_control_block pipe_exitblock =
1010 {(struct exit_control_block *) 0,
1011 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1015 popen_completion_ast(struct pipe_details *thispipe)
1017 thispipe->done = TRUE;
1018 if (waitpid_asleep) {
1025 safe_popen(char *cmd, char *mode)
1027 static int handler_set_up = FALSE;
1029 unsigned short int chan;
1030 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
1032 struct pipe_details *info;
1033 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
1034 DSC$K_CLASS_S, mbxname},
1035 cmddsc = {0, DSC$K_DTYPE_T,
1039 cmddsc.dsc$w_length=strlen(cmd);
1040 cmddsc.dsc$a_pointer=cmd;
1041 if (cmddsc.dsc$w_length > 255) {
1042 set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
1046 New(1301,info,1,struct pipe_details);
1048 /* create mailbox */
1049 create_mbx(&chan,&namdsc);
1051 /* open a FILE* onto it */
1052 info->fp = PerlIO_open(mbxname, mode);
1054 /* give up other channel onto it */
1055 _ckvmssts(sys$dassgn(chan));
1065 _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
1066 0 /* name */, &info->pid, &info->completion,
1067 0, popen_completion_ast,info,0,0,0));
1070 _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
1071 0 /* name */, &info->pid, &info->completion,
1072 0, popen_completion_ast,info,0,0,0));
1075 if (!handler_set_up) {
1076 _ckvmssts(sys$dclexh(&pipe_exitblock));
1077 handler_set_up = TRUE;
1079 info->next=open_pipes; /* prepend to list */
1082 PL_forkprocess = info->pid;
1084 } /* end of safe_popen */
1087 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
1089 Perl_my_popen(pTHX_ char *cmd, char *mode)
1092 TAINT_PROPER("popen");
1093 PERL_FLUSHALL_FOR_CHILD;
1094 return safe_popen(cmd,mode);
1099 /*{{{ I32 my_pclose(FILE *fp)*/
1100 I32 Perl_my_pclose(pTHX_ FILE *fp)
1102 struct pipe_details *info, *last = NULL;
1103 unsigned long int retsts;
1105 for (info = open_pipes; info != NULL; last = info, info = info->next)
1106 if (info->fp == fp) break;
1108 if (info == NULL) { /* no such pipe open */
1109 set_errno(ECHILD); /* quoth POSIX */
1110 set_vaxc_errno(SS$_NONEXPR);
1114 /* If we were writing to a subprocess, insure that someone reading from
1115 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1116 * produce an EOF record in the mailbox. */
1117 if (info->mode != 'r' && !info->done) pipe_eof(info->fp,0);
1118 PerlIO_close(info->fp);
1120 if (info->done) retsts = info->completion;
1121 else waitpid(info->pid,(int *) &retsts,0);
1123 /* remove from list of open pipes */
1124 if (last) last->next = info->next;
1125 else open_pipes = info->next;
1130 } /* end of my_pclose() */
1132 /* sort-of waitpid; use only with popen() */
1133 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
1135 my_waitpid(Pid_t pid, int *statusp, int flags)
1137 struct pipe_details *info;
1140 for (info = open_pipes; info != NULL; info = info->next)
1141 if (info->pid == pid) break;
1143 if (info != NULL) { /* we know about this child */
1144 while (!info->done) {
1149 *statusp = info->completion;
1152 else { /* we haven't heard of this child */
1153 $DESCRIPTOR(intdsc,"0 00:00:01");
1154 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
1155 unsigned long int interval[2],sts;
1157 if (ckWARN(WARN_EXEC)) {
1158 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
1159 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
1160 if (ownerpid != mypid)
1161 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
1164 _ckvmssts(sys$bintim(&intdsc,interval));
1165 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
1166 _ckvmssts(sys$schdwk(0,0,interval,0));
1167 _ckvmssts(sys$hiber());
1171 /* There's no easy way to find the termination status a child we're
1172 * not aware of beforehand. If we're really interested in the future,
1173 * we can go looking for a termination mailbox, or chase after the
1174 * accounting record for the process.
1180 } /* end of waitpid() */
1185 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
1187 my_gconvert(double val, int ndig, int trail, char *buf)
1189 static char __gcvtbuf[DBL_DIG+1];
1192 loc = buf ? buf : __gcvtbuf;
1194 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
1196 sprintf(loc,"%.*g",ndig,val);
1202 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
1203 return gcvt(val,ndig,loc);
1206 loc[0] = '0'; loc[1] = '\0';
1214 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
1215 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
1216 * to expand file specification. Allows for a single default file
1217 * specification and a simple mask of options. If outbuf is non-NULL,
1218 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
1219 * the resultant file specification is placed. If outbuf is NULL, the
1220 * resultant file specification is placed into a static buffer.
1221 * The third argument, if non-NULL, is taken to be a default file
1222 * specification string. The fourth argument is unused at present.
1223 * rmesexpand() returns the address of the resultant string if
1224 * successful, and NULL on error.
1226 static char *do_tounixspec(char *, char *, int);
1229 do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
1231 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
1232 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
1233 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
1234 struct FAB myfab = cc$rms_fab;
1235 struct NAM mynam = cc$rms_nam;
1237 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
1239 if (!filespec || !*filespec) {
1240 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
1244 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
1245 else outbuf = __rmsexpand_retbuf;
1247 if ((isunix = (strchr(filespec,'/') != NULL))) {
1248 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
1249 filespec = vmsfspec;
1252 myfab.fab$l_fna = filespec;
1253 myfab.fab$b_fns = strlen(filespec);
1254 myfab.fab$l_nam = &mynam;
1256 if (defspec && *defspec) {
1257 if (strchr(defspec,'/') != NULL) {
1258 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
1261 myfab.fab$l_dna = defspec;
1262 myfab.fab$b_dns = strlen(defspec);
1265 mynam.nam$l_esa = esa;
1266 mynam.nam$b_ess = sizeof esa;
1267 mynam.nam$l_rsa = outbuf;
1268 mynam.nam$b_rss = NAM$C_MAXRSS;
1270 retsts = sys$parse(&myfab,0,0);
1271 if (!(retsts & 1)) {
1272 mynam.nam$b_nop |= NAM$M_SYNCHK;
1273 if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
1274 retsts == RMS$_DEV || retsts == RMS$_DEV) {
1275 retsts = sys$parse(&myfab,0,0);
1276 if (retsts & 1) goto expanded;
1278 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
1279 (void) sys$parse(&myfab,0,0); /* Free search context */
1280 if (out) Safefree(out);
1281 set_vaxc_errno(retsts);
1282 if (retsts == RMS$_PRV) set_errno(EACCES);
1283 else if (retsts == RMS$_DEV) set_errno(ENODEV);
1284 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
1285 else set_errno(EVMSERR);
1288 retsts = sys$search(&myfab,0,0);
1289 if (!(retsts & 1) && retsts != RMS$_FNF) {
1290 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1291 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1292 if (out) Safefree(out);
1293 set_vaxc_errno(retsts);
1294 if (retsts == RMS$_PRV) set_errno(EACCES);
1295 else set_errno(EVMSERR);
1299 /* If the input filespec contained any lowercase characters,
1300 * downcase the result for compatibility with Unix-minded code. */
1302 for (out = myfab.fab$l_fna; *out; out++)
1303 if (islower(*out)) { haslower = 1; break; }
1304 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
1305 else { out = esa; speclen = mynam.nam$b_esl; }
1306 /* Trim off null fields added by $PARSE
1307 * If type > 1 char, must have been specified in original or default spec
1308 * (not true for version; $SEARCH may have added version of existing file).
1310 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
1311 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
1312 (mynam.nam$l_ver - mynam.nam$l_type == 1);
1313 if (trimver || trimtype) {
1314 if (defspec && *defspec) {
1315 char defesa[NAM$C_MAXRSS];
1316 struct FAB deffab = cc$rms_fab;
1317 struct NAM defnam = cc$rms_nam;
1319 deffab.fab$l_nam = &defnam;
1320 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
1321 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
1322 defnam.nam$b_nop = NAM$M_SYNCHK;
1323 if (sys$parse(&deffab,0,0) & 1) {
1324 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
1325 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
1328 if (trimver) speclen = mynam.nam$l_ver - out;
1330 /* If we didn't already trim version, copy down */
1331 if (speclen > mynam.nam$l_ver - out)
1332 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
1333 speclen - (mynam.nam$l_ver - out));
1334 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
1337 /* If we just had a directory spec on input, $PARSE "helpfully"
1338 * adds an empty name and type for us */
1339 if (mynam.nam$l_name == mynam.nam$l_type &&
1340 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
1341 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
1342 speclen = mynam.nam$l_name - out;
1343 out[speclen] = '\0';
1344 if (haslower) __mystrtolower(out);
1346 /* Have we been working with an expanded, but not resultant, spec? */
1347 /* Also, convert back to Unix syntax if necessary. */
1348 if (!mynam.nam$b_rsl) {
1350 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
1352 else strcpy(outbuf,esa);
1355 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
1356 strcpy(outbuf,tmpfspec);
1358 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
1359 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
1360 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
1364 /* External entry points */
1365 char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
1366 { return do_rmsexpand(spec,buf,0,def,opt); }
1367 char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
1368 { return do_rmsexpand(spec,buf,1,def,opt); }
1372 ** The following routines are provided to make life easier when
1373 ** converting among VMS-style and Unix-style directory specifications.
1374 ** All will take input specifications in either VMS or Unix syntax. On
1375 ** failure, all return NULL. If successful, the routines listed below
1376 ** return a pointer to a buffer containing the appropriately
1377 ** reformatted spec (and, therefore, subsequent calls to that routine
1378 ** will clobber the result), while the routines of the same names with
1379 ** a _ts suffix appended will return a pointer to a mallocd string
1380 ** containing the appropriately reformatted spec.
1381 ** In all cases, only explicit syntax is altered; no check is made that
1382 ** the resulting string is valid or that the directory in question
1385 ** fileify_dirspec() - convert a directory spec into the name of the
1386 ** directory file (i.e. what you can stat() to see if it's a dir).
1387 ** The style (VMS or Unix) of the result is the same as the style
1388 ** of the parameter passed in.
1389 ** pathify_dirspec() - convert a directory spec into a path (i.e.
1390 ** what you prepend to a filename to indicate what directory it's in).
1391 ** The style (VMS or Unix) of the result is the same as the style
1392 ** of the parameter passed in.
1393 ** tounixpath() - convert a directory spec into a Unix-style path.
1394 ** tovmspath() - convert a directory spec into a VMS-style path.
1395 ** tounixspec() - convert any file spec into a Unix-style file spec.
1396 ** tovmsspec() - convert any file spec into a VMS-style spec.
1398 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
1399 ** Permission is given to distribute this code as part of the Perl
1400 ** standard distribution under the terms of the GNU General Public
1401 ** License or the Perl Artistic License. Copies of each may be
1402 ** found in the Perl standard distribution.
1405 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
1406 static char *do_fileify_dirspec(char *dir,char *buf,int ts)
1408 static char __fileify_retbuf[NAM$C_MAXRSS+1];
1409 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
1410 char *retspec, *cp1, *cp2, *lastdir;
1411 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
1413 if (!dir || !*dir) {
1414 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1416 dirlen = strlen(dir);
1417 while (dir[dirlen-1] == '/') --dirlen;
1418 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
1419 strcpy(trndir,"/sys$disk/000000");
1423 if (dirlen > NAM$C_MAXRSS) {
1424 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
1426 if (!strpbrk(dir+1,"/]>:")) {
1427 strcpy(trndir,*dir == '/' ? dir + 1: dir);
1428 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
1430 dirlen = strlen(dir);
1433 strncpy(trndir,dir,dirlen);
1434 trndir[dirlen] = '\0';
1437 /* If we were handed a rooted logical name or spec, treat it like a
1438 * simple directory, so that
1439 * $ Define myroot dev:[dir.]
1440 * ... do_fileify_dirspec("myroot",buf,1) ...
1441 * does something useful.
1443 if (!strcmp(dir+dirlen-2,".]")) {
1444 dir[--dirlen] = '\0';
1445 dir[dirlen-1] = ']';
1448 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
1449 /* If we've got an explicit filename, we can just shuffle the string. */
1450 if (*(cp1+1)) hasfilename = 1;
1451 /* Similarly, we can just back up a level if we've got multiple levels
1452 of explicit directories in a VMS spec which ends with directories. */
1454 for (cp2 = cp1; cp2 > dir; cp2--) {
1456 *cp2 = *cp1; *cp1 = '\0';
1460 if (*cp2 == '[' || *cp2 == '<') break;
1465 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
1466 if (dir[0] == '.') {
1467 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
1468 return do_fileify_dirspec("[]",buf,ts);
1469 else if (dir[1] == '.' &&
1470 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
1471 return do_fileify_dirspec("[-]",buf,ts);
1473 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
1474 dirlen -= 1; /* to last element */
1475 lastdir = strrchr(dir,'/');
1477 else if ((cp1 = strstr(dir,"/.")) != NULL) {
1478 /* If we have "/." or "/..", VMSify it and let the VMS code
1479 * below expand it, rather than repeating the code to handle
1480 * relative components of a filespec here */
1482 if (*(cp1+2) == '.') cp1++;
1483 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
1484 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1485 if (strchr(vmsdir,'/') != NULL) {
1486 /* If do_tovmsspec() returned it, it must have VMS syntax
1487 * delimiters in it, so it's a mixed VMS/Unix spec. We take
1488 * the time to check this here only so we avoid a recursion
1489 * loop; otherwise, gigo.
1491 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
1493 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1494 return do_tounixspec(trndir,buf,ts);
1497 } while ((cp1 = strstr(cp1,"/.")) != NULL);
1498 lastdir = strrchr(dir,'/');
1500 else if (!strcmp(&dir[dirlen-7],"/000000")) {
1501 /* Ditto for specs that end in an MFD -- let the VMS code
1502 * figure out whether it's a real device or a rooted logical. */
1503 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
1504 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
1505 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
1506 return do_tounixspec(trndir,buf,ts);
1509 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
1510 !(lastdir = cp1 = strrchr(dir,']')) &&
1511 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
1512 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
1514 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1515 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1516 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1517 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1518 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1519 (ver || *cp3)))))) {
1521 set_vaxc_errno(RMS$_DIR);
1527 /* If we lead off with a device or rooted logical, add the MFD
1528 if we're specifying a top-level directory. */
1529 if (lastdir && *dir == '/') {
1531 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
1538 retlen = dirlen + (addmfd ? 13 : 6);
1539 if (buf) retspec = buf;
1540 else if (ts) New(1309,retspec,retlen+1,char);
1541 else retspec = __fileify_retbuf;
1543 dirlen = lastdir - dir;
1544 memcpy(retspec,dir,dirlen);
1545 strcpy(&retspec[dirlen],"/000000");
1546 strcpy(&retspec[dirlen+7],lastdir);
1549 memcpy(retspec,dir,dirlen);
1550 retspec[dirlen] = '\0';
1552 /* We've picked up everything up to the directory file name.
1553 Now just add the type and version, and we're set. */
1554 strcat(retspec,".dir;1");
1557 else { /* VMS-style directory spec */
1558 char esa[NAM$C_MAXRSS+1], term, *cp;
1559 unsigned long int sts, cmplen, haslower = 0;
1560 struct FAB dirfab = cc$rms_fab;
1561 struct NAM savnam, dirnam = cc$rms_nam;
1563 dirfab.fab$b_fns = strlen(dir);
1564 dirfab.fab$l_fna = dir;
1565 dirfab.fab$l_nam = &dirnam;
1566 dirfab.fab$l_dna = ".DIR;1";
1567 dirfab.fab$b_dns = 6;
1568 dirnam.nam$b_ess = NAM$C_MAXRSS;
1569 dirnam.nam$l_esa = esa;
1571 for (cp = dir; *cp; cp++)
1572 if (islower(*cp)) { haslower = 1; break; }
1573 if (!((sts = sys$parse(&dirfab))&1)) {
1574 if (dirfab.fab$l_sts == RMS$_DIR) {
1575 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1576 sts = sys$parse(&dirfab) & 1;
1580 set_vaxc_errno(dirfab.fab$l_sts);
1586 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
1587 /* Yes; fake the fnb bits so we'll check type below */
1588 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
1591 if (dirfab.fab$l_sts != RMS$_FNF) {
1593 set_vaxc_errno(dirfab.fab$l_sts);
1596 dirnam = savnam; /* No; just work with potential name */
1599 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
1600 cp1 = strchr(esa,']');
1601 if (!cp1) cp1 = strchr(esa,'>');
1602 if (cp1) { /* Should always be true */
1603 dirnam.nam$b_esl -= cp1 - esa - 1;
1604 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
1607 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1608 /* Yep; check version while we're at it, if it's there. */
1609 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1610 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1611 /* Something other than .DIR[;1]. Bzzt. */
1613 set_vaxc_errno(RMS$_DIR);
1617 esa[dirnam.nam$b_esl] = '\0';
1618 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
1619 /* They provided at least the name; we added the type, if necessary, */
1620 if (buf) retspec = buf; /* in sys$parse() */
1621 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
1622 else retspec = __fileify_retbuf;
1623 strcpy(retspec,esa);
1626 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
1627 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
1629 dirnam.nam$b_esl -= 9;
1631 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
1632 if (cp1 == NULL) return NULL; /* should never happen */
1635 retlen = strlen(esa);
1636 if ((cp1 = strrchr(esa,'.')) != NULL) {
1637 /* There's more than one directory in the path. Just roll back. */
1639 if (buf) retspec = buf;
1640 else if (ts) New(1311,retspec,retlen+7,char);
1641 else retspec = __fileify_retbuf;
1642 strcpy(retspec,esa);
1645 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
1646 /* Go back and expand rooted logical name */
1647 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
1648 if (!(sys$parse(&dirfab) & 1)) {
1650 set_vaxc_errno(dirfab.fab$l_sts);
1653 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
1654 if (buf) retspec = buf;
1655 else if (ts) New(1312,retspec,retlen+16,char);
1656 else retspec = __fileify_retbuf;
1657 cp1 = strstr(esa,"][");
1659 memcpy(retspec,esa,dirlen);
1660 if (!strncmp(cp1+2,"000000]",7)) {
1661 retspec[dirlen-1] = '\0';
1662 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1663 if (*cp1 == '.') *cp1 = ']';
1665 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1666 memcpy(cp1+1,"000000]",7);
1670 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
1671 retspec[retlen] = '\0';
1672 /* Convert last '.' to ']' */
1673 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
1674 if (*cp1 == '.') *cp1 = ']';
1676 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
1677 memcpy(cp1+1,"000000]",7);
1681 else { /* This is a top-level dir. Add the MFD to the path. */
1682 if (buf) retspec = buf;
1683 else if (ts) New(1312,retspec,retlen+16,char);
1684 else retspec = __fileify_retbuf;
1687 while (*cp1 != ':') *(cp2++) = *(cp1++);
1688 strcpy(cp2,":[000000]");
1693 /* We've set up the string up through the filename. Add the
1694 type and version, and we're done. */
1695 strcat(retspec,".DIR;1");
1697 /* $PARSE may have upcased filespec, so convert output to lower
1698 * case if input contained any lowercase characters. */
1699 if (haslower) __mystrtolower(retspec);
1702 } /* end of do_fileify_dirspec() */
1704 /* External entry points */
1705 char *fileify_dirspec(char *dir, char *buf)
1706 { return do_fileify_dirspec(dir,buf,0); }
1707 char *fileify_dirspec_ts(char *dir, char *buf)
1708 { return do_fileify_dirspec(dir,buf,1); }
1710 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
1711 static char *do_pathify_dirspec(char *dir,char *buf, int ts)
1713 static char __pathify_retbuf[NAM$C_MAXRSS+1];
1714 unsigned long int retlen;
1715 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
1717 if (!dir || !*dir) {
1718 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
1721 if (*dir) strcpy(trndir,dir);
1722 else getcwd(trndir,sizeof trndir - 1);
1724 while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir,0)) {
1725 STRLEN trnlen = strlen(trndir);
1727 /* Trap simple rooted lnms, and return lnm:[000000] */
1728 if (!strcmp(trndir+trnlen-2,".]")) {
1729 if (buf) retpath = buf;
1730 else if (ts) New(1318,retpath,strlen(dir)+10,char);
1731 else retpath = __pathify_retbuf;
1732 strcpy(retpath,dir);
1733 strcat(retpath,":[000000]");
1739 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
1740 if (*dir == '.' && (*(dir+1) == '\0' ||
1741 (*(dir+1) == '.' && *(dir+2) == '\0')))
1742 retlen = 2 + (*(dir+1) != '\0');
1744 if ( !(cp1 = strrchr(dir,'/')) &&
1745 !(cp1 = strrchr(dir,']')) &&
1746 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
1747 if ((cp2 = strchr(cp1,'.')) != NULL &&
1748 (*(cp2-1) != '/' || /* Trailing '.', '..', */
1749 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
1750 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
1751 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
1753 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1754 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1755 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1756 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1757 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1758 (ver || *cp3)))))) {
1760 set_vaxc_errno(RMS$_DIR);
1763 retlen = cp2 - dir + 1;
1765 else { /* No file type present. Treat the filename as a directory. */
1766 retlen = strlen(dir) + 1;
1769 if (buf) retpath = buf;
1770 else if (ts) New(1313,retpath,retlen+1,char);
1771 else retpath = __pathify_retbuf;
1772 strncpy(retpath,dir,retlen-1);
1773 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
1774 retpath[retlen-1] = '/'; /* with '/', add it. */
1775 retpath[retlen] = '\0';
1777 else retpath[retlen-1] = '\0';
1779 else { /* VMS-style directory spec */
1780 char esa[NAM$C_MAXRSS+1], *cp;
1781 unsigned long int sts, cmplen, haslower;
1782 struct FAB dirfab = cc$rms_fab;
1783 struct NAM savnam, dirnam = cc$rms_nam;
1785 /* If we've got an explicit filename, we can just shuffle the string. */
1786 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
1787 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
1788 if ((cp2 = strchr(cp1,'.')) != NULL) {
1790 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
1791 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
1792 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
1793 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
1794 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
1795 (ver || *cp3)))))) {
1797 set_vaxc_errno(RMS$_DIR);
1801 else { /* No file type, so just draw name into directory part */
1802 for (cp2 = cp1; *cp2; cp2++) ;
1805 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
1807 /* We've now got a VMS 'path'; fall through */
1809 dirfab.fab$b_fns = strlen(dir);
1810 dirfab.fab$l_fna = dir;
1811 if (dir[dirfab.fab$b_fns-1] == ']' ||
1812 dir[dirfab.fab$b_fns-1] == '>' ||
1813 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
1814 if (buf) retpath = buf;
1815 else if (ts) New(1314,retpath,strlen(dir)+1,char);
1816 else retpath = __pathify_retbuf;
1817 strcpy(retpath,dir);
1820 dirfab.fab$l_dna = ".DIR;1";
1821 dirfab.fab$b_dns = 6;
1822 dirfab.fab$l_nam = &dirnam;
1823 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
1824 dirnam.nam$l_esa = esa;
1826 for (cp = dir; *cp; cp++)
1827 if (islower(*cp)) { haslower = 1; break; }
1829 if (!(sts = (sys$parse(&dirfab)&1))) {
1830 if (dirfab.fab$l_sts == RMS$_DIR) {
1831 dirnam.nam$b_nop |= NAM$M_SYNCHK;
1832 sts = sys$parse(&dirfab) & 1;
1836 set_vaxc_errno(dirfab.fab$l_sts);
1842 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
1843 if (dirfab.fab$l_sts != RMS$_FNF) {
1845 set_vaxc_errno(dirfab.fab$l_sts);
1848 dirnam = savnam; /* No; just work with potential name */
1851 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
1852 /* Yep; check version while we're at it, if it's there. */
1853 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
1854 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
1855 /* Something other than .DIR[;1]. Bzzt. */
1857 set_vaxc_errno(RMS$_DIR);
1861 /* OK, the type was fine. Now pull any file name into the
1863 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
1865 cp1 = strrchr(esa,'>');
1866 *dirnam.nam$l_type = '>';
1869 *(dirnam.nam$l_type + 1) = '\0';
1870 retlen = dirnam.nam$l_type - esa + 2;
1871 if (buf) retpath = buf;
1872 else if (ts) New(1314,retpath,retlen,char);
1873 else retpath = __pathify_retbuf;
1874 strcpy(retpath,esa);
1875 /* $PARSE may have upcased filespec, so convert output to lower
1876 * case if input contained any lowercase characters. */
1877 if (haslower) __mystrtolower(retpath);
1881 } /* end of do_pathify_dirspec() */
1883 /* External entry points */
1884 char *pathify_dirspec(char *dir, char *buf)
1885 { return do_pathify_dirspec(dir,buf,0); }
1886 char *pathify_dirspec_ts(char *dir, char *buf)
1887 { return do_pathify_dirspec(dir,buf,1); }
1889 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
1890 static char *do_tounixspec(char *spec, char *buf, int ts)
1892 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
1893 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
1894 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
1896 if (spec == NULL) return NULL;
1897 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
1898 if (buf) rslt = buf;
1900 retlen = strlen(spec);
1901 cp1 = strchr(spec,'[');
1902 if (!cp1) cp1 = strchr(spec,'<');
1904 for (cp1++; *cp1; cp1++) {
1905 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
1906 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
1907 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
1910 New(1315,rslt,retlen+2+2*expand,char);
1912 else rslt = __tounixspec_retbuf;
1913 if (strchr(spec,'/') != NULL) {
1920 dirend = strrchr(spec,']');
1921 if (dirend == NULL) dirend = strrchr(spec,'>');
1922 if (dirend == NULL) dirend = strchr(spec,':');
1923 if (dirend == NULL) {
1927 if (*cp2 != '[' && *cp2 != '<') {
1930 else { /* the VMS spec begins with directories */
1932 if (*cp2 == ']' || *cp2 == '>') {
1933 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
1936 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
1937 if (getcwd(tmp,sizeof tmp,1) == NULL) {
1938 if (ts) Safefree(rslt);
1943 while (*cp3 != ':' && *cp3) cp3++;
1945 if (strchr(cp3,']') != NULL) break;
1946 } while (vmstrnenv(tmp,tmp,0,fildev,0));
1948 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
1949 retlen = devlen + dirlen;
1950 Renew(rslt,retlen+1+2*expand,char);
1956 *(cp1++) = *(cp3++);
1957 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
1961 else if ( *cp2 == '.') {
1962 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
1963 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1969 for (; cp2 <= dirend; cp2++) {
1972 if (*(cp2+1) == '[') cp2++;
1974 else if (*cp2 == ']' || *cp2 == '>') {
1975 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
1977 else if (*cp2 == '.') {
1979 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
1980 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
1981 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
1982 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
1983 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
1985 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
1986 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
1990 else if (*cp2 == '-') {
1991 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
1992 while (*cp2 == '-') {
1994 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
1996 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
1997 if (ts) Safefree(rslt); /* filespecs like */
1998 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
2002 else *(cp1++) = *cp2;
2004 else *(cp1++) = *cp2;
2006 while (*cp2) *(cp1++) = *(cp2++);
2011 } /* end of do_tounixspec() */
2013 /* External entry points */
2014 char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
2015 char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
2017 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
2018 static char *do_tovmsspec(char *path, char *buf, int ts) {
2019 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
2020 char *rslt, *dirend;
2021 register char *cp1, *cp2;
2022 unsigned long int infront = 0, hasdir = 1;
2024 if (path == NULL) return NULL;
2025 if (buf) rslt = buf;
2026 else if (ts) New(1316,rslt,strlen(path)+9,char);
2027 else rslt = __tovmsspec_retbuf;
2028 if (strpbrk(path,"]:>") ||
2029 (dirend = strrchr(path,'/')) == NULL) {
2030 if (path[0] == '.') {
2031 if (path[1] == '\0') strcpy(rslt,"[]");
2032 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
2033 else strcpy(rslt,path); /* probably garbage */
2035 else strcpy(rslt,path);
2038 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
2039 if (!*(dirend+2)) dirend +=2;
2040 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
2041 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
2046 char trndev[NAM$C_MAXRSS+1];
2050 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
2052 if (!buf & ts) Renew(rslt,18,char);
2053 strcpy(rslt,"sys$disk:[000000]");
2056 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
2058 islnm = my_trnlnm(rslt,trndev,0);
2059 trnend = islnm ? strlen(trndev) - 1 : 0;
2060 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
2061 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
2062 /* If the first element of the path is a logical name, determine
2063 * whether it has to be translated so we can add more directories. */
2064 if (!islnm || rooted) {
2067 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
2071 if (cp2 != dirend) {
2072 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
2073 strcpy(rslt,trndev);
2074 cp1 = rslt + trnend;
2087 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
2088 cp2 += 2; /* skip over "./" - it's redundant */
2089 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
2091 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2092 *(cp1++) = '-'; /* "../" --> "-" */
2095 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
2096 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
2097 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2098 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
2101 if (cp2 > dirend) cp2 = dirend;
2103 else *(cp1++) = '.';
2105 for (; cp2 < dirend; cp2++) {
2107 if (*(cp2-1) == '/') continue;
2108 if (*(cp1-1) != '.') *(cp1++) = '.';
2111 else if (!infront && *cp2 == '.') {
2112 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
2113 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
2114 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
2115 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
2116 else if (*(cp1-2) == '[') *(cp1-1) = '-';
2117 else { /* back up over previous directory name */
2119 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
2120 if (*(cp1-1) == '[') {
2121 memcpy(cp1,"000000.",7);
2126 if (cp2 == dirend) break;
2128 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
2129 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
2130 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
2131 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
2133 *(cp1++) = '.'; /* Simulate trailing '/' */
2134 cp2 += 2; /* for loop will incr this to == dirend */
2136 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
2138 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
2141 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
2142 if (*cp2 == '.') *(cp1++) = '_';
2143 else *(cp1++) = *cp2;
2147 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
2148 if (hasdir) *(cp1++) = ']';
2149 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
2150 while (*cp2) *(cp1++) = *(cp2++);
2155 } /* end of do_tovmsspec() */
2157 /* External entry points */
2158 char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
2159 char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
2161 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
2162 static char *do_tovmspath(char *path, char *buf, int ts) {
2163 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
2165 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
2167 if (path == NULL) return NULL;
2168 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2169 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
2170 if (buf) return buf;
2172 vmslen = strlen(vmsified);
2173 New(1317,cp,vmslen+1,char);
2174 memcpy(cp,vmsified,vmslen);
2179 strcpy(__tovmspath_retbuf,vmsified);
2180 return __tovmspath_retbuf;
2183 } /* end of do_tovmspath() */
2185 /* External entry points */
2186 char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
2187 char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
2190 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
2191 static char *do_tounixpath(char *path, char *buf, int ts) {
2192 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
2194 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
2196 if (path == NULL) return NULL;
2197 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
2198 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
2199 if (buf) return buf;
2201 unixlen = strlen(unixified);
2202 New(1317,cp,unixlen+1,char);
2203 memcpy(cp,unixified,unixlen);
2208 strcpy(__tounixpath_retbuf,unixified);
2209 return __tounixpath_retbuf;
2212 } /* end of do_tounixpath() */
2214 /* External entry points */
2215 char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
2216 char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
2219 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
2221 *****************************************************************************
2223 * Copyright (C) 1989-1994 by *
2224 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
2226 * Permission is hereby granted for the reproduction of this software, *
2227 * on condition that this copyright notice is included in the reproduction, *
2228 * and that such reproduction is not for purposes of profit or material *
2231 * 27-Aug-1994 Modified for inclusion in perl5 *
2232 * by Charles Bailey bailey@newman.upenn.edu *
2233 *****************************************************************************
2237 * getredirection() is intended to aid in porting C programs
2238 * to VMS (Vax-11 C). The native VMS environment does not support
2239 * '>' and '<' I/O redirection, or command line wild card expansion,
2240 * or a command line pipe mechanism using the '|' AND background
2241 * command execution '&'. All of these capabilities are provided to any
2242 * C program which calls this procedure as the first thing in the
2244 * The piping mechanism will probably work with almost any 'filter' type
2245 * of program. With suitable modification, it may useful for other
2246 * portability problems as well.
2248 * Author: Mark Pizzolato mark@infocomm.com
2252 struct list_item *next;
2256 static void add_item(struct list_item **head,
2257 struct list_item **tail,
2261 static void expand_wild_cards(char *item,
2262 struct list_item **head,
2263 struct list_item **tail,
2266 static int background_process(int argc, char **argv);
2268 static void pipe_and_fork(char **cmargv);
2270 /*{{{ void getredirection(int *ac, char ***av)*/
2272 getredirection(int *ac, char ***av)
2274 * Process vms redirection arg's. Exit if any error is seen.
2275 * If getredirection() processes an argument, it is erased
2276 * from the vector. getredirection() returns a new argc and argv value.
2277 * In the event that a background command is requested (by a trailing "&"),
2278 * this routine creates a background subprocess, and simply exits the program.
2280 * Warning: do not try to simplify the code for vms. The code
2281 * presupposes that getredirection() is called before any data is
2282 * read from stdin or written to stdout.
2284 * Normal usage is as follows:
2290 * getredirection(&argc, &argv);
2294 int argc = *ac; /* Argument Count */
2295 char **argv = *av; /* Argument Vector */
2296 char *ap; /* Argument pointer */
2297 int j; /* argv[] index */
2298 int item_count = 0; /* Count of Items in List */
2299 struct list_item *list_head = 0; /* First Item in List */
2300 struct list_item *list_tail; /* Last Item in List */
2301 char *in = NULL; /* Input File Name */
2302 char *out = NULL; /* Output File Name */
2303 char *outmode = "w"; /* Mode to Open Output File */
2304 char *err = NULL; /* Error File Name */
2305 char *errmode = "w"; /* Mode to Open Error File */
2306 int cmargc = 0; /* Piped Command Arg Count */
2307 char **cmargv = NULL;/* Piped Command Arg Vector */
2310 * First handle the case where the last thing on the line ends with
2311 * a '&'. This indicates the desire for the command to be run in a
2312 * subprocess, so we satisfy that desire.
2315 if (0 == strcmp("&", ap))
2316 exit(background_process(--argc, argv));
2317 if (*ap && '&' == ap[strlen(ap)-1])
2319 ap[strlen(ap)-1] = '\0';
2320 exit(background_process(argc, argv));
2323 * Now we handle the general redirection cases that involve '>', '>>',
2324 * '<', and pipes '|'.
2326 for (j = 0; j < argc; ++j)
2328 if (0 == strcmp("<", argv[j]))
2332 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
2333 exit(LIB$_WRONUMARG);
2338 if ('<' == *(ap = argv[j]))
2343 if (0 == strcmp(">", ap))
2347 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
2348 exit(LIB$_WRONUMARG);
2367 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
2368 exit(LIB$_WRONUMARG);
2372 if (('2' == *ap) && ('>' == ap[1]))
2389 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
2390 exit(LIB$_WRONUMARG);
2394 if (0 == strcmp("|", argv[j]))
2398 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
2399 exit(LIB$_WRONUMARG);
2401 cmargc = argc-(j+1);
2402 cmargv = &argv[j+1];
2406 if ('|' == *(ap = argv[j]))
2414 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
2417 * Allocate and fill in the new argument vector, Some Unix's terminate
2418 * the list with an extra null pointer.
2420 New(1302, argv, item_count+1, char *);
2422 for (j = 0; j < item_count; ++j, list_head = list_head->next)
2423 argv[j] = list_head->value;
2429 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
2430 exit(LIB$_INVARGORD);
2432 pipe_and_fork(cmargv);
2435 /* Check for input from a pipe (mailbox) */
2437 if (in == NULL && 1 == isapipe(0))
2439 char mbxname[L_tmpnam];
2441 long int dvi_item = DVI$_DEVBUFSIZ;
2442 $DESCRIPTOR(mbxnam, "");
2443 $DESCRIPTOR(mbxdevnam, "");
2445 /* Input from a pipe, reopen it in binary mode to disable */
2446 /* carriage control processing. */
2448 PerlIO_getname(stdin, mbxname);
2449 mbxnam.dsc$a_pointer = mbxname;
2450 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
2451 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
2452 mbxdevnam.dsc$a_pointer = mbxname;
2453 mbxdevnam.dsc$w_length = sizeof(mbxname);
2454 dvi_item = DVI$_DEVNAM;
2455 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
2456 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
2459 freopen(mbxname, "rb", stdin);
2462 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
2466 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
2468 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
2471 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
2473 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
2478 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
2480 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
2484 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
2489 #ifdef ARGPROC_DEBUG
2490 PerlIO_printf(Perl_debug_log, "Arglist:\n");
2491 for (j = 0; j < *ac; ++j)
2492 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
2494 /* Clear errors we may have hit expanding wildcards, so they don't
2495 show up in Perl's $! later */
2496 set_errno(0); set_vaxc_errno(1);
2497 } /* end of getredirection() */
2500 static void add_item(struct list_item **head,
2501 struct list_item **tail,
2507 New(1303,*head,1,struct list_item);
2511 New(1304,(*tail)->next,1,struct list_item);
2512 *tail = (*tail)->next;
2514 (*tail)->value = value;
2518 static void expand_wild_cards(char *item,
2519 struct list_item **head,
2520 struct list_item **tail,
2524 unsigned long int context = 0;
2530 char vmsspec[NAM$C_MAXRSS+1];
2531 $DESCRIPTOR(filespec, "");
2532 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
2533 $DESCRIPTOR(resultspec, "");
2534 unsigned long int zero = 0, sts;
2536 for (cp = item; *cp; cp++) {
2537 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
2538 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
2540 if (!*cp || isspace(*cp))
2542 add_item(head, tail, item, count);
2545 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
2546 resultspec.dsc$b_class = DSC$K_CLASS_D;
2547 resultspec.dsc$a_pointer = NULL;
2548 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
2549 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
2550 if (!isunix || !filespec.dsc$a_pointer)
2551 filespec.dsc$a_pointer = item;
2552 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
2554 * Only return version specs, if the caller specified a version
2556 had_version = strchr(item, ';');
2558 * Only return device and directory specs, if the caller specifed either.
2560 had_device = strchr(item, ':');
2561 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
2563 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
2564 &defaultspec, 0, 0, &zero))))
2569 New(1305,string,resultspec.dsc$w_length+1,char);
2570 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
2571 string[resultspec.dsc$w_length] = '\0';
2572 if (NULL == had_version)
2573 *((char *)strrchr(string, ';')) = '\0';
2574 if ((!had_directory) && (had_device == NULL))
2576 if (NULL == (devdir = strrchr(string, ']')))
2577 devdir = strrchr(string, '>');
2578 strcpy(string, devdir + 1);
2581 * Be consistent with what the C RTL has already done to the rest of
2582 * the argv items and lowercase all of these names.
2584 for (c = string; *c; ++c)
2587 if (isunix) trim_unixpath(string,item,1);
2588 add_item(head, tail, string, count);
2591 if (sts != RMS$_NMF)
2593 set_vaxc_errno(sts);
2599 set_errno(ENOENT); break;
2601 set_errno(ENODEV); break;
2604 set_errno(EINVAL); break;
2606 set_errno(EACCES); break;
2608 _ckvmssts_noperl(sts);
2612 add_item(head, tail, item, count);
2613 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
2614 _ckvmssts_noperl(lib$find_file_end(&context));
2617 static int child_st[2];/* Event Flag set when child process completes */
2619 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
2621 static unsigned long int exit_handler(int *status)
2625 if (0 == child_st[0])
2627 #ifdef ARGPROC_DEBUG
2628 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
2630 fflush(stdout); /* Have to flush pipe for binary data to */
2631 /* terminate properly -- <tp@mccall.com> */
2632 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
2633 sys$dassgn(child_chan);
2635 sys$synch(0, child_st);
2640 static void sig_child(int chan)
2642 #ifdef ARGPROC_DEBUG
2643 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
2645 if (child_st[0] == 0)
2649 static struct exit_control_block exit_block =
2654 &exit_block.exit_status,
2658 static void pipe_and_fork(char **cmargv)
2661 $DESCRIPTOR(cmddsc, "");
2662 static char mbxname[64];
2663 $DESCRIPTOR(mbxdsc, mbxname);
2665 unsigned long int zero = 0, one = 1;
2667 strcpy(subcmd, cmargv[0]);
2668 for (j = 1; NULL != cmargv[j]; ++j)
2670 strcat(subcmd, " \"");
2671 strcat(subcmd, cmargv[j]);
2672 strcat(subcmd, "\"");
2674 cmddsc.dsc$a_pointer = subcmd;
2675 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
2677 create_mbx(&child_chan,&mbxdsc);
2678 #ifdef ARGPROC_DEBUG
2679 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
2680 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
2682 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
2683 0, &pid, child_st, &zero, sig_child,
2685 #ifdef ARGPROC_DEBUG
2686 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
2688 sys$dclexh(&exit_block);
2689 if (NULL == freopen(mbxname, "wb", stdout))
2691 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
2695 static int background_process(int argc, char **argv)
2697 char command[2048] = "$";
2698 $DESCRIPTOR(value, "");
2699 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
2700 static $DESCRIPTOR(null, "NLA0:");
2701 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
2703 $DESCRIPTOR(pidstr, "");
2705 unsigned long int flags = 17, one = 1, retsts;
2707 strcat(command, argv[0]);
2710 strcat(command, " \"");
2711 strcat(command, *(++argv));
2712 strcat(command, "\"");
2714 value.dsc$a_pointer = command;
2715 value.dsc$w_length = strlen(value.dsc$a_pointer);
2716 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
2717 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
2718 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
2719 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
2722 _ckvmssts_noperl(retsts);
2724 #ifdef ARGPROC_DEBUG
2725 PerlIO_printf(Perl_debug_log, "%s\n", command);
2727 sprintf(pidstring, "%08X", pid);
2728 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
2729 pidstr.dsc$a_pointer = pidstring;
2730 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
2731 lib$set_symbol(&pidsymbol, &pidstr);
2735 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
2738 /* OS-specific initialization at image activation (not thread startup) */
2739 /* Older VAXC header files lack these constants */
2740 #ifndef JPI$_RIGHTS_SIZE
2741 # define JPI$_RIGHTS_SIZE 817
2743 #ifndef KGB$M_SUBSYSTEM
2744 # define KGB$M_SUBSYSTEM 0x8
2747 /*{{{void vms_image_init(int *, char ***)*/
2749 vms_image_init(int *argcp, char ***argvp)
2751 char eqv[LNM$C_NAMLENGTH+1] = "";
2752 unsigned int len, tabct = 8, tabidx = 0;
2753 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
2754 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
2755 unsigned short int dummy, rlen;
2756 struct dsc$descriptor_s **tabvec;
2758 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
2759 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
2760 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
2763 _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
2765 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
2766 if (iprv[i]) { /* Running image installed with privs? */
2767 _ckvmssts(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
2772 /* Rights identifiers might trigger tainting as well. */
2773 if (!will_taint && (rlen || rsz)) {
2774 while (rlen < rsz) {
2775 /* We didn't get all the identifiers on the first pass. Allocate a
2776 * buffer much larger than $GETJPI wants (rsz is size in bytes that
2777 * were needed to hold all identifiers at time of last call; we'll
2778 * allocate that many unsigned long ints), and go back and get 'em.
2780 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
2781 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
2782 jpilist[1].buflen = rsz * sizeof(unsigned long int);
2783 _ckvmssts(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
2786 mask = jpilist[1].bufadr;
2787 /* Check attribute flags for each identifier (2nd longword); protected
2788 * subsystem identifiers trigger tainting.
2790 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
2791 if (mask[i] & KGB$M_SUBSYSTEM) {
2796 if (mask != rlst) Safefree(mask);
2798 /* We need to use this hack to tell Perl it should run with tainting,
2799 * since its tainting flag may be part of the PL_curinterp struct, which
2800 * hasn't been allocated when vms_image_init() is called.
2804 New(1320,newap,*argcp+2,char **);
2805 newap[0] = argvp[0];
2807 Copy(argvp[1],newap[2],*argcp-1,char **);
2808 /* We orphan the old argv, since we don't know where it's come from,
2809 * so we don't know how to free it.
2811 *argcp++; argvp = newap;
2813 else { /* Did user explicitly request tainting? */
2815 char *cp, **av = *argvp;
2816 for (i = 1; i < *argcp; i++) {
2817 if (*av[i] != '-') break;
2818 for (cp = av[i]+1; *cp; cp++) {
2819 if (*cp == 'T') { will_taint = 1; break; }
2820 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
2821 strchr("DFIiMmx",*cp)) break;
2823 if (will_taint) break;
2828 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
2830 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
2831 else if (tabidx >= tabct) {
2833 Renew(tabvec,tabct,struct dsc$descriptor_s *);
2835 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
2836 tabvec[tabidx]->dsc$w_length = 0;
2837 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
2838 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
2839 tabvec[tabidx]->dsc$a_pointer = NULL;
2840 _ckvmssts(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
2842 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
2844 getredirection(argcp,argvp);
2845 #if defined(USE_THREADS) && defined(__DECC)
2847 # include <reentrancy.h>
2848 (void) decc$set_reentrancy(C$C_MULTITHREAD);
2857 * Trim Unix-style prefix off filespec, so it looks like what a shell
2858 * glob expansion would return (i.e. from specified prefix on, not
2859 * full path). Note that returned filespec is Unix-style, regardless
2860 * of whether input filespec was VMS-style or Unix-style.
2862 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
2863 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
2864 * vector of options; at present, only bit 0 is used, and if set tells
2865 * trim unixpath to try the current default directory as a prefix when
2866 * presented with a possibly ambiguous ... wildcard.
2868 * Returns !=0 on success, with trimmed filespec replacing contents of
2869 * fspec, and 0 on failure, with contents of fpsec unchanged.
2871 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
2873 trim_unixpath(char *fspec, char *wildspec, int opts)
2875 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
2876 *template, *base, *end, *cp1, *cp2;
2877 register int tmplen, reslen = 0, dirs = 0;
2879 if (!wildspec || !fspec) return 0;
2880 if (strpbrk(wildspec,"]>:") != NULL) {
2881 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
2882 else template = unixwild;
2884 else template = wildspec;
2885 if (strpbrk(fspec,"]>:") != NULL) {
2886 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
2887 else base = unixified;
2888 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
2889 * check to see that final result fits into (isn't longer than) fspec */
2890 reslen = strlen(fspec);
2894 /* No prefix or absolute path on wildcard, so nothing to remove */
2895 if (!*template || *template == '/') {
2896 if (base == fspec) return 1;
2897 tmplen = strlen(unixified);
2898 if (tmplen > reslen) return 0; /* not enough space */
2899 /* Copy unixified resultant, including trailing NUL */
2900 memmove(fspec,unixified,tmplen+1);
2904 for (end = base; *end; end++) ; /* Find end of resultant filespec */
2905 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
2906 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
2907 for (cp1 = end ;cp1 >= base; cp1--)
2908 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
2910 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
2914 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
2915 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
2916 int ells = 1, totells, segdirs, match;
2917 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
2918 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2920 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
2922 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
2923 if (ellipsis == template && opts & 1) {
2924 /* Template begins with an ellipsis. Since we can't tell how many
2925 * directory names at the front of the resultant to keep for an
2926 * arbitrary starting point, we arbitrarily choose the current
2927 * default directory as a starting point. If it's there as a prefix,
2928 * clip it off. If not, fall through and act as if the leading
2929 * ellipsis weren't there (i.e. return shortest possible path that
2930 * could match template).
2932 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
2933 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2934 if (_tolower(*cp1) != _tolower(*cp2)) break;
2935 segdirs = dirs - totells; /* Min # of dirs we must have left */
2936 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
2937 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
2938 memcpy(fspec,cp2+1,end - cp2);
2942 /* First off, back up over constant elements at end of path */
2944 for (front = end ; front >= base; front--)
2945 if (*front == '/' && !dirs--) { front++; break; }
2947 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
2948 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
2949 if (cp1 != '\0') return 0; /* Path too long. */
2951 *cp2 = '\0'; /* Pick up with memcpy later */
2952 lcfront = lcres + (front - base);
2953 /* Now skip over each ellipsis and try to match the path in front of it. */
2955 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
2956 if (*(cp1) == '.' && *(cp1+1) == '.' &&
2957 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
2958 if (cp1 < template) break; /* template started with an ellipsis */
2959 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
2960 ellipsis = cp1; continue;
2962 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
2964 for (segdirs = 0, cp2 = tpl;
2965 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
2967 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
2968 else *cp2 = _tolower(*cp1); /* else lowercase for match */
2969 if (*cp2 == '/') segdirs++;
2971 if (cp1 != ellipsis - 1) return 0; /* Path too long */
2972 /* Back up at least as many dirs as in template before matching */
2973 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
2974 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
2975 for (match = 0; cp1 > lcres;) {
2976 resdsc.dsc$a_pointer = cp1;
2977 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
2979 if (match == 1) lcfront = cp1;
2981 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
2983 if (!match) return 0; /* Can't find prefix ??? */
2984 if (match > 1 && opts & 1) {
2985 /* This ... wildcard could cover more than one set of dirs (i.e.
2986 * a set of similar dir names is repeated). If the template
2987 * contains more than 1 ..., upstream elements could resolve the
2988 * ambiguity, but it's not worth a full backtracking setup here.
2989 * As a quick heuristic, clip off the current default directory
2990 * if it's present to find the trimmed spec, else use the
2991 * shortest string that this ... could cover.
2993 char def[NAM$C_MAXRSS+1], *st;
2995 if (getcwd(def, sizeof def,0) == NULL) return 0;
2996 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
2997 if (_tolower(*cp1) != _tolower(*cp2)) break;
2998 segdirs = dirs - totells; /* Min # of dirs we must have left */
2999 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
3000 if (*cp1 == '\0' && *cp2 == '/') {
3001 memcpy(fspec,cp2+1,end - cp2);
3004 /* Nope -- stick with lcfront from above and keep going. */
3007 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
3012 } /* end of trim_unixpath() */
3017 * VMS readdir() routines.
3018 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
3020 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
3021 * Minor modifications to original routines.
3024 /* Number of elements in vms_versions array */
3025 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
3028 * Open a directory, return a handle for later use.
3030 /*{{{ DIR *opendir(char*name) */
3035 char dir[NAM$C_MAXRSS+1];
3038 if (do_tovmspath(name,dir,0) == NULL) {
3041 if (flex_stat(dir,&sb) == -1) return NULL;
3042 if (!S_ISDIR(sb.st_mode)) {
3043 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
3046 if (!cando_by_name(S_IRUSR,0,dir)) {
3047 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
3050 /* Get memory for the handle, and the pattern. */
3052 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
3054 /* Fill in the fields; mainly playing with the descriptor. */
3055 (void)sprintf(dd->pattern, "%s*.*",dir);
3058 dd->vms_wantversions = 0;
3059 dd->pat.dsc$a_pointer = dd->pattern;
3060 dd->pat.dsc$w_length = strlen(dd->pattern);
3061 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
3062 dd->pat.dsc$b_class = DSC$K_CLASS_S;
3065 } /* end of opendir() */
3069 * Set the flag to indicate we want versions or not.
3071 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
3073 vmsreaddirversions(DIR *dd, int flag)
3075 dd->vms_wantversions = flag;
3080 * Free up an opened directory.
3082 /*{{{ void closedir(DIR *dd)*/
3086 (void)lib$find_file_end(&dd->context);
3087 Safefree(dd->pattern);
3088 Safefree((char *)dd);
3093 * Collect all the version numbers for the current file.
3099 struct dsc$descriptor_s pat;
3100 struct dsc$descriptor_s res;
3102 char *p, *text, buff[sizeof dd->entry.d_name];
3104 unsigned long context, tmpsts;
3107 /* Convenient shorthand. */
3110 /* Add the version wildcard, ignoring the "*.*" put on before */
3111 i = strlen(dd->pattern);
3112 New(1308,text,i + e->d_namlen + 3,char);
3113 (void)strcpy(text, dd->pattern);
3114 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
3116 /* Set up the pattern descriptor. */
3117 pat.dsc$a_pointer = text;
3118 pat.dsc$w_length = i + e->d_namlen - 1;
3119 pat.dsc$b_dtype = DSC$K_DTYPE_T;
3120 pat.dsc$b_class = DSC$K_CLASS_S;
3122 /* Set up result descriptor. */
3123 res.dsc$a_pointer = buff;
3124 res.dsc$w_length = sizeof buff - 2;
3125 res.dsc$b_dtype = DSC$K_DTYPE_T;
3126 res.dsc$b_class = DSC$K_CLASS_S;
3128 /* Read files, collecting versions. */
3129 for (context = 0, e->vms_verscount = 0;
3130 e->vms_verscount < VERSIZE(e);
3131 e->vms_verscount++) {
3132 tmpsts = lib$find_file(&pat, &res, &context);
3133 if (tmpsts == RMS$_NMF || context == 0) break;
3135 buff[sizeof buff - 1] = '\0';
3136 if ((p = strchr(buff, ';')))
3137 e->vms_versions[e->vms_verscount] = atoi(p + 1);
3139 e->vms_versions[e->vms_verscount] = -1;
3142 _ckvmssts(lib$find_file_end(&context));
3145 } /* end of collectversions() */
3148 * Read the next entry from the directory.
3150 /*{{{ struct dirent *readdir(DIR *dd)*/
3154 struct dsc$descriptor_s res;
3155 char *p, buff[sizeof dd->entry.d_name];
3156 unsigned long int tmpsts;
3158 /* Set up result descriptor, and get next file. */
3159 res.dsc$a_pointer = buff;
3160 res.dsc$w_length = sizeof buff - 2;
3161 res.dsc$b_dtype = DSC$K_DTYPE_T;
3162 res.dsc$b_class = DSC$K_CLASS_S;
3163 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
3164 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
3165 if (!(tmpsts & 1)) {
3166 set_vaxc_errno(tmpsts);
3169 set_errno(EACCES); break;
3171 set_errno(ENODEV); break;
3174 set_errno(ENOENT); break;
3181 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
3182 buff[sizeof buff - 1] = '\0';
3183 for (p = buff; *p; p++) *p = _tolower(*p);
3184 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
3187 /* Skip any directory component and just copy the name. */
3188 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
3189 else (void)strcpy(dd->entry.d_name, buff);
3191 /* Clobber the version. */
3192 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
3194 dd->entry.d_namlen = strlen(dd->entry.d_name);
3195 dd->entry.vms_verscount = 0;
3196 if (dd->vms_wantversions) collectversions(dd);
3199 } /* end of readdir() */
3203 * Return something that can be used in a seekdir later.
3205 /*{{{ long telldir(DIR *dd)*/
3214 * Return to a spot where we used to be. Brute force.
3216 /*{{{ void seekdir(DIR *dd,long count)*/
3218 seekdir(DIR *dd, long count)
3220 int vms_wantversions;
3223 /* If we haven't done anything yet... */
3227 /* Remember some state, and clear it. */
3228 vms_wantversions = dd->vms_wantversions;
3229 dd->vms_wantversions = 0;
3230 _ckvmssts(lib$find_file_end(&dd->context));
3233 /* The increment is in readdir(). */
3234 for (dd->count = 0; dd->count < count; )
3237 dd->vms_wantversions = vms_wantversions;
3239 } /* end of seekdir() */
3242 /* VMS subprocess management
3244 * my_vfork() - just a vfork(), after setting a flag to record that
3245 * the current script is trying a Unix-style fork/exec.
3247 * vms_do_aexec() and vms_do_exec() are called in response to the
3248 * perl 'exec' function. If this follows a vfork call, then they
3249 * call out the the regular perl routines in doio.c which do an
3250 * execvp (for those who really want to try this under VMS).
3251 * Otherwise, they do exactly what the perl docs say exec should
3252 * do - terminate the current script and invoke a new command
3253 * (See below for notes on command syntax.)
3255 * do_aspawn() and do_spawn() implement the VMS side of the perl
3256 * 'system' function.
3258 * Note on command arguments to perl 'exec' and 'system': When handled
3259 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
3260 * are concatenated to form a DCL command string. If the first arg
3261 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
3262 * the the command string is handed off to DCL directly. Otherwise,
3263 * the first token of the command is taken as the filespec of an image
3264 * to run. The filespec is expanded using a default type of '.EXE' and
3265 * the process defaults for device, directory, etc., and if found, the resultant
3266 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
3267 * the command string as parameters. This is perhaps a bit complicated,
3268 * but I hope it will form a happy medium between what VMS folks expect
3269 * from lib$spawn and what Unix folks expect from exec.
3272 static int vfork_called;
3274 /*{{{int my_vfork()*/
3284 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
3292 if (VMScmd.dsc$a_pointer) {
3293 Safefree(VMScmd.dsc$a_pointer);
3294 VMScmd.dsc$w_length = 0;
3295 VMScmd.dsc$a_pointer = Nullch;
3300 setup_argstr(SV *really, SV **mark, SV **sp)
3303 char *junk, *tmps = Nullch;
3304 register size_t cmdlen = 0;
3311 tmps = SvPV(really,rlen);
3318 for (idx++; idx <= sp; idx++) {
3320 junk = SvPVx(*idx,rlen);
3321 cmdlen += rlen ? rlen + 1 : 0;
3324 New(401,PL_Cmd,cmdlen+1,char);
3326 if (tmps && *tmps) {
3327 strcpy(PL_Cmd,tmps);
3330 else *PL_Cmd = '\0';
3331 while (++mark <= sp) {
3333 char *s = SvPVx(*mark,n_a);
3335 if (*PL_Cmd) strcat(PL_Cmd," ");
3341 } /* end of setup_argstr() */
3344 static unsigned long int
3345 setup_cmddsc(char *cmd, int check_img)
3347 char resspec[NAM$C_MAXRSS+1];
3348 $DESCRIPTOR(defdsc,".EXE");
3349 $DESCRIPTOR(resdsc,resspec);
3350 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
3351 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
3352 register char *s, *rest, *cp;
3353 register int isdcl = 0;
3357 while (*s && isspace(*s)) s++;
3359 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
3360 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
3361 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
3362 if (*cp == ':' || *cp == '[' || *cp == '<') {
3372 while (*s && !isspace(*s)) s++;
3374 imgdsc.dsc$a_pointer = cmd;
3375 imgdsc.dsc$w_length = s - cmd;
3376 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
3378 _ckvmssts(lib$find_file_end(&cxt));
3380 while (*s && !isspace(*s)) s++;
3382 if (cando_by_name(S_IXUSR,0,resspec)) {
3383 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
3384 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
3385 strcat(VMScmd.dsc$a_pointer,resspec);
3386 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
3387 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
3390 else retsts = RMS$_PRV;
3393 /* It's either a DCL command or we couldn't find a suitable image */
3394 VMScmd.dsc$w_length = strlen(cmd);
3395 if (cmd == PL_Cmd) {
3396 VMScmd.dsc$a_pointer = PL_Cmd;
3397 PL_Cmd = Nullch; /* Don't try to free twice in vms_execfree() */
3399 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
3400 if (!(retsts & 1)) {
3401 /* just hand off status values likely to be due to user error */
3402 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
3403 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
3404 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
3405 else { _ckvmssts(retsts); }
3408 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
3410 } /* end of setup_cmddsc() */
3413 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
3415 vms_do_aexec(SV *really,SV **mark,SV **sp)
3419 if (vfork_called) { /* this follows a vfork - act Unixish */
3421 if (vfork_called < 0) {
3422 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3425 else return do_aexec(really,mark,sp);
3427 /* no vfork - act VMSish */
3428 return vms_do_exec(setup_argstr(really,mark,sp));
3433 } /* end of vms_do_aexec() */
3436 /* {{{bool vms_do_exec(char *cmd) */
3438 vms_do_exec(char *cmd)
3442 if (vfork_called) { /* this follows a vfork - act Unixish */
3444 if (vfork_called < 0) {
3445 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
3448 else return do_exec(cmd);
3451 { /* no vfork - act VMSish */
3452 unsigned long int retsts;
3455 TAINT_PROPER("exec");
3456 if ((retsts = setup_cmddsc(cmd,1)) & 1)
3457 retsts = lib$do_command(&VMScmd);
3461 set_errno(ENOENT); break;
3462 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3463 set_errno(ENOTDIR); break;
3465 set_errno(EACCES); break;
3467 set_errno(EINVAL); break;
3469 set_errno(E2BIG); break;
3470 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3471 _ckvmssts(retsts); /* fall through */
3472 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3475 set_vaxc_errno(retsts);
3476 if (ckWARN(WARN_EXEC)) {
3477 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
3478 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
3485 } /* end of vms_do_exec() */
3488 unsigned long int do_spawn(char *);
3490 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
3492 do_aspawn(void *really,void **mark,void **sp)
3495 if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
3498 } /* end of do_aspawn() */
3501 /* {{{unsigned long int do_spawn(char *cmd) */
3505 unsigned long int sts, substs, hadcmd = 1;
3509 TAINT_PROPER("spawn");
3510 if (!cmd || !*cmd) {
3512 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
3514 else if ((sts = setup_cmddsc(cmd,0)) & 1) {
3515 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
3521 set_errno(ENOENT); break;
3522 case RMS$_DNF: case RMS$_DIR: case RMS$_DEV:
3523 set_errno(ENOTDIR); break;
3525 set_errno(EACCES); break;
3527 set_errno(EINVAL); break;
3529 set_errno(E2BIG); break;
3530 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3531 _ckvmssts(sts); /* fall through */
3532 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3535 set_vaxc_errno(sts);
3536 if (ckWARN(WARN_EXEC)) {
3537 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
3538 hadcmd ? VMScmd.dsc$w_length : 0,
3539 hadcmd ? VMScmd.dsc$a_pointer : "",
3546 } /* end of do_spawn() */
3550 * A simple fwrite replacement which outputs itmsz*nitm chars without
3551 * introducing record boundaries every itmsz chars.
3553 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
3555 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
3557 register char *cp, *end;
3559 end = (char *)src + itmsz * nitm;
3561 while ((char *)src <= end) {
3562 for (cp = src; cp <= end; cp++) if (!*cp) break;
3563 if (fputs(src,dest) == EOF) return EOF;
3565 if (fputc('\0',dest) == EOF) return EOF;
3571 } /* end of my_fwrite() */
3574 /*{{{ int my_flush(FILE *fp)*/
3579 if ((res = fflush(fp)) == 0 && fp) {
3580 #ifdef VMS_DO_SOCKETS
3582 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
3584 res = fsync(fileno(fp));
3591 * Here are replacements for the following Unix routines in the VMS environment:
3592 * getpwuid Get information for a particular UIC or UID
3593 * getpwnam Get information for a named user
3594 * getpwent Get information for each user in the rights database
3595 * setpwent Reset search to the start of the rights database
3596 * endpwent Finish searching for users in the rights database
3598 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
3599 * (defined in pwd.h), which contains the following fields:-
3601 * char *pw_name; Username (in lower case)
3602 * char *pw_passwd; Hashed password
3603 * unsigned int pw_uid; UIC
3604 * unsigned int pw_gid; UIC group number
3605 * char *pw_unixdir; Default device/directory (VMS-style)
3606 * char *pw_gecos; Owner name
3607 * char *pw_dir; Default device/directory (Unix-style)
3608 * char *pw_shell; Default CLI name (eg. DCL)
3610 * If the specified user does not exist, getpwuid and getpwnam return NULL.
3612 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
3613 * not the UIC member number (eg. what's returned by getuid()),
3614 * getpwuid() can accept either as input (if uid is specified, the caller's
3615 * UIC group is used), though it won't recognise gid=0.
3617 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
3618 * information about other users in your group or in other groups, respectively.
3619 * If the required privilege is not available, then these routines fill only
3620 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
3623 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
3626 /* sizes of various UAF record fields */
3627 #define UAI$S_USERNAME 12
3628 #define UAI$S_IDENT 31
3629 #define UAI$S_OWNER 31
3630 #define UAI$S_DEFDEV 31
3631 #define UAI$S_DEFDIR 63
3632 #define UAI$S_DEFCLI 31
3635 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
3636 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
3637 (uic).uic$v_group != UIC$K_WILD_GROUP)
3639 static char __empty[]= "";
3640 static struct passwd __passwd_empty=
3641 {(char *) __empty, (char *) __empty, 0, 0,
3642 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
3643 static int contxt= 0;
3644 static struct passwd __pwdcache;
3645 static char __pw_namecache[UAI$S_IDENT+1];
3648 * This routine does most of the work extracting the user information.
3650 static int fillpasswd (const char *name, struct passwd *pwd)
3654 unsigned char length;
3655 char pw_gecos[UAI$S_OWNER+1];
3657 static union uicdef uic;
3659 unsigned char length;
3660 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
3663 unsigned char length;
3664 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
3667 unsigned char length;
3668 char pw_shell[UAI$S_DEFCLI+1];
3670 static char pw_passwd[UAI$S_PWD+1];
3672 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
3673 struct dsc$descriptor_s name_desc;
3674 unsigned long int sts;
3676 static struct itmlst_3 itmlst[]= {
3677 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
3678 {sizeof(uic), UAI$_UIC, &uic, &luic},
3679 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
3680 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
3681 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
3682 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
3683 {0, 0, NULL, NULL}};
3685 name_desc.dsc$w_length= strlen(name);
3686 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3687 name_desc.dsc$b_class= DSC$K_CLASS_S;
3688 name_desc.dsc$a_pointer= (char *) name;
3690 /* Note that sys$getuai returns many fields as counted strings. */
3691 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
3692 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
3693 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
3695 else { _ckvmssts(sts); }
3696 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
3698 if ((int) owner.length < lowner) lowner= (int) owner.length;
3699 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
3700 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
3701 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
3702 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
3703 owner.pw_gecos[lowner]= '\0';
3704 defdev.pw_dir[ldefdev+ldefdir]= '\0';
3705 defcli.pw_shell[ldefcli]= '\0';
3706 if (valid_uic(uic)) {
3707 pwd->pw_uid= uic.uic$l_uic;
3708 pwd->pw_gid= uic.uic$v_group;
3711 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
3712 pwd->pw_passwd= pw_passwd;
3713 pwd->pw_gecos= owner.pw_gecos;
3714 pwd->pw_dir= defdev.pw_dir;
3715 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
3716 pwd->pw_shell= defcli.pw_shell;
3717 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
3719 ldir= strlen(pwd->pw_unixdir) - 1;
3720 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
3723 strcpy(pwd->pw_unixdir, pwd->pw_dir);
3724 __mystrtolower(pwd->pw_unixdir);
3729 * Get information for a named user.
3731 /*{{{struct passwd *getpwnam(char *name)*/
3732 struct passwd *my_getpwnam(char *name)
3734 struct dsc$descriptor_s name_desc;
3736 unsigned long int status, sts;
3739 __pwdcache = __passwd_empty;
3740 if (!fillpasswd(name, &__pwdcache)) {
3741 /* We still may be able to determine pw_uid and pw_gid */
3742 name_desc.dsc$w_length= strlen(name);
3743 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
3744 name_desc.dsc$b_class= DSC$K_CLASS_S;
3745 name_desc.dsc$a_pointer= (char *) name;
3746 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
3747 __pwdcache.pw_uid= uic.uic$l_uic;
3748 __pwdcache.pw_gid= uic.uic$v_group;
3751 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
3752 set_vaxc_errno(sts);
3753 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
3756 else { _ckvmssts(sts); }
3759 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
3760 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
3761 __pwdcache.pw_name= __pw_namecache;
3763 } /* end of my_getpwnam() */
3767 * Get information for a particular UIC or UID.
3768 * Called by my_getpwent with uid=-1 to list all users.
3770 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
3771 struct passwd *my_getpwuid(Uid_t uid)
3773 const $DESCRIPTOR(name_desc,__pw_namecache);
3774 unsigned short lname;
3776 unsigned long int status;
3779 if (uid == (unsigned int) -1) {
3781 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
3782 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
3783 set_vaxc_errno(status);
3784 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3788 else { _ckvmssts(status); }
3789 } while (!valid_uic (uic));
3793 if (!uic.uic$v_group)
3794 uic.uic$v_group= PerlProc_getgid();
3796 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
3797 else status = SS$_IVIDENT;
3798 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
3799 status == RMS$_PRV) {
3800 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
3803 else { _ckvmssts(status); }
3805 __pw_namecache[lname]= '\0';
3806 __mystrtolower(__pw_namecache);
3808 __pwdcache = __passwd_empty;
3809 __pwdcache.pw_name = __pw_namecache;
3811 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
3812 The identifier's value is usually the UIC, but it doesn't have to be,
3813 so if we can, we let fillpasswd update this. */
3814 __pwdcache.pw_uid = uic.uic$l_uic;
3815 __pwdcache.pw_gid = uic.uic$v_group;
3817 fillpasswd(__pw_namecache, &__pwdcache);
3820 } /* end of my_getpwuid() */
3824 * Get information for next user.
3826 /*{{{struct passwd *my_getpwent()*/
3827 struct passwd *my_getpwent()
3829 return (my_getpwuid((unsigned int) -1));
3834 * Finish searching rights database for users.
3836 /*{{{void my_endpwent()*/
3841 _ckvmssts(sys$finish_rdb(&contxt));
3847 #ifdef HOMEGROWN_POSIX_SIGNALS
3848 /* Signal handling routines, pulled into the core from POSIX.xs.
3850 * We need these for threads, so they've been rolled into the core,
3851 * rather than left in POSIX.xs.
3853 * (DRS, Oct 23, 1997)
3856 /* sigset_t is atomic under VMS, so these routines are easy */
3857 /*{{{int my_sigemptyset(sigset_t *) */
3858 int my_sigemptyset(sigset_t *set) {
3859 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3865 /*{{{int my_sigfillset(sigset_t *)*/
3866 int my_sigfillset(sigset_t *set) {
3868 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3869 for (i = 0; i < NSIG; i++) *set |= (1 << i);
3875 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
3876 int my_sigaddset(sigset_t *set, int sig) {
3877 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3878 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3879 *set |= (1 << (sig - 1));
3885 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
3886 int my_sigdelset(sigset_t *set, int sig) {
3887 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3888 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3889 *set &= ~(1 << (sig - 1));
3895 /*{{{int my_sigismember(sigset_t *set, int sig)*/
3896 int my_sigismember(sigset_t *set, int sig) {
3897 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
3898 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
3899 *set & (1 << (sig - 1));
3904 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
3905 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
3908 /* If set and oset are both null, then things are badly wrong. Bail out. */
3909 if ((oset == NULL) && (set == NULL)) {
3910 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
3914 /* If set's null, then we're just handling a fetch. */
3916 tempmask = sigblock(0);
3921 tempmask = sigsetmask(*set);
3924 tempmask = sigblock(*set);
3927 tempmask = sigblock(0);
3928 sigsetmask(*oset & ~tempmask);
3931 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
3936 /* Did they pass us an oset? If so, stick our holding mask into it */
3943 #endif /* HOMEGROWN_POSIX_SIGNALS */
3946 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
3947 * my_utime(), and flex_stat(), all of which operate on UTC unless
3948 * VMSISH_TIMES is true.
3950 /* method used to handle UTC conversions:
3951 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
3953 static int gmtime_emulation_type;
3954 /* number of secs to add to UTC POSIX-style time to get local time */
3955 static long int utc_offset_secs;
3957 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
3958 * in vmsish.h. #undef them here so we can call the CRTL routines
3965 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
3966 # define RTL_USES_UTC 1
3969 static time_t toutc_dst(time_t loc) {
3972 if ((rsltmp = localtime(&loc)) == NULL) return -1;
3973 loc -= utc_offset_secs;
3974 if (rsltmp->tm_isdst) loc -= 3600;
3977 #define _toutc(secs) ((secs) == -1 ? -1 : \
3978 ((gmtime_emulation_type || my_time(NULL)), \
3979 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
3980 ((secs) - utc_offset_secs))))
3982 static time_t toloc_dst(time_t utc) {
3985 utc += utc_offset_secs;
3986 if ((rsltmp = localtime(&utc)) == NULL) return -1;
3987 if (rsltmp->tm_isdst) utc += 3600;
3990 #define _toloc(secs) ((secs) == -1 ? -1 : \
3991 ((gmtime_emulation_type || my_time(NULL)), \
3992 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
3993 ((secs) + utc_offset_secs))))
3996 /* my_time(), my_localtime(), my_gmtime()
3997 * By default traffic in UTC time values, using CRTL gmtime() or
3998 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
3999 * Note: We need to use these functions even when the CRTL has working
4000 * UTC support, since they also handle C<use vmsish qw(times);>
4002 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
4003 * Modified by Charles Bailey <bailey@newman.upenn.edu>
4006 /*{{{time_t my_time(time_t *timep)*/
4007 time_t my_time(time_t *timep)
4013 if (gmtime_emulation_type == 0) {
4015 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
4016 /* results of calls to gmtime() and localtime() */
4017 /* for same &base */
4019 gmtime_emulation_type++;
4020 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
4021 char off[LNM$C_NAMLENGTH+1];;
4023 gmtime_emulation_type++;
4024 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
4025 gmtime_emulation_type++;
4026 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
4028 else { utc_offset_secs = atol(off); }
4030 else { /* We've got a working gmtime() */
4031 struct tm gmt, local;
4034 tm_p = localtime(&base);
4036 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
4037 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
4038 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
4039 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
4045 # ifdef RTL_USES_UTC
4046 if (VMSISH_TIME) when = _toloc(when);
4048 if (!VMSISH_TIME) when = _toutc(when);
4051 if (timep != NULL) *timep = when;
4054 } /* end of my_time() */
4058 /*{{{struct tm *my_gmtime(const time_t *timep)*/
4060 my_gmtime(const time_t *timep)
4067 if (timep == NULL) {
4068 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4071 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4075 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
4077 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
4078 return gmtime(&when);
4080 /* CRTL localtime() wants local time as input, so does no tz correction */
4081 rsltmp = localtime(&when);
4082 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
4085 } /* end of my_gmtime() */
4089 /*{{{struct tm *my_localtime(const time_t *timep)*/
4091 my_localtime(const time_t *timep)
4097 if (timep == NULL) {
4098 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4101 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
4102 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
4105 # ifdef RTL_USES_UTC
4107 if (VMSISH_TIME) when = _toutc(when);
4109 /* CRTL localtime() wants UTC as input, does tz correction itself */
4110 return localtime(&when);
4113 if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */
4116 /* CRTL localtime() wants local time as input, so does no tz correction */
4117 rsltmp = localtime(&when);
4118 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1;
4121 } /* end of my_localtime() */
4124 /* Reset definitions for later calls */
4125 #define gmtime(t) my_gmtime(t)
4126 #define localtime(t) my_localtime(t)
4127 #define time(t) my_time(t)
4130 /* my_utime - update modification time of a file
4131 * calling sequence is identical to POSIX utime(), but under
4132 * VMS only the modification time is changed; ODS-2 does not
4133 * maintain access times. Restrictions differ from the POSIX
4134 * definition in that the time can be changed as long as the
4135 * caller has permission to execute the necessary IO$_MODIFY $QIO;
4136 * no separate checks are made to insure that the caller is the
4137 * owner of the file or has special privs enabled.
4138 * Code here is based on Joe Meadows' FILE utility.
4141 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
4142 * to VMS epoch (01-JAN-1858 00:00:00.00)
4143 * in 100 ns intervals.
4145 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
4147 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
4148 int my_utime(char *file, struct utimbuf *utimes)
4152 long int bintime[2], len = 2, lowbit, unixtime,
4153 secscale = 10000000; /* seconds --> 100 ns intervals */
4154 unsigned long int chan, iosb[2], retsts;
4155 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
4156 struct FAB myfab = cc$rms_fab;
4157 struct NAM mynam = cc$rms_nam;
4158 #if defined (__DECC) && defined (__VAX)
4159 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
4160 * at least through VMS V6.1, which causes a type-conversion warning.
4162 # pragma message save
4163 # pragma message disable cvtdiftypes
4165 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
4166 struct fibdef myfib;
4167 #if defined (__DECC) && defined (__VAX)
4168 /* This should be right after the declaration of myatr, but due
4169 * to a bug in VAX DEC C, this takes effect a statement early.
4171 # pragma message restore
4173 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
4174 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
4175 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
4177 if (file == NULL || *file == '\0') {
4179 set_vaxc_errno(LIB$_INVARG);
4182 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
4184 if (utimes != NULL) {
4185 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
4186 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
4187 * Since time_t is unsigned long int, and lib$emul takes a signed long int
4188 * as input, we force the sign bit to be clear by shifting unixtime right
4189 * one bit, then multiplying by an extra factor of 2 in lib$emul().
4191 lowbit = (utimes->modtime & 1) ? secscale : 0;
4192 unixtime = (long int) utimes->modtime;
4194 /* If input was UTC; convert to local for sys svc */
4195 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
4197 unixtime >> 1; secscale << 1;
4198 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
4199 if (!(retsts & 1)) {
4201 set_vaxc_errno(retsts);
4204 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
4205 if (!(retsts & 1)) {
4207 set_vaxc_errno(retsts);
4212 /* Just get the current time in VMS format directly */
4213 retsts = sys$gettim(bintime);
4214 if (!(retsts & 1)) {
4216 set_vaxc_errno(retsts);
4221 myfab.fab$l_fna = vmsspec;
4222 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
4223 myfab.fab$l_nam = &mynam;
4224 mynam.nam$l_esa = esa;
4225 mynam.nam$b_ess = (unsigned char) sizeof esa;
4226 mynam.nam$l_rsa = rsa;
4227 mynam.nam$b_rss = (unsigned char) sizeof rsa;
4229 /* Look for the file to be affected, letting RMS parse the file
4230 * specification for us as well. I have set errno using only
4231 * values documented in the utime() man page for VMS POSIX.
4233 retsts = sys$parse(&myfab,0,0);
4234 if (!(retsts & 1)) {
4235 set_vaxc_errno(retsts);
4236 if (retsts == RMS$_PRV) set_errno(EACCES);
4237 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4238 else set_errno(EVMSERR);
4241 retsts = sys$search(&myfab,0,0);
4242 if (!(retsts & 1)) {
4243 set_vaxc_errno(retsts);
4244 if (retsts == RMS$_PRV) set_errno(EACCES);
4245 else if (retsts == RMS$_FNF) set_errno(ENOENT);
4246 else set_errno(EVMSERR);
4250 devdsc.dsc$w_length = mynam.nam$b_dev;
4251 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
4253 retsts = sys$assign(&devdsc,&chan,0,0);
4254 if (!(retsts & 1)) {
4255 set_vaxc_errno(retsts);
4256 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
4257 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
4258 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
4259 else set_errno(EVMSERR);
4263 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
4264 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
4266 memset((void *) &myfib, 0, sizeof myfib);
4268 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
4269 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
4270 /* This prevents the revision time of the file being reset to the current
4271 * time as a result of our IO$_MODIFY $QIO. */
4272 myfib.fib$l_acctl = FIB$M_NORECORD;
4274 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
4275 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
4276 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
4278 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
4279 _ckvmssts(sys$dassgn(chan));
4280 if (retsts & 1) retsts = iosb[0];
4281 if (!(retsts & 1)) {
4282 set_vaxc_errno(retsts);
4283 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4284 else set_errno(EVMSERR);
4289 } /* end of my_utime() */
4293 * flex_stat, flex_fstat
4294 * basic stat, but gets it right when asked to stat
4295 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
4298 /* encode_dev packs a VMS device name string into an integer to allow
4299 * simple comparisons. This can be used, for example, to check whether two
4300 * files are located on the same device, by comparing their encoded device
4301 * names. Even a string comparison would not do, because stat() reuses the
4302 * device name buffer for each call; so without encode_dev, it would be
4303 * necessary to save the buffer and use strcmp (this would mean a number of
4304 * changes to the standard Perl code, to say nothing of what a Perl script
4307 * The device lock id, if it exists, should be unique (unless perhaps compared
4308 * with lock ids transferred from other nodes). We have a lock id if the disk is
4309 * mounted cluster-wide, which is when we tend to get long (host-qualified)
4310 * device names. Thus we use the lock id in preference, and only if that isn't
4311 * available, do we try to pack the device name into an integer (flagged by
4312 * the sign bit (LOCKID_MASK) being set).
4314 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
4315 * name and its encoded form, but it seems very unlikely that we will find
4316 * two files on different disks that share the same encoded device names,
4317 * and even more remote that they will share the same file id (if the test
4318 * is to check for the same file).
4320 * A better method might be to use sys$device_scan on the first call, and to
4321 * search for the device, returning an index into the cached array.
4322 * The number returned would be more intelligable.
4323 * This is probably not worth it, and anyway would take quite a bit longer
4324 * on the first call.
4326 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
4327 static mydev_t encode_dev (const char *dev)
4330 unsigned long int f;
4336 if (!dev || !dev[0]) return 0;
4340 struct dsc$descriptor_s dev_desc;
4341 unsigned long int status, lockid, item = DVI$_LOCKID;
4343 /* For cluster-mounted disks, the disk lock identifier is unique, so we
4344 can try that first. */
4345 dev_desc.dsc$w_length = strlen (dev);
4346 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
4347 dev_desc.dsc$b_class = DSC$K_CLASS_S;
4348 dev_desc.dsc$a_pointer = (char *) dev;
4349 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
4350 if (lockid) return (lockid & ~LOCKID_MASK);
4354 /* Otherwise we try to encode the device name */
4358 for (q = dev + strlen(dev); q--; q >= dev) {
4361 else if (isalpha (toupper (*q)))
4362 c= toupper (*q) - 'A' + (char)10;
4364 continue; /* Skip '$'s */
4366 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
4368 enc += f * (unsigned long int) c;
4370 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
4372 } /* end of encode_dev() */
4374 static char namecache[NAM$C_MAXRSS+1];
4377 is_null_device(name)
4381 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
4382 The underscore prefix, controller letter, and unit number are
4383 independently optional; for our purposes, the colon punctuation
4384 is not. The colon can be trailed by optional directory and/or
4385 filename, but two consecutive colons indicates a nodename rather
4386 than a device. [pr] */
4387 if (*name == '_') ++name;
4388 if (tolower(*name++) != 'n') return 0;
4389 if (tolower(*name++) != 'l') return 0;
4390 if (tolower(*name) == 'a') ++name;
4391 if (*name == '0') ++name;
4392 return (*name++ == ':') && (*name != ':');
4395 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
4396 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
4397 * subset of the applicable information.
4399 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
4401 Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
4403 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
4405 char fname[NAM$C_MAXRSS+1];
4406 unsigned long int retsts;
4407 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4408 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4410 /* If the struct mystat is stale, we're OOL; stat() overwrites the
4411 device name on successive calls */
4412 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
4413 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
4414 namdsc.dsc$a_pointer = fname;
4415 namdsc.dsc$w_length = sizeof fname - 1;
4417 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
4418 &namdsc,&namdsc.dsc$w_length,0,0);
4420 fname[namdsc.dsc$w_length] = '\0';
4421 return cando_by_name(bit,effective,fname);
4423 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
4424 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
4428 return FALSE; /* Should never get to here */
4430 } /* end of cando() */
4434 /*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
4436 cando_by_name(I32 bit, I32 effective, char *fname)
4438 static char usrname[L_cuserid];
4439 static struct dsc$descriptor_s usrdsc =
4440 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
4441 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
4442 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
4443 unsigned short int retlen;
4445 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4446 union prvdef curprv;
4447 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
4448 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
4449 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
4452 if (!fname || !*fname) return FALSE;
4453 /* Make sure we expand logical names, since sys$check_access doesn't */
4454 if (!strpbrk(fname,"/]>:")) {
4455 strcpy(fileified,fname);
4456 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
4459 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
4460 retlen = namdsc.dsc$w_length = strlen(vmsname);
4461 namdsc.dsc$a_pointer = vmsname;
4462 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
4463 vmsname[retlen-1] == ':') {
4464 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
4465 namdsc.dsc$w_length = strlen(fileified);
4466 namdsc.dsc$a_pointer = fileified;
4469 if (!usrdsc.dsc$w_length) {
4471 usrdsc.dsc$w_length = strlen(usrname);
4478 access = ARM$M_EXECUTE;
4483 access = ARM$M_READ;
4488 access = ARM$M_WRITE;
4493 access = ARM$M_DELETE;
4499 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
4500 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
4501 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
4502 retsts == RMS$_DIR || retsts == RMS$_DEV) {
4503 set_vaxc_errno(retsts);
4504 if (retsts == SS$_NOPRIV) set_errno(EACCES);
4505 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
4506 else set_errno(ENOENT);
4509 if (retsts == SS$_NORMAL) {
4510 if (!privused) return TRUE;
4511 /* We can get access, but only by using privs. Do we have the
4512 necessary privs currently enabled? */
4513 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
4514 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
4515 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
4516 !curprv.prv$v_bypass) return FALSE;
4517 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
4518 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
4519 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
4522 if (retsts == SS$_ACCONFLICT) {
4527 return FALSE; /* Should never get here */
4529 } /* end of cando_by_name() */
4533 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
4535 flex_fstat(int fd, Stat_t *statbufp)
4538 if (!fstat(fd,(stat_t *) statbufp)) {
4539 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
4540 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4541 # ifdef RTL_USES_UTC
4544 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4545 statbufp->st_atime = _toloc(statbufp->st_atime);
4546 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4551 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4555 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4556 statbufp->st_atime = _toutc(statbufp->st_atime);
4557 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4564 } /* end of flex_fstat() */
4567 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
4569 flex_stat(const char *fspec, Stat_t *statbufp)
4572 char fileified[NAM$C_MAXRSS+1];
4573 char temp_fspec[NAM$C_MAXRSS+300];
4576 strcpy(temp_fspec, fspec);
4577 if (statbufp == (Stat_t *) &PL_statcache)
4578 do_tovmsspec(temp_fspec,namecache,0);
4579 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
4580 memset(statbufp,0,sizeof *statbufp);
4581 statbufp->st_dev = encode_dev("_NLA0:");
4582 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
4583 statbufp->st_uid = 0x00010001;
4584 statbufp->st_gid = 0x0001;
4585 time((time_t *)&statbufp->st_mtime);
4586 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
4590 /* Try for a directory name first. If fspec contains a filename without
4591 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
4592 * and sea:[wine.dark]water. exist, we prefer the directory here.
4593 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
4594 * not sea:[wine.dark]., if the latter exists. If the intended target is
4595 * the file with null type, specify this by calling flex_stat() with
4596 * a '.' at the end of fspec.
4598 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
4599 retval = stat(fileified,(stat_t *) statbufp);
4600 if (!retval && statbufp == (Stat_t *) &PL_statcache)
4601 strcpy(namecache,fileified);
4603 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
4605 statbufp->st_dev = encode_dev(statbufp->st_devnam);
4606 # ifdef RTL_USES_UTC
4609 statbufp->st_mtime = _toloc(statbufp->st_mtime);
4610 statbufp->st_atime = _toloc(statbufp->st_atime);
4611 statbufp->st_ctime = _toloc(statbufp->st_ctime);
4616 if (!VMSISH_TIME) { /* Return UTC instead of local time */
4620 statbufp->st_mtime = _toutc(statbufp->st_mtime);
4621 statbufp->st_atime = _toutc(statbufp->st_atime);
4622 statbufp->st_ctime = _toutc(statbufp->st_ctime);
4628 } /* end of flex_stat() */
4632 /*{{{char *my_getlogin()*/
4633 /* VMS cuserid == Unix getlogin, except calling sequence */
4637 static char user[L_cuserid];
4638 return cuserid(user);
4643 /* rmscopy - copy a file using VMS RMS routines
4645 * Copies contents and attributes of spec_in to spec_out, except owner
4646 * and protection information. Name and type of spec_in are used as
4647 * defaults for spec_out. The third parameter specifies whether rmscopy()
4648 * should try to propagate timestamps from the input file to the output file.
4649 * If it is less than 0, no timestamps are preserved. If it is 0, then
4650 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
4651 * propagated to the output file at creation iff the output file specification
4652 * did not contain an explicit name or type, and the revision date is always
4653 * updated at the end of the copy operation. If it is greater than 0, then
4654 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
4655 * other than the revision date should be propagated, and bit 1 indicates
4656 * that the revision date should be propagated.
4658 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
4660 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
4661 * Incorporates, with permission, some code from EZCOPY by Tim Adye
4662 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
4663 * as part of the Perl standard distribution under the terms of the
4664 * GNU General Public License or the Perl Artistic License. Copies
4665 * of each may be found in the Perl standard distribution.
4667 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
4669 rmscopy(char *spec_in, char *spec_out, int preserve_dates)
4671 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
4672 rsa[NAM$C_MAXRSS], ubf[32256];
4673 unsigned long int i, sts, sts2;
4674 struct FAB fab_in, fab_out;
4675 struct RAB rab_in, rab_out;
4677 struct XABDAT xabdat;
4678 struct XABFHC xabfhc;
4679 struct XABRDT xabrdt;
4680 struct XABSUM xabsum;
4682 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
4683 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
4684 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4688 fab_in = cc$rms_fab;
4689 fab_in.fab$l_fna = vmsin;
4690 fab_in.fab$b_fns = strlen(vmsin);
4691 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
4692 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
4693 fab_in.fab$l_fop = FAB$M_SQO;
4694 fab_in.fab$l_nam = &nam;
4695 fab_in.fab$l_xab = (void *) &xabdat;
4698 nam.nam$l_rsa = rsa;
4699 nam.nam$b_rss = sizeof(rsa);
4700 nam.nam$l_esa = esa;
4701 nam.nam$b_ess = sizeof (esa);
4702 nam.nam$b_esl = nam.nam$b_rsl = 0;
4704 xabdat = cc$rms_xabdat; /* To get creation date */
4705 xabdat.xab$l_nxt = (void *) &xabfhc;
4707 xabfhc = cc$rms_xabfhc; /* To get record length */
4708 xabfhc.xab$l_nxt = (void *) &xabsum;
4710 xabsum = cc$rms_xabsum; /* To get key and area information */
4712 if (!((sts = sys$open(&fab_in)) & 1)) {
4713 set_vaxc_errno(sts);
4717 set_errno(ENOENT); break;
4719 set_errno(ENODEV); break;
4721 set_errno(EINVAL); break;
4723 set_errno(EACCES); break;
4731 fab_out.fab$w_ifi = 0;
4732 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
4733 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
4734 fab_out.fab$l_fop = FAB$M_SQO;
4735 fab_out.fab$l_fna = vmsout;
4736 fab_out.fab$b_fns = strlen(vmsout);
4737 fab_out.fab$l_dna = nam.nam$l_name;
4738 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
4740 if (preserve_dates == 0) { /* Act like DCL COPY */
4741 nam.nam$b_nop = NAM$M_SYNCHK;
4742 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
4743 if (!((sts = sys$parse(&fab_out)) & 1)) {
4744 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
4745 set_vaxc_errno(sts);
4748 fab_out.fab$l_xab = (void *) &xabdat;
4749 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
4751 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
4752 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
4753 preserve_dates =0; /* bitmask from this point forward */
4755 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
4756 if (!((sts = sys$create(&fab_out)) & 1)) {
4757 set_vaxc_errno(sts);
4760 set_errno(ENOENT); break;
4762 set_errno(ENODEV); break;
4764 set_errno(EINVAL); break;
4766 set_errno(EACCES); break;
4772 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
4773 if (preserve_dates & 2) {
4774 /* sys$close() will process xabrdt, not xabdat */
4775 xabrdt = cc$rms_xabrdt;
4777 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
4779 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
4780 * is unsigned long[2], while DECC & VAXC use a struct */
4781 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
4783 fab_out.fab$l_xab = (void *) &xabrdt;
4786 rab_in = cc$rms_rab;
4787 rab_in.rab$l_fab = &fab_in;
4788 rab_in.rab$l_rop = RAB$M_BIO;
4789 rab_in.rab$l_ubf = ubf;
4790 rab_in.rab$w_usz = sizeof ubf;
4791 if (!((sts = sys$connect(&rab_in)) & 1)) {
4792 sys$close(&fab_in); sys$close(&fab_out);
4793 set_errno(EVMSERR); set_vaxc_errno(sts);
4797 rab_out = cc$rms_rab;
4798 rab_out.rab$l_fab = &fab_out;
4799 rab_out.rab$l_rbf = ubf;
4800 if (!((sts = sys$connect(&rab_out)) & 1)) {
4801 sys$close(&fab_in); sys$close(&fab_out);
4802 set_errno(EVMSERR); set_vaxc_errno(sts);
4806 while ((sts = sys$read(&rab_in))) { /* always true */
4807 if (sts == RMS$_EOF) break;
4808 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
4809 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
4810 sys$close(&fab_in); sys$close(&fab_out);
4811 set_errno(EVMSERR); set_vaxc_errno(sts);
4816 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
4817 sys$close(&fab_in); sys$close(&fab_out);
4818 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
4820 set_errno(EVMSERR); set_vaxc_errno(sts);
4826 } /* end of rmscopy() */
4830 /*** The following glue provides 'hooks' to make some of the routines
4831 * from this file available from Perl. These routines are sufficiently
4832 * basic, and are required sufficiently early in the build process,
4833 * that's it's nice to have them available to miniperl as well as the
4834 * full Perl, so they're set up here instead of in an extension. The
4835 * Perl code which handles importation of these names into a given
4836 * package lives in [.VMS]Filespec.pm in @INC.
4840 rmsexpand_fromperl(pTHX_ CV *cv)
4843 char *fspec, *defspec = NULL, *rslt;
4846 if (!items || items > 2)
4847 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
4848 fspec = SvPV(ST(0),n_a);
4849 if (!fspec || !*fspec) XSRETURN_UNDEF;
4850 if (items == 2) defspec = SvPV(ST(1),n_a);
4852 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
4853 ST(0) = sv_newmortal();
4854 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
4859 vmsify_fromperl(pTHX_ CV *cv)
4865 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
4866 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
4867 ST(0) = sv_newmortal();
4868 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
4873 unixify_fromperl(pTHX_ CV *cv)
4879 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
4880 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
4881 ST(0) = sv_newmortal();
4882 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
4887 fileify_fromperl(pTHX_ CV *cv)
4893 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
4894 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
4895 ST(0) = sv_newmortal();
4896 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
4901 pathify_fromperl(pTHX_ CV *cv)
4907 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
4908 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
4909 ST(0) = sv_newmortal();
4910 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
4915 vmspath_fromperl(pTHX_ CV *cv)
4921 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
4922 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
4923 ST(0) = sv_newmortal();
4924 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
4929 unixpath_fromperl(pTHX_ CV *cv)
4935 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
4936 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
4937 ST(0) = sv_newmortal();
4938 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
4943 candelete_fromperl(pTHX_ CV *cv)
4946 char fspec[NAM$C_MAXRSS+1], *fsp;
4951 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
4953 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4954 if (SvTYPE(mysv) == SVt_PVGV) {
4955 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
4956 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4963 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
4964 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
4970 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
4975 rmscopy_fromperl(pTHX_ CV *cv)
4978 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
4980 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
4981 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4982 unsigned long int sts;
4987 if (items < 2 || items > 3)
4988 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
4990 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
4991 if (SvTYPE(mysv) == SVt_PVGV) {
4992 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
4993 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5000 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
5001 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5006 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
5007 if (SvTYPE(mysv) == SVt_PVGV) {
5008 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
5009 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5016 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
5017 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5022 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
5024 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
5031 char* file = __FILE__;
5034 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
5035 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
5036 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
5037 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
5038 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
5039 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
5040 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
5041 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
5042 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);