3 * VMS-specific routines for perl5
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
18 #include <climsgdef.h>
28 #include <libclidef.h>
30 #include <lib$routines.h>
39 #include <str$routines.h>
44 /* Older versions of ssdef.h don't have these */
45 #ifndef SS$_INVFILFOROP
46 # define SS$_INVFILFOROP 3930
48 #ifndef SS$_NOSUCHOBJECT
49 # define SS$_NOSUCHOBJECT 2696
52 /* Don't replace system definitions of vfork, getenv, and stat,
53 * code below needs to get to the underlying CRTL routines. */
54 #define DONT_MASK_RTL_CALLS
58 /* Anticipating future expansion in lexical warnings . . . */
60 # define WARN_INTERNAL WARN_MISC
63 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
64 # define RTL_USES_UTC 1
68 /* gcc's header files don't #define direct access macros
69 * corresponding to VAXC's variant structs */
71 # define uic$v_format uic$r_uic_form.uic$v_format
72 # define uic$v_group uic$r_uic_form.uic$v_group
73 # define uic$v_member uic$r_uic_form.uic$v_member
74 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
75 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
76 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
77 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
80 #if defined(NEED_AN_H_ERRNO)
85 unsigned short int buflen;
86 unsigned short int itmcode;
88 unsigned short int *retlen;
91 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
92 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
93 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
94 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
95 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
96 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
97 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
98 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
99 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
101 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
102 #define PERL_LNM_MAX_ALLOWED_INDEX 127
104 static char *__mystrtolower(char *str)
106 if (str) for (; *str; ++str) *str= tolower(*str);
110 static struct dsc$descriptor_s fildevdsc =
111 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
112 static struct dsc$descriptor_s crtlenvdsc =
113 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
114 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
115 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
116 static struct dsc$descriptor_s **env_tables = defenv;
117 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
119 /* True if we shouldn't treat barewords as logicals during directory */
121 static int no_translate_barewords;
123 /* Temp for subprocess commands */
124 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
127 static int tz_updated = 1;
130 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
132 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
133 struct dsc$descriptor_s **tabvec, unsigned long int flags)
135 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
136 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
137 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
138 unsigned char acmode;
139 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
140 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
141 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
142 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
144 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
145 #if defined(PERL_IMPLICIT_CONTEXT)
147 # if defined(USE_5005THREADS)
148 /* We jump through these hoops because we can be called at */
149 /* platform-specific initialization time, which is before anything is */
150 /* set up--we can't even do a plain dTHX since that relies on the */
151 /* interpreter structure to be initialized */
153 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
159 aTHX = PERL_GET_INTERP;
167 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
168 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
170 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
171 *cp2 = _toupper(*cp1);
172 if (cp1 - lnm > LNM$C_NAMLENGTH) {
173 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
177 lnmdsc.dsc$w_length = cp1 - lnm;
178 lnmdsc.dsc$a_pointer = uplnm;
179 uplnm[lnmdsc.dsc$w_length] = '\0';
180 secure = flags & PERL__TRNENV_SECURE;
181 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
182 if (!tabvec || !*tabvec) tabvec = env_tables;
184 for (curtab = 0; tabvec[curtab]; curtab++) {
185 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
186 if (!ivenv && !secure) {
191 Perl_warn(aTHX_ "Can't read CRTL environ\n");
194 retsts = SS$_NOLOGNAM;
195 for (i = 0; environ[i]; i++) {
196 if ((eq = strchr(environ[i],'=')) &&
197 !strncmp(environ[i],uplnm,eq - environ[i])) {
199 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
200 if (!eqvlen) continue;
205 if (retsts != SS$_NOLOGNAM) break;
208 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
209 !str$case_blind_compare(&tmpdsc,&clisym)) {
210 if (!ivsym && !secure) {
211 unsigned short int deflen = LNM$C_NAMLENGTH;
212 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
213 /* dynamic dsc to accomodate possible long value */
214 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
215 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
218 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
220 /* Special hack--we might be called before the interpreter's */
221 /* fully initialized, in which case either thr or PL_curcop */
222 /* might be bogus. We have to check, since ckWARN needs them */
223 /* both to be valid if running threaded */
224 #if defined(USE_THREADS)
225 if (thr && PL_curcop) {
227 if (ckWARN(WARN_MISC)) {
228 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
230 #if defined(USE_THREADS)
232 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
237 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
239 _ckvmssts(lib$sfree1_dd(&eqvdsc));
240 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
241 if (retsts == LIB$_NOSUCHSYM) continue;
246 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
247 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
248 if (retsts == SS$_NOLOGNAM) continue;
249 /* PPFs have a prefix */
252 *((int *)uplnm) == *((int *)"SYS$") &&
254 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
255 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
256 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
257 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
258 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
259 memcpy(eqv,eqv+4,eqvlen-4);
265 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
266 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
267 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
268 retsts == SS$_NOLOGNAM) {
269 set_errno(EINVAL); set_vaxc_errno(retsts);
271 else _ckvmssts(retsts);
273 } /* end of vmstrnenv */
276 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
277 /* Define as a function so we can access statics. */
278 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
280 return vmstrnenv(lnm,eqv,idx,fildev,
281 #ifdef SECURE_INTERNAL_GETENV
282 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
291 * Note: Uses Perl temp to store result so char * can be returned to
292 * caller; this pointer will be invalidated at next Perl statement
294 * We define this as a function rather than a macro in terms of my_getenv_len()
295 * so that it'll work when PL_curinterp is undefined (and we therefore can't
298 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
300 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
302 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
303 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
304 unsigned long int idx = 0;
305 int trnsuccess, success, secure, saverr, savvmserr;
308 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
309 /* Set up a temporary buffer for the return value; Perl will
310 * clean it up at the next statement transition */
311 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
312 if (!tmpsv) return NULL;
315 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
316 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
317 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
318 getcwd(eqv,LNM$C_NAMLENGTH);
322 if ((cp2 = strchr(lnm,';')) != NULL) {
324 uplnm[cp2-lnm] = '\0';
325 idx = strtoul(cp2+1,NULL,0);
328 /* Impose security constraints only if tainting */
330 /* Impose security constraints only if tainting */
331 secure = PL_curinterp ? PL_tainting : will_taint;
332 saverr = errno; savvmserr = vaxc$errno;
335 success = vmstrnenv(lnm,eqv,idx,
336 secure ? fildev : NULL,
337 #ifdef SECURE_INTERNAL_GETENV
338 secure ? PERL__TRNENV_SECURE : 0
343 /* Discard NOLOGNAM on internal calls since we're often looking
344 * for an optional name, and this "error" often shows up as the
345 * (bogus) exit status for a die() call later on. */
346 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
347 return success ? eqv : Nullch;
350 } /* end of my_getenv() */
354 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
356 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
358 char *buf, *cp1, *cp2;
359 unsigned long idx = 0;
360 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
361 int secure, saverr, savvmserr;
364 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
365 /* Set up a temporary buffer for the return value; Perl will
366 * clean it up at the next statement transition */
367 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
368 if (!tmpsv) return NULL;
371 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
372 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
373 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
374 getcwd(buf,LNM$C_NAMLENGTH);
379 if ((cp2 = strchr(lnm,';')) != NULL) {
382 idx = strtoul(cp2+1,NULL,0);
386 /* Impose security constraints only if tainting */
387 secure = PL_curinterp ? PL_tainting : will_taint;
388 saverr = errno; savvmserr = vaxc$errno;
391 *len = vmstrnenv(lnm,buf,idx,
392 secure ? fildev : NULL,
393 #ifdef SECURE_INTERNAL_GETENV
394 secure ? PERL__TRNENV_SECURE : 0
399 /* Discard NOLOGNAM on internal calls since we're often looking
400 * for an optional name, and this "error" often shows up as the
401 * (bogus) exit status for a die() call later on. */
402 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
403 return *len ? buf : Nullch;
406 } /* end of my_getenv_len() */
409 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
411 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
413 /*{{{ void prime_env_iter() */
416 /* Fill the %ENV associative array with all logical names we can
417 * find, in preparation for iterating over it.
420 static int primed = 0;
421 HV *seenhv = NULL, *envhv;
422 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
423 unsigned short int chan;
424 #ifndef CLI$M_TRUSTED
425 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
427 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
428 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
430 bool have_sym = FALSE, have_lnm = FALSE;
431 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
432 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
433 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
434 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
435 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
436 #if defined(PERL_IMPLICIT_CONTEXT)
439 #if defined(USE_THREADS) || defined(USE_ITHREADS)
440 static perl_mutex primenv_mutex;
441 MUTEX_INIT(&primenv_mutex);
444 #if defined(PERL_IMPLICIT_CONTEXT)
445 /* We jump through these hoops because we can be called at */
446 /* platform-specific initialization time, which is before anything is */
447 /* set up--we can't even do a plain dTHX since that relies on the */
448 /* interpreter structure to be initialized */
449 #if defined(USE_5005THREADS)
451 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
457 aTHX = PERL_GET_INTERP;
464 if (primed || !PL_envgv) return;
465 MUTEX_LOCK(&primenv_mutex);
466 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
467 envhv = GvHVn(PL_envgv);
468 /* Perform a dummy fetch as an lval to insure that the hash table is
469 * set up. Otherwise, the hv_store() will turn into a nullop. */
470 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
472 for (i = 0; env_tables[i]; i++) {
473 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
474 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
475 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
477 if (have_sym || have_lnm) {
478 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
479 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
480 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
481 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
484 for (i--; i >= 0; i--) {
485 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
488 for (j = 0; environ[j]; j++) {
489 if (!(start = strchr(environ[j],'='))) {
490 if (ckWARN(WARN_INTERNAL))
491 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
495 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
501 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
502 !str$case_blind_compare(&tmpdsc,&clisym)) {
503 strcpy(cmd,"Show Symbol/Global *");
504 cmddsc.dsc$w_length = 20;
505 if (env_tables[i]->dsc$w_length == 12 &&
506 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
507 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
508 flags = defflags | CLI$M_NOLOGNAM;
511 strcpy(cmd,"Show Logical *");
512 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
513 strcat(cmd," /Table=");
514 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
515 cmddsc.dsc$w_length = strlen(cmd);
517 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
518 flags = defflags | CLI$M_NOCLISYM;
521 /* Create a new subprocess to execute each command, to exclude the
522 * remote possibility that someone could subvert a mbx or file used
523 * to write multiple commands to a single subprocess.
526 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
527 0,&riseandshine,0,0,&clidsc,&clitabdsc);
528 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
529 defflags &= ~CLI$M_TRUSTED;
530 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
532 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
533 if (seenhv) SvREFCNT_dec(seenhv);
536 char *cp1, *cp2, *key;
537 unsigned long int sts, iosb[2], retlen, keylen;
540 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
541 if (sts & 1) sts = iosb[0] & 0xffff;
542 if (sts == SS$_ENDOFFILE) {
544 while (substs == 0) { sys$hiber(); wakect++;}
545 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
550 retlen = iosb[0] >> 16;
551 if (!retlen) continue; /* blank line */
553 if (iosb[1] != subpid) {
555 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
559 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
560 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
562 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
563 if (*cp1 == '(' || /* Logical name table name */
564 *cp1 == '=' /* Next eqv of searchlist */) continue;
565 if (*cp1 == '"') cp1++;
566 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
567 key = cp1; keylen = cp2 - cp1;
568 if (keylen && hv_exists(seenhv,key,keylen)) continue;
569 while (*cp2 && *cp2 != '=') cp2++;
570 while (*cp2 && *cp2 == '=') cp2++;
571 while (*cp2 && *cp2 == ' ') cp2++;
572 if (*cp2 == '"') { /* String translation; may embed "" */
573 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
574 cp2++; cp1--; /* Skip "" surrounding translation */
576 else { /* Numeric translation */
577 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
578 cp1--; /* stop on last non-space char */
580 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
581 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
584 PERL_HASH(hash,key,keylen);
585 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
586 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
588 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
589 /* get the PPFs for this process, not the subprocess */
590 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
591 char eqv[LNM$C_NAMLENGTH+1];
593 for (i = 0; ppfs[i]; i++) {
594 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
595 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
600 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
601 if (buf) Safefree(buf);
602 if (seenhv) SvREFCNT_dec(seenhv);
603 MUTEX_UNLOCK(&primenv_mutex);
606 } /* end of prime_env_iter */
610 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
611 /* Define or delete an element in the same "environment" as
612 * vmstrnenv(). If an element is to be deleted, it's removed from
613 * the first place it's found. If it's to be set, it's set in the
614 * place designated by the first element of the table vector.
615 * Like setenv() returns 0 for success, non-zero on error.
618 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
620 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
621 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
622 unsigned long int retsts, usermode = PSL$C_USER;
623 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
624 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
625 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
626 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
627 $DESCRIPTOR(local,"_LOCAL");
629 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
630 *cp2 = _toupper(*cp1);
631 if (cp1 - lnm > LNM$C_NAMLENGTH) {
632 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
636 lnmdsc.dsc$w_length = cp1 - lnm;
637 if (!tabvec || !*tabvec) tabvec = env_tables;
639 if (!eqv) { /* we're deleting n element */
640 for (curtab = 0; tabvec[curtab]; curtab++) {
641 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
643 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
644 if ((cp1 = strchr(environ[i],'=')) &&
645 !strncmp(environ[i],lnm,cp1 - environ[i])) {
647 return setenv(lnm,"",1) ? vaxc$errno : 0;
650 ivenv = 1; retsts = SS$_NOLOGNAM;
652 if (ckWARN(WARN_INTERNAL))
653 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
654 ivenv = 1; retsts = SS$_NOSUCHPGM;
660 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
661 !str$case_blind_compare(&tmpdsc,&clisym)) {
662 unsigned int symtype;
663 if (tabvec[curtab]->dsc$w_length == 12 &&
664 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
665 !str$case_blind_compare(&tmpdsc,&local))
666 symtype = LIB$K_CLI_LOCAL_SYM;
667 else symtype = LIB$K_CLI_GLOBAL_SYM;
668 retsts = lib$delete_symbol(&lnmdsc,&symtype);
669 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
670 if (retsts == LIB$_NOSUCHSYM) continue;
674 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
675 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
676 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
677 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
678 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
682 else { /* we're defining a value */
683 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
685 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
687 if (ckWARN(WARN_INTERNAL))
688 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
689 retsts = SS$_NOSUCHPGM;
693 eqvdsc.dsc$a_pointer = eqv;
694 eqvdsc.dsc$w_length = strlen(eqv);
695 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
696 !str$case_blind_compare(&tmpdsc,&clisym)) {
697 unsigned int symtype;
698 if (tabvec[0]->dsc$w_length == 12 &&
699 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
700 !str$case_blind_compare(&tmpdsc,&local))
701 symtype = LIB$K_CLI_LOCAL_SYM;
702 else symtype = LIB$K_CLI_GLOBAL_SYM;
703 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
706 if (!*eqv) eqvdsc.dsc$w_length = 1;
707 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
708 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
709 if (ckWARN(WARN_MISC)) {
710 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
713 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
719 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
720 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
721 set_errno(EVMSERR); break;
722 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
723 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
724 set_errno(EINVAL); break;
731 set_vaxc_errno(retsts);
732 return (int) retsts || 44; /* retsts should never be 0, but just in case */
735 /* We reset error values on success because Perl does an hv_fetch()
736 * before each hv_store(), and if the thing we're setting didn't
737 * previously exist, we've got a leftover error message. (Of course,
738 * this fails in the face of
739 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
740 * in that the error reported in $! isn't spurious,
741 * but it's right more often than not.)
743 set_errno(0); set_vaxc_errno(retsts);
747 } /* end of vmssetenv() */
750 /*{{{ void my_setenv(char *lnm, char *eqv)*/
751 /* This has to be a function since there's a prototype for it in proto.h */
753 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
756 int len = strlen(lnm);
760 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
761 if (!strcmp(uplnm,"DEFAULT")) {
762 if (eqv && *eqv) chdir(eqv);
767 if (len == 6 || len == 2) {
770 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
772 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
773 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
777 (void) vmssetenv(lnm,eqv,NULL);
781 /*{{{static void vmssetuserlnm(char *name, char *eqv);
783 * sets a user-mode logical in the process logical name table
784 * used for redirection of sys$error
787 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
789 $DESCRIPTOR(d_tab, "LNM$PROCESS");
790 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
791 unsigned long int iss, attr = LNM$M_CONFINE;
792 unsigned char acmode = PSL$C_USER;
793 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
795 d_name.dsc$a_pointer = name;
796 d_name.dsc$w_length = strlen(name);
798 lnmlst[0].buflen = strlen(eqv);
799 lnmlst[0].bufadr = eqv;
801 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
802 if (!(iss&1)) lib$signal(iss);
807 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
808 /* my_crypt - VMS password hashing
809 * my_crypt() provides an interface compatible with the Unix crypt()
810 * C library function, and uses sys$hash_password() to perform VMS
811 * password hashing. The quadword hashed password value is returned
812 * as a NUL-terminated 8 character string. my_crypt() does not change
813 * the case of its string arguments; in order to match the behavior
814 * of LOGINOUT et al., alphabetic characters in both arguments must
815 * be upcased by the caller.
818 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
820 # ifndef UAI$C_PREFERRED_ALGORITHM
821 # define UAI$C_PREFERRED_ALGORITHM 127
823 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
824 unsigned short int salt = 0;
825 unsigned long int sts;
827 unsigned short int dsc$w_length;
828 unsigned char dsc$b_type;
829 unsigned char dsc$b_class;
830 const char * dsc$a_pointer;
831 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
832 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
833 struct itmlst_3 uailst[3] = {
834 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
835 { sizeof salt, UAI$_SALT, &salt, 0},
836 { 0, 0, NULL, NULL}};
839 usrdsc.dsc$w_length = strlen(usrname);
840 usrdsc.dsc$a_pointer = usrname;
841 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
843 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
847 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
853 if (sts != RMS$_RNF) return NULL;
856 txtdsc.dsc$w_length = strlen(textpasswd);
857 txtdsc.dsc$a_pointer = textpasswd;
858 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
859 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
862 return (char *) hash;
864 } /* end of my_crypt() */
868 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
869 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
870 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
872 /*{{{int do_rmdir(char *name)*/
874 Perl_do_rmdir(pTHX_ char *name)
876 char dirfile[NAM$C_MAXRSS+1];
880 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
881 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
882 else retval = kill_file(dirfile);
885 } /* end of do_rmdir */
889 * Delete any file to which user has control access, regardless of whether
890 * delete access is explicitly allowed.
891 * Limitations: User must have write access to parent directory.
892 * Does not block signals or ASTs; if interrupted in midstream
893 * may leave file with an altered ACL.
896 /*{{{int kill_file(char *name)*/
898 Perl_kill_file(pTHX_ char *name)
900 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
901 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
902 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
903 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
905 unsigned char myace$b_length;
906 unsigned char myace$b_type;
907 unsigned short int myace$w_flags;
908 unsigned long int myace$l_access;
909 unsigned long int myace$l_ident;
910 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
911 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
912 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
914 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
915 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
916 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
917 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
918 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
919 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
921 /* Expand the input spec using RMS, since the CRTL remove() and
922 * system services won't do this by themselves, so we may miss
923 * a file "hiding" behind a logical name or search list. */
924 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
925 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
926 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
927 /* If not, can changing protections help? */
928 if (vaxc$errno != RMS$_PRV) return -1;
930 /* No, so we get our own UIC to use as a rights identifier,
931 * and the insert an ACE at the head of the ACL which allows us
932 * to delete the file.
934 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
935 fildsc.dsc$w_length = strlen(rspec);
936 fildsc.dsc$a_pointer = rspec;
938 newace.myace$l_ident = oldace.myace$l_ident;
939 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
941 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
942 set_errno(ENOENT); break;
944 set_errno(ENOTDIR); break;
946 set_errno(ENODEV); break;
947 case RMS$_SYN: case SS$_INVFILFOROP:
948 set_errno(EINVAL); break;
950 set_errno(EACCES); break;
954 set_vaxc_errno(aclsts);
957 /* Grab any existing ACEs with this identifier in case we fail */
958 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
959 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
960 || fndsts == SS$_NOMOREACE ) {
961 /* Add the new ACE . . . */
962 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
964 if ((rmsts = remove(name))) {
965 /* We blew it - dir with files in it, no write priv for
966 * parent directory, etc. Put things back the way they were. */
967 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
970 addlst[0].bufadr = &oldace;
971 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
978 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
979 /* We just deleted it, so of course it's not there. Some versions of
980 * VMS seem to return success on the unlock operation anyhow (after all
981 * the unlock is successful), but others don't.
983 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
984 if (aclsts & 1) aclsts = fndsts;
987 set_vaxc_errno(aclsts);
993 } /* end of kill_file() */
997 /*{{{int my_mkdir(char *,Mode_t)*/
999 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1001 STRLEN dirlen = strlen(dir);
1003 /* zero length string sometimes gives ACCVIO */
1004 if (dirlen == 0) return -1;
1006 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1007 * null file name/type. However, it's commonplace under Unix,
1008 * so we'll allow it for a gain in portability.
1010 if (dir[dirlen-1] == '/') {
1011 char *newdir = savepvn(dir,dirlen-1);
1012 int ret = mkdir(newdir,mode);
1016 else return mkdir(dir,mode);
1017 } /* end of my_mkdir */
1020 /*{{{int my_chdir(char *)*/
1022 Perl_my_chdir(pTHX_ char *dir)
1024 STRLEN dirlen = strlen(dir);
1026 /* zero length string sometimes gives ACCVIO */
1027 if (dirlen == 0) return -1;
1029 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1031 * null file name/type. However, it's commonplace under Unix,
1032 * so we'll allow it for a gain in portability.
1034 if (dir[dirlen-1] == '/') {
1035 char *newdir = savepvn(dir,dirlen-1);
1036 int ret = chdir(newdir);
1040 else return chdir(dir);
1041 } /* end of my_chdir */
1045 /*{{{FILE *my_tmpfile()*/
1052 if ((fp = tmpfile())) return fp;
1054 New(1323,cp,L_tmpnam+24,char);
1055 strcpy(cp,"Sys$Scratch:");
1056 tmpnam(cp+strlen(cp));
1057 strcat(cp,".Perltmp");
1058 fp = fopen(cp,"w+","fop=dlt");
1064 /* default piping mailbox size */
1065 #define PERL_BUFSIZ 512
1069 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1071 unsigned long int mbxbufsiz;
1072 static unsigned long int syssize = 0;
1073 unsigned long int dviitm = DVI$_DEVNAM;
1074 char csize[LNM$C_NAMLENGTH+1];
1077 unsigned long syiitm = SYI$_MAXBUF;
1079 * Get the SYSGEN parameter MAXBUF
1081 * If the logical 'PERL_MBX_SIZE' is defined
1082 * use the value of the logical instead of PERL_BUFSIZ, but
1083 * keep the size between 128 and MAXBUF.
1086 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1089 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1090 mbxbufsiz = atoi(csize);
1092 mbxbufsiz = PERL_BUFSIZ;
1094 if (mbxbufsiz < 128) mbxbufsiz = 128;
1095 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1097 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1099 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1100 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1102 } /* end of create_mbx() */
1105 /*{{{ my_popen and my_pclose*/
1107 typedef struct _iosb IOSB;
1108 typedef struct _iosb* pIOSB;
1109 typedef struct _pipe Pipe;
1110 typedef struct _pipe* pPipe;
1111 typedef struct pipe_details Info;
1112 typedef struct pipe_details* pInfo;
1113 typedef struct _srqp RQE;
1114 typedef struct _srqp* pRQE;
1115 typedef struct _tochildbuf CBuf;
1116 typedef struct _tochildbuf* pCBuf;
1119 unsigned short status;
1120 unsigned short count;
1121 unsigned long dvispec;
1124 #pragma member_alignment save
1125 #pragma nomember_alignment quadword
1126 struct _srqp { /* VMS self-relative queue entry */
1127 unsigned long qptr[2];
1129 #pragma member_alignment restore
1130 static RQE RQE_ZERO = {0,0};
1132 struct _tochildbuf {
1135 unsigned short size;
1143 unsigned short chan_in;
1144 unsigned short chan_out;
1146 unsigned int bufsize;
1158 #if defined(PERL_IMPLICIT_CONTEXT)
1159 void *thx; /* Either a thread or an interpreter */
1160 /* pointer, depending on how we're built */
1168 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1169 int pid; /* PID of subprocess */
1170 int mode; /* == 'r' if pipe open for reading */
1171 int done; /* subprocess has completed */
1172 int closing; /* my_pclose is closing this pipe */
1173 unsigned long completion; /* termination status of subprocess */
1174 pPipe in; /* pipe in to sub */
1175 pPipe out; /* pipe out of sub */
1176 pPipe err; /* pipe of sub's sys$error */
1177 int in_done; /* true when in pipe finished */
1182 struct exit_control_block
1184 struct exit_control_block *flink;
1185 unsigned long int (*exit_routine)();
1186 unsigned long int arg_count;
1187 unsigned long int *status_address;
1188 unsigned long int exit_status;
1191 #define RETRY_DELAY "0 ::0.20"
1192 #define MAX_RETRY 50
1194 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1195 static unsigned long mypid;
1196 static unsigned long delaytime[2];
1198 static pInfo open_pipes = NULL;
1199 static $DESCRIPTOR(nl_desc, "NL:");
1202 static unsigned long int
1203 pipe_exit_routine(pTHX)
1206 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1207 int sts, did_stuff, need_eof;
1210 first we try sending an EOF...ignore if doesn't work, make sure we
1218 _ckvmssts(sys$setast(0));
1219 if (info->in && !info->in->shut_on_empty) {
1220 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1224 _ckvmssts(sys$setast(1));
1227 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1232 _ckvmssts(sys$setast(0));
1233 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1234 sts = sys$forcex(&info->pid,0,&abort);
1235 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1238 _ckvmssts(sys$setast(1));
1241 if (did_stuff) sleep(1); /* wait for them to respond */
1245 _ckvmssts(sys$setast(0));
1246 if (!info->done) { /* We tried to be nice . . . */
1247 sts = sys$delprc(&info->pid,0);
1248 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1250 _ckvmssts(sys$setast(1));
1255 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1256 else if (!(sts & 1)) retsts = sts;
1261 static struct exit_control_block pipe_exitblock =
1262 {(struct exit_control_block *) 0,
1263 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1265 static void pipe_mbxtofd_ast(pPipe p);
1266 static void pipe_tochild1_ast(pPipe p);
1267 static void pipe_tochild2_ast(pPipe p);
1270 popen_completion_ast(pInfo info)
1272 pInfo i = open_pipes;
1276 if (i == info) break;
1279 if (!i) return; /* unlinked, probably freed too */
1281 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1285 Writing to subprocess ...
1286 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1288 chan_out may be waiting for "done" flag, or hung waiting
1289 for i/o completion to child...cancel the i/o. This will
1290 put it into "snarf mode" (done but no EOF yet) that discards
1293 Output from subprocess (stdout, stderr) needs to be flushed and
1294 shut down. We try sending an EOF, but if the mbx is full the pipe
1295 routine should still catch the "shut_on_empty" flag, telling it to
1296 use immediate-style reads so that "mbx empty" -> EOF.
1300 if (info->in && !info->in_done) { /* only for mode=w */
1301 if (info->in->shut_on_empty && info->in->need_wake) {
1302 info->in->need_wake = FALSE;
1303 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1305 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1309 if (info->out && !info->out_done) { /* were we also piping output? */
1310 info->out->shut_on_empty = TRUE;
1311 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1312 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1313 _ckvmssts_noperl(iss);
1316 if (info->err && !info->err_done) { /* we were piping stderr */
1317 info->err->shut_on_empty = TRUE;
1318 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1319 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1320 _ckvmssts_noperl(iss);
1322 _ckvmssts_noperl(sys$setef(pipe_ef));
1326 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
1327 static void vms_execfree(pTHX);
1330 we actually differ from vmstrnenv since we use this to
1331 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1332 are pointing to the same thing
1335 static unsigned short
1336 popen_translate(pTHX_ char *logical, char *result)
1339 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1340 $DESCRIPTOR(d_log,"");
1342 unsigned short length;
1343 unsigned short code;
1345 unsigned short *retlenaddr;
1347 unsigned short l, ifi;
1349 d_log.dsc$a_pointer = logical;
1350 d_log.dsc$w_length = strlen(logical);
1352 itmlst[0].code = LNM$_STRING;
1353 itmlst[0].length = 255;
1354 itmlst[0].buffer_addr = result;
1355 itmlst[0].retlenaddr = &l;
1358 itmlst[1].length = 0;
1359 itmlst[1].buffer_addr = 0;
1360 itmlst[1].retlenaddr = 0;
1362 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1363 if (iss == SS$_NOLOGNAM) {
1367 if (!(iss&1)) lib$signal(iss);
1370 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1371 strip it off and return the ifi, if any
1374 if (result[0] == 0x1b && result[1] == 0x00) {
1375 memcpy(&ifi,result+2,2);
1376 strcpy(result,result+4);
1378 return ifi; /* this is the RMS internal file id */
1381 #define MAX_DCL_SYMBOL 255
1382 static void pipe_infromchild_ast(pPipe p);
1385 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1386 inside an AST routine without worrying about reentrancy and which Perl
1387 memory allocator is being used.
1389 We read data and queue up the buffers, then spit them out one at a
1390 time to the output mailbox when the output mailbox is ready for one.
1393 #define INITIAL_TOCHILDQUEUE 2
1396 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1400 char mbx1[64], mbx2[64];
1401 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1402 DSC$K_CLASS_S, mbx1},
1403 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1404 DSC$K_CLASS_S, mbx2};
1405 unsigned int dviitm = DVI$_DEVBUFSIZ;
1408 New(1368, p, 1, Pipe);
1410 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1411 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1412 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1415 p->shut_on_empty = FALSE;
1416 p->need_wake = FALSE;
1419 p->iosb.status = SS$_NORMAL;
1420 p->iosb2.status = SS$_NORMAL;
1426 #ifdef PERL_IMPLICIT_CONTEXT
1430 n = sizeof(CBuf) + p->bufsize;
1432 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1433 _ckvmssts(lib$get_vm(&n, &b));
1434 b->buf = (char *) b + sizeof(CBuf);
1435 _ckvmssts(lib$insqhi(b, &p->free));
1438 pipe_tochild2_ast(p);
1439 pipe_tochild1_ast(p);
1445 /* reads the MBX Perl is writing, and queues */
1448 pipe_tochild1_ast(pPipe p)
1451 int iss = p->iosb.status;
1452 int eof = (iss == SS$_ENDOFFILE);
1453 #ifdef PERL_IMPLICIT_CONTEXT
1459 p->shut_on_empty = TRUE;
1461 _ckvmssts(sys$dassgn(p->chan_in));
1467 b->size = p->iosb.count;
1468 _ckvmssts(lib$insqhi(b, &p->wait));
1470 p->need_wake = FALSE;
1471 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1474 p->retry = 1; /* initial call */
1477 if (eof) { /* flush the free queue, return when done */
1478 int n = sizeof(CBuf) + p->bufsize;
1480 iss = lib$remqti(&p->free, &b);
1481 if (iss == LIB$_QUEWASEMP) return;
1483 _ckvmssts(lib$free_vm(&n, &b));
1487 iss = lib$remqti(&p->free, &b);
1488 if (iss == LIB$_QUEWASEMP) {
1489 int n = sizeof(CBuf) + p->bufsize;
1490 _ckvmssts(lib$get_vm(&n, &b));
1491 b->buf = (char *) b + sizeof(CBuf);
1497 iss = sys$qio(0,p->chan_in,
1498 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1500 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1501 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1506 /* writes queued buffers to output, waits for each to complete before
1510 pipe_tochild2_ast(pPipe p)
1513 int iss = p->iosb2.status;
1514 int n = sizeof(CBuf) + p->bufsize;
1515 int done = (p->info && p->info->done) ||
1516 iss == SS$_CANCEL || iss == SS$_ABORT;
1517 #if defined(PERL_IMPLICIT_CONTEXT)
1522 if (p->type) { /* type=1 has old buffer, dispose */
1523 if (p->shut_on_empty) {
1524 _ckvmssts(lib$free_vm(&n, &b));
1526 _ckvmssts(lib$insqhi(b, &p->free));
1531 iss = lib$remqti(&p->wait, &b);
1532 if (iss == LIB$_QUEWASEMP) {
1533 if (p->shut_on_empty) {
1535 _ckvmssts(sys$dassgn(p->chan_out));
1536 *p->pipe_done = TRUE;
1537 _ckvmssts(sys$setef(pipe_ef));
1539 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1540 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1544 p->need_wake = TRUE;
1554 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1555 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1557 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1558 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1567 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1570 char mbx1[64], mbx2[64];
1571 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1572 DSC$K_CLASS_S, mbx1},
1573 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1574 DSC$K_CLASS_S, mbx2};
1575 unsigned int dviitm = DVI$_DEVBUFSIZ;
1577 New(1367, p, 1, Pipe);
1578 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1579 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1581 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1582 New(1367, p->buf, p->bufsize, char);
1583 p->shut_on_empty = FALSE;
1586 p->iosb.status = SS$_NORMAL;
1587 #if defined(PERL_IMPLICIT_CONTEXT)
1590 pipe_infromchild_ast(p);
1598 pipe_infromchild_ast(pPipe p)
1600 int iss = p->iosb.status;
1601 int eof = (iss == SS$_ENDOFFILE);
1602 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1603 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1604 #if defined(PERL_IMPLICIT_CONTEXT)
1608 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1609 _ckvmssts(sys$dassgn(p->chan_out));
1614 input shutdown if EOF from self (done or shut_on_empty)
1615 output shutdown if closing flag set (my_pclose)
1616 send data/eof from child or eof from self
1617 otherwise, re-read (snarf of data from child)
1622 if (myeof && p->chan_in) { /* input shutdown */
1623 _ckvmssts(sys$dassgn(p->chan_in));
1628 if (myeof || kideof) { /* pass EOF to parent */
1629 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1630 pipe_infromchild_ast, p,
1633 } else if (eof) { /* eat EOF --- fall through to read*/
1635 } else { /* transmit data */
1636 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1637 pipe_infromchild_ast,p,
1638 p->buf, p->iosb.count, 0, 0, 0, 0));
1644 /* everything shut? flag as done */
1646 if (!p->chan_in && !p->chan_out) {
1647 *p->pipe_done = TRUE;
1648 _ckvmssts(sys$setef(pipe_ef));
1652 /* write completed (or read, if snarfing from child)
1653 if still have input active,
1654 queue read...immediate mode if shut_on_empty so we get EOF if empty
1656 check if Perl reading, generate EOFs as needed
1662 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1663 pipe_infromchild_ast,p,
1664 p->buf, p->bufsize, 0, 0, 0, 0);
1665 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1667 } else { /* send EOFs for extra reads */
1668 p->iosb.status = SS$_ENDOFFILE;
1669 p->iosb.dvispec = 0;
1670 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1672 pipe_infromchild_ast, p, 0, 0, 0, 0));
1678 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1682 unsigned long dviitm = DVI$_DEVBUFSIZ;
1684 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1685 DSC$K_CLASS_S, mbx};
1687 /* things like terminals and mbx's don't need this filter */
1688 if (fd && fstat(fd,&s) == 0) {
1689 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1690 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1691 DSC$K_CLASS_S, s.st_dev};
1693 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1694 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1695 strcpy(out, s.st_dev);
1700 New(1366, p, 1, Pipe);
1701 p->fd_out = dup(fd);
1702 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1703 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1704 New(1366, p->buf, p->bufsize+1, char);
1705 p->shut_on_empty = FALSE;
1710 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1711 pipe_mbxtofd_ast, p,
1712 p->buf, p->bufsize, 0, 0, 0, 0));
1718 pipe_mbxtofd_ast(pPipe p)
1720 int iss = p->iosb.status;
1721 int done = p->info->done;
1723 int eof = (iss == SS$_ENDOFFILE);
1724 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1725 int err = !(iss&1) && !eof;
1726 #if defined(PERL_IMPLICIT_CONTEXT)
1730 if (done && myeof) { /* end piping */
1732 sys$dassgn(p->chan_in);
1733 *p->pipe_done = TRUE;
1734 _ckvmssts(sys$setef(pipe_ef));
1738 if (!err && !eof) { /* good data to send to file */
1739 p->buf[p->iosb.count] = '\n';
1740 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1743 if (p->retry < MAX_RETRY) {
1744 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1754 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1755 pipe_mbxtofd_ast, p,
1756 p->buf, p->bufsize, 0, 0, 0, 0);
1757 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1762 typedef struct _pipeloc PLOC;
1763 typedef struct _pipeloc* pPLOC;
1767 char dir[NAM$C_MAXRSS+1];
1769 static pPLOC head_PLOC = 0;
1772 free_pipelocs(pTHX_ void *head)
1785 store_pipelocs(pTHX)
1789 AV *av = GvAVn(PL_incgv);
1794 char temp[NAM$C_MAXRSS+1];
1797 /* the . directory from @INC comes last */
1800 p->next = head_PLOC;
1802 strcpy(p->dir,"./");
1804 /* get the directory from $^X */
1806 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1807 strcpy(temp, PL_origargv[0]);
1808 x = strrchr(temp,']');
1811 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1813 p->next = head_PLOC;
1815 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1816 p->dir[NAM$C_MAXRSS] = '\0';
1820 /* reverse order of @INC entries, skip "." since entered above */
1822 for (i = 0; i <= AvFILL(av); i++) {
1823 dirsv = *av_fetch(av,i,TRUE);
1825 if (SvROK(dirsv)) continue;
1826 dir = SvPVx(dirsv,n_a);
1827 if (strcmp(dir,".") == 0) continue;
1828 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1832 p->next = head_PLOC;
1834 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1835 p->dir[NAM$C_MAXRSS] = '\0';
1838 /* most likely spot (ARCHLIB) put first in the list */
1841 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1843 p->next = head_PLOC;
1845 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1846 p->dir[NAM$C_MAXRSS] = '\0';
1849 Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
1856 static int vmspipe_file_status = 0;
1857 static char vmspipe_file[NAM$C_MAXRSS+1];
1859 /* already found? Check and use ... need read+execute permission */
1861 if (vmspipe_file_status == 1) {
1862 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1863 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1864 return vmspipe_file;
1866 vmspipe_file_status = 0;
1869 /* scan through stored @INC, $^X */
1871 if (vmspipe_file_status == 0) {
1872 char file[NAM$C_MAXRSS+1];
1873 pPLOC p = head_PLOC;
1876 strcpy(file, p->dir);
1877 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1878 file[NAM$C_MAXRSS] = '\0';
1881 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1883 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1884 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1885 vmspipe_file_status = 1;
1886 return vmspipe_file;
1889 vmspipe_file_status = -1; /* failed, use tempfiles */
1896 vmspipe_tempfile(pTHX)
1898 char file[NAM$C_MAXRSS+1];
1900 static int index = 0;
1903 /* create a tempfile */
1905 /* we can't go from W, shr=get to R, shr=get without
1906 an intermediate vulnerable state, so don't bother trying...
1908 and lib$spawn doesn't shr=put, so have to close the write
1910 So... match up the creation date/time and the FID to
1911 make sure we're dealing with the same file
1916 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1917 fp = fopen(file,"w");
1919 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1920 fp = fopen(file,"w");
1922 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1923 fp = fopen(file,"w");
1926 if (!fp) return 0; /* we're hosed */
1928 fprintf(fp,"$! 'f$verify(0)\n");
1929 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1930 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1931 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1932 fprintf(fp,"$ perl_on = \"set noon\"\n");
1933 fprintf(fp,"$ perl_exit = \"exit\"\n");
1934 fprintf(fp,"$ perl_del = \"delete\"\n");
1935 fprintf(fp,"$ pif = \"if\"\n");
1936 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1937 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
1938 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
1939 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1940 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1941 fprintf(fp,"$! --- get rid of global symbols\n");
1942 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1943 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1944 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1945 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1946 fprintf(fp,"$ perl_on\n");
1947 fprintf(fp,"$ 'cmd\n");
1948 fprintf(fp,"$ perl_status = $STATUS\n");
1949 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1950 fprintf(fp,"$ perl_exit 'perl_status'\n");
1953 fgetname(fp, file, 1);
1954 fstat(fileno(fp), &s0);
1957 fp = fopen(file,"r","shr=get");
1959 fstat(fileno(fp), &s1);
1961 if (s0.st_ino[0] != s1.st_ino[0] ||
1962 s0.st_ino[1] != s1.st_ino[1] ||
1963 s0.st_ino[2] != s1.st_ino[2] ||
1964 s0.st_ctime != s1.st_ctime ) {
1975 safe_popen(pTHX_ char *cmd, char *mode)
1977 static int handler_set_up = FALSE;
1978 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1979 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1980 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1981 char in[512], out[512], err[512], mbx[512];
1983 char tfilebuf[NAM$C_MAXRSS+1];
1985 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1986 DSC$K_CLASS_S, symbol};
1987 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1990 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1991 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1992 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
1993 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1995 /* once-per-program initialization...
1996 note that the SETAST calls and the dual test of pipe_ef
1997 makes sure that only the FIRST thread through here does
1998 the initialization...all other threads wait until it's
2001 Yeah, uglier than a pthread call, it's got all the stuff inline
2002 rather than in a separate routine.
2006 _ckvmssts(sys$setast(0));
2008 unsigned long int pidcode = JPI$_PID;
2009 $DESCRIPTOR(d_delay, RETRY_DELAY);
2010 _ckvmssts(lib$get_ef(&pipe_ef));
2011 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2012 _ckvmssts(sys$bintim(&d_delay, delaytime));
2014 if (!handler_set_up) {
2015 _ckvmssts(sys$dclexh(&pipe_exitblock));
2016 handler_set_up = TRUE;
2018 _ckvmssts(sys$setast(1));
2021 /* see if we can find a VMSPIPE.COM */
2024 vmspipe = find_vmspipe(aTHX);
2026 strcpy(tfilebuf+1,vmspipe);
2027 } else { /* uh, oh...we're in tempfile hell */
2028 tpipe = vmspipe_tempfile(aTHX);
2029 if (!tpipe) { /* a fish popular in Boston */
2030 if (ckWARN(WARN_PIPE)) {
2031 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2035 fgetname(tpipe,tfilebuf+1,1);
2037 vmspipedsc.dsc$a_pointer = tfilebuf;
2038 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2040 if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
2041 New(1301,info,1,Info);
2045 info->completion = 0;
2046 info->closing = FALSE;
2050 info->in_done = TRUE;
2051 info->out_done = TRUE;
2052 info->err_done = TRUE;
2053 in[0] = out[0] = err[0] = '\0';
2055 if (*mode == 'r') { /* piping from subroutine */
2057 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2059 info->out->pipe_done = &info->out_done;
2060 info->out_done = FALSE;
2061 info->out->info = info;
2063 info->fp = PerlIO_open(mbx, mode);
2064 if (!info->fp && info->out) {
2065 sys$cancel(info->out->chan_out);
2067 while (!info->out_done) {
2069 _ckvmssts(sys$setast(0));
2070 done = info->out_done;
2071 if (!done) _ckvmssts(sys$clref(pipe_ef));
2072 _ckvmssts(sys$setast(1));
2073 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2076 if (info->out->buf) Safefree(info->out->buf);
2077 Safefree(info->out);
2082 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2084 info->err->pipe_done = &info->err_done;
2085 info->err_done = FALSE;
2086 info->err->info = info;
2089 } else { /* piping to subroutine , mode=w*/
2091 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2092 info->fp = PerlIO_open(mbx, mode);
2094 info->in->pipe_done = &info->in_done;
2095 info->in_done = FALSE;
2096 info->in->info = info;
2100 if (!info->fp && info->in) {
2102 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2103 0, 0, 0, 0, 0, 0, 0, 0));
2105 while (!info->in_done) {
2107 _ckvmssts(sys$setast(0));
2108 done = info->in_done;
2109 if (!done) _ckvmssts(sys$clref(pipe_ef));
2110 _ckvmssts(sys$setast(1));
2111 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2114 if (info->in->buf) Safefree(info->in->buf);
2121 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2123 info->out->pipe_done = &info->out_done;
2124 info->out_done = FALSE;
2125 info->out->info = info;
2128 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2130 info->err->pipe_done = &info->err_done;
2131 info->err_done = FALSE;
2132 info->err->info = info;
2136 symbol[MAX_DCL_SYMBOL] = '\0';
2138 strncpy(symbol, in, MAX_DCL_SYMBOL);
2139 d_symbol.dsc$w_length = strlen(symbol);
2140 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2142 strncpy(symbol, err, MAX_DCL_SYMBOL);
2143 d_symbol.dsc$w_length = strlen(symbol);
2144 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2146 strncpy(symbol, out, MAX_DCL_SYMBOL);
2147 d_symbol.dsc$w_length = strlen(symbol);
2148 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2150 p = VMScmd.dsc$a_pointer;
2151 while (*p && *p != '\n') p++;
2152 *p = '\0'; /* truncate on \n */
2153 p = VMScmd.dsc$a_pointer;
2154 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2155 if (*p == '$') p++; /* remove leading $ */
2156 while (*p == ' ' || *p == '\t') p++;
2157 strncpy(symbol, p, MAX_DCL_SYMBOL);
2158 d_symbol.dsc$w_length = strlen(symbol);
2159 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2161 _ckvmssts(sys$setast(0));
2162 info->next=open_pipes; /* prepend to list */
2164 _ckvmssts(sys$setast(1));
2165 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2166 0, &info->pid, &info->completion,
2167 0, popen_completion_ast,info,0,0,0));
2169 /* if we were using a tempfile, close it now */
2171 if (tpipe) fclose(tpipe);
2173 /* once the subprocess is spawned, its copied the symbols and
2174 we can get rid of ours */
2176 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2177 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2178 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2179 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2182 PL_forkprocess = info->pid;
2184 } /* end of safe_popen */
2187 /*{{{ FILE *my_popen(char *cmd, char *mode)*/
2189 Perl_my_popen(pTHX_ char *cmd, char *mode)
2192 TAINT_PROPER("popen");
2193 PERL_FLUSHALL_FOR_CHILD;
2194 return safe_popen(aTHX_ cmd,mode);
2199 /*{{{ I32 my_pclose(FILE *fp)*/
2200 I32 Perl_my_pclose(pTHX_ FILE *fp)
2202 pInfo info, last = NULL;
2203 unsigned long int retsts;
2206 for (info = open_pipes; info != NULL; last = info, info = info->next)
2207 if (info->fp == fp) break;
2209 if (info == NULL) { /* no such pipe open */
2210 set_errno(ECHILD); /* quoth POSIX */
2211 set_vaxc_errno(SS$_NONEXPR);
2215 /* If we were writing to a subprocess, insure that someone reading from
2216 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2217 * produce an EOF record in the mailbox.
2219 * well, at least sometimes it *does*, so we have to watch out for
2220 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2223 fsync(fileno(info->fp)); /* first, flush data */
2225 _ckvmssts(sys$setast(0));
2226 info->closing = TRUE;
2227 done = info->done && info->in_done && info->out_done && info->err_done;
2228 /* hanging on write to Perl's input? cancel it */
2229 if (info->mode == 'r' && info->out && !info->out_done) {
2230 if (info->out->chan_out) {
2231 _ckvmssts(sys$cancel(info->out->chan_out));
2232 if (!info->out->chan_in) { /* EOF generation, need AST */
2233 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2237 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2238 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2240 _ckvmssts(sys$setast(1));
2241 PerlIO_close(info->fp);
2244 we have to wait until subprocess completes, but ALSO wait until all
2245 the i/o completes...otherwise we'll be freeing the "info" structure
2246 that the i/o ASTs could still be using...
2250 _ckvmssts(sys$setast(0));
2251 done = info->done && info->in_done && info->out_done && info->err_done;
2252 if (!done) _ckvmssts(sys$clref(pipe_ef));
2253 _ckvmssts(sys$setast(1));
2254 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2256 retsts = info->completion;
2258 /* remove from list of open pipes */
2259 _ckvmssts(sys$setast(0));
2260 if (last) last->next = info->next;
2261 else open_pipes = info->next;
2262 _ckvmssts(sys$setast(1));
2264 /* free buffers and structures */
2267 if (info->in->buf) Safefree(info->in->buf);
2271 if (info->out->buf) Safefree(info->out->buf);
2272 Safefree(info->out);
2275 if (info->err->buf) Safefree(info->err->buf);
2276 Safefree(info->err);
2282 } /* end of my_pclose() */
2284 /* sort-of waitpid; use only with popen() */
2285 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2287 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2292 for (info = open_pipes; info != NULL; info = info->next)
2293 if (info->pid == pid) break;
2295 if (info != NULL) { /* we know about this child */
2296 while (!info->done) {
2297 _ckvmssts(sys$setast(0));
2299 if (!done) _ckvmssts(sys$clref(pipe_ef));
2300 _ckvmssts(sys$setast(1));
2301 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2304 *statusp = info->completion;
2307 else { /* we haven't heard of this child */
2308 $DESCRIPTOR(intdsc,"0 00:00:01");
2309 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2310 unsigned long int interval[2],sts;
2312 if (ckWARN(WARN_EXEC)) {
2313 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2314 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2315 if (ownerpid != mypid)
2316 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2319 _ckvmssts(sys$bintim(&intdsc,interval));
2320 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2321 _ckvmssts(sys$schdwk(0,0,interval,0));
2322 _ckvmssts(sys$hiber());
2324 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2327 /* There's no easy way to find the termination status a child we're
2328 * not aware of beforehand. If we're really interested in the future,
2329 * we can go looking for a termination mailbox, or chase after the
2330 * accounting record for the process.
2336 } /* end of waitpid() */
2341 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2343 my_gconvert(double val, int ndig, int trail, char *buf)
2345 static char __gcvtbuf[DBL_DIG+1];
2348 loc = buf ? buf : __gcvtbuf;
2350 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2352 sprintf(loc,"%.*g",ndig,val);
2358 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2359 return gcvt(val,ndig,loc);
2362 loc[0] = '0'; loc[1] = '\0';
2370 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2371 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2372 * to expand file specification. Allows for a single default file
2373 * specification and a simple mask of options. If outbuf is non-NULL,
2374 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2375 * the resultant file specification is placed. If outbuf is NULL, the
2376 * resultant file specification is placed into a static buffer.
2377 * The third argument, if non-NULL, is taken to be a default file
2378 * specification string. The fourth argument is unused at present.
2379 * rmesexpand() returns the address of the resultant string if
2380 * successful, and NULL on error.
2382 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2385 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2387 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2388 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2389 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2390 struct FAB myfab = cc$rms_fab;
2391 struct NAM mynam = cc$rms_nam;
2393 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2395 if (!filespec || !*filespec) {
2396 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2400 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2401 else outbuf = __rmsexpand_retbuf;
2403 if ((isunix = (strchr(filespec,'/') != NULL))) {
2404 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2405 filespec = vmsfspec;
2408 myfab.fab$l_fna = filespec;
2409 myfab.fab$b_fns = strlen(filespec);
2410 myfab.fab$l_nam = &mynam;
2412 if (defspec && *defspec) {
2413 if (strchr(defspec,'/') != NULL) {
2414 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2417 myfab.fab$l_dna = defspec;
2418 myfab.fab$b_dns = strlen(defspec);
2421 mynam.nam$l_esa = esa;
2422 mynam.nam$b_ess = sizeof esa;
2423 mynam.nam$l_rsa = outbuf;
2424 mynam.nam$b_rss = NAM$C_MAXRSS;
2426 retsts = sys$parse(&myfab,0,0);
2427 if (!(retsts & 1)) {
2428 mynam.nam$b_nop |= NAM$M_SYNCHK;
2429 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2430 retsts = sys$parse(&myfab,0,0);
2431 if (retsts & 1) goto expanded;
2433 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2434 (void) sys$parse(&myfab,0,0); /* Free search context */
2435 if (out) Safefree(out);
2436 set_vaxc_errno(retsts);
2437 if (retsts == RMS$_PRV) set_errno(EACCES);
2438 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2439 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2440 else set_errno(EVMSERR);
2443 retsts = sys$search(&myfab,0,0);
2444 if (!(retsts & 1) && retsts != RMS$_FNF) {
2445 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2446 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2447 if (out) Safefree(out);
2448 set_vaxc_errno(retsts);
2449 if (retsts == RMS$_PRV) set_errno(EACCES);
2450 else set_errno(EVMSERR);
2454 /* If the input filespec contained any lowercase characters,
2455 * downcase the result for compatibility with Unix-minded code. */
2457 for (out = myfab.fab$l_fna; *out; out++)
2458 if (islower(*out)) { haslower = 1; break; }
2459 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2460 else { out = esa; speclen = mynam.nam$b_esl; }
2461 /* Trim off null fields added by $PARSE
2462 * If type > 1 char, must have been specified in original or default spec
2463 * (not true for version; $SEARCH may have added version of existing file).
2465 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2466 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2467 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2468 if (trimver || trimtype) {
2469 if (defspec && *defspec) {
2470 char defesa[NAM$C_MAXRSS];
2471 struct FAB deffab = cc$rms_fab;
2472 struct NAM defnam = cc$rms_nam;
2474 deffab.fab$l_nam = &defnam;
2475 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2476 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2477 defnam.nam$b_nop = NAM$M_SYNCHK;
2478 if (sys$parse(&deffab,0,0) & 1) {
2479 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2480 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2483 if (trimver) speclen = mynam.nam$l_ver - out;
2485 /* If we didn't already trim version, copy down */
2486 if (speclen > mynam.nam$l_ver - out)
2487 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2488 speclen - (mynam.nam$l_ver - out));
2489 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2492 /* If we just had a directory spec on input, $PARSE "helpfully"
2493 * adds an empty name and type for us */
2494 if (mynam.nam$l_name == mynam.nam$l_type &&
2495 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2496 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2497 speclen = mynam.nam$l_name - out;
2498 out[speclen] = '\0';
2499 if (haslower) __mystrtolower(out);
2501 /* Have we been working with an expanded, but not resultant, spec? */
2502 /* Also, convert back to Unix syntax if necessary. */
2503 if (!mynam.nam$b_rsl) {
2505 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2507 else strcpy(outbuf,esa);
2510 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2511 strcpy(outbuf,tmpfspec);
2513 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2514 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2515 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2519 /* External entry points */
2520 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2521 { return do_rmsexpand(spec,buf,0,def,opt); }
2522 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2523 { return do_rmsexpand(spec,buf,1,def,opt); }
2527 ** The following routines are provided to make life easier when
2528 ** converting among VMS-style and Unix-style directory specifications.
2529 ** All will take input specifications in either VMS or Unix syntax. On
2530 ** failure, all return NULL. If successful, the routines listed below
2531 ** return a pointer to a buffer containing the appropriately
2532 ** reformatted spec (and, therefore, subsequent calls to that routine
2533 ** will clobber the result), while the routines of the same names with
2534 ** a _ts suffix appended will return a pointer to a mallocd string
2535 ** containing the appropriately reformatted spec.
2536 ** In all cases, only explicit syntax is altered; no check is made that
2537 ** the resulting string is valid or that the directory in question
2540 ** fileify_dirspec() - convert a directory spec into the name of the
2541 ** directory file (i.e. what you can stat() to see if it's a dir).
2542 ** The style (VMS or Unix) of the result is the same as the style
2543 ** of the parameter passed in.
2544 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2545 ** what you prepend to a filename to indicate what directory it's in).
2546 ** The style (VMS or Unix) of the result is the same as the style
2547 ** of the parameter passed in.
2548 ** tounixpath() - convert a directory spec into a Unix-style path.
2549 ** tovmspath() - convert a directory spec into a VMS-style path.
2550 ** tounixspec() - convert any file spec into a Unix-style file spec.
2551 ** tovmsspec() - convert any file spec into a VMS-style spec.
2553 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2554 ** Permission is given to distribute this code as part of the Perl
2555 ** standard distribution under the terms of the GNU General Public
2556 ** License or the Perl Artistic License. Copies of each may be
2557 ** found in the Perl standard distribution.
2560 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2561 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2563 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2564 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2565 char *retspec, *cp1, *cp2, *lastdir;
2566 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2568 if (!dir || !*dir) {
2569 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2571 dirlen = strlen(dir);
2572 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2573 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2574 strcpy(trndir,"/sys$disk/000000");
2578 if (dirlen > NAM$C_MAXRSS) {
2579 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2581 if (!strpbrk(dir+1,"/]>:")) {
2582 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2583 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2585 dirlen = strlen(dir);
2588 strncpy(trndir,dir,dirlen);
2589 trndir[dirlen] = '\0';
2592 /* If we were handed a rooted logical name or spec, treat it like a
2593 * simple directory, so that
2594 * $ Define myroot dev:[dir.]
2595 * ... do_fileify_dirspec("myroot",buf,1) ...
2596 * does something useful.
2598 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2599 dir[--dirlen] = '\0';
2600 dir[dirlen-1] = ']';
2603 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2604 /* If we've got an explicit filename, we can just shuffle the string. */
2605 if (*(cp1+1)) hasfilename = 1;
2606 /* Similarly, we can just back up a level if we've got multiple levels
2607 of explicit directories in a VMS spec which ends with directories. */
2609 for (cp2 = cp1; cp2 > dir; cp2--) {
2611 *cp2 = *cp1; *cp1 = '\0';
2615 if (*cp2 == '[' || *cp2 == '<') break;
2620 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2621 if (dir[0] == '.') {
2622 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2623 return do_fileify_dirspec("[]",buf,ts);
2624 else if (dir[1] == '.' &&
2625 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2626 return do_fileify_dirspec("[-]",buf,ts);
2628 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2629 dirlen -= 1; /* to last element */
2630 lastdir = strrchr(dir,'/');
2632 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2633 /* If we have "/." or "/..", VMSify it and let the VMS code
2634 * below expand it, rather than repeating the code to handle
2635 * relative components of a filespec here */
2637 if (*(cp1+2) == '.') cp1++;
2638 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2639 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2640 if (strchr(vmsdir,'/') != NULL) {
2641 /* If do_tovmsspec() returned it, it must have VMS syntax
2642 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2643 * the time to check this here only so we avoid a recursion
2644 * loop; otherwise, gigo.
2646 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2648 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2649 return do_tounixspec(trndir,buf,ts);
2652 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2653 lastdir = strrchr(dir,'/');
2655 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2656 /* Ditto for specs that end in an MFD -- let the VMS code
2657 * figure out whether it's a real device or a rooted logical. */
2658 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2659 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2660 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2661 return do_tounixspec(trndir,buf,ts);
2664 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2665 !(lastdir = cp1 = strrchr(dir,']')) &&
2666 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2667 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2669 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2670 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2671 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2672 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2673 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2674 (ver || *cp3)))))) {
2676 set_vaxc_errno(RMS$_DIR);
2682 /* If we lead off with a device or rooted logical, add the MFD
2683 if we're specifying a top-level directory. */
2684 if (lastdir && *dir == '/') {
2686 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2693 retlen = dirlen + (addmfd ? 13 : 6);
2694 if (buf) retspec = buf;
2695 else if (ts) New(1309,retspec,retlen+1,char);
2696 else retspec = __fileify_retbuf;
2698 dirlen = lastdir - dir;
2699 memcpy(retspec,dir,dirlen);
2700 strcpy(&retspec[dirlen],"/000000");
2701 strcpy(&retspec[dirlen+7],lastdir);
2704 memcpy(retspec,dir,dirlen);
2705 retspec[dirlen] = '\0';
2707 /* We've picked up everything up to the directory file name.
2708 Now just add the type and version, and we're set. */
2709 strcat(retspec,".dir;1");
2712 else { /* VMS-style directory spec */
2713 char esa[NAM$C_MAXRSS+1], term, *cp;
2714 unsigned long int sts, cmplen, haslower = 0;
2715 struct FAB dirfab = cc$rms_fab;
2716 struct NAM savnam, dirnam = cc$rms_nam;
2718 dirfab.fab$b_fns = strlen(dir);
2719 dirfab.fab$l_fna = dir;
2720 dirfab.fab$l_nam = &dirnam;
2721 dirfab.fab$l_dna = ".DIR;1";
2722 dirfab.fab$b_dns = 6;
2723 dirnam.nam$b_ess = NAM$C_MAXRSS;
2724 dirnam.nam$l_esa = esa;
2726 for (cp = dir; *cp; cp++)
2727 if (islower(*cp)) { haslower = 1; break; }
2728 if (!((sts = sys$parse(&dirfab))&1)) {
2729 if (dirfab.fab$l_sts == RMS$_DIR) {
2730 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2731 sts = sys$parse(&dirfab) & 1;
2735 set_vaxc_errno(dirfab.fab$l_sts);
2741 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2742 /* Yes; fake the fnb bits so we'll check type below */
2743 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2745 else { /* No; just work with potential name */
2746 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2748 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2749 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2750 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2755 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2756 cp1 = strchr(esa,']');
2757 if (!cp1) cp1 = strchr(esa,'>');
2758 if (cp1) { /* Should always be true */
2759 dirnam.nam$b_esl -= cp1 - esa - 1;
2760 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2763 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2764 /* Yep; check version while we're at it, if it's there. */
2765 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2766 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2767 /* Something other than .DIR[;1]. Bzzt. */
2768 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2769 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2771 set_vaxc_errno(RMS$_DIR);
2775 esa[dirnam.nam$b_esl] = '\0';
2776 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2777 /* They provided at least the name; we added the type, if necessary, */
2778 if (buf) retspec = buf; /* in sys$parse() */
2779 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2780 else retspec = __fileify_retbuf;
2781 strcpy(retspec,esa);
2782 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2783 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2786 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2787 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2789 dirnam.nam$b_esl -= 9;
2791 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2792 if (cp1 == NULL) { /* should never happen */
2793 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2794 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2799 retlen = strlen(esa);
2800 if ((cp1 = strrchr(esa,'.')) != NULL) {
2801 /* There's more than one directory in the path. Just roll back. */
2803 if (buf) retspec = buf;
2804 else if (ts) New(1311,retspec,retlen+7,char);
2805 else retspec = __fileify_retbuf;
2806 strcpy(retspec,esa);
2809 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2810 /* Go back and expand rooted logical name */
2811 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2812 if (!(sys$parse(&dirfab) & 1)) {
2813 dirnam.nam$l_rlf = NULL;
2814 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2816 set_vaxc_errno(dirfab.fab$l_sts);
2819 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2820 if (buf) retspec = buf;
2821 else if (ts) New(1312,retspec,retlen+16,char);
2822 else retspec = __fileify_retbuf;
2823 cp1 = strstr(esa,"][");
2825 memcpy(retspec,esa,dirlen);
2826 if (!strncmp(cp1+2,"000000]",7)) {
2827 retspec[dirlen-1] = '\0';
2828 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2829 if (*cp1 == '.') *cp1 = ']';
2831 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2832 memcpy(cp1+1,"000000]",7);
2836 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2837 retspec[retlen] = '\0';
2838 /* Convert last '.' to ']' */
2839 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2840 if (*cp1 == '.') *cp1 = ']';
2842 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2843 memcpy(cp1+1,"000000]",7);
2847 else { /* This is a top-level dir. Add the MFD to the path. */
2848 if (buf) retspec = buf;
2849 else if (ts) New(1312,retspec,retlen+16,char);
2850 else retspec = __fileify_retbuf;
2853 while (*cp1 != ':') *(cp2++) = *(cp1++);
2854 strcpy(cp2,":[000000]");
2859 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2860 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2861 /* We've set up the string up through the filename. Add the
2862 type and version, and we're done. */
2863 strcat(retspec,".DIR;1");
2865 /* $PARSE may have upcased filespec, so convert output to lower
2866 * case if input contained any lowercase characters. */
2867 if (haslower) __mystrtolower(retspec);
2870 } /* end of do_fileify_dirspec() */
2872 /* External entry points */
2873 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2874 { return do_fileify_dirspec(dir,buf,0); }
2875 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2876 { return do_fileify_dirspec(dir,buf,1); }
2878 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2879 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2881 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2882 unsigned long int retlen;
2883 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2885 if (!dir || !*dir) {
2886 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2889 if (*dir) strcpy(trndir,dir);
2890 else getcwd(trndir,sizeof trndir - 1);
2892 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2893 && my_trnlnm(trndir,trndir,0)) {
2894 STRLEN trnlen = strlen(trndir);
2896 /* Trap simple rooted lnms, and return lnm:[000000] */
2897 if (!strcmp(trndir+trnlen-2,".]")) {
2898 if (buf) retpath = buf;
2899 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2900 else retpath = __pathify_retbuf;
2901 strcpy(retpath,dir);
2902 strcat(retpath,":[000000]");
2908 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2909 if (*dir == '.' && (*(dir+1) == '\0' ||
2910 (*(dir+1) == '.' && *(dir+2) == '\0')))
2911 retlen = 2 + (*(dir+1) != '\0');
2913 if ( !(cp1 = strrchr(dir,'/')) &&
2914 !(cp1 = strrchr(dir,']')) &&
2915 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2916 if ((cp2 = strchr(cp1,'.')) != NULL &&
2917 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2918 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2919 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2920 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2922 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2923 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2924 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2925 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2926 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2927 (ver || *cp3)))))) {
2929 set_vaxc_errno(RMS$_DIR);
2932 retlen = cp2 - dir + 1;
2934 else { /* No file type present. Treat the filename as a directory. */
2935 retlen = strlen(dir) + 1;
2938 if (buf) retpath = buf;
2939 else if (ts) New(1313,retpath,retlen+1,char);
2940 else retpath = __pathify_retbuf;
2941 strncpy(retpath,dir,retlen-1);
2942 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2943 retpath[retlen-1] = '/'; /* with '/', add it. */
2944 retpath[retlen] = '\0';
2946 else retpath[retlen-1] = '\0';
2948 else { /* VMS-style directory spec */
2949 char esa[NAM$C_MAXRSS+1], *cp;
2950 unsigned long int sts, cmplen, haslower;
2951 struct FAB dirfab = cc$rms_fab;
2952 struct NAM savnam, dirnam = cc$rms_nam;
2954 /* If we've got an explicit filename, we can just shuffle the string. */
2955 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2956 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2957 if ((cp2 = strchr(cp1,'.')) != NULL) {
2959 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2960 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2961 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2962 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2963 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2964 (ver || *cp3)))))) {
2966 set_vaxc_errno(RMS$_DIR);
2970 else { /* No file type, so just draw name into directory part */
2971 for (cp2 = cp1; *cp2; cp2++) ;
2974 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2976 /* We've now got a VMS 'path'; fall through */
2978 dirfab.fab$b_fns = strlen(dir);
2979 dirfab.fab$l_fna = dir;
2980 if (dir[dirfab.fab$b_fns-1] == ']' ||
2981 dir[dirfab.fab$b_fns-1] == '>' ||
2982 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2983 if (buf) retpath = buf;
2984 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2985 else retpath = __pathify_retbuf;
2986 strcpy(retpath,dir);
2989 dirfab.fab$l_dna = ".DIR;1";
2990 dirfab.fab$b_dns = 6;
2991 dirfab.fab$l_nam = &dirnam;
2992 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2993 dirnam.nam$l_esa = esa;
2995 for (cp = dir; *cp; cp++)
2996 if (islower(*cp)) { haslower = 1; break; }
2998 if (!(sts = (sys$parse(&dirfab)&1))) {
2999 if (dirfab.fab$l_sts == RMS$_DIR) {
3000 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3001 sts = sys$parse(&dirfab) & 1;
3005 set_vaxc_errno(dirfab.fab$l_sts);
3011 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3012 if (dirfab.fab$l_sts != RMS$_FNF) {
3013 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3014 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3016 set_vaxc_errno(dirfab.fab$l_sts);
3019 dirnam = savnam; /* No; just work with potential name */
3022 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3023 /* Yep; check version while we're at it, if it's there. */
3024 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3025 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3026 /* Something other than .DIR[;1]. Bzzt. */
3027 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3028 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3030 set_vaxc_errno(RMS$_DIR);
3034 /* OK, the type was fine. Now pull any file name into the
3036 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3038 cp1 = strrchr(esa,'>');
3039 *dirnam.nam$l_type = '>';
3042 *(dirnam.nam$l_type + 1) = '\0';
3043 retlen = dirnam.nam$l_type - esa + 2;
3044 if (buf) retpath = buf;
3045 else if (ts) New(1314,retpath,retlen,char);
3046 else retpath = __pathify_retbuf;
3047 strcpy(retpath,esa);
3048 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3049 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3050 /* $PARSE may have upcased filespec, so convert output to lower
3051 * case if input contained any lowercase characters. */
3052 if (haslower) __mystrtolower(retpath);
3056 } /* end of do_pathify_dirspec() */
3058 /* External entry points */
3059 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3060 { return do_pathify_dirspec(dir,buf,0); }
3061 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3062 { return do_pathify_dirspec(dir,buf,1); }
3064 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3065 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3067 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3068 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3069 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3071 if (spec == NULL) return NULL;
3072 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3073 if (buf) rslt = buf;
3075 retlen = strlen(spec);
3076 cp1 = strchr(spec,'[');
3077 if (!cp1) cp1 = strchr(spec,'<');
3079 for (cp1++; *cp1; cp1++) {
3080 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3081 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3082 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3085 New(1315,rslt,retlen+2+2*expand,char);
3087 else rslt = __tounixspec_retbuf;
3088 if (strchr(spec,'/') != NULL) {
3095 dirend = strrchr(spec,']');
3096 if (dirend == NULL) dirend = strrchr(spec,'>');
3097 if (dirend == NULL) dirend = strchr(spec,':');
3098 if (dirend == NULL) {
3102 if (*cp2 != '[' && *cp2 != '<') {
3105 else { /* the VMS spec begins with directories */
3107 if (*cp2 == ']' || *cp2 == '>') {
3108 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3111 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3112 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3113 if (ts) Safefree(rslt);
3118 while (*cp3 != ':' && *cp3) cp3++;
3120 if (strchr(cp3,']') != NULL) break;
3121 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3123 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3124 retlen = devlen + dirlen;
3125 Renew(rslt,retlen+1+2*expand,char);
3131 *(cp1++) = *(cp3++);
3132 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3136 else if ( *cp2 == '.') {
3137 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3138 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3144 for (; cp2 <= dirend; cp2++) {
3147 if (*(cp2+1) == '[') cp2++;
3149 else if (*cp2 == ']' || *cp2 == '>') {
3150 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3152 else if (*cp2 == '.') {
3154 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3155 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3156 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3157 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3158 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3160 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3161 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3165 else if (*cp2 == '-') {
3166 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3167 while (*cp2 == '-') {
3169 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3171 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3172 if (ts) Safefree(rslt); /* filespecs like */
3173 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3177 else *(cp1++) = *cp2;
3179 else *(cp1++) = *cp2;
3181 while (*cp2) *(cp1++) = *(cp2++);
3186 } /* end of do_tounixspec() */
3188 /* External entry points */
3189 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3190 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3192 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3193 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3194 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3195 char *rslt, *dirend;
3196 register char *cp1, *cp2;
3197 unsigned long int infront = 0, hasdir = 1;
3199 if (path == NULL) return NULL;
3200 if (buf) rslt = buf;
3201 else if (ts) New(1316,rslt,strlen(path)+9,char);
3202 else rslt = __tovmsspec_retbuf;
3203 if (strpbrk(path,"]:>") ||
3204 (dirend = strrchr(path,'/')) == NULL) {
3205 if (path[0] == '.') {
3206 if (path[1] == '\0') strcpy(rslt,"[]");
3207 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3208 else strcpy(rslt,path); /* probably garbage */
3210 else strcpy(rslt,path);
3213 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3214 if (!*(dirend+2)) dirend +=2;
3215 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3216 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3221 char trndev[NAM$C_MAXRSS+1];
3225 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3227 if (!buf & ts) Renew(rslt,18,char);
3228 strcpy(rslt,"sys$disk:[000000]");
3231 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3233 islnm = my_trnlnm(rslt,trndev,0);
3234 trnend = islnm ? strlen(trndev) - 1 : 0;
3235 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3236 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3237 /* If the first element of the path is a logical name, determine
3238 * whether it has to be translated so we can add more directories. */
3239 if (!islnm || rooted) {
3242 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3246 if (cp2 != dirend) {
3247 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3248 strcpy(rslt,trndev);
3249 cp1 = rslt + trnend;
3262 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3263 cp2 += 2; /* skip over "./" - it's redundant */
3264 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3266 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3267 *(cp1++) = '-'; /* "../" --> "-" */
3270 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3271 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3272 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3273 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3276 if (cp2 > dirend) cp2 = dirend;
3278 else *(cp1++) = '.';
3280 for (; cp2 < dirend; cp2++) {
3282 if (*(cp2-1) == '/') continue;
3283 if (*(cp1-1) != '.') *(cp1++) = '.';
3286 else if (!infront && *cp2 == '.') {
3287 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3288 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3289 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3290 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3291 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3292 else { /* back up over previous directory name */
3294 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3295 if (*(cp1-1) == '[') {
3296 memcpy(cp1,"000000.",7);
3301 if (cp2 == dirend) break;
3303 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3304 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3305 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3306 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3308 *(cp1++) = '.'; /* Simulate trailing '/' */
3309 cp2 += 2; /* for loop will incr this to == dirend */
3311 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3313 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3316 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3317 if (*cp2 == '.') *(cp1++) = '_';
3318 else *(cp1++) = *cp2;
3322 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3323 if (hasdir) *(cp1++) = ']';
3324 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3325 while (*cp2) *(cp1++) = *(cp2++);
3330 } /* end of do_tovmsspec() */
3332 /* External entry points */
3333 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3334 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3336 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3337 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3338 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3340 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3342 if (path == NULL) return NULL;
3343 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3344 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3345 if (buf) return buf;
3347 vmslen = strlen(vmsified);
3348 New(1317,cp,vmslen+1,char);
3349 memcpy(cp,vmsified,vmslen);
3354 strcpy(__tovmspath_retbuf,vmsified);
3355 return __tovmspath_retbuf;
3358 } /* end of do_tovmspath() */
3360 /* External entry points */
3361 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3362 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3365 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3366 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3367 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3369 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3371 if (path == NULL) return NULL;
3372 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3373 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3374 if (buf) return buf;
3376 unixlen = strlen(unixified);
3377 New(1317,cp,unixlen+1,char);
3378 memcpy(cp,unixified,unixlen);
3383 strcpy(__tounixpath_retbuf,unixified);
3384 return __tounixpath_retbuf;
3387 } /* end of do_tounixpath() */
3389 /* External entry points */
3390 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3391 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3394 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3396 *****************************************************************************
3398 * Copyright (C) 1989-1994 by *
3399 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3401 * Permission is hereby granted for the reproduction of this software, *
3402 * on condition that this copyright notice is included in the reproduction, *
3403 * and that such reproduction is not for purposes of profit or material *
3406 * 27-Aug-1994 Modified for inclusion in perl5 *
3407 * by Charles Bailey bailey@newman.upenn.edu *
3408 *****************************************************************************
3412 * getredirection() is intended to aid in porting C programs
3413 * to VMS (Vax-11 C). The native VMS environment does not support
3414 * '>' and '<' I/O redirection, or command line wild card expansion,
3415 * or a command line pipe mechanism using the '|' AND background
3416 * command execution '&'. All of these capabilities are provided to any
3417 * C program which calls this procedure as the first thing in the
3419 * The piping mechanism will probably work with almost any 'filter' type
3420 * of program. With suitable modification, it may useful for other
3421 * portability problems as well.
3423 * Author: Mark Pizzolato mark@infocomm.com
3427 struct list_item *next;
3431 static void add_item(struct list_item **head,
3432 struct list_item **tail,
3436 static void mp_expand_wild_cards(pTHX_ char *item,
3437 struct list_item **head,
3438 struct list_item **tail,
3441 static int background_process(int argc, char **argv);
3443 static void pipe_and_fork(pTHX_ char **cmargv);
3445 /*{{{ void getredirection(int *ac, char ***av)*/
3447 mp_getredirection(pTHX_ int *ac, char ***av)
3449 * Process vms redirection arg's. Exit if any error is seen.
3450 * If getredirection() processes an argument, it is erased
3451 * from the vector. getredirection() returns a new argc and argv value.
3452 * In the event that a background command is requested (by a trailing "&"),
3453 * this routine creates a background subprocess, and simply exits the program.
3455 * Warning: do not try to simplify the code for vms. The code
3456 * presupposes that getredirection() is called before any data is
3457 * read from stdin or written to stdout.
3459 * Normal usage is as follows:
3465 * getredirection(&argc, &argv);
3469 int argc = *ac; /* Argument Count */
3470 char **argv = *av; /* Argument Vector */
3471 char *ap; /* Argument pointer */
3472 int j; /* argv[] index */
3473 int item_count = 0; /* Count of Items in List */
3474 struct list_item *list_head = 0; /* First Item in List */
3475 struct list_item *list_tail; /* Last Item in List */
3476 char *in = NULL; /* Input File Name */
3477 char *out = NULL; /* Output File Name */
3478 char *outmode = "w"; /* Mode to Open Output File */
3479 char *err = NULL; /* Error File Name */
3480 char *errmode = "w"; /* Mode to Open Error File */
3481 int cmargc = 0; /* Piped Command Arg Count */
3482 char **cmargv = NULL;/* Piped Command Arg Vector */
3485 * First handle the case where the last thing on the line ends with
3486 * a '&'. This indicates the desire for the command to be run in a
3487 * subprocess, so we satisfy that desire.
3490 if (0 == strcmp("&", ap))
3491 exit(background_process(--argc, argv));
3492 if (*ap && '&' == ap[strlen(ap)-1])
3494 ap[strlen(ap)-1] = '\0';
3495 exit(background_process(argc, argv));
3498 * Now we handle the general redirection cases that involve '>', '>>',
3499 * '<', and pipes '|'.
3501 for (j = 0; j < argc; ++j)
3503 if (0 == strcmp("<", argv[j]))
3507 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3508 exit(LIB$_WRONUMARG);
3513 if ('<' == *(ap = argv[j]))
3518 if (0 == strcmp(">", ap))
3522 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3523 exit(LIB$_WRONUMARG);
3542 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3543 exit(LIB$_WRONUMARG);
3547 if (('2' == *ap) && ('>' == ap[1]))
3564 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3565 exit(LIB$_WRONUMARG);
3569 if (0 == strcmp("|", argv[j]))
3573 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3574 exit(LIB$_WRONUMARG);
3576 cmargc = argc-(j+1);
3577 cmargv = &argv[j+1];
3581 if ('|' == *(ap = argv[j]))
3589 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3592 * Allocate and fill in the new argument vector, Some Unix's terminate
3593 * the list with an extra null pointer.
3595 New(1302, argv, item_count+1, char *);
3597 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3598 argv[j] = list_head->value;
3604 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3605 exit(LIB$_INVARGORD);
3607 pipe_and_fork(aTHX_ cmargv);
3610 /* Check for input from a pipe (mailbox) */
3612 if (in == NULL && 1 == isapipe(0))
3614 char mbxname[L_tmpnam];
3616 long int dvi_item = DVI$_DEVBUFSIZ;
3617 $DESCRIPTOR(mbxnam, "");
3618 $DESCRIPTOR(mbxdevnam, "");
3620 /* Input from a pipe, reopen it in binary mode to disable */
3621 /* carriage control processing. */
3623 PerlIO_getname(stdin, mbxname);
3624 mbxnam.dsc$a_pointer = mbxname;
3625 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3626 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3627 mbxdevnam.dsc$a_pointer = mbxname;
3628 mbxdevnam.dsc$w_length = sizeof(mbxname);
3629 dvi_item = DVI$_DEVNAM;
3630 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3631 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3634 freopen(mbxname, "rb", stdin);
3637 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3641 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3643 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3646 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3648 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3651 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3654 if (strcmp(err,"&1") == 0) {
3655 dup2(fileno(stdout), fileno(Perl_debug_log));
3656 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3659 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3661 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3665 if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
3669 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3672 #ifdef ARGPROC_DEBUG
3673 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3674 for (j = 0; j < *ac; ++j)
3675 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3677 /* Clear errors we may have hit expanding wildcards, so they don't
3678 show up in Perl's $! later */
3679 set_errno(0); set_vaxc_errno(1);
3680 } /* end of getredirection() */
3683 static void add_item(struct list_item **head,
3684 struct list_item **tail,
3690 New(1303,*head,1,struct list_item);
3694 New(1304,(*tail)->next,1,struct list_item);
3695 *tail = (*tail)->next;
3697 (*tail)->value = value;
3701 static void mp_expand_wild_cards(pTHX_ char *item,
3702 struct list_item **head,
3703 struct list_item **tail,
3707 unsigned long int context = 0;
3713 char vmsspec[NAM$C_MAXRSS+1];
3714 $DESCRIPTOR(filespec, "");
3715 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3716 $DESCRIPTOR(resultspec, "");
3717 unsigned long int zero = 0, sts;
3719 for (cp = item; *cp; cp++) {
3720 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3721 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3723 if (!*cp || isspace(*cp))
3725 add_item(head, tail, item, count);
3728 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3729 resultspec.dsc$b_class = DSC$K_CLASS_D;
3730 resultspec.dsc$a_pointer = NULL;
3731 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3732 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3733 if (!isunix || !filespec.dsc$a_pointer)
3734 filespec.dsc$a_pointer = item;
3735 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3737 * Only return version specs, if the caller specified a version
3739 had_version = strchr(item, ';');
3741 * Only return device and directory specs, if the caller specifed either.
3743 had_device = strchr(item, ':');
3744 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3746 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3747 &defaultspec, 0, 0, &zero))))
3752 New(1305,string,resultspec.dsc$w_length+1,char);
3753 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3754 string[resultspec.dsc$w_length] = '\0';
3755 if (NULL == had_version)
3756 *((char *)strrchr(string, ';')) = '\0';
3757 if ((!had_directory) && (had_device == NULL))
3759 if (NULL == (devdir = strrchr(string, ']')))
3760 devdir = strrchr(string, '>');
3761 strcpy(string, devdir + 1);
3764 * Be consistent with what the C RTL has already done to the rest of
3765 * the argv items and lowercase all of these names.
3767 for (c = string; *c; ++c)
3770 if (isunix) trim_unixpath(string,item,1);
3771 add_item(head, tail, string, count);
3774 if (sts != RMS$_NMF)
3776 set_vaxc_errno(sts);
3779 case RMS$_FNF: case RMS$_DNF:
3780 set_errno(ENOENT); break;
3782 set_errno(ENOTDIR); break;
3784 set_errno(ENODEV); break;
3785 case RMS$_FNM: case RMS$_SYN:
3786 set_errno(EINVAL); break;
3788 set_errno(EACCES); break;
3790 _ckvmssts_noperl(sts);
3794 add_item(head, tail, item, count);
3795 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3796 _ckvmssts_noperl(lib$find_file_end(&context));
3799 static int child_st[2];/* Event Flag set when child process completes */
3801 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3803 static unsigned long int exit_handler(int *status)
3807 if (0 == child_st[0])
3809 #ifdef ARGPROC_DEBUG
3810 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3812 fflush(stdout); /* Have to flush pipe for binary data to */
3813 /* terminate properly -- <tp@mccall.com> */
3814 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3815 sys$dassgn(child_chan);
3817 sys$synch(0, child_st);
3822 static void sig_child(int chan)
3824 #ifdef ARGPROC_DEBUG
3825 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3827 if (child_st[0] == 0)
3831 static struct exit_control_block exit_block =
3836 &exit_block.exit_status,
3840 static void pipe_and_fork(pTHX_ char **cmargv)
3843 $DESCRIPTOR(cmddsc, "");
3844 static char mbxname[64];
3845 $DESCRIPTOR(mbxdsc, mbxname);
3847 unsigned long int zero = 0, one = 1;
3849 strcpy(subcmd, cmargv[0]);
3850 for (j = 1; NULL != cmargv[j]; ++j)
3852 strcat(subcmd, " \"");
3853 strcat(subcmd, cmargv[j]);
3854 strcat(subcmd, "\"");
3856 cmddsc.dsc$a_pointer = subcmd;
3857 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3859 create_mbx(aTHX_ &child_chan,&mbxdsc);
3860 #ifdef ARGPROC_DEBUG
3861 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3862 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3864 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3865 0, &pid, child_st, &zero, sig_child,
3867 #ifdef ARGPROC_DEBUG
3868 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3870 sys$dclexh(&exit_block);
3871 if (NULL == freopen(mbxname, "wb", stdout))
3873 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3877 static int background_process(int argc, char **argv)
3879 char command[2048] = "$";
3880 $DESCRIPTOR(value, "");
3881 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3882 static $DESCRIPTOR(null, "NLA0:");
3883 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3885 $DESCRIPTOR(pidstr, "");
3887 unsigned long int flags = 17, one = 1, retsts;
3889 strcat(command, argv[0]);
3892 strcat(command, " \"");
3893 strcat(command, *(++argv));
3894 strcat(command, "\"");
3896 value.dsc$a_pointer = command;
3897 value.dsc$w_length = strlen(value.dsc$a_pointer);
3898 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3899 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3900 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3901 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3904 _ckvmssts_noperl(retsts);
3906 #ifdef ARGPROC_DEBUG
3907 PerlIO_printf(Perl_debug_log, "%s\n", command);
3909 sprintf(pidstring, "%08X", pid);
3910 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3911 pidstr.dsc$a_pointer = pidstring;
3912 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3913 lib$set_symbol(&pidsymbol, &pidstr);
3917 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3920 /* OS-specific initialization at image activation (not thread startup) */
3921 /* Older VAXC header files lack these constants */
3922 #ifndef JPI$_RIGHTS_SIZE
3923 # define JPI$_RIGHTS_SIZE 817
3925 #ifndef KGB$M_SUBSYSTEM
3926 # define KGB$M_SUBSYSTEM 0x8
3929 /*{{{void vms_image_init(int *, char ***)*/
3931 vms_image_init(int *argcp, char ***argvp)
3933 char eqv[LNM$C_NAMLENGTH+1] = "";
3934 unsigned int len, tabct = 8, tabidx = 0;
3935 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3936 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3937 unsigned short int dummy, rlen;
3938 struct dsc$descriptor_s **tabvec;
3939 #if defined(PERL_IMPLICIT_CONTEXT)
3942 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3943 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3944 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3947 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3948 _ckvmssts_noperl(iosb[0]);
3949 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3950 if (iprv[i]) { /* Running image installed with privs? */
3951 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3956 /* Rights identifiers might trigger tainting as well. */
3957 if (!will_taint && (rlen || rsz)) {
3958 while (rlen < rsz) {
3959 /* We didn't get all the identifiers on the first pass. Allocate a
3960 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3961 * were needed to hold all identifiers at time of last call; we'll
3962 * allocate that many unsigned long ints), and go back and get 'em.
3963 * If it gave us less than it wanted to despite ample buffer space,
3964 * something's broken. Is your system missing a system identifier?
3966 if (rsz <= jpilist[1].buflen) {
3967 /* Perl_croak accvios when used this early in startup. */
3968 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3969 rsz, (unsigned long) jpilist[1].buflen,
3970 "Check your rights database for corruption.\n");
3973 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3974 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3975 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3976 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3977 _ckvmssts_noperl(iosb[0]);
3979 mask = jpilist[1].bufadr;
3980 /* Check attribute flags for each identifier (2nd longword); protected
3981 * subsystem identifiers trigger tainting.
3983 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3984 if (mask[i] & KGB$M_SUBSYSTEM) {
3989 if (mask != rlst) Safefree(mask);
3991 /* We need to use this hack to tell Perl it should run with tainting,
3992 * since its tainting flag may be part of the PL_curinterp struct, which
3993 * hasn't been allocated when vms_image_init() is called.
3997 New(1320,newap,*argcp+2,char **);
3998 newap[0] = argvp[0];
4000 Copy(argvp[1],newap[2],*argcp-1,char **);
4001 /* We orphan the old argv, since we don't know where it's come from,
4002 * so we don't know how to free it.
4004 *argcp++; argvp = newap;
4006 else { /* Did user explicitly request tainting? */
4008 char *cp, **av = *argvp;
4009 for (i = 1; i < *argcp; i++) {
4010 if (*av[i] != '-') break;
4011 for (cp = av[i]+1; *cp; cp++) {
4012 if (*cp == 'T') { will_taint = 1; break; }
4013 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4014 strchr("DFIiMmx",*cp)) break;
4016 if (will_taint) break;
4021 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4023 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4024 else if (tabidx >= tabct) {
4026 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4028 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4029 tabvec[tabidx]->dsc$w_length = 0;
4030 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4031 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4032 tabvec[tabidx]->dsc$a_pointer = NULL;
4033 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4035 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4037 getredirection(argcp,argvp);
4038 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4040 # include <reentrancy.h>
4041 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4050 * Trim Unix-style prefix off filespec, so it looks like what a shell
4051 * glob expansion would return (i.e. from specified prefix on, not
4052 * full path). Note that returned filespec is Unix-style, regardless
4053 * of whether input filespec was VMS-style or Unix-style.
4055 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4056 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4057 * vector of options; at present, only bit 0 is used, and if set tells
4058 * trim unixpath to try the current default directory as a prefix when
4059 * presented with a possibly ambiguous ... wildcard.
4061 * Returns !=0 on success, with trimmed filespec replacing contents of
4062 * fspec, and 0 on failure, with contents of fpsec unchanged.
4064 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4066 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4068 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4069 *template, *base, *end, *cp1, *cp2;
4070 register int tmplen, reslen = 0, dirs = 0;
4072 if (!wildspec || !fspec) return 0;
4073 if (strpbrk(wildspec,"]>:") != NULL) {
4074 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4075 else template = unixwild;
4077 else template = wildspec;
4078 if (strpbrk(fspec,"]>:") != NULL) {
4079 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4080 else base = unixified;
4081 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4082 * check to see that final result fits into (isn't longer than) fspec */
4083 reslen = strlen(fspec);
4087 /* No prefix or absolute path on wildcard, so nothing to remove */
4088 if (!*template || *template == '/') {
4089 if (base == fspec) return 1;
4090 tmplen = strlen(unixified);
4091 if (tmplen > reslen) return 0; /* not enough space */
4092 /* Copy unixified resultant, including trailing NUL */
4093 memmove(fspec,unixified,tmplen+1);
4097 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4098 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4099 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4100 for (cp1 = end ;cp1 >= base; cp1--)
4101 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4103 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4107 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4108 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4109 int ells = 1, totells, segdirs, match;
4110 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4111 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4113 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4115 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4116 if (ellipsis == template && opts & 1) {
4117 /* Template begins with an ellipsis. Since we can't tell how many
4118 * directory names at the front of the resultant to keep for an
4119 * arbitrary starting point, we arbitrarily choose the current
4120 * default directory as a starting point. If it's there as a prefix,
4121 * clip it off. If not, fall through and act as if the leading
4122 * ellipsis weren't there (i.e. return shortest possible path that
4123 * could match template).
4125 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4126 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4127 if (_tolower(*cp1) != _tolower(*cp2)) break;
4128 segdirs = dirs - totells; /* Min # of dirs we must have left */
4129 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4130 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4131 memcpy(fspec,cp2+1,end - cp2);
4135 /* First off, back up over constant elements at end of path */
4137 for (front = end ; front >= base; front--)
4138 if (*front == '/' && !dirs--) { front++; break; }
4140 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4141 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4142 if (cp1 != '\0') return 0; /* Path too long. */
4144 *cp2 = '\0'; /* Pick up with memcpy later */
4145 lcfront = lcres + (front - base);
4146 /* Now skip over each ellipsis and try to match the path in front of it. */
4148 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4149 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4150 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4151 if (cp1 < template) break; /* template started with an ellipsis */
4152 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4153 ellipsis = cp1; continue;
4155 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4157 for (segdirs = 0, cp2 = tpl;
4158 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4160 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4161 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4162 if (*cp2 == '/') segdirs++;
4164 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4165 /* Back up at least as many dirs as in template before matching */
4166 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4167 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4168 for (match = 0; cp1 > lcres;) {
4169 resdsc.dsc$a_pointer = cp1;
4170 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4172 if (match == 1) lcfront = cp1;
4174 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4176 if (!match) return 0; /* Can't find prefix ??? */
4177 if (match > 1 && opts & 1) {
4178 /* This ... wildcard could cover more than one set of dirs (i.e.
4179 * a set of similar dir names is repeated). If the template
4180 * contains more than 1 ..., upstream elements could resolve the
4181 * ambiguity, but it's not worth a full backtracking setup here.
4182 * As a quick heuristic, clip off the current default directory
4183 * if it's present to find the trimmed spec, else use the
4184 * shortest string that this ... could cover.
4186 char def[NAM$C_MAXRSS+1], *st;
4188 if (getcwd(def, sizeof def,0) == NULL) return 0;
4189 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4190 if (_tolower(*cp1) != _tolower(*cp2)) break;
4191 segdirs = dirs - totells; /* Min # of dirs we must have left */
4192 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4193 if (*cp1 == '\0' && *cp2 == '/') {
4194 memcpy(fspec,cp2+1,end - cp2);
4197 /* Nope -- stick with lcfront from above and keep going. */
4200 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4205 } /* end of trim_unixpath() */
4210 * VMS readdir() routines.
4211 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4213 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4214 * Minor modifications to original routines.
4217 /* Number of elements in vms_versions array */
4218 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4221 * Open a directory, return a handle for later use.
4223 /*{{{ DIR *opendir(char*name) */
4225 Perl_opendir(pTHX_ char *name)
4228 char dir[NAM$C_MAXRSS+1];
4231 if (do_tovmspath(name,dir,0) == NULL) {
4234 if (flex_stat(dir,&sb) == -1) return NULL;
4235 if (!S_ISDIR(sb.st_mode)) {
4236 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4239 if (!cando_by_name(S_IRUSR,0,dir)) {
4240 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4243 /* Get memory for the handle, and the pattern. */
4245 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4247 /* Fill in the fields; mainly playing with the descriptor. */
4248 (void)sprintf(dd->pattern, "%s*.*",dir);
4251 dd->vms_wantversions = 0;
4252 dd->pat.dsc$a_pointer = dd->pattern;
4253 dd->pat.dsc$w_length = strlen(dd->pattern);
4254 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4255 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4258 } /* end of opendir() */
4262 * Set the flag to indicate we want versions or not.
4264 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4266 vmsreaddirversions(DIR *dd, int flag)
4268 dd->vms_wantversions = flag;
4273 * Free up an opened directory.
4275 /*{{{ void closedir(DIR *dd)*/
4279 (void)lib$find_file_end(&dd->context);
4280 Safefree(dd->pattern);
4281 Safefree((char *)dd);
4286 * Collect all the version numbers for the current file.
4289 collectversions(pTHX_ DIR *dd)
4291 struct dsc$descriptor_s pat;
4292 struct dsc$descriptor_s res;
4294 char *p, *text, buff[sizeof dd->entry.d_name];
4296 unsigned long context, tmpsts;
4298 /* Convenient shorthand. */
4301 /* Add the version wildcard, ignoring the "*.*" put on before */
4302 i = strlen(dd->pattern);
4303 New(1308,text,i + e->d_namlen + 3,char);
4304 (void)strcpy(text, dd->pattern);
4305 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4307 /* Set up the pattern descriptor. */
4308 pat.dsc$a_pointer = text;
4309 pat.dsc$w_length = i + e->d_namlen - 1;
4310 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4311 pat.dsc$b_class = DSC$K_CLASS_S;
4313 /* Set up result descriptor. */
4314 res.dsc$a_pointer = buff;
4315 res.dsc$w_length = sizeof buff - 2;
4316 res.dsc$b_dtype = DSC$K_DTYPE_T;
4317 res.dsc$b_class = DSC$K_CLASS_S;
4319 /* Read files, collecting versions. */
4320 for (context = 0, e->vms_verscount = 0;
4321 e->vms_verscount < VERSIZE(e);
4322 e->vms_verscount++) {
4323 tmpsts = lib$find_file(&pat, &res, &context);
4324 if (tmpsts == RMS$_NMF || context == 0) break;
4326 buff[sizeof buff - 1] = '\0';
4327 if ((p = strchr(buff, ';')))
4328 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4330 e->vms_versions[e->vms_verscount] = -1;
4333 _ckvmssts(lib$find_file_end(&context));
4336 } /* end of collectversions() */
4339 * Read the next entry from the directory.
4341 /*{{{ struct dirent *readdir(DIR *dd)*/
4343 Perl_readdir(pTHX_ DIR *dd)
4345 struct dsc$descriptor_s res;
4346 char *p, buff[sizeof dd->entry.d_name];
4347 unsigned long int tmpsts;
4349 /* Set up result descriptor, and get next file. */
4350 res.dsc$a_pointer = buff;
4351 res.dsc$w_length = sizeof buff - 2;
4352 res.dsc$b_dtype = DSC$K_DTYPE_T;
4353 res.dsc$b_class = DSC$K_CLASS_S;
4354 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4355 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4356 if (!(tmpsts & 1)) {
4357 set_vaxc_errno(tmpsts);
4360 set_errno(EACCES); break;
4362 set_errno(ENODEV); break;
4364 set_errno(ENOTDIR); break;
4365 case RMS$_FNF: case RMS$_DNF:
4366 set_errno(ENOENT); break;
4373 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4374 buff[sizeof buff - 1] = '\0';
4375 for (p = buff; *p; p++) *p = _tolower(*p);
4376 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4379 /* Skip any directory component and just copy the name. */
4380 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4381 else (void)strcpy(dd->entry.d_name, buff);
4383 /* Clobber the version. */
4384 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4386 dd->entry.d_namlen = strlen(dd->entry.d_name);
4387 dd->entry.vms_verscount = 0;
4388 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4391 } /* end of readdir() */
4395 * Return something that can be used in a seekdir later.
4397 /*{{{ long telldir(DIR *dd)*/
4406 * Return to a spot where we used to be. Brute force.
4408 /*{{{ void seekdir(DIR *dd,long count)*/
4410 Perl_seekdir(pTHX_ DIR *dd, long count)
4412 int vms_wantversions;
4414 /* If we haven't done anything yet... */
4418 /* Remember some state, and clear it. */
4419 vms_wantversions = dd->vms_wantversions;
4420 dd->vms_wantversions = 0;
4421 _ckvmssts(lib$find_file_end(&dd->context));
4424 /* The increment is in readdir(). */
4425 for (dd->count = 0; dd->count < count; )
4428 dd->vms_wantversions = vms_wantversions;
4430 } /* end of seekdir() */
4433 /* VMS subprocess management
4435 * my_vfork() - just a vfork(), after setting a flag to record that
4436 * the current script is trying a Unix-style fork/exec.
4438 * vms_do_aexec() and vms_do_exec() are called in response to the
4439 * perl 'exec' function. If this follows a vfork call, then they
4440 * call out the the regular perl routines in doio.c which do an
4441 * execvp (for those who really want to try this under VMS).
4442 * Otherwise, they do exactly what the perl docs say exec should
4443 * do - terminate the current script and invoke a new command
4444 * (See below for notes on command syntax.)
4446 * do_aspawn() and do_spawn() implement the VMS side of the perl
4447 * 'system' function.
4449 * Note on command arguments to perl 'exec' and 'system': When handled
4450 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4451 * are concatenated to form a DCL command string. If the first arg
4452 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4453 * the the command string is handed off to DCL directly. Otherwise,
4454 * the first token of the command is taken as the filespec of an image
4455 * to run. The filespec is expanded using a default type of '.EXE' and
4456 * the process defaults for device, directory, etc., and if found, the resultant
4457 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4458 * the command string as parameters. This is perhaps a bit complicated,
4459 * but I hope it will form a happy medium between what VMS folks expect
4460 * from lib$spawn and what Unix folks expect from exec.
4463 static int vfork_called;
4465 /*{{{int my_vfork()*/
4476 vms_execfree(pTHX) {
4478 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4481 if (VMScmd.dsc$a_pointer) {
4482 Safefree(VMScmd.dsc$a_pointer);
4483 VMScmd.dsc$w_length = 0;
4484 VMScmd.dsc$a_pointer = Nullch;
4489 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4491 char *junk, *tmps = Nullch;
4492 register size_t cmdlen = 0;
4499 tmps = SvPV(really,rlen);
4506 for (idx++; idx <= sp; idx++) {
4508 junk = SvPVx(*idx,rlen);
4509 cmdlen += rlen ? rlen + 1 : 0;
4512 New(401,PL_Cmd,cmdlen+1,char);
4514 if (tmps && *tmps) {
4515 strcpy(PL_Cmd,tmps);
4518 else *PL_Cmd = '\0';
4519 while (++mark <= sp) {
4521 char *s = SvPVx(*mark,n_a);
4523 if (*PL_Cmd) strcat(PL_Cmd," ");
4529 } /* end of setup_argstr() */
4532 static unsigned long int
4533 setup_cmddsc(pTHX_ char *cmd, int check_img)
4535 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4536 $DESCRIPTOR(defdsc,".EXE");
4537 $DESCRIPTOR(defdsc2,".");
4538 $DESCRIPTOR(resdsc,resspec);
4539 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4540 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4541 register char *s, *rest, *cp, *wordbreak;
4545 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4548 while (*s && isspace(*s)) s++;
4550 if (*s == '@' || *s == '$') {
4551 vmsspec[0] = *s; rest = s + 1;
4552 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4554 else { cp = vmsspec; rest = s; }
4555 if (*rest == '.' || *rest == '/') {
4558 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4559 rest++, cp2++) *cp2 = *rest;
4561 if (do_tovmsspec(resspec,cp,0)) {
4564 for (cp2 = vmsspec + strlen(vmsspec);
4565 *rest && cp2 - vmsspec < sizeof vmsspec;
4566 rest++, cp2++) *cp2 = *rest;
4571 /* Intuit whether verb (first word of cmd) is a DCL command:
4572 * - if first nonspace char is '@', it's a DCL indirection
4574 * - if verb contains a filespec separator, it's not a DCL command
4575 * - if it doesn't, caller tells us whether to default to a DCL
4576 * command, or to a local image unless told it's DCL (by leading '$')
4578 if (*s == '@') isdcl = 1;
4580 register char *filespec = strpbrk(s,":<[.;");
4581 rest = wordbreak = strpbrk(s," \"\t/");
4582 if (!wordbreak) wordbreak = s + strlen(s);
4583 if (*s == '$') check_img = 0;
4584 if (filespec && (filespec < wordbreak)) isdcl = 0;
4585 else isdcl = !check_img;
4589 imgdsc.dsc$a_pointer = s;
4590 imgdsc.dsc$w_length = wordbreak - s;
4591 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4593 _ckvmssts(lib$find_file_end(&cxt));
4594 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4595 if (!(retsts & 1) && *s == '$') {
4596 _ckvmssts(lib$find_file_end(&cxt));
4597 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4598 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4600 _ckvmssts(lib$find_file_end(&cxt));
4601 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4605 _ckvmssts(lib$find_file_end(&cxt));
4610 while (*s && !isspace(*s)) s++;
4613 /* check that it's really not DCL with no file extension */
4614 fp = fopen(resspec,"r","ctx=bin,shr=get");
4616 char b[4] = {0,0,0,0};
4617 read(fileno(fp),b,4);
4618 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4621 if (check_img && isdcl) return RMS$_FNF;
4623 if (cando_by_name(S_IXUSR,0,resspec)) {
4624 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4626 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4628 strcpy(VMScmd.dsc$a_pointer,"@");
4630 strcat(VMScmd.dsc$a_pointer,resspec);
4631 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4632 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4635 else retsts = RMS$_PRV;
4638 /* It's either a DCL command or we couldn't find a suitable image */
4639 VMScmd.dsc$w_length = strlen(cmd);
4640 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4641 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4642 if (!(retsts & 1)) {
4643 /* just hand off status values likely to be due to user error */
4644 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4645 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4646 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4647 else { _ckvmssts(retsts); }
4650 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4652 } /* end of setup_cmddsc() */
4655 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4657 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4660 if (vfork_called) { /* this follows a vfork - act Unixish */
4662 if (vfork_called < 0) {
4663 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4666 else return do_aexec(really,mark,sp);
4668 /* no vfork - act VMSish */
4669 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4674 } /* end of vms_do_aexec() */
4677 /* {{{bool vms_do_exec(char *cmd) */
4679 Perl_vms_do_exec(pTHX_ char *cmd)
4682 if (vfork_called) { /* this follows a vfork - act Unixish */
4684 if (vfork_called < 0) {
4685 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4688 else return do_exec(cmd);
4691 { /* no vfork - act VMSish */
4692 unsigned long int retsts;
4695 TAINT_PROPER("exec");
4696 if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4697 retsts = lib$do_command(&VMScmd);
4700 case RMS$_FNF: case RMS$_DNF:
4701 set_errno(ENOENT); break;
4703 set_errno(ENOTDIR); break;
4705 set_errno(ENODEV); break;
4707 set_errno(EACCES); break;
4709 set_errno(EINVAL); break;
4711 set_errno(E2BIG); break;
4712 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4713 _ckvmssts(retsts); /* fall through */
4714 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4717 set_vaxc_errno(retsts);
4718 if (ckWARN(WARN_EXEC)) {
4719 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4720 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4727 } /* end of vms_do_exec() */
4730 unsigned long int Perl_do_spawn(pTHX_ char *);
4732 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4734 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4736 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4739 } /* end of do_aspawn() */
4742 /* {{{unsigned long int do_spawn(char *cmd) */
4744 Perl_do_spawn(pTHX_ char *cmd)
4746 unsigned long int sts, substs, hadcmd = 1;
4749 TAINT_PROPER("spawn");
4750 if (!cmd || !*cmd) {
4752 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4754 else if ((sts = setup_cmddsc(aTHX_ cmd,0)) & 1) {
4755 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4760 case RMS$_FNF: case RMS$_DNF:
4761 set_errno(ENOENT); break;
4763 set_errno(ENOTDIR); break;
4765 set_errno(ENODEV); break;
4767 set_errno(EACCES); break;
4769 set_errno(EINVAL); break;
4771 set_errno(E2BIG); break;
4772 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4773 _ckvmssts(sts); /* fall through */
4774 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4777 set_vaxc_errno(sts);
4778 if (ckWARN(WARN_EXEC)) {
4779 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4780 hadcmd ? VMScmd.dsc$w_length : 0,
4781 hadcmd ? VMScmd.dsc$a_pointer : "",
4788 } /* end of do_spawn() */
4792 static unsigned int *sockflags, sockflagsize;
4795 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4796 * routines found in some versions of the CRTL can't deal with sockets.
4797 * We don't shim the other file open routines since a socket isn't
4798 * likely to be opened by a name.
4800 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4801 FILE *my_fdopen(int fd, const char *mode)
4803 FILE *fp = fdopen(fd, (char *) mode);
4806 unsigned int fdoff = fd / sizeof(unsigned int);
4807 struct stat sbuf; /* native stat; we don't need flex_stat */
4808 if (!sockflagsize || fdoff > sockflagsize) {
4809 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4810 else New (1324,sockflags,fdoff+2,unsigned int);
4811 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4812 sockflagsize = fdoff + 2;
4814 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4815 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4824 * Clear the corresponding bit when the (possibly) socket stream is closed.
4825 * There still a small hole: we miss an implicit close which might occur
4826 * via freopen(). >> Todo
4828 /*{{{ int my_fclose(FILE *fp)*/
4829 int my_fclose(FILE *fp) {
4831 unsigned int fd = fileno(fp);
4832 unsigned int fdoff = fd / sizeof(unsigned int);
4834 if (sockflagsize && fdoff <= sockflagsize)
4835 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4843 * A simple fwrite replacement which outputs itmsz*nitm chars without
4844 * introducing record boundaries every itmsz chars.
4845 * We are using fputs, which depends on a terminating null. We may
4846 * well be writing binary data, so we need to accommodate not only
4847 * data with nulls sprinkled in the middle but also data with no null
4850 /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4852 my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
4854 register char *cp, *end, *cpd, *data;
4855 register unsigned int fd = fileno(dest);
4856 register unsigned int fdoff = fd / sizeof(unsigned int);
4858 int bufsize = itmsz * nitm + 1;
4860 if (fdoff < sockflagsize &&
4861 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4862 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4866 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4867 memcpy( data, src, itmsz*nitm );
4868 data[itmsz*nitm] = '\0';
4870 end = data + itmsz * nitm;
4871 retval = (int) nitm; /* on success return # items written */
4874 while (cpd <= end) {
4875 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4876 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4878 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4882 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4885 } /* end of my_fwrite() */
4888 /*{{{ int my_flush(FILE *fp)*/
4890 Perl_my_flush(pTHX_ FILE *fp)
4893 if ((res = fflush(fp)) == 0 && fp) {
4894 #ifdef VMS_DO_SOCKETS
4896 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4898 res = fsync(fileno(fp));
4901 * If the flush succeeded but set end-of-file, we need to clear
4902 * the error because our caller may check ferror(). BTW, this
4903 * probably means we just flushed an empty file.
4905 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4912 * Here are replacements for the following Unix routines in the VMS environment:
4913 * getpwuid Get information for a particular UIC or UID
4914 * getpwnam Get information for a named user
4915 * getpwent Get information for each user in the rights database
4916 * setpwent Reset search to the start of the rights database
4917 * endpwent Finish searching for users in the rights database
4919 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4920 * (defined in pwd.h), which contains the following fields:-
4922 * char *pw_name; Username (in lower case)
4923 * char *pw_passwd; Hashed password
4924 * unsigned int pw_uid; UIC
4925 * unsigned int pw_gid; UIC group number
4926 * char *pw_unixdir; Default device/directory (VMS-style)
4927 * char *pw_gecos; Owner name
4928 * char *pw_dir; Default device/directory (Unix-style)
4929 * char *pw_shell; Default CLI name (eg. DCL)
4931 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4933 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4934 * not the UIC member number (eg. what's returned by getuid()),
4935 * getpwuid() can accept either as input (if uid is specified, the caller's
4936 * UIC group is used), though it won't recognise gid=0.
4938 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4939 * information about other users in your group or in other groups, respectively.
4940 * If the required privilege is not available, then these routines fill only
4941 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4944 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4947 /* sizes of various UAF record fields */
4948 #define UAI$S_USERNAME 12
4949 #define UAI$S_IDENT 31
4950 #define UAI$S_OWNER 31
4951 #define UAI$S_DEFDEV 31
4952 #define UAI$S_DEFDIR 63
4953 #define UAI$S_DEFCLI 31
4956 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4957 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4958 (uic).uic$v_group != UIC$K_WILD_GROUP)
4960 static char __empty[]= "";
4961 static struct passwd __passwd_empty=
4962 {(char *) __empty, (char *) __empty, 0, 0,
4963 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4964 static int contxt= 0;
4965 static struct passwd __pwdcache;
4966 static char __pw_namecache[UAI$S_IDENT+1];
4969 * This routine does most of the work extracting the user information.
4971 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
4974 unsigned char length;
4975 char pw_gecos[UAI$S_OWNER+1];
4977 static union uicdef uic;
4979 unsigned char length;
4980 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4983 unsigned char length;
4984 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4987 unsigned char length;
4988 char pw_shell[UAI$S_DEFCLI+1];
4990 static char pw_passwd[UAI$S_PWD+1];
4992 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4993 struct dsc$descriptor_s name_desc;
4994 unsigned long int sts;
4996 static struct itmlst_3 itmlst[]= {
4997 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
4998 {sizeof(uic), UAI$_UIC, &uic, &luic},
4999 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5000 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5001 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5002 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5003 {0, 0, NULL, NULL}};
5005 name_desc.dsc$w_length= strlen(name);
5006 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5007 name_desc.dsc$b_class= DSC$K_CLASS_S;
5008 name_desc.dsc$a_pointer= (char *) name;
5010 /* Note that sys$getuai returns many fields as counted strings. */
5011 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5012 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5013 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5015 else { _ckvmssts(sts); }
5016 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5018 if ((int) owner.length < lowner) lowner= (int) owner.length;
5019 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5020 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5021 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5022 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5023 owner.pw_gecos[lowner]= '\0';
5024 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5025 defcli.pw_shell[ldefcli]= '\0';
5026 if (valid_uic(uic)) {
5027 pwd->pw_uid= uic.uic$l_uic;
5028 pwd->pw_gid= uic.uic$v_group;
5031 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5032 pwd->pw_passwd= pw_passwd;
5033 pwd->pw_gecos= owner.pw_gecos;
5034 pwd->pw_dir= defdev.pw_dir;
5035 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5036 pwd->pw_shell= defcli.pw_shell;
5037 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5039 ldir= strlen(pwd->pw_unixdir) - 1;
5040 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5043 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5044 __mystrtolower(pwd->pw_unixdir);
5049 * Get information for a named user.
5051 /*{{{struct passwd *getpwnam(char *name)*/
5052 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5054 struct dsc$descriptor_s name_desc;
5056 unsigned long int status, sts;
5058 __pwdcache = __passwd_empty;
5059 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5060 /* We still may be able to determine pw_uid and pw_gid */
5061 name_desc.dsc$w_length= strlen(name);
5062 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5063 name_desc.dsc$b_class= DSC$K_CLASS_S;
5064 name_desc.dsc$a_pointer= (char *) name;
5065 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5066 __pwdcache.pw_uid= uic.uic$l_uic;
5067 __pwdcache.pw_gid= uic.uic$v_group;
5070 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5071 set_vaxc_errno(sts);
5072 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5075 else { _ckvmssts(sts); }
5078 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5079 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5080 __pwdcache.pw_name= __pw_namecache;
5082 } /* end of my_getpwnam() */
5086 * Get information for a particular UIC or UID.
5087 * Called by my_getpwent with uid=-1 to list all users.
5089 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5090 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5092 const $DESCRIPTOR(name_desc,__pw_namecache);
5093 unsigned short lname;
5095 unsigned long int status;
5097 if (uid == (unsigned int) -1) {
5099 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5100 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5101 set_vaxc_errno(status);
5102 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5106 else { _ckvmssts(status); }
5107 } while (!valid_uic (uic));
5111 if (!uic.uic$v_group)
5112 uic.uic$v_group= PerlProc_getgid();
5114 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5115 else status = SS$_IVIDENT;
5116 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5117 status == RMS$_PRV) {
5118 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5121 else { _ckvmssts(status); }
5123 __pw_namecache[lname]= '\0';
5124 __mystrtolower(__pw_namecache);
5126 __pwdcache = __passwd_empty;
5127 __pwdcache.pw_name = __pw_namecache;
5129 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5130 The identifier's value is usually the UIC, but it doesn't have to be,
5131 so if we can, we let fillpasswd update this. */
5132 __pwdcache.pw_uid = uic.uic$l_uic;
5133 __pwdcache.pw_gid = uic.uic$v_group;
5135 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5138 } /* end of my_getpwuid() */
5142 * Get information for next user.
5144 /*{{{struct passwd *my_getpwent()*/
5145 struct passwd *Perl_my_getpwent(pTHX)
5147 return (my_getpwuid((unsigned int) -1));
5152 * Finish searching rights database for users.
5154 /*{{{void my_endpwent()*/
5155 void Perl_my_endpwent(pTHX)
5158 _ckvmssts(sys$finish_rdb(&contxt));
5164 #ifdef HOMEGROWN_POSIX_SIGNALS
5165 /* Signal handling routines, pulled into the core from POSIX.xs.
5167 * We need these for threads, so they've been rolled into the core,
5168 * rather than left in POSIX.xs.
5170 * (DRS, Oct 23, 1997)
5173 /* sigset_t is atomic under VMS, so these routines are easy */
5174 /*{{{int my_sigemptyset(sigset_t *) */
5175 int my_sigemptyset(sigset_t *set) {
5176 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5182 /*{{{int my_sigfillset(sigset_t *)*/
5183 int my_sigfillset(sigset_t *set) {
5185 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5186 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5192 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5193 int my_sigaddset(sigset_t *set, int sig) {
5194 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5195 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5196 *set |= (1 << (sig - 1));
5202 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5203 int my_sigdelset(sigset_t *set, int sig) {
5204 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5205 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5206 *set &= ~(1 << (sig - 1));
5212 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5213 int my_sigismember(sigset_t *set, int sig) {
5214 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5215 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5216 *set & (1 << (sig - 1));
5221 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5222 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5225 /* If set and oset are both null, then things are badly wrong. Bail out. */
5226 if ((oset == NULL) && (set == NULL)) {
5227 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5231 /* If set's null, then we're just handling a fetch. */
5233 tempmask = sigblock(0);
5238 tempmask = sigsetmask(*set);
5241 tempmask = sigblock(*set);
5244 tempmask = sigblock(0);
5245 sigsetmask(*oset & ~tempmask);
5248 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5253 /* Did they pass us an oset? If so, stick our holding mask into it */
5260 #endif /* HOMEGROWN_POSIX_SIGNALS */
5263 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5264 * my_utime(), and flex_stat(), all of which operate on UTC unless
5265 * VMSISH_TIMES is true.
5267 /* method used to handle UTC conversions:
5268 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5270 static int gmtime_emulation_type;
5271 /* number of secs to add to UTC POSIX-style time to get local time */
5272 static long int utc_offset_secs;
5274 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5275 * in vmsish.h. #undef them here so we can call the CRTL routines
5284 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5285 * qualifier with the extern prefix pragma. This provisional
5286 * hack circumvents this prefix pragma problem in previous
5289 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5290 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5291 # pragma __extern_prefix save
5292 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5293 # define gmtime decc$__utctz_gmtime
5294 # define localtime decc$__utctz_localtime
5295 # define time decc$__utc_time
5296 # pragma __extern_prefix restore
5298 struct tm *gmtime(), *localtime();
5304 static time_t toutc_dst(time_t loc) {
5307 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5308 loc -= utc_offset_secs;
5309 if (rsltmp->tm_isdst) loc -= 3600;
5312 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5313 ((gmtime_emulation_type || my_time(NULL)), \
5314 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5315 ((secs) - utc_offset_secs))))
5317 static time_t toloc_dst(time_t utc) {
5320 utc += utc_offset_secs;
5321 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5322 if (rsltmp->tm_isdst) utc += 3600;
5325 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5326 ((gmtime_emulation_type || my_time(NULL)), \
5327 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5328 ((secs) + utc_offset_secs))))
5330 #ifndef RTL_USES_UTC
5333 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5334 DST starts on 1st sun of april at 02:00 std time
5335 ends on last sun of october at 02:00 dst time
5336 see the UCX management command reference, SET CONFIG TIMEZONE
5337 for formatting info.
5339 No, it's not as general as it should be, but then again, NOTHING
5340 will handle UK times in a sensible way.
5345 parse the DST start/end info:
5346 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5350 tz_parse_startend(char *s, struct tm *w, int *past)
5352 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5353 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5358 if (!past) return 0;
5361 if (w->tm_year % 4 == 0) ly = 1;
5362 if (w->tm_year % 100 == 0) ly = 0;
5363 if (w->tm_year+1900 % 400 == 0) ly = 1;
5366 dozjd = isdigit(*s);
5367 if (*s == 'J' || *s == 'j' || dozjd) {
5368 if (!dozjd && !isdigit(*++s)) return 0;
5371 d = d*10 + *s++ - '0';
5373 d = d*10 + *s++ - '0';
5376 if (d == 0) return 0;
5377 if (d > 366) return 0;
5379 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5382 } else if (*s == 'M' || *s == 'm') {
5383 if (!isdigit(*++s)) return 0;
5385 if (isdigit(*s)) m = 10*m + *s++ - '0';
5386 if (*s != '.') return 0;
5387 if (!isdigit(*++s)) return 0;
5389 if (n < 1 || n > 5) return 0;
5390 if (*s != '.') return 0;
5391 if (!isdigit(*++s)) return 0;
5393 if (d > 6) return 0;
5397 if (!isdigit(*++s)) return 0;
5399 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5401 if (!isdigit(*++s)) return 0;
5403 if (isdigit(*s)) min = 10*min + *s++ - '0';
5405 if (!isdigit(*++s)) return 0;
5407 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5417 if (w->tm_yday < d) goto before;
5418 if (w->tm_yday > d) goto after;
5420 if (w->tm_mon+1 < m) goto before;
5421 if (w->tm_mon+1 > m) goto after;
5423 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5424 k = d - j; /* mday of first d */
5426 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5427 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5428 if (w->tm_mday < k) goto before;
5429 if (w->tm_mday > k) goto after;
5432 if (w->tm_hour < hour) goto before;
5433 if (w->tm_hour > hour) goto after;
5434 if (w->tm_min < min) goto before;
5435 if (w->tm_min > min) goto after;
5436 if (w->tm_sec < sec) goto before;
5450 /* parse the offset: (+|-)hh[:mm[:ss]] */
5453 tz_parse_offset(char *s, int *offset)
5455 int hour = 0, min = 0, sec = 0;
5458 if (!offset) return 0;
5460 if (*s == '-') {neg++; s++;}
5462 if (!isdigit(*s)) return 0;
5464 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5465 if (hour > 24) return 0;
5467 if (!isdigit(*++s)) return 0;
5469 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5470 if (min > 59) return 0;
5472 if (!isdigit(*++s)) return 0;
5474 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5475 if (sec > 59) return 0;
5479 *offset = (hour*60+min)*60 + sec;
5480 if (neg) *offset = -*offset;
5485 input time is w, whatever type of time the CRTL localtime() uses.
5486 sets dst, the zone, and the gmtoff (seconds)
5488 caches the value of TZ and UCX$TZ env variables; note that
5489 my_setenv looks for these and sets a flag if they're changed
5492 We have to watch out for the "australian" case (dst starts in
5493 october, ends in april)...flagged by "reverse" and checked by
5494 scanning through the months of the previous year.
5499 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5504 char *dstzone, *tz, *s_start, *s_end;
5505 int std_off, dst_off, isdst;
5506 int y, dststart, dstend;
5507 static char envtz[1025]; /* longer than any logical, symbol, ... */
5508 static char ucxtz[1025];
5509 static char reversed = 0;
5515 reversed = -1; /* flag need to check */
5516 envtz[0] = ucxtz[0] = '\0';
5517 tz = my_getenv("TZ",0);
5518 if (tz) strcpy(envtz, tz);
5519 tz = my_getenv("UCX$TZ",0);
5520 if (tz) strcpy(ucxtz, tz);
5521 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5524 if (!*tz) tz = ucxtz;
5527 while (isalpha(*s)) s++;
5528 s = tz_parse_offset(s, &std_off);
5530 if (!*s) { /* no DST, hurray we're done! */
5536 while (isalpha(*s)) s++;
5537 s2 = tz_parse_offset(s, &dst_off);
5541 dst_off = std_off - 3600;
5544 if (!*s) { /* default dst start/end?? */
5545 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5546 s = strchr(ucxtz,',');
5548 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5550 if (*s != ',') return 0;
5553 when = _toutc(when); /* convert to utc */
5554 when = when - std_off; /* convert to pseudolocal time*/
5556 w2 = localtime(&when);
5559 s = tz_parse_startend(s_start,w2,&dststart);
5561 if (*s != ',') return 0;
5564 when = _toutc(when); /* convert to utc */
5565 when = when - dst_off; /* convert to pseudolocal time*/
5566 w2 = localtime(&when);
5567 if (w2->tm_year != y) { /* spans a year, just check one time */
5568 when += dst_off - std_off;
5569 w2 = localtime(&when);
5572 s = tz_parse_startend(s_end,w2,&dstend);
5575 if (reversed == -1) { /* need to check if start later than end */
5579 if (when < 2*365*86400) {
5580 when += 2*365*86400;
5584 w2 =localtime(&when);
5585 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5587 for (j = 0; j < 12; j++) {
5588 w2 =localtime(&when);
5589 (void) tz_parse_startend(s_start,w2,&ds);
5590 (void) tz_parse_startend(s_end,w2,&de);
5591 if (ds != de) break;
5595 if (de && !ds) reversed = 1;
5598 isdst = dststart && !dstend;
5599 if (reversed) isdst = dststart || !dstend;
5602 if (dst) *dst = isdst;
5603 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5604 if (isdst) tz = dstzone;
5606 while(isalpha(*tz)) *zone++ = *tz++;
5612 #endif /* !RTL_USES_UTC */
5614 /* my_time(), my_localtime(), my_gmtime()
5615 * By default traffic in UTC time values, using CRTL gmtime() or
5616 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5617 * Note: We need to use these functions even when the CRTL has working
5618 * UTC support, since they also handle C<use vmsish qw(times);>
5620 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5621 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5624 /*{{{time_t my_time(time_t *timep)*/
5625 time_t Perl_my_time(pTHX_ time_t *timep)
5630 if (gmtime_emulation_type == 0) {
5632 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5633 /* results of calls to gmtime() and localtime() */
5634 /* for same &base */
5636 gmtime_emulation_type++;
5637 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5638 char off[LNM$C_NAMLENGTH+1];;
5640 gmtime_emulation_type++;
5641 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5642 gmtime_emulation_type++;
5643 utc_offset_secs = 0;
5644 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5646 else { utc_offset_secs = atol(off); }
5648 else { /* We've got a working gmtime() */
5649 struct tm gmt, local;
5652 tm_p = localtime(&base);
5654 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5655 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5656 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5657 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5663 # ifdef RTL_USES_UTC
5664 if (VMSISH_TIME) when = _toloc(when);
5666 if (!VMSISH_TIME) when = _toutc(when);
5669 if (timep != NULL) *timep = when;
5672 } /* end of my_time() */
5676 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5678 Perl_my_gmtime(pTHX_ const time_t *timep)
5684 if (timep == NULL) {
5685 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5688 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5692 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5694 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5695 return gmtime(&when);
5697 /* CRTL localtime() wants local time as input, so does no tz correction */
5698 rsltmp = localtime(&when);
5699 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5702 } /* end of my_gmtime() */
5706 /*{{{struct tm *my_localtime(const time_t *timep)*/
5708 Perl_my_localtime(pTHX_ const time_t *timep)
5710 time_t when, whenutc;
5714 if (timep == NULL) {
5715 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5718 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5719 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5722 # ifdef RTL_USES_UTC
5724 if (VMSISH_TIME) when = _toutc(when);
5726 /* CRTL localtime() wants UTC as input, does tz correction itself */
5727 return localtime(&when);
5729 # else /* !RTL_USES_UTC */
5732 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5733 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5736 #ifndef RTL_USES_UTC
5737 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5738 when = whenutc - offset; /* pseudolocal time*/
5741 /* CRTL localtime() wants local time as input, so does no tz correction */
5742 rsltmp = localtime(&when);
5743 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5747 } /* end of my_localtime() */
5750 /* Reset definitions for later calls */
5751 #define gmtime(t) my_gmtime(t)
5752 #define localtime(t) my_localtime(t)
5753 #define time(t) my_time(t)
5756 /* my_utime - update modification time of a file
5757 * calling sequence is identical to POSIX utime(), but under
5758 * VMS only the modification time is changed; ODS-2 does not
5759 * maintain access times. Restrictions differ from the POSIX
5760 * definition in that the time can be changed as long as the
5761 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5762 * no separate checks are made to insure that the caller is the
5763 * owner of the file or has special privs enabled.
5764 * Code here is based on Joe Meadows' FILE utility.
5767 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5768 * to VMS epoch (01-JAN-1858 00:00:00.00)
5769 * in 100 ns intervals.
5771 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5773 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5774 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5777 long int bintime[2], len = 2, lowbit, unixtime,
5778 secscale = 10000000; /* seconds --> 100 ns intervals */
5779 unsigned long int chan, iosb[2], retsts;
5780 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5781 struct FAB myfab = cc$rms_fab;
5782 struct NAM mynam = cc$rms_nam;
5783 #if defined (__DECC) && defined (__VAX)
5784 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5785 * at least through VMS V6.1, which causes a type-conversion warning.
5787 # pragma message save
5788 # pragma message disable cvtdiftypes
5790 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5791 struct fibdef myfib;
5792 #if defined (__DECC) && defined (__VAX)
5793 /* This should be right after the declaration of myatr, but due
5794 * to a bug in VAX DEC C, this takes effect a statement early.
5796 # pragma message restore
5798 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5799 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5800 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5802 if (file == NULL || *file == '\0') {
5804 set_vaxc_errno(LIB$_INVARG);
5807 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5809 if (utimes != NULL) {
5810 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5811 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5812 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5813 * as input, we force the sign bit to be clear by shifting unixtime right
5814 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5816 lowbit = (utimes->modtime & 1) ? secscale : 0;
5817 unixtime = (long int) utimes->modtime;
5819 /* If input was UTC; convert to local for sys svc */
5820 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5822 unixtime >>= 1; secscale <<= 1;
5823 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5824 if (!(retsts & 1)) {
5826 set_vaxc_errno(retsts);
5829 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5830 if (!(retsts & 1)) {
5832 set_vaxc_errno(retsts);
5837 /* Just get the current time in VMS format directly */
5838 retsts = sys$gettim(bintime);
5839 if (!(retsts & 1)) {
5841 set_vaxc_errno(retsts);
5846 myfab.fab$l_fna = vmsspec;
5847 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5848 myfab.fab$l_nam = &mynam;
5849 mynam.nam$l_esa = esa;
5850 mynam.nam$b_ess = (unsigned char) sizeof esa;
5851 mynam.nam$l_rsa = rsa;
5852 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5854 /* Look for the file to be affected, letting RMS parse the file
5855 * specification for us as well. I have set errno using only
5856 * values documented in the utime() man page for VMS POSIX.
5858 retsts = sys$parse(&myfab,0,0);
5859 if (!(retsts & 1)) {
5860 set_vaxc_errno(retsts);
5861 if (retsts == RMS$_PRV) set_errno(EACCES);
5862 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5863 else set_errno(EVMSERR);
5866 retsts = sys$search(&myfab,0,0);
5867 if (!(retsts & 1)) {
5868 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5869 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5870 set_vaxc_errno(retsts);
5871 if (retsts == RMS$_PRV) set_errno(EACCES);
5872 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5873 else set_errno(EVMSERR);
5877 devdsc.dsc$w_length = mynam.nam$b_dev;
5878 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5880 retsts = sys$assign(&devdsc,&chan,0,0);
5881 if (!(retsts & 1)) {
5882 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5883 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5884 set_vaxc_errno(retsts);
5885 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5886 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5887 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5888 else set_errno(EVMSERR);
5892 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5893 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5895 memset((void *) &myfib, 0, sizeof myfib);
5896 #if defined(__DECC) || defined(__DECCXX)
5897 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5898 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5899 /* This prevents the revision time of the file being reset to the current
5900 * time as a result of our IO$_MODIFY $QIO. */
5901 myfib.fib$l_acctl = FIB$M_NORECORD;
5903 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5904 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5905 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5907 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5908 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5909 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5910 _ckvmssts(sys$dassgn(chan));
5911 if (retsts & 1) retsts = iosb[0];
5912 if (!(retsts & 1)) {
5913 set_vaxc_errno(retsts);
5914 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5915 else set_errno(EVMSERR);
5920 } /* end of my_utime() */
5924 * flex_stat, flex_fstat
5925 * basic stat, but gets it right when asked to stat
5926 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5929 /* encode_dev packs a VMS device name string into an integer to allow
5930 * simple comparisons. This can be used, for example, to check whether two
5931 * files are located on the same device, by comparing their encoded device
5932 * names. Even a string comparison would not do, because stat() reuses the
5933 * device name buffer for each call; so without encode_dev, it would be
5934 * necessary to save the buffer and use strcmp (this would mean a number of
5935 * changes to the standard Perl code, to say nothing of what a Perl script
5938 * The device lock id, if it exists, should be unique (unless perhaps compared
5939 * with lock ids transferred from other nodes). We have a lock id if the disk is
5940 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5941 * device names. Thus we use the lock id in preference, and only if that isn't
5942 * available, do we try to pack the device name into an integer (flagged by
5943 * the sign bit (LOCKID_MASK) being set).
5945 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5946 * name and its encoded form, but it seems very unlikely that we will find
5947 * two files on different disks that share the same encoded device names,
5948 * and even more remote that they will share the same file id (if the test
5949 * is to check for the same file).
5951 * A better method might be to use sys$device_scan on the first call, and to
5952 * search for the device, returning an index into the cached array.
5953 * The number returned would be more intelligable.
5954 * This is probably not worth it, and anyway would take quite a bit longer
5955 * on the first call.
5957 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5958 static mydev_t encode_dev (pTHX_ const char *dev)
5961 unsigned long int f;
5966 if (!dev || !dev[0]) return 0;
5970 struct dsc$descriptor_s dev_desc;
5971 unsigned long int status, lockid, item = DVI$_LOCKID;
5973 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5974 can try that first. */
5975 dev_desc.dsc$w_length = strlen (dev);
5976 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5977 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5978 dev_desc.dsc$a_pointer = (char *) dev;
5979 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5980 if (lockid) return (lockid & ~LOCKID_MASK);
5984 /* Otherwise we try to encode the device name */
5988 for (q = dev + strlen(dev); q--; q >= dev) {
5991 else if (isalpha (toupper (*q)))
5992 c= toupper (*q) - 'A' + (char)10;
5994 continue; /* Skip '$'s */
5996 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
5998 enc += f * (unsigned long int) c;
6000 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6002 } /* end of encode_dev() */
6004 static char namecache[NAM$C_MAXRSS+1];
6007 is_null_device(name)
6010 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6011 The underscore prefix, controller letter, and unit number are
6012 independently optional; for our purposes, the colon punctuation
6013 is not. The colon can be trailed by optional directory and/or
6014 filename, but two consecutive colons indicates a nodename rather
6015 than a device. [pr] */
6016 if (*name == '_') ++name;
6017 if (tolower(*name++) != 'n') return 0;
6018 if (tolower(*name++) != 'l') return 0;
6019 if (tolower(*name) == 'a') ++name;
6020 if (*name == '0') ++name;
6021 return (*name++ == ':') && (*name != ':');
6024 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6025 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6026 * subset of the applicable information.
6029 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6031 char fname_phdev[NAM$C_MAXRSS+1];
6032 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6034 char fname[NAM$C_MAXRSS+1];
6035 unsigned long int retsts;
6036 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6037 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6039 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6040 device name on successive calls */
6041 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6042 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6043 namdsc.dsc$a_pointer = fname;
6044 namdsc.dsc$w_length = sizeof fname - 1;
6046 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6047 &namdsc,&namdsc.dsc$w_length,0,0);
6049 fname[namdsc.dsc$w_length] = '\0';
6051 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6052 * but if someone has redefined that logical, Perl gets very lost. Since
6053 * we have the physical device name from the stat buffer, just paste it on.
6055 strcpy( fname_phdev, statbufp->st_devnam );
6056 strcat( fname_phdev, strrchr(fname, ':') );
6058 return cando_by_name(bit,effective,fname_phdev);
6060 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6061 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6065 return FALSE; /* Should never get to here */
6067 } /* end of cando() */
6071 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6073 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6075 static char usrname[L_cuserid];
6076 static struct dsc$descriptor_s usrdsc =
6077 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6078 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6079 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6080 unsigned short int retlen;
6081 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6082 union prvdef curprv;
6083 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6084 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6085 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6088 if (!fname || !*fname) return FALSE;
6089 /* Make sure we expand logical names, since sys$check_access doesn't */
6090 if (!strpbrk(fname,"/]>:")) {
6091 strcpy(fileified,fname);
6092 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6095 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6096 retlen = namdsc.dsc$w_length = strlen(vmsname);
6097 namdsc.dsc$a_pointer = vmsname;
6098 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6099 vmsname[retlen-1] == ':') {
6100 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6101 namdsc.dsc$w_length = strlen(fileified);
6102 namdsc.dsc$a_pointer = fileified;
6105 if (!usrdsc.dsc$w_length) {
6107 usrdsc.dsc$w_length = strlen(usrname);
6111 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6112 access = ARM$M_EXECUTE; break;
6113 case S_IRUSR: case S_IRGRP: case S_IROTH:
6114 access = ARM$M_READ; break;
6115 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6116 access = ARM$M_WRITE; break;
6117 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6118 access = ARM$M_DELETE; break;
6123 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6124 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6125 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6126 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6127 set_vaxc_errno(retsts);
6128 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6129 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6130 else set_errno(ENOENT);
6133 if (retsts == SS$_NORMAL) {
6134 if (!privused) return TRUE;
6135 /* We can get access, but only by using privs. Do we have the
6136 necessary privs currently enabled? */
6137 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6138 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6139 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6140 !curprv.prv$v_bypass) return FALSE;
6141 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6142 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6143 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6146 if (retsts == SS$_ACCONFLICT) {
6151 return FALSE; /* Should never get here */
6153 } /* end of cando_by_name() */
6157 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6159 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6161 if (!fstat(fd,(stat_t *) statbufp)) {
6162 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6163 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6164 # ifdef RTL_USES_UTC
6167 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6168 statbufp->st_atime = _toloc(statbufp->st_atime);
6169 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6174 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6178 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6179 statbufp->st_atime = _toutc(statbufp->st_atime);
6180 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6187 } /* end of flex_fstat() */
6190 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6192 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6194 char fileified[NAM$C_MAXRSS+1];
6195 char temp_fspec[NAM$C_MAXRSS+300];
6198 strcpy(temp_fspec, fspec);
6199 if (statbufp == (Stat_t *) &PL_statcache)
6200 do_tovmsspec(temp_fspec,namecache,0);
6201 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6202 memset(statbufp,0,sizeof *statbufp);
6203 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6204 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6205 statbufp->st_uid = 0x00010001;
6206 statbufp->st_gid = 0x0001;
6207 time((time_t *)&statbufp->st_mtime);
6208 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6212 /* Try for a directory name first. If fspec contains a filename without
6213 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6214 * and sea:[wine.dark]water. exist, we prefer the directory here.
6215 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6216 * not sea:[wine.dark]., if the latter exists. If the intended target is
6217 * the file with null type, specify this by calling flex_stat() with
6218 * a '.' at the end of fspec.
6220 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6221 retval = stat(fileified,(stat_t *) statbufp);
6222 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6223 strcpy(namecache,fileified);
6225 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6227 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6228 # ifdef RTL_USES_UTC
6231 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6232 statbufp->st_atime = _toloc(statbufp->st_atime);
6233 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6238 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6242 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6243 statbufp->st_atime = _toutc(statbufp->st_atime);
6244 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6250 } /* end of flex_stat() */
6254 /*{{{char *my_getlogin()*/
6255 /* VMS cuserid == Unix getlogin, except calling sequence */
6259 static char user[L_cuserid];
6260 return cuserid(user);
6265 /* rmscopy - copy a file using VMS RMS routines
6267 * Copies contents and attributes of spec_in to spec_out, except owner
6268 * and protection information. Name and type of spec_in are used as
6269 * defaults for spec_out. The third parameter specifies whether rmscopy()
6270 * should try to propagate timestamps from the input file to the output file.
6271 * If it is less than 0, no timestamps are preserved. If it is 0, then
6272 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6273 * propagated to the output file at creation iff the output file specification
6274 * did not contain an explicit name or type, and the revision date is always
6275 * updated at the end of the copy operation. If it is greater than 0, then
6276 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6277 * other than the revision date should be propagated, and bit 1 indicates
6278 * that the revision date should be propagated.
6280 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6282 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6283 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6284 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6285 * as part of the Perl standard distribution under the terms of the
6286 * GNU General Public License or the Perl Artistic License. Copies
6287 * of each may be found in the Perl standard distribution.
6289 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6291 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6293 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6294 rsa[NAM$C_MAXRSS], ubf[32256];
6295 unsigned long int i, sts, sts2;
6296 struct FAB fab_in, fab_out;
6297 struct RAB rab_in, rab_out;
6299 struct XABDAT xabdat;
6300 struct XABFHC xabfhc;
6301 struct XABRDT xabrdt;
6302 struct XABSUM xabsum;
6304 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6305 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6306 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6310 fab_in = cc$rms_fab;
6311 fab_in.fab$l_fna = vmsin;
6312 fab_in.fab$b_fns = strlen(vmsin);
6313 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6314 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6315 fab_in.fab$l_fop = FAB$M_SQO;
6316 fab_in.fab$l_nam = &nam;
6317 fab_in.fab$l_xab = (void *) &xabdat;
6320 nam.nam$l_rsa = rsa;
6321 nam.nam$b_rss = sizeof(rsa);
6322 nam.nam$l_esa = esa;
6323 nam.nam$b_ess = sizeof (esa);
6324 nam.nam$b_esl = nam.nam$b_rsl = 0;
6326 xabdat = cc$rms_xabdat; /* To get creation date */
6327 xabdat.xab$l_nxt = (void *) &xabfhc;
6329 xabfhc = cc$rms_xabfhc; /* To get record length */
6330 xabfhc.xab$l_nxt = (void *) &xabsum;
6332 xabsum = cc$rms_xabsum; /* To get key and area information */
6334 if (!((sts = sys$open(&fab_in)) & 1)) {
6335 set_vaxc_errno(sts);
6337 case RMS$_FNF: case RMS$_DNF:
6338 set_errno(ENOENT); break;
6340 set_errno(ENOTDIR); break;
6342 set_errno(ENODEV); break;
6344 set_errno(EINVAL); break;
6346 set_errno(EACCES); break;
6354 fab_out.fab$w_ifi = 0;
6355 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6356 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6357 fab_out.fab$l_fop = FAB$M_SQO;
6358 fab_out.fab$l_fna = vmsout;
6359 fab_out.fab$b_fns = strlen(vmsout);
6360 fab_out.fab$l_dna = nam.nam$l_name;
6361 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6363 if (preserve_dates == 0) { /* Act like DCL COPY */
6364 nam.nam$b_nop = NAM$M_SYNCHK;
6365 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6366 if (!((sts = sys$parse(&fab_out)) & 1)) {
6367 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6368 set_vaxc_errno(sts);
6371 fab_out.fab$l_xab = (void *) &xabdat;
6372 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6374 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6375 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6376 preserve_dates =0; /* bitmask from this point forward */
6378 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6379 if (!((sts = sys$create(&fab_out)) & 1)) {
6380 set_vaxc_errno(sts);
6383 set_errno(ENOENT); break;
6385 set_errno(ENOTDIR); break;
6387 set_errno(ENODEV); break;
6389 set_errno(EINVAL); break;
6391 set_errno(EACCES); break;
6397 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6398 if (preserve_dates & 2) {
6399 /* sys$close() will process xabrdt, not xabdat */
6400 xabrdt = cc$rms_xabrdt;
6402 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6404 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6405 * is unsigned long[2], while DECC & VAXC use a struct */
6406 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6408 fab_out.fab$l_xab = (void *) &xabrdt;
6411 rab_in = cc$rms_rab;
6412 rab_in.rab$l_fab = &fab_in;
6413 rab_in.rab$l_rop = RAB$M_BIO;
6414 rab_in.rab$l_ubf = ubf;
6415 rab_in.rab$w_usz = sizeof ubf;
6416 if (!((sts = sys$connect(&rab_in)) & 1)) {
6417 sys$close(&fab_in); sys$close(&fab_out);
6418 set_errno(EVMSERR); set_vaxc_errno(sts);
6422 rab_out = cc$rms_rab;
6423 rab_out.rab$l_fab = &fab_out;
6424 rab_out.rab$l_rbf = ubf;
6425 if (!((sts = sys$connect(&rab_out)) & 1)) {
6426 sys$close(&fab_in); sys$close(&fab_out);
6427 set_errno(EVMSERR); set_vaxc_errno(sts);
6431 while ((sts = sys$read(&rab_in))) { /* always true */
6432 if (sts == RMS$_EOF) break;
6433 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6434 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6435 sys$close(&fab_in); sys$close(&fab_out);
6436 set_errno(EVMSERR); set_vaxc_errno(sts);
6441 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6442 sys$close(&fab_in); sys$close(&fab_out);
6443 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6445 set_errno(EVMSERR); set_vaxc_errno(sts);
6451 } /* end of rmscopy() */
6455 /*** The following glue provides 'hooks' to make some of the routines
6456 * from this file available from Perl. These routines are sufficiently
6457 * basic, and are required sufficiently early in the build process,
6458 * that's it's nice to have them available to miniperl as well as the
6459 * full Perl, so they're set up here instead of in an extension. The
6460 * Perl code which handles importation of these names into a given
6461 * package lives in [.VMS]Filespec.pm in @INC.
6465 rmsexpand_fromperl(pTHX_ CV *cv)
6468 char *fspec, *defspec = NULL, *rslt;
6471 if (!items || items > 2)
6472 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6473 fspec = SvPV(ST(0),n_a);
6474 if (!fspec || !*fspec) XSRETURN_UNDEF;
6475 if (items == 2) defspec = SvPV(ST(1),n_a);
6477 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6478 ST(0) = sv_newmortal();
6479 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6484 vmsify_fromperl(pTHX_ CV *cv)
6490 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6491 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6492 ST(0) = sv_newmortal();
6493 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6498 unixify_fromperl(pTHX_ CV *cv)
6504 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6505 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6506 ST(0) = sv_newmortal();
6507 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6512 fileify_fromperl(pTHX_ CV *cv)
6518 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6519 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6520 ST(0) = sv_newmortal();
6521 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6526 pathify_fromperl(pTHX_ CV *cv)
6532 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6533 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6534 ST(0) = sv_newmortal();
6535 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6540 vmspath_fromperl(pTHX_ CV *cv)
6546 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6547 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6548 ST(0) = sv_newmortal();
6549 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6554 unixpath_fromperl(pTHX_ CV *cv)
6560 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6561 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6562 ST(0) = sv_newmortal();
6563 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6568 candelete_fromperl(pTHX_ CV *cv)
6571 char fspec[NAM$C_MAXRSS+1], *fsp;
6576 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6578 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6579 if (SvTYPE(mysv) == SVt_PVGV) {
6580 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec,1)) {
6581 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6588 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6589 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6595 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6600 rmscopy_fromperl(pTHX_ CV *cv)
6603 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6605 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6606 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6607 unsigned long int sts;
6612 if (items < 2 || items > 3)
6613 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6615 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6616 if (SvTYPE(mysv) == SVt_PVGV) {
6617 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec,1)) {
6618 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6625 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6626 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6631 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6632 if (SvTYPE(mysv) == SVt_PVGV) {
6633 if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec,1)) {
6634 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6641 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6642 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6647 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6649 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6655 mod2fname(pTHX_ CV *cv)
6658 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6659 workbuff[NAM$C_MAXRSS*1 + 1];
6660 int total_namelen = 3, counter, num_entries;
6661 /* ODS-5 ups this, but we want to be consistent, so... */
6662 int max_name_len = 39;
6663 AV *in_array = (AV *)SvRV(ST(0));
6665 num_entries = av_len(in_array);
6667 /* All the names start with PL_. */
6668 strcpy(ultimate_name, "PL_");
6670 /* Clean up our working buffer */
6671 Zero(work_name, sizeof(work_name), char);
6673 /* Run through the entries and build up a working name */
6674 for(counter = 0; counter <= num_entries; counter++) {
6675 /* If it's not the first name then tack on a __ */
6677 strcat(work_name, "__");
6679 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6683 /* Check to see if we actually have to bother...*/
6684 if (strlen(work_name) + 3 <= max_name_len) {
6685 strcat(ultimate_name, work_name);
6687 /* It's too darned big, so we need to go strip. We use the same */
6688 /* algorithm as xsubpp does. First, strip out doubled __ */
6689 char *source, *dest, last;
6692 for (source = work_name; *source; source++) {
6693 if (last == *source && last == '_') {
6699 /* Go put it back */
6700 strcpy(work_name, workbuff);
6701 /* Is it still too big? */
6702 if (strlen(work_name) + 3 > max_name_len) {
6703 /* Strip duplicate letters */
6706 for (source = work_name; *source; source++) {
6707 if (last == toupper(*source)) {
6711 last = toupper(*source);
6713 strcpy(work_name, workbuff);
6716 /* Is it *still* too big? */
6717 if (strlen(work_name) + 3 > max_name_len) {
6718 /* Too bad, we truncate */
6719 work_name[max_name_len - 2] = 0;
6721 strcat(ultimate_name, work_name);
6724 /* Okay, return it */
6725 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6733 char* file = __FILE__;
6734 char temp_buff[512];
6735 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6736 no_translate_barewords = TRUE;
6738 no_translate_barewords = FALSE;
6741 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6742 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6743 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6744 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6745 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6746 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6747 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6748 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6749 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6750 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6752 store_pipelocs(aTHX);