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 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
53 #define PERLIO_NOT_STDIO 0
55 /* Don't replace system definitions of vfork, getenv, and stat,
56 * code below needs to get to the underlying CRTL routines. */
57 #define DONT_MASK_RTL_CALLS
61 /* Anticipating future expansion in lexical warnings . . . */
63 # define WARN_INTERNAL WARN_MISC
66 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
67 # define RTL_USES_UTC 1
71 /* gcc's header files don't #define direct access macros
72 * corresponding to VAXC's variant structs */
74 # define uic$v_format uic$r_uic_form.uic$v_format
75 # define uic$v_group uic$r_uic_form.uic$v_group
76 # define uic$v_member uic$r_uic_form.uic$v_member
77 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
78 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
79 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
80 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
83 #if defined(NEED_AN_H_ERRNO)
88 unsigned short int buflen;
89 unsigned short int itmcode;
91 unsigned short int *retlen;
94 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
95 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
96 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
97 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
98 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
99 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
100 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
101 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
102 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
104 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
105 #define PERL_LNM_MAX_ALLOWED_INDEX 127
107 static char *__mystrtolower(char *str)
109 if (str) for (; *str; ++str) *str= tolower(*str);
113 static struct dsc$descriptor_s fildevdsc =
114 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
115 static struct dsc$descriptor_s crtlenvdsc =
116 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
117 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
118 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
119 static struct dsc$descriptor_s **env_tables = defenv;
120 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
122 /* True if we shouldn't treat barewords as logicals during directory */
124 static int no_translate_barewords;
126 /* Temp for subprocess commands */
127 static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch};
130 static int tz_updated = 1;
133 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
135 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
136 struct dsc$descriptor_s **tabvec, unsigned long int flags)
138 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
139 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
140 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
141 unsigned char acmode;
142 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
143 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
144 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
145 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
147 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
148 #if defined(PERL_IMPLICIT_CONTEXT)
150 # if defined(USE_5005THREADS)
151 /* We jump through these hoops because we can be called at */
152 /* platform-specific initialization time, which is before anything is */
153 /* set up--we can't even do a plain dTHX since that relies on the */
154 /* interpreter structure to be initialized */
156 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
162 aTHX = PERL_GET_INTERP;
170 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
171 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
173 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
174 *cp2 = _toupper(*cp1);
175 if (cp1 - lnm > LNM$C_NAMLENGTH) {
176 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
180 lnmdsc.dsc$w_length = cp1 - lnm;
181 lnmdsc.dsc$a_pointer = uplnm;
182 uplnm[lnmdsc.dsc$w_length] = '\0';
183 secure = flags & PERL__TRNENV_SECURE;
184 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
185 if (!tabvec || !*tabvec) tabvec = env_tables;
187 for (curtab = 0; tabvec[curtab]; curtab++) {
188 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
189 if (!ivenv && !secure) {
194 Perl_warn(aTHX_ "Can't read CRTL environ\n");
197 retsts = SS$_NOLOGNAM;
198 for (i = 0; environ[i]; i++) {
199 if ((eq = strchr(environ[i],'=')) &&
200 !strncmp(environ[i],uplnm,eq - environ[i])) {
202 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
203 if (!eqvlen) continue;
208 if (retsts != SS$_NOLOGNAM) break;
211 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
212 !str$case_blind_compare(&tmpdsc,&clisym)) {
213 if (!ivsym && !secure) {
214 unsigned short int deflen = LNM$C_NAMLENGTH;
215 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
216 /* dynamic dsc to accomodate possible long value */
217 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
218 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
221 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
223 /* Special hack--we might be called before the interpreter's */
224 /* fully initialized, in which case either thr or PL_curcop */
225 /* might be bogus. We have to check, since ckWARN needs them */
226 /* both to be valid if running threaded */
227 #if defined(USE_THREADS)
228 if (thr && PL_curcop) {
230 if (ckWARN(WARN_MISC)) {
231 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
233 #if defined(USE_THREADS)
235 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
240 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
242 _ckvmssts(lib$sfree1_dd(&eqvdsc));
243 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
244 if (retsts == LIB$_NOSUCHSYM) continue;
249 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
250 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
251 if (retsts == SS$_NOLOGNAM) continue;
252 /* PPFs have a prefix */
255 *((int *)uplnm) == *((int *)"SYS$") &&
257 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
258 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
259 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
260 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
261 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
262 memcpy(eqv,eqv+4,eqvlen-4);
268 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
269 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
270 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
271 retsts == SS$_NOLOGNAM) {
272 set_errno(EINVAL); set_vaxc_errno(retsts);
274 else _ckvmssts(retsts);
276 } /* end of vmstrnenv */
279 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
280 /* Define as a function so we can access statics. */
281 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
283 return vmstrnenv(lnm,eqv,idx,fildev,
284 #ifdef SECURE_INTERNAL_GETENV
285 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
294 * Note: Uses Perl temp to store result so char * can be returned to
295 * caller; this pointer will be invalidated at next Perl statement
297 * We define this as a function rather than a macro in terms of my_getenv_len()
298 * so that it'll work when PL_curinterp is undefined (and we therefore can't
301 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
303 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
305 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
306 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
307 unsigned long int idx = 0;
308 int trnsuccess, success, secure, saverr, savvmserr;
311 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
312 /* Set up a temporary buffer for the return value; Perl will
313 * clean it up at the next statement transition */
314 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
315 if (!tmpsv) return NULL;
318 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
319 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
320 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
321 getcwd(eqv,LNM$C_NAMLENGTH);
325 if ((cp2 = strchr(lnm,';')) != NULL) {
327 uplnm[cp2-lnm] = '\0';
328 idx = strtoul(cp2+1,NULL,0);
331 /* Impose security constraints only if tainting */
333 /* Impose security constraints only if tainting */
334 secure = PL_curinterp ? PL_tainting : will_taint;
335 saverr = errno; savvmserr = vaxc$errno;
338 success = vmstrnenv(lnm,eqv,idx,
339 secure ? fildev : NULL,
340 #ifdef SECURE_INTERNAL_GETENV
341 secure ? PERL__TRNENV_SECURE : 0
346 /* Discard NOLOGNAM on internal calls since we're often looking
347 * for an optional name, and this "error" often shows up as the
348 * (bogus) exit status for a die() call later on. */
349 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
350 return success ? eqv : Nullch;
353 } /* end of my_getenv() */
357 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
359 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
361 char *buf, *cp1, *cp2;
362 unsigned long idx = 0;
363 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
364 int secure, saverr, savvmserr;
367 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
368 /* Set up a temporary buffer for the return value; Perl will
369 * clean it up at the next statement transition */
370 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
371 if (!tmpsv) return NULL;
374 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
375 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
376 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
377 getcwd(buf,LNM$C_NAMLENGTH);
382 if ((cp2 = strchr(lnm,';')) != NULL) {
385 idx = strtoul(cp2+1,NULL,0);
389 /* Impose security constraints only if tainting */
390 secure = PL_curinterp ? PL_tainting : will_taint;
391 saverr = errno; savvmserr = vaxc$errno;
394 *len = vmstrnenv(lnm,buf,idx,
395 secure ? fildev : NULL,
396 #ifdef SECURE_INTERNAL_GETENV
397 secure ? PERL__TRNENV_SECURE : 0
402 /* Discard NOLOGNAM on internal calls since we're often looking
403 * for an optional name, and this "error" often shows up as the
404 * (bogus) exit status for a die() call later on. */
405 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
406 return *len ? buf : Nullch;
409 } /* end of my_getenv_len() */
412 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
414 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
416 /*{{{ void prime_env_iter() */
419 /* Fill the %ENV associative array with all logical names we can
420 * find, in preparation for iterating over it.
423 static int primed = 0;
424 HV *seenhv = NULL, *envhv;
425 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
426 unsigned short int chan;
427 #ifndef CLI$M_TRUSTED
428 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
430 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
431 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
433 bool have_sym = FALSE, have_lnm = FALSE;
434 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
435 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
436 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
437 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
438 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
439 #if defined(PERL_IMPLICIT_CONTEXT)
442 #if defined(USE_THREADS) || defined(USE_ITHREADS)
443 static perl_mutex primenv_mutex;
444 MUTEX_INIT(&primenv_mutex);
447 #if defined(PERL_IMPLICIT_CONTEXT)
448 /* We jump through these hoops because we can be called at */
449 /* platform-specific initialization time, which is before anything is */
450 /* set up--we can't even do a plain dTHX since that relies on the */
451 /* interpreter structure to be initialized */
452 #if defined(USE_5005THREADS)
454 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
460 aTHX = PERL_GET_INTERP;
467 if (primed || !PL_envgv) return;
468 MUTEX_LOCK(&primenv_mutex);
469 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
470 envhv = GvHVn(PL_envgv);
471 /* Perform a dummy fetch as an lval to insure that the hash table is
472 * set up. Otherwise, the hv_store() will turn into a nullop. */
473 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
475 for (i = 0; env_tables[i]; i++) {
476 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
477 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
478 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
480 if (have_sym || have_lnm) {
481 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
482 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
483 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
484 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
487 for (i--; i >= 0; i--) {
488 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
491 for (j = 0; environ[j]; j++) {
492 if (!(start = strchr(environ[j],'='))) {
493 if (ckWARN(WARN_INTERNAL))
494 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
498 (void) hv_store(envhv,environ[j],start - environ[j] - 1,
504 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
505 !str$case_blind_compare(&tmpdsc,&clisym)) {
506 strcpy(cmd,"Show Symbol/Global *");
507 cmddsc.dsc$w_length = 20;
508 if (env_tables[i]->dsc$w_length == 12 &&
509 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
510 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
511 flags = defflags | CLI$M_NOLOGNAM;
514 strcpy(cmd,"Show Logical *");
515 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
516 strcat(cmd," /Table=");
517 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
518 cmddsc.dsc$w_length = strlen(cmd);
520 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
521 flags = defflags | CLI$M_NOCLISYM;
524 /* Create a new subprocess to execute each command, to exclude the
525 * remote possibility that someone could subvert a mbx or file used
526 * to write multiple commands to a single subprocess.
529 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
530 0,&riseandshine,0,0,&clidsc,&clitabdsc);
531 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
532 defflags &= ~CLI$M_TRUSTED;
533 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
535 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
536 if (seenhv) SvREFCNT_dec(seenhv);
539 char *cp1, *cp2, *key;
540 unsigned long int sts, iosb[2], retlen, keylen;
543 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
544 if (sts & 1) sts = iosb[0] & 0xffff;
545 if (sts == SS$_ENDOFFILE) {
547 while (substs == 0) { sys$hiber(); wakect++;}
548 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
553 retlen = iosb[0] >> 16;
554 if (!retlen) continue; /* blank line */
556 if (iosb[1] != subpid) {
558 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
562 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
563 Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
565 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
566 if (*cp1 == '(' || /* Logical name table name */
567 *cp1 == '=' /* Next eqv of searchlist */) continue;
568 if (*cp1 == '"') cp1++;
569 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
570 key = cp1; keylen = cp2 - cp1;
571 if (keylen && hv_exists(seenhv,key,keylen)) continue;
572 while (*cp2 && *cp2 != '=') cp2++;
573 while (*cp2 && *cp2 == '=') cp2++;
574 while (*cp2 && *cp2 == ' ') cp2++;
575 if (*cp2 == '"') { /* String translation; may embed "" */
576 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
577 cp2++; cp1--; /* Skip "" surrounding translation */
579 else { /* Numeric translation */
580 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
581 cp1--; /* stop on last non-space char */
583 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
584 Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
587 PERL_HASH(hash,key,keylen);
588 hv_store(envhv,key,keylen,newSVpvn(cp2,cp1 - cp2 + 1),hash);
589 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
591 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
592 /* get the PPFs for this process, not the subprocess */
593 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
594 char eqv[LNM$C_NAMLENGTH+1];
596 for (i = 0; ppfs[i]; i++) {
597 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
598 hv_store(envhv,ppfs[i],strlen(ppfs[i]),newSVpv(eqv,trnlen),0);
603 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
604 if (buf) Safefree(buf);
605 if (seenhv) SvREFCNT_dec(seenhv);
606 MUTEX_UNLOCK(&primenv_mutex);
609 } /* end of prime_env_iter */
613 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
614 /* Define or delete an element in the same "environment" as
615 * vmstrnenv(). If an element is to be deleted, it's removed from
616 * the first place it's found. If it's to be set, it's set in the
617 * place designated by the first element of the table vector.
618 * Like setenv() returns 0 for success, non-zero on error.
621 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
623 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
624 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
625 unsigned long int retsts, usermode = PSL$C_USER;
626 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
627 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
628 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
629 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
630 $DESCRIPTOR(local,"_LOCAL");
632 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
633 *cp2 = _toupper(*cp1);
634 if (cp1 - lnm > LNM$C_NAMLENGTH) {
635 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
639 lnmdsc.dsc$w_length = cp1 - lnm;
640 if (!tabvec || !*tabvec) tabvec = env_tables;
642 if (!eqv) { /* we're deleting n element */
643 for (curtab = 0; tabvec[curtab]; curtab++) {
644 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
646 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
647 if ((cp1 = strchr(environ[i],'=')) &&
648 !strncmp(environ[i],lnm,cp1 - environ[i])) {
650 return setenv(lnm,"",1) ? vaxc$errno : 0;
653 ivenv = 1; retsts = SS$_NOLOGNAM;
655 if (ckWARN(WARN_INTERNAL))
656 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
657 ivenv = 1; retsts = SS$_NOSUCHPGM;
663 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
664 !str$case_blind_compare(&tmpdsc,&clisym)) {
665 unsigned int symtype;
666 if (tabvec[curtab]->dsc$w_length == 12 &&
667 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
668 !str$case_blind_compare(&tmpdsc,&local))
669 symtype = LIB$K_CLI_LOCAL_SYM;
670 else symtype = LIB$K_CLI_GLOBAL_SYM;
671 retsts = lib$delete_symbol(&lnmdsc,&symtype);
672 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
673 if (retsts == LIB$_NOSUCHSYM) continue;
677 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
678 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
679 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
680 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
681 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
685 else { /* we're defining a value */
686 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
688 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
690 if (ckWARN(WARN_INTERNAL))
691 Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
692 retsts = SS$_NOSUCHPGM;
696 eqvdsc.dsc$a_pointer = eqv;
697 eqvdsc.dsc$w_length = strlen(eqv);
698 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
699 !str$case_blind_compare(&tmpdsc,&clisym)) {
700 unsigned int symtype;
701 if (tabvec[0]->dsc$w_length == 12 &&
702 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
703 !str$case_blind_compare(&tmpdsc,&local))
704 symtype = LIB$K_CLI_LOCAL_SYM;
705 else symtype = LIB$K_CLI_GLOBAL_SYM;
706 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
709 if (!*eqv) eqvdsc.dsc$w_length = 1;
710 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
711 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
712 if (ckWARN(WARN_MISC)) {
713 Perl_warner(aTHX_ WARN_MISC,"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
716 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
722 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
723 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
724 set_errno(EVMSERR); break;
725 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
726 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
727 set_errno(EINVAL); break;
734 set_vaxc_errno(retsts);
735 return (int) retsts || 44; /* retsts should never be 0, but just in case */
738 /* We reset error values on success because Perl does an hv_fetch()
739 * before each hv_store(), and if the thing we're setting didn't
740 * previously exist, we've got a leftover error message. (Of course,
741 * this fails in the face of
742 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
743 * in that the error reported in $! isn't spurious,
744 * but it's right more often than not.)
746 set_errno(0); set_vaxc_errno(retsts);
750 } /* end of vmssetenv() */
753 /*{{{ void my_setenv(char *lnm, char *eqv)*/
754 /* This has to be a function since there's a prototype for it in proto.h */
756 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
759 int len = strlen(lnm);
763 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
764 if (!strcmp(uplnm,"DEFAULT")) {
765 if (eqv && *eqv) chdir(eqv);
770 if (len == 6 || len == 2) {
773 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
775 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
776 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
780 (void) vmssetenv(lnm,eqv,NULL);
784 /*{{{static void vmssetuserlnm(char *name, char *eqv);
786 * sets a user-mode logical in the process logical name table
787 * used for redirection of sys$error
790 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
792 $DESCRIPTOR(d_tab, "LNM$PROCESS");
793 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
794 unsigned long int iss, attr = LNM$M_CONFINE;
795 unsigned char acmode = PSL$C_USER;
796 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
798 d_name.dsc$a_pointer = name;
799 d_name.dsc$w_length = strlen(name);
801 lnmlst[0].buflen = strlen(eqv);
802 lnmlst[0].bufadr = eqv;
804 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
805 if (!(iss&1)) lib$signal(iss);
810 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
811 /* my_crypt - VMS password hashing
812 * my_crypt() provides an interface compatible with the Unix crypt()
813 * C library function, and uses sys$hash_password() to perform VMS
814 * password hashing. The quadword hashed password value is returned
815 * as a NUL-terminated 8 character string. my_crypt() does not change
816 * the case of its string arguments; in order to match the behavior
817 * of LOGINOUT et al., alphabetic characters in both arguments must
818 * be upcased by the caller.
821 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
823 # ifndef UAI$C_PREFERRED_ALGORITHM
824 # define UAI$C_PREFERRED_ALGORITHM 127
826 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
827 unsigned short int salt = 0;
828 unsigned long int sts;
830 unsigned short int dsc$w_length;
831 unsigned char dsc$b_type;
832 unsigned char dsc$b_class;
833 const char * dsc$a_pointer;
834 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
835 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
836 struct itmlst_3 uailst[3] = {
837 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
838 { sizeof salt, UAI$_SALT, &salt, 0},
839 { 0, 0, NULL, NULL}};
842 usrdsc.dsc$w_length = strlen(usrname);
843 usrdsc.dsc$a_pointer = usrname;
844 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
846 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
850 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
856 if (sts != RMS$_RNF) return NULL;
859 txtdsc.dsc$w_length = strlen(textpasswd);
860 txtdsc.dsc$a_pointer = textpasswd;
861 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
862 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
865 return (char *) hash;
867 } /* end of my_crypt() */
871 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
872 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
873 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
875 /*{{{int do_rmdir(char *name)*/
877 Perl_do_rmdir(pTHX_ char *name)
879 char dirfile[NAM$C_MAXRSS+1];
883 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
884 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
885 else retval = kill_file(dirfile);
888 } /* end of do_rmdir */
892 * Delete any file to which user has control access, regardless of whether
893 * delete access is explicitly allowed.
894 * Limitations: User must have write access to parent directory.
895 * Does not block signals or ASTs; if interrupted in midstream
896 * may leave file with an altered ACL.
899 /*{{{int kill_file(char *name)*/
901 Perl_kill_file(pTHX_ char *name)
903 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
904 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
905 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
906 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
908 unsigned char myace$b_length;
909 unsigned char myace$b_type;
910 unsigned short int myace$w_flags;
911 unsigned long int myace$l_access;
912 unsigned long int myace$l_ident;
913 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
914 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
915 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
917 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
918 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
919 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
920 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
921 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
922 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
924 /* Expand the input spec using RMS, since the CRTL remove() and
925 * system services won't do this by themselves, so we may miss
926 * a file "hiding" behind a logical name or search list. */
927 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
928 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
929 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
930 /* If not, can changing protections help? */
931 if (vaxc$errno != RMS$_PRV) return -1;
933 /* No, so we get our own UIC to use as a rights identifier,
934 * and the insert an ACE at the head of the ACL which allows us
935 * to delete the file.
937 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
938 fildsc.dsc$w_length = strlen(rspec);
939 fildsc.dsc$a_pointer = rspec;
941 newace.myace$l_ident = oldace.myace$l_ident;
942 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
944 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
945 set_errno(ENOENT); break;
947 set_errno(ENOTDIR); break;
949 set_errno(ENODEV); break;
950 case RMS$_SYN: case SS$_INVFILFOROP:
951 set_errno(EINVAL); break;
953 set_errno(EACCES); break;
957 set_vaxc_errno(aclsts);
960 /* Grab any existing ACEs with this identifier in case we fail */
961 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
962 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
963 || fndsts == SS$_NOMOREACE ) {
964 /* Add the new ACE . . . */
965 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
967 if ((rmsts = remove(name))) {
968 /* We blew it - dir with files in it, no write priv for
969 * parent directory, etc. Put things back the way they were. */
970 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
973 addlst[0].bufadr = &oldace;
974 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
981 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
982 /* We just deleted it, so of course it's not there. Some versions of
983 * VMS seem to return success on the unlock operation anyhow (after all
984 * the unlock is successful), but others don't.
986 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
987 if (aclsts & 1) aclsts = fndsts;
990 set_vaxc_errno(aclsts);
996 } /* end of kill_file() */
1000 /*{{{int my_mkdir(char *,Mode_t)*/
1002 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1004 STRLEN dirlen = strlen(dir);
1006 /* zero length string sometimes gives ACCVIO */
1007 if (dirlen == 0) return -1;
1009 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1010 * null file name/type. However, it's commonplace under Unix,
1011 * so we'll allow it for a gain in portability.
1013 if (dir[dirlen-1] == '/') {
1014 char *newdir = savepvn(dir,dirlen-1);
1015 int ret = mkdir(newdir,mode);
1019 else return mkdir(dir,mode);
1020 } /* end of my_mkdir */
1023 /*{{{int my_chdir(char *)*/
1025 Perl_my_chdir(pTHX_ char *dir)
1027 STRLEN dirlen = strlen(dir);
1029 /* zero length string sometimes gives ACCVIO */
1030 if (dirlen == 0) return -1;
1032 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1034 * null file name/type. However, it's commonplace under Unix,
1035 * so we'll allow it for a gain in portability.
1037 if (dir[dirlen-1] == '/') {
1038 char *newdir = savepvn(dir,dirlen-1);
1039 int ret = chdir(newdir);
1043 else return chdir(dir);
1044 } /* end of my_chdir */
1048 /*{{{FILE *my_tmpfile()*/
1055 if ((fp = tmpfile())) return fp;
1057 New(1323,cp,L_tmpnam+24,char);
1058 strcpy(cp,"Sys$Scratch:");
1059 tmpnam(cp+strlen(cp));
1060 strcat(cp,".Perltmp");
1061 fp = fopen(cp,"w+","fop=dlt");
1067 /* default piping mailbox size */
1068 #define PERL_BUFSIZ 512
1072 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1074 unsigned long int mbxbufsiz;
1075 static unsigned long int syssize = 0;
1076 unsigned long int dviitm = DVI$_DEVNAM;
1077 char csize[LNM$C_NAMLENGTH+1];
1080 unsigned long syiitm = SYI$_MAXBUF;
1082 * Get the SYSGEN parameter MAXBUF
1084 * If the logical 'PERL_MBX_SIZE' is defined
1085 * use the value of the logical instead of PERL_BUFSIZ, but
1086 * keep the size between 128 and MAXBUF.
1089 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1092 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1093 mbxbufsiz = atoi(csize);
1095 mbxbufsiz = PERL_BUFSIZ;
1097 if (mbxbufsiz < 128) mbxbufsiz = 128;
1098 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1100 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1102 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1103 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1105 } /* end of create_mbx() */
1108 /*{{{ my_popen and my_pclose*/
1110 typedef struct _iosb IOSB;
1111 typedef struct _iosb* pIOSB;
1112 typedef struct _pipe Pipe;
1113 typedef struct _pipe* pPipe;
1114 typedef struct pipe_details Info;
1115 typedef struct pipe_details* pInfo;
1116 typedef struct _srqp RQE;
1117 typedef struct _srqp* pRQE;
1118 typedef struct _tochildbuf CBuf;
1119 typedef struct _tochildbuf* pCBuf;
1122 unsigned short status;
1123 unsigned short count;
1124 unsigned long dvispec;
1127 #pragma member_alignment save
1128 #pragma nomember_alignment quadword
1129 struct _srqp { /* VMS self-relative queue entry */
1130 unsigned long qptr[2];
1132 #pragma member_alignment restore
1133 static RQE RQE_ZERO = {0,0};
1135 struct _tochildbuf {
1138 unsigned short size;
1146 unsigned short chan_in;
1147 unsigned short chan_out;
1149 unsigned int bufsize;
1161 #if defined(PERL_IMPLICIT_CONTEXT)
1162 void *thx; /* Either a thread or an interpreter */
1163 /* pointer, depending on how we're built */
1171 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1172 int pid; /* PID of subprocess */
1173 int mode; /* == 'r' if pipe open for reading */
1174 int done; /* subprocess has completed */
1175 int closing; /* my_pclose is closing this pipe */
1176 unsigned long completion; /* termination status of subprocess */
1177 pPipe in; /* pipe in to sub */
1178 pPipe out; /* pipe out of sub */
1179 pPipe err; /* pipe of sub's sys$error */
1180 int in_done; /* true when in pipe finished */
1185 struct exit_control_block
1187 struct exit_control_block *flink;
1188 unsigned long int (*exit_routine)();
1189 unsigned long int arg_count;
1190 unsigned long int *status_address;
1191 unsigned long int exit_status;
1194 #define RETRY_DELAY "0 ::0.20"
1195 #define MAX_RETRY 50
1197 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1198 static unsigned long mypid;
1199 static unsigned long delaytime[2];
1201 static pInfo open_pipes = NULL;
1202 static $DESCRIPTOR(nl_desc, "NL:");
1205 static unsigned long int
1206 pipe_exit_routine(pTHX)
1209 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1210 int sts, did_stuff, need_eof;
1213 first we try sending an EOF...ignore if doesn't work, make sure we
1221 _ckvmssts(sys$setast(0));
1222 if (info->in && !info->in->shut_on_empty) {
1223 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1227 _ckvmssts(sys$setast(1));
1230 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1235 _ckvmssts(sys$setast(0));
1236 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1237 sts = sys$forcex(&info->pid,0,&abort);
1238 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1241 _ckvmssts(sys$setast(1));
1244 if (did_stuff) sleep(1); /* wait for them to respond */
1248 _ckvmssts(sys$setast(0));
1249 if (!info->done) { /* We tried to be nice . . . */
1250 sts = sys$delprc(&info->pid,0);
1251 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1253 _ckvmssts(sys$setast(1));
1258 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1259 else if (!(sts & 1)) retsts = sts;
1264 static struct exit_control_block pipe_exitblock =
1265 {(struct exit_control_block *) 0,
1266 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1268 static void pipe_mbxtofd_ast(pPipe p);
1269 static void pipe_tochild1_ast(pPipe p);
1270 static void pipe_tochild2_ast(pPipe p);
1273 popen_completion_ast(pInfo info)
1275 pInfo i = open_pipes;
1279 if (i == info) break;
1282 if (!i) return; /* unlinked, probably freed too */
1284 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1288 Writing to subprocess ...
1289 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1291 chan_out may be waiting for "done" flag, or hung waiting
1292 for i/o completion to child...cancel the i/o. This will
1293 put it into "snarf mode" (done but no EOF yet) that discards
1296 Output from subprocess (stdout, stderr) needs to be flushed and
1297 shut down. We try sending an EOF, but if the mbx is full the pipe
1298 routine should still catch the "shut_on_empty" flag, telling it to
1299 use immediate-style reads so that "mbx empty" -> EOF.
1303 if (info->in && !info->in_done) { /* only for mode=w */
1304 if (info->in->shut_on_empty && info->in->need_wake) {
1305 info->in->need_wake = FALSE;
1306 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1308 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1312 if (info->out && !info->out_done) { /* were we also piping output? */
1313 info->out->shut_on_empty = TRUE;
1314 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1315 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1316 _ckvmssts_noperl(iss);
1319 if (info->err && !info->err_done) { /* we were piping stderr */
1320 info->err->shut_on_empty = TRUE;
1321 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1322 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1323 _ckvmssts_noperl(iss);
1325 _ckvmssts_noperl(sys$setef(pipe_ef));
1329 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
1330 static void vms_execfree(pTHX);
1333 we actually differ from vmstrnenv since we use this to
1334 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1335 are pointing to the same thing
1338 static unsigned short
1339 popen_translate(pTHX_ char *logical, char *result)
1342 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1343 $DESCRIPTOR(d_log,"");
1345 unsigned short length;
1346 unsigned short code;
1348 unsigned short *retlenaddr;
1350 unsigned short l, ifi;
1352 d_log.dsc$a_pointer = logical;
1353 d_log.dsc$w_length = strlen(logical);
1355 itmlst[0].code = LNM$_STRING;
1356 itmlst[0].length = 255;
1357 itmlst[0].buffer_addr = result;
1358 itmlst[0].retlenaddr = &l;
1361 itmlst[1].length = 0;
1362 itmlst[1].buffer_addr = 0;
1363 itmlst[1].retlenaddr = 0;
1365 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1366 if (iss == SS$_NOLOGNAM) {
1370 if (!(iss&1)) lib$signal(iss);
1373 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1374 strip it off and return the ifi, if any
1377 if (result[0] == 0x1b && result[1] == 0x00) {
1378 memcpy(&ifi,result+2,2);
1379 strcpy(result,result+4);
1381 return ifi; /* this is the RMS internal file id */
1384 #define MAX_DCL_SYMBOL 255
1385 static void pipe_infromchild_ast(pPipe p);
1388 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1389 inside an AST routine without worrying about reentrancy and which Perl
1390 memory allocator is being used.
1392 We read data and queue up the buffers, then spit them out one at a
1393 time to the output mailbox when the output mailbox is ready for one.
1396 #define INITIAL_TOCHILDQUEUE 2
1399 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1403 char mbx1[64], mbx2[64];
1404 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1405 DSC$K_CLASS_S, mbx1},
1406 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1407 DSC$K_CLASS_S, mbx2};
1408 unsigned int dviitm = DVI$_DEVBUFSIZ;
1411 New(1368, p, 1, Pipe);
1413 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1414 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1415 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1418 p->shut_on_empty = FALSE;
1419 p->need_wake = FALSE;
1422 p->iosb.status = SS$_NORMAL;
1423 p->iosb2.status = SS$_NORMAL;
1429 #ifdef PERL_IMPLICIT_CONTEXT
1433 n = sizeof(CBuf) + p->bufsize;
1435 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1436 _ckvmssts(lib$get_vm(&n, &b));
1437 b->buf = (char *) b + sizeof(CBuf);
1438 _ckvmssts(lib$insqhi(b, &p->free));
1441 pipe_tochild2_ast(p);
1442 pipe_tochild1_ast(p);
1448 /* reads the MBX Perl is writing, and queues */
1451 pipe_tochild1_ast(pPipe p)
1454 int iss = p->iosb.status;
1455 int eof = (iss == SS$_ENDOFFILE);
1456 #ifdef PERL_IMPLICIT_CONTEXT
1462 p->shut_on_empty = TRUE;
1464 _ckvmssts(sys$dassgn(p->chan_in));
1470 b->size = p->iosb.count;
1471 _ckvmssts(lib$insqhi(b, &p->wait));
1473 p->need_wake = FALSE;
1474 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1477 p->retry = 1; /* initial call */
1480 if (eof) { /* flush the free queue, return when done */
1481 int n = sizeof(CBuf) + p->bufsize;
1483 iss = lib$remqti(&p->free, &b);
1484 if (iss == LIB$_QUEWASEMP) return;
1486 _ckvmssts(lib$free_vm(&n, &b));
1490 iss = lib$remqti(&p->free, &b);
1491 if (iss == LIB$_QUEWASEMP) {
1492 int n = sizeof(CBuf) + p->bufsize;
1493 _ckvmssts(lib$get_vm(&n, &b));
1494 b->buf = (char *) b + sizeof(CBuf);
1500 iss = sys$qio(0,p->chan_in,
1501 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1503 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1504 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1509 /* writes queued buffers to output, waits for each to complete before
1513 pipe_tochild2_ast(pPipe p)
1516 int iss = p->iosb2.status;
1517 int n = sizeof(CBuf) + p->bufsize;
1518 int done = (p->info && p->info->done) ||
1519 iss == SS$_CANCEL || iss == SS$_ABORT;
1520 #if defined(PERL_IMPLICIT_CONTEXT)
1525 if (p->type) { /* type=1 has old buffer, dispose */
1526 if (p->shut_on_empty) {
1527 _ckvmssts(lib$free_vm(&n, &b));
1529 _ckvmssts(lib$insqhi(b, &p->free));
1534 iss = lib$remqti(&p->wait, &b);
1535 if (iss == LIB$_QUEWASEMP) {
1536 if (p->shut_on_empty) {
1538 _ckvmssts(sys$dassgn(p->chan_out));
1539 *p->pipe_done = TRUE;
1540 _ckvmssts(sys$setef(pipe_ef));
1542 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1543 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1547 p->need_wake = TRUE;
1557 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1558 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1560 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1561 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1570 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1573 char mbx1[64], mbx2[64];
1574 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1575 DSC$K_CLASS_S, mbx1},
1576 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1577 DSC$K_CLASS_S, mbx2};
1578 unsigned int dviitm = DVI$_DEVBUFSIZ;
1580 New(1367, p, 1, Pipe);
1581 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1582 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1584 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1585 New(1367, p->buf, p->bufsize, char);
1586 p->shut_on_empty = FALSE;
1589 p->iosb.status = SS$_NORMAL;
1590 #if defined(PERL_IMPLICIT_CONTEXT)
1593 pipe_infromchild_ast(p);
1601 pipe_infromchild_ast(pPipe p)
1603 int iss = p->iosb.status;
1604 int eof = (iss == SS$_ENDOFFILE);
1605 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1606 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1607 #if defined(PERL_IMPLICIT_CONTEXT)
1611 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1612 _ckvmssts(sys$dassgn(p->chan_out));
1617 input shutdown if EOF from self (done or shut_on_empty)
1618 output shutdown if closing flag set (my_pclose)
1619 send data/eof from child or eof from self
1620 otherwise, re-read (snarf of data from child)
1625 if (myeof && p->chan_in) { /* input shutdown */
1626 _ckvmssts(sys$dassgn(p->chan_in));
1631 if (myeof || kideof) { /* pass EOF to parent */
1632 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1633 pipe_infromchild_ast, p,
1636 } else if (eof) { /* eat EOF --- fall through to read*/
1638 } else { /* transmit data */
1639 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1640 pipe_infromchild_ast,p,
1641 p->buf, p->iosb.count, 0, 0, 0, 0));
1647 /* everything shut? flag as done */
1649 if (!p->chan_in && !p->chan_out) {
1650 *p->pipe_done = TRUE;
1651 _ckvmssts(sys$setef(pipe_ef));
1655 /* write completed (or read, if snarfing from child)
1656 if still have input active,
1657 queue read...immediate mode if shut_on_empty so we get EOF if empty
1659 check if Perl reading, generate EOFs as needed
1665 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1666 pipe_infromchild_ast,p,
1667 p->buf, p->bufsize, 0, 0, 0, 0);
1668 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1670 } else { /* send EOFs for extra reads */
1671 p->iosb.status = SS$_ENDOFFILE;
1672 p->iosb.dvispec = 0;
1673 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1675 pipe_infromchild_ast, p, 0, 0, 0, 0));
1681 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1685 unsigned long dviitm = DVI$_DEVBUFSIZ;
1687 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1688 DSC$K_CLASS_S, mbx};
1690 /* things like terminals and mbx's don't need this filter */
1691 if (fd && fstat(fd,&s) == 0) {
1692 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1693 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1694 DSC$K_CLASS_S, s.st_dev};
1696 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1697 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1698 strcpy(out, s.st_dev);
1703 New(1366, p, 1, Pipe);
1704 p->fd_out = dup(fd);
1705 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1706 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1707 New(1366, p->buf, p->bufsize+1, char);
1708 p->shut_on_empty = FALSE;
1713 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1714 pipe_mbxtofd_ast, p,
1715 p->buf, p->bufsize, 0, 0, 0, 0));
1721 pipe_mbxtofd_ast(pPipe p)
1723 int iss = p->iosb.status;
1724 int done = p->info->done;
1726 int eof = (iss == SS$_ENDOFFILE);
1727 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1728 int err = !(iss&1) && !eof;
1729 #if defined(PERL_IMPLICIT_CONTEXT)
1733 if (done && myeof) { /* end piping */
1735 sys$dassgn(p->chan_in);
1736 *p->pipe_done = TRUE;
1737 _ckvmssts(sys$setef(pipe_ef));
1741 if (!err && !eof) { /* good data to send to file */
1742 p->buf[p->iosb.count] = '\n';
1743 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1746 if (p->retry < MAX_RETRY) {
1747 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1757 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1758 pipe_mbxtofd_ast, p,
1759 p->buf, p->bufsize, 0, 0, 0, 0);
1760 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1765 typedef struct _pipeloc PLOC;
1766 typedef struct _pipeloc* pPLOC;
1770 char dir[NAM$C_MAXRSS+1];
1772 static pPLOC head_PLOC = 0;
1775 free_pipelocs(pTHX_ void *head)
1788 store_pipelocs(pTHX)
1792 AV *av = GvAVn(PL_incgv);
1797 char temp[NAM$C_MAXRSS+1];
1800 /* the . directory from @INC comes last */
1803 p->next = head_PLOC;
1805 strcpy(p->dir,"./");
1807 /* get the directory from $^X */
1809 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1810 strcpy(temp, PL_origargv[0]);
1811 x = strrchr(temp,']');
1814 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1816 p->next = head_PLOC;
1818 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1819 p->dir[NAM$C_MAXRSS] = '\0';
1823 /* reverse order of @INC entries, skip "." since entered above */
1825 for (i = 0; i <= AvFILL(av); i++) {
1826 dirsv = *av_fetch(av,i,TRUE);
1828 if (SvROK(dirsv)) continue;
1829 dir = SvPVx(dirsv,n_a);
1830 if (strcmp(dir,".") == 0) continue;
1831 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1835 p->next = head_PLOC;
1837 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1838 p->dir[NAM$C_MAXRSS] = '\0';
1841 /* most likely spot (ARCHLIB) put first in the list */
1844 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1846 p->next = head_PLOC;
1848 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1849 p->dir[NAM$C_MAXRSS] = '\0';
1852 Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
1859 static int vmspipe_file_status = 0;
1860 static char vmspipe_file[NAM$C_MAXRSS+1];
1862 /* already found? Check and use ... need read+execute permission */
1864 if (vmspipe_file_status == 1) {
1865 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1866 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1867 return vmspipe_file;
1869 vmspipe_file_status = 0;
1872 /* scan through stored @INC, $^X */
1874 if (vmspipe_file_status == 0) {
1875 char file[NAM$C_MAXRSS+1];
1876 pPLOC p = head_PLOC;
1879 strcpy(file, p->dir);
1880 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1881 file[NAM$C_MAXRSS] = '\0';
1884 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1886 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1887 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1888 vmspipe_file_status = 1;
1889 return vmspipe_file;
1892 vmspipe_file_status = -1; /* failed, use tempfiles */
1899 vmspipe_tempfile(pTHX)
1901 char file[NAM$C_MAXRSS+1];
1903 static int index = 0;
1906 /* create a tempfile */
1908 /* we can't go from W, shr=get to R, shr=get without
1909 an intermediate vulnerable state, so don't bother trying...
1911 and lib$spawn doesn't shr=put, so have to close the write
1913 So... match up the creation date/time and the FID to
1914 make sure we're dealing with the same file
1919 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1920 fp = fopen(file,"w");
1922 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1923 fp = fopen(file,"w");
1925 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1926 fp = fopen(file,"w");
1929 if (!fp) return 0; /* we're hosed */
1931 fprintf(fp,"$! 'f$verify(0)\n");
1932 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1933 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1934 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1935 fprintf(fp,"$ perl_on = \"set noon\"\n");
1936 fprintf(fp,"$ perl_exit = \"exit\"\n");
1937 fprintf(fp,"$ perl_del = \"delete\"\n");
1938 fprintf(fp,"$ pif = \"if\"\n");
1939 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1940 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
1941 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
1942 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1943 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1944 fprintf(fp,"$! --- get rid of global symbols\n");
1945 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1946 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1947 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1948 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1949 fprintf(fp,"$ perl_on\n");
1950 fprintf(fp,"$ 'cmd\n");
1951 fprintf(fp,"$ perl_status = $STATUS\n");
1952 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1953 fprintf(fp,"$ perl_exit 'perl_status'\n");
1956 fgetname(fp, file, 1);
1957 fstat(fileno(fp), &s0);
1960 fp = fopen(file,"r","shr=get");
1962 fstat(fileno(fp), &s1);
1964 if (s0.st_ino[0] != s1.st_ino[0] ||
1965 s0.st_ino[1] != s1.st_ino[1] ||
1966 s0.st_ino[2] != s1.st_ino[2] ||
1967 s0.st_ctime != s1.st_ctime ) {
1978 safe_popen(pTHX_ char *cmd, char *mode)
1980 static int handler_set_up = FALSE;
1981 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
1982 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
1983 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
1984 char in[512], out[512], err[512], mbx[512];
1986 char tfilebuf[NAM$C_MAXRSS+1];
1988 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
1989 DSC$K_CLASS_S, symbol};
1990 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
1993 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
1994 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
1995 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
1996 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
1998 /* once-per-program initialization...
1999 note that the SETAST calls and the dual test of pipe_ef
2000 makes sure that only the FIRST thread through here does
2001 the initialization...all other threads wait until it's
2004 Yeah, uglier than a pthread call, it's got all the stuff inline
2005 rather than in a separate routine.
2009 _ckvmssts(sys$setast(0));
2011 unsigned long int pidcode = JPI$_PID;
2012 $DESCRIPTOR(d_delay, RETRY_DELAY);
2013 _ckvmssts(lib$get_ef(&pipe_ef));
2014 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2015 _ckvmssts(sys$bintim(&d_delay, delaytime));
2017 if (!handler_set_up) {
2018 _ckvmssts(sys$dclexh(&pipe_exitblock));
2019 handler_set_up = TRUE;
2021 _ckvmssts(sys$setast(1));
2024 /* see if we can find a VMSPIPE.COM */
2027 vmspipe = find_vmspipe(aTHX);
2029 strcpy(tfilebuf+1,vmspipe);
2030 } else { /* uh, oh...we're in tempfile hell */
2031 tpipe = vmspipe_tempfile(aTHX);
2032 if (!tpipe) { /* a fish popular in Boston */
2033 if (ckWARN(WARN_PIPE)) {
2034 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2038 fgetname(tpipe,tfilebuf+1,1);
2040 vmspipedsc.dsc$a_pointer = tfilebuf;
2041 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2043 if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
2044 New(1301,info,1,Info);
2048 info->completion = 0;
2049 info->closing = FALSE;
2053 info->in_done = TRUE;
2054 info->out_done = TRUE;
2055 info->err_done = TRUE;
2056 in[0] = out[0] = err[0] = '\0';
2058 if (*mode == 'r') { /* piping from subroutine */
2060 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2062 info->out->pipe_done = &info->out_done;
2063 info->out_done = FALSE;
2064 info->out->info = info;
2066 info->fp = PerlIO_open(mbx, mode);
2067 if (!info->fp && info->out) {
2068 sys$cancel(info->out->chan_out);
2070 while (!info->out_done) {
2072 _ckvmssts(sys$setast(0));
2073 done = info->out_done;
2074 if (!done) _ckvmssts(sys$clref(pipe_ef));
2075 _ckvmssts(sys$setast(1));
2076 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2079 if (info->out->buf) Safefree(info->out->buf);
2080 Safefree(info->out);
2085 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2087 info->err->pipe_done = &info->err_done;
2088 info->err_done = FALSE;
2089 info->err->info = info;
2092 } else { /* piping to subroutine , mode=w*/
2094 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2095 info->fp = PerlIO_open(mbx, mode);
2097 info->in->pipe_done = &info->in_done;
2098 info->in_done = FALSE;
2099 info->in->info = info;
2103 if (!info->fp && info->in) {
2105 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2106 0, 0, 0, 0, 0, 0, 0, 0));
2108 while (!info->in_done) {
2110 _ckvmssts(sys$setast(0));
2111 done = info->in_done;
2112 if (!done) _ckvmssts(sys$clref(pipe_ef));
2113 _ckvmssts(sys$setast(1));
2114 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2117 if (info->in->buf) Safefree(info->in->buf);
2124 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2126 info->out->pipe_done = &info->out_done;
2127 info->out_done = FALSE;
2128 info->out->info = info;
2131 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2133 info->err->pipe_done = &info->err_done;
2134 info->err_done = FALSE;
2135 info->err->info = info;
2139 symbol[MAX_DCL_SYMBOL] = '\0';
2141 strncpy(symbol, in, MAX_DCL_SYMBOL);
2142 d_symbol.dsc$w_length = strlen(symbol);
2143 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2145 strncpy(symbol, err, MAX_DCL_SYMBOL);
2146 d_symbol.dsc$w_length = strlen(symbol);
2147 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2149 strncpy(symbol, out, MAX_DCL_SYMBOL);
2150 d_symbol.dsc$w_length = strlen(symbol);
2151 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2153 p = VMScmd.dsc$a_pointer;
2154 while (*p && *p != '\n') p++;
2155 *p = '\0'; /* truncate on \n */
2156 p = VMScmd.dsc$a_pointer;
2157 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2158 if (*p == '$') p++; /* remove leading $ */
2159 while (*p == ' ' || *p == '\t') p++;
2160 strncpy(symbol, p, MAX_DCL_SYMBOL);
2161 d_symbol.dsc$w_length = strlen(symbol);
2162 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2164 _ckvmssts(sys$setast(0));
2165 info->next=open_pipes; /* prepend to list */
2167 _ckvmssts(sys$setast(1));
2168 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2169 0, &info->pid, &info->completion,
2170 0, popen_completion_ast,info,0,0,0));
2172 /* if we were using a tempfile, close it now */
2174 if (tpipe) fclose(tpipe);
2176 /* once the subprocess is spawned, its copied the symbols and
2177 we can get rid of ours */
2179 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2180 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2181 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2182 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2185 PL_forkprocess = info->pid;
2187 } /* end of safe_popen */
2190 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2192 Perl_my_popen(pTHX_ char *cmd, char *mode)
2195 TAINT_PROPER("popen");
2196 PERL_FLUSHALL_FOR_CHILD;
2197 return safe_popen(aTHX_ cmd,mode);
2202 /*{{{ I32 my_pclose(PerlIO *fp)*/
2203 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2205 pInfo info, last = NULL;
2206 unsigned long int retsts;
2209 for (info = open_pipes; info != NULL; last = info, info = info->next)
2210 if (info->fp == fp) break;
2212 if (info == NULL) { /* no such pipe open */
2213 set_errno(ECHILD); /* quoth POSIX */
2214 set_vaxc_errno(SS$_NONEXPR);
2218 /* If we were writing to a subprocess, insure that someone reading from
2219 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2220 * produce an EOF record in the mailbox.
2222 * well, at least sometimes it *does*, so we have to watch out for
2223 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2226 PerlIO_flush(info->fp); /* first, flush data */
2228 _ckvmssts(sys$setast(0));
2229 info->closing = TRUE;
2230 done = info->done && info->in_done && info->out_done && info->err_done;
2231 /* hanging on write to Perl's input? cancel it */
2232 if (info->mode == 'r' && info->out && !info->out_done) {
2233 if (info->out->chan_out) {
2234 _ckvmssts(sys$cancel(info->out->chan_out));
2235 if (!info->out->chan_in) { /* EOF generation, need AST */
2236 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2240 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2241 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2243 _ckvmssts(sys$setast(1));
2244 PerlIO_close(info->fp);
2247 we have to wait until subprocess completes, but ALSO wait until all
2248 the i/o completes...otherwise we'll be freeing the "info" structure
2249 that the i/o ASTs could still be using...
2253 _ckvmssts(sys$setast(0));
2254 done = info->done && info->in_done && info->out_done && info->err_done;
2255 if (!done) _ckvmssts(sys$clref(pipe_ef));
2256 _ckvmssts(sys$setast(1));
2257 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2259 retsts = info->completion;
2261 /* remove from list of open pipes */
2262 _ckvmssts(sys$setast(0));
2263 if (last) last->next = info->next;
2264 else open_pipes = info->next;
2265 _ckvmssts(sys$setast(1));
2267 /* free buffers and structures */
2270 if (info->in->buf) Safefree(info->in->buf);
2274 if (info->out->buf) Safefree(info->out->buf);
2275 Safefree(info->out);
2278 if (info->err->buf) Safefree(info->err->buf);
2279 Safefree(info->err);
2285 } /* end of my_pclose() */
2287 /* sort-of waitpid; use only with popen() */
2288 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2290 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2295 for (info = open_pipes; info != NULL; info = info->next)
2296 if (info->pid == pid) break;
2298 if (info != NULL) { /* we know about this child */
2299 while (!info->done) {
2300 _ckvmssts(sys$setast(0));
2302 if (!done) _ckvmssts(sys$clref(pipe_ef));
2303 _ckvmssts(sys$setast(1));
2304 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2307 *statusp = info->completion;
2310 else { /* we haven't heard of this child */
2311 $DESCRIPTOR(intdsc,"0 00:00:01");
2312 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2313 unsigned long int interval[2],sts;
2315 if (ckWARN(WARN_EXEC)) {
2316 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2317 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2318 if (ownerpid != mypid)
2319 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2322 _ckvmssts(sys$bintim(&intdsc,interval));
2323 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2324 _ckvmssts(sys$schdwk(0,0,interval,0));
2325 _ckvmssts(sys$hiber());
2327 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2330 /* There's no easy way to find the termination status a child we're
2331 * not aware of beforehand. If we're really interested in the future,
2332 * we can go looking for a termination mailbox, or chase after the
2333 * accounting record for the process.
2339 } /* end of waitpid() */
2344 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2346 my_gconvert(double val, int ndig, int trail, char *buf)
2348 static char __gcvtbuf[DBL_DIG+1];
2351 loc = buf ? buf : __gcvtbuf;
2353 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2355 sprintf(loc,"%.*g",ndig,val);
2361 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2362 return gcvt(val,ndig,loc);
2365 loc[0] = '0'; loc[1] = '\0';
2373 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2374 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2375 * to expand file specification. Allows for a single default file
2376 * specification and a simple mask of options. If outbuf is non-NULL,
2377 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2378 * the resultant file specification is placed. If outbuf is NULL, the
2379 * resultant file specification is placed into a static buffer.
2380 * The third argument, if non-NULL, is taken to be a default file
2381 * specification string. The fourth argument is unused at present.
2382 * rmesexpand() returns the address of the resultant string if
2383 * successful, and NULL on error.
2385 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2388 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2390 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2391 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2392 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2393 struct FAB myfab = cc$rms_fab;
2394 struct NAM mynam = cc$rms_nam;
2396 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2398 if (!filespec || !*filespec) {
2399 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2403 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2404 else outbuf = __rmsexpand_retbuf;
2406 if ((isunix = (strchr(filespec,'/') != NULL))) {
2407 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2408 filespec = vmsfspec;
2411 myfab.fab$l_fna = filespec;
2412 myfab.fab$b_fns = strlen(filespec);
2413 myfab.fab$l_nam = &mynam;
2415 if (defspec && *defspec) {
2416 if (strchr(defspec,'/') != NULL) {
2417 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2420 myfab.fab$l_dna = defspec;
2421 myfab.fab$b_dns = strlen(defspec);
2424 mynam.nam$l_esa = esa;
2425 mynam.nam$b_ess = sizeof esa;
2426 mynam.nam$l_rsa = outbuf;
2427 mynam.nam$b_rss = NAM$C_MAXRSS;
2429 retsts = sys$parse(&myfab,0,0);
2430 if (!(retsts & 1)) {
2431 mynam.nam$b_nop |= NAM$M_SYNCHK;
2432 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2433 retsts = sys$parse(&myfab,0,0);
2434 if (retsts & 1) goto expanded;
2436 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2437 (void) sys$parse(&myfab,0,0); /* Free search context */
2438 if (out) Safefree(out);
2439 set_vaxc_errno(retsts);
2440 if (retsts == RMS$_PRV) set_errno(EACCES);
2441 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2442 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2443 else set_errno(EVMSERR);
2446 retsts = sys$search(&myfab,0,0);
2447 if (!(retsts & 1) && retsts != RMS$_FNF) {
2448 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2449 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2450 if (out) Safefree(out);
2451 set_vaxc_errno(retsts);
2452 if (retsts == RMS$_PRV) set_errno(EACCES);
2453 else set_errno(EVMSERR);
2457 /* If the input filespec contained any lowercase characters,
2458 * downcase the result for compatibility with Unix-minded code. */
2460 for (out = myfab.fab$l_fna; *out; out++)
2461 if (islower(*out)) { haslower = 1; break; }
2462 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2463 else { out = esa; speclen = mynam.nam$b_esl; }
2464 /* Trim off null fields added by $PARSE
2465 * If type > 1 char, must have been specified in original or default spec
2466 * (not true for version; $SEARCH may have added version of existing file).
2468 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2469 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2470 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2471 if (trimver || trimtype) {
2472 if (defspec && *defspec) {
2473 char defesa[NAM$C_MAXRSS];
2474 struct FAB deffab = cc$rms_fab;
2475 struct NAM defnam = cc$rms_nam;
2477 deffab.fab$l_nam = &defnam;
2478 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2479 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2480 defnam.nam$b_nop = NAM$M_SYNCHK;
2481 if (sys$parse(&deffab,0,0) & 1) {
2482 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2483 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2486 if (trimver) speclen = mynam.nam$l_ver - out;
2488 /* If we didn't already trim version, copy down */
2489 if (speclen > mynam.nam$l_ver - out)
2490 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2491 speclen - (mynam.nam$l_ver - out));
2492 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2495 /* If we just had a directory spec on input, $PARSE "helpfully"
2496 * adds an empty name and type for us */
2497 if (mynam.nam$l_name == mynam.nam$l_type &&
2498 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2499 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2500 speclen = mynam.nam$l_name - out;
2501 out[speclen] = '\0';
2502 if (haslower) __mystrtolower(out);
2504 /* Have we been working with an expanded, but not resultant, spec? */
2505 /* Also, convert back to Unix syntax if necessary. */
2506 if (!mynam.nam$b_rsl) {
2508 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2510 else strcpy(outbuf,esa);
2513 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2514 strcpy(outbuf,tmpfspec);
2516 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2517 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2518 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2522 /* External entry points */
2523 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2524 { return do_rmsexpand(spec,buf,0,def,opt); }
2525 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2526 { return do_rmsexpand(spec,buf,1,def,opt); }
2530 ** The following routines are provided to make life easier when
2531 ** converting among VMS-style and Unix-style directory specifications.
2532 ** All will take input specifications in either VMS or Unix syntax. On
2533 ** failure, all return NULL. If successful, the routines listed below
2534 ** return a pointer to a buffer containing the appropriately
2535 ** reformatted spec (and, therefore, subsequent calls to that routine
2536 ** will clobber the result), while the routines of the same names with
2537 ** a _ts suffix appended will return a pointer to a mallocd string
2538 ** containing the appropriately reformatted spec.
2539 ** In all cases, only explicit syntax is altered; no check is made that
2540 ** the resulting string is valid or that the directory in question
2543 ** fileify_dirspec() - convert a directory spec into the name of the
2544 ** directory file (i.e. what you can stat() to see if it's a dir).
2545 ** The style (VMS or Unix) of the result is the same as the style
2546 ** of the parameter passed in.
2547 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2548 ** what you prepend to a filename to indicate what directory it's in).
2549 ** The style (VMS or Unix) of the result is the same as the style
2550 ** of the parameter passed in.
2551 ** tounixpath() - convert a directory spec into a Unix-style path.
2552 ** tovmspath() - convert a directory spec into a VMS-style path.
2553 ** tounixspec() - convert any file spec into a Unix-style file spec.
2554 ** tovmsspec() - convert any file spec into a VMS-style spec.
2556 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2557 ** Permission is given to distribute this code as part of the Perl
2558 ** standard distribution under the terms of the GNU General Public
2559 ** License or the Perl Artistic License. Copies of each may be
2560 ** found in the Perl standard distribution.
2563 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2564 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2566 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2567 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2568 char *retspec, *cp1, *cp2, *lastdir;
2569 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2571 if (!dir || !*dir) {
2572 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2574 dirlen = strlen(dir);
2575 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2576 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2577 strcpy(trndir,"/sys$disk/000000");
2581 if (dirlen > NAM$C_MAXRSS) {
2582 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2584 if (!strpbrk(dir+1,"/]>:")) {
2585 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2586 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2588 dirlen = strlen(dir);
2591 strncpy(trndir,dir,dirlen);
2592 trndir[dirlen] = '\0';
2595 /* If we were handed a rooted logical name or spec, treat it like a
2596 * simple directory, so that
2597 * $ Define myroot dev:[dir.]
2598 * ... do_fileify_dirspec("myroot",buf,1) ...
2599 * does something useful.
2601 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2602 dir[--dirlen] = '\0';
2603 dir[dirlen-1] = ']';
2606 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2607 /* If we've got an explicit filename, we can just shuffle the string. */
2608 if (*(cp1+1)) hasfilename = 1;
2609 /* Similarly, we can just back up a level if we've got multiple levels
2610 of explicit directories in a VMS spec which ends with directories. */
2612 for (cp2 = cp1; cp2 > dir; cp2--) {
2614 *cp2 = *cp1; *cp1 = '\0';
2618 if (*cp2 == '[' || *cp2 == '<') break;
2623 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2624 if (dir[0] == '.') {
2625 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2626 return do_fileify_dirspec("[]",buf,ts);
2627 else if (dir[1] == '.' &&
2628 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2629 return do_fileify_dirspec("[-]",buf,ts);
2631 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2632 dirlen -= 1; /* to last element */
2633 lastdir = strrchr(dir,'/');
2635 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2636 /* If we have "/." or "/..", VMSify it and let the VMS code
2637 * below expand it, rather than repeating the code to handle
2638 * relative components of a filespec here */
2640 if (*(cp1+2) == '.') cp1++;
2641 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2642 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2643 if (strchr(vmsdir,'/') != NULL) {
2644 /* If do_tovmsspec() returned it, it must have VMS syntax
2645 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2646 * the time to check this here only so we avoid a recursion
2647 * loop; otherwise, gigo.
2649 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2651 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2652 return do_tounixspec(trndir,buf,ts);
2655 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2656 lastdir = strrchr(dir,'/');
2658 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2659 /* Ditto for specs that end in an MFD -- let the VMS code
2660 * figure out whether it's a real device or a rooted logical. */
2661 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2662 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2663 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2664 return do_tounixspec(trndir,buf,ts);
2667 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2668 !(lastdir = cp1 = strrchr(dir,']')) &&
2669 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2670 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2672 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2673 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2674 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2675 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2676 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2677 (ver || *cp3)))))) {
2679 set_vaxc_errno(RMS$_DIR);
2685 /* If we lead off with a device or rooted logical, add the MFD
2686 if we're specifying a top-level directory. */
2687 if (lastdir && *dir == '/') {
2689 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2696 retlen = dirlen + (addmfd ? 13 : 6);
2697 if (buf) retspec = buf;
2698 else if (ts) New(1309,retspec,retlen+1,char);
2699 else retspec = __fileify_retbuf;
2701 dirlen = lastdir - dir;
2702 memcpy(retspec,dir,dirlen);
2703 strcpy(&retspec[dirlen],"/000000");
2704 strcpy(&retspec[dirlen+7],lastdir);
2707 memcpy(retspec,dir,dirlen);
2708 retspec[dirlen] = '\0';
2710 /* We've picked up everything up to the directory file name.
2711 Now just add the type and version, and we're set. */
2712 strcat(retspec,".dir;1");
2715 else { /* VMS-style directory spec */
2716 char esa[NAM$C_MAXRSS+1], term, *cp;
2717 unsigned long int sts, cmplen, haslower = 0;
2718 struct FAB dirfab = cc$rms_fab;
2719 struct NAM savnam, dirnam = cc$rms_nam;
2721 dirfab.fab$b_fns = strlen(dir);
2722 dirfab.fab$l_fna = dir;
2723 dirfab.fab$l_nam = &dirnam;
2724 dirfab.fab$l_dna = ".DIR;1";
2725 dirfab.fab$b_dns = 6;
2726 dirnam.nam$b_ess = NAM$C_MAXRSS;
2727 dirnam.nam$l_esa = esa;
2729 for (cp = dir; *cp; cp++)
2730 if (islower(*cp)) { haslower = 1; break; }
2731 if (!((sts = sys$parse(&dirfab))&1)) {
2732 if (dirfab.fab$l_sts == RMS$_DIR) {
2733 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2734 sts = sys$parse(&dirfab) & 1;
2738 set_vaxc_errno(dirfab.fab$l_sts);
2744 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2745 /* Yes; fake the fnb bits so we'll check type below */
2746 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2748 else { /* No; just work with potential name */
2749 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2751 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2752 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2753 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2758 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2759 cp1 = strchr(esa,']');
2760 if (!cp1) cp1 = strchr(esa,'>');
2761 if (cp1) { /* Should always be true */
2762 dirnam.nam$b_esl -= cp1 - esa - 1;
2763 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2766 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2767 /* Yep; check version while we're at it, if it's there. */
2768 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2769 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2770 /* Something other than .DIR[;1]. Bzzt. */
2771 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2772 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2774 set_vaxc_errno(RMS$_DIR);
2778 esa[dirnam.nam$b_esl] = '\0';
2779 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2780 /* They provided at least the name; we added the type, if necessary, */
2781 if (buf) retspec = buf; /* in sys$parse() */
2782 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2783 else retspec = __fileify_retbuf;
2784 strcpy(retspec,esa);
2785 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2786 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2789 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2790 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2792 dirnam.nam$b_esl -= 9;
2794 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2795 if (cp1 == NULL) { /* should never happen */
2796 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2797 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2802 retlen = strlen(esa);
2803 if ((cp1 = strrchr(esa,'.')) != NULL) {
2804 /* There's more than one directory in the path. Just roll back. */
2806 if (buf) retspec = buf;
2807 else if (ts) New(1311,retspec,retlen+7,char);
2808 else retspec = __fileify_retbuf;
2809 strcpy(retspec,esa);
2812 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2813 /* Go back and expand rooted logical name */
2814 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2815 if (!(sys$parse(&dirfab) & 1)) {
2816 dirnam.nam$l_rlf = NULL;
2817 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2819 set_vaxc_errno(dirfab.fab$l_sts);
2822 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2823 if (buf) retspec = buf;
2824 else if (ts) New(1312,retspec,retlen+16,char);
2825 else retspec = __fileify_retbuf;
2826 cp1 = strstr(esa,"][");
2828 memcpy(retspec,esa,dirlen);
2829 if (!strncmp(cp1+2,"000000]",7)) {
2830 retspec[dirlen-1] = '\0';
2831 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2832 if (*cp1 == '.') *cp1 = ']';
2834 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2835 memcpy(cp1+1,"000000]",7);
2839 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2840 retspec[retlen] = '\0';
2841 /* Convert last '.' to ']' */
2842 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2843 if (*cp1 == '.') *cp1 = ']';
2845 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2846 memcpy(cp1+1,"000000]",7);
2850 else { /* This is a top-level dir. Add the MFD to the path. */
2851 if (buf) retspec = buf;
2852 else if (ts) New(1312,retspec,retlen+16,char);
2853 else retspec = __fileify_retbuf;
2856 while (*cp1 != ':') *(cp2++) = *(cp1++);
2857 strcpy(cp2,":[000000]");
2862 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2863 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2864 /* We've set up the string up through the filename. Add the
2865 type and version, and we're done. */
2866 strcat(retspec,".DIR;1");
2868 /* $PARSE may have upcased filespec, so convert output to lower
2869 * case if input contained any lowercase characters. */
2870 if (haslower) __mystrtolower(retspec);
2873 } /* end of do_fileify_dirspec() */
2875 /* External entry points */
2876 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2877 { return do_fileify_dirspec(dir,buf,0); }
2878 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2879 { return do_fileify_dirspec(dir,buf,1); }
2881 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2882 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2884 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2885 unsigned long int retlen;
2886 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2888 if (!dir || !*dir) {
2889 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2892 if (*dir) strcpy(trndir,dir);
2893 else getcwd(trndir,sizeof trndir - 1);
2895 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2896 && my_trnlnm(trndir,trndir,0)) {
2897 STRLEN trnlen = strlen(trndir);
2899 /* Trap simple rooted lnms, and return lnm:[000000] */
2900 if (!strcmp(trndir+trnlen-2,".]")) {
2901 if (buf) retpath = buf;
2902 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2903 else retpath = __pathify_retbuf;
2904 strcpy(retpath,dir);
2905 strcat(retpath,":[000000]");
2911 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2912 if (*dir == '.' && (*(dir+1) == '\0' ||
2913 (*(dir+1) == '.' && *(dir+2) == '\0')))
2914 retlen = 2 + (*(dir+1) != '\0');
2916 if ( !(cp1 = strrchr(dir,'/')) &&
2917 !(cp1 = strrchr(dir,']')) &&
2918 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2919 if ((cp2 = strchr(cp1,'.')) != NULL &&
2920 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2921 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2922 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2923 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2925 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2926 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2927 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2928 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2929 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2930 (ver || *cp3)))))) {
2932 set_vaxc_errno(RMS$_DIR);
2935 retlen = cp2 - dir + 1;
2937 else { /* No file type present. Treat the filename as a directory. */
2938 retlen = strlen(dir) + 1;
2941 if (buf) retpath = buf;
2942 else if (ts) New(1313,retpath,retlen+1,char);
2943 else retpath = __pathify_retbuf;
2944 strncpy(retpath,dir,retlen-1);
2945 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2946 retpath[retlen-1] = '/'; /* with '/', add it. */
2947 retpath[retlen] = '\0';
2949 else retpath[retlen-1] = '\0';
2951 else { /* VMS-style directory spec */
2952 char esa[NAM$C_MAXRSS+1], *cp;
2953 unsigned long int sts, cmplen, haslower;
2954 struct FAB dirfab = cc$rms_fab;
2955 struct NAM savnam, dirnam = cc$rms_nam;
2957 /* If we've got an explicit filename, we can just shuffle the string. */
2958 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2959 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2960 if ((cp2 = strchr(cp1,'.')) != NULL) {
2962 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2963 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2964 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2965 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2966 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2967 (ver || *cp3)))))) {
2969 set_vaxc_errno(RMS$_DIR);
2973 else { /* No file type, so just draw name into directory part */
2974 for (cp2 = cp1; *cp2; cp2++) ;
2977 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
2979 /* We've now got a VMS 'path'; fall through */
2981 dirfab.fab$b_fns = strlen(dir);
2982 dirfab.fab$l_fna = dir;
2983 if (dir[dirfab.fab$b_fns-1] == ']' ||
2984 dir[dirfab.fab$b_fns-1] == '>' ||
2985 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
2986 if (buf) retpath = buf;
2987 else if (ts) New(1314,retpath,strlen(dir)+1,char);
2988 else retpath = __pathify_retbuf;
2989 strcpy(retpath,dir);
2992 dirfab.fab$l_dna = ".DIR;1";
2993 dirfab.fab$b_dns = 6;
2994 dirfab.fab$l_nam = &dirnam;
2995 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
2996 dirnam.nam$l_esa = esa;
2998 for (cp = dir; *cp; cp++)
2999 if (islower(*cp)) { haslower = 1; break; }
3001 if (!(sts = (sys$parse(&dirfab)&1))) {
3002 if (dirfab.fab$l_sts == RMS$_DIR) {
3003 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3004 sts = sys$parse(&dirfab) & 1;
3008 set_vaxc_errno(dirfab.fab$l_sts);
3014 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3015 if (dirfab.fab$l_sts != RMS$_FNF) {
3016 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3017 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3019 set_vaxc_errno(dirfab.fab$l_sts);
3022 dirnam = savnam; /* No; just work with potential name */
3025 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3026 /* Yep; check version while we're at it, if it's there. */
3027 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3028 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3029 /* Something other than .DIR[;1]. Bzzt. */
3030 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3031 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3033 set_vaxc_errno(RMS$_DIR);
3037 /* OK, the type was fine. Now pull any file name into the
3039 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3041 cp1 = strrchr(esa,'>');
3042 *dirnam.nam$l_type = '>';
3045 *(dirnam.nam$l_type + 1) = '\0';
3046 retlen = dirnam.nam$l_type - esa + 2;
3047 if (buf) retpath = buf;
3048 else if (ts) New(1314,retpath,retlen,char);
3049 else retpath = __pathify_retbuf;
3050 strcpy(retpath,esa);
3051 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3052 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3053 /* $PARSE may have upcased filespec, so convert output to lower
3054 * case if input contained any lowercase characters. */
3055 if (haslower) __mystrtolower(retpath);
3059 } /* end of do_pathify_dirspec() */
3061 /* External entry points */
3062 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3063 { return do_pathify_dirspec(dir,buf,0); }
3064 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3065 { return do_pathify_dirspec(dir,buf,1); }
3067 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3068 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3070 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3071 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3072 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3074 if (spec == NULL) return NULL;
3075 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3076 if (buf) rslt = buf;
3078 retlen = strlen(spec);
3079 cp1 = strchr(spec,'[');
3080 if (!cp1) cp1 = strchr(spec,'<');
3082 for (cp1++; *cp1; cp1++) {
3083 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3084 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3085 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3088 New(1315,rslt,retlen+2+2*expand,char);
3090 else rslt = __tounixspec_retbuf;
3091 if (strchr(spec,'/') != NULL) {
3098 dirend = strrchr(spec,']');
3099 if (dirend == NULL) dirend = strrchr(spec,'>');
3100 if (dirend == NULL) dirend = strchr(spec,':');
3101 if (dirend == NULL) {
3105 if (*cp2 != '[' && *cp2 != '<') {
3108 else { /* the VMS spec begins with directories */
3110 if (*cp2 == ']' || *cp2 == '>') {
3111 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3114 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3115 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3116 if (ts) Safefree(rslt);
3121 while (*cp3 != ':' && *cp3) cp3++;
3123 if (strchr(cp3,']') != NULL) break;
3124 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3126 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3127 retlen = devlen + dirlen;
3128 Renew(rslt,retlen+1+2*expand,char);
3134 *(cp1++) = *(cp3++);
3135 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3139 else if ( *cp2 == '.') {
3140 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3141 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3147 for (; cp2 <= dirend; cp2++) {
3150 if (*(cp2+1) == '[') cp2++;
3152 else if (*cp2 == ']' || *cp2 == '>') {
3153 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3155 else if (*cp2 == '.') {
3157 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3158 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3159 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3160 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3161 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3163 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3164 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3168 else if (*cp2 == '-') {
3169 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3170 while (*cp2 == '-') {
3172 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3174 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3175 if (ts) Safefree(rslt); /* filespecs like */
3176 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3180 else *(cp1++) = *cp2;
3182 else *(cp1++) = *cp2;
3184 while (*cp2) *(cp1++) = *(cp2++);
3189 } /* end of do_tounixspec() */
3191 /* External entry points */
3192 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3193 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3195 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3196 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3197 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3198 char *rslt, *dirend;
3199 register char *cp1, *cp2;
3200 unsigned long int infront = 0, hasdir = 1;
3202 if (path == NULL) return NULL;
3203 if (buf) rslt = buf;
3204 else if (ts) New(1316,rslt,strlen(path)+9,char);
3205 else rslt = __tovmsspec_retbuf;
3206 if (strpbrk(path,"]:>") ||
3207 (dirend = strrchr(path,'/')) == NULL) {
3208 if (path[0] == '.') {
3209 if (path[1] == '\0') strcpy(rslt,"[]");
3210 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3211 else strcpy(rslt,path); /* probably garbage */
3213 else strcpy(rslt,path);
3216 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3217 if (!*(dirend+2)) dirend +=2;
3218 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3219 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3224 char trndev[NAM$C_MAXRSS+1];
3228 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3230 if (!buf & ts) Renew(rslt,18,char);
3231 strcpy(rslt,"sys$disk:[000000]");
3234 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3236 islnm = my_trnlnm(rslt,trndev,0);
3237 trnend = islnm ? strlen(trndev) - 1 : 0;
3238 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3239 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3240 /* If the first element of the path is a logical name, determine
3241 * whether it has to be translated so we can add more directories. */
3242 if (!islnm || rooted) {
3245 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3249 if (cp2 != dirend) {
3250 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3251 strcpy(rslt,trndev);
3252 cp1 = rslt + trnend;
3265 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3266 cp2 += 2; /* skip over "./" - it's redundant */
3267 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3269 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3270 *(cp1++) = '-'; /* "../" --> "-" */
3273 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3274 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3275 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3276 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3279 if (cp2 > dirend) cp2 = dirend;
3281 else *(cp1++) = '.';
3283 for (; cp2 < dirend; cp2++) {
3285 if (*(cp2-1) == '/') continue;
3286 if (*(cp1-1) != '.') *(cp1++) = '.';
3289 else if (!infront && *cp2 == '.') {
3290 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3291 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3292 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3293 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3294 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3295 else { /* back up over previous directory name */
3297 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3298 if (*(cp1-1) == '[') {
3299 memcpy(cp1,"000000.",7);
3304 if (cp2 == dirend) break;
3306 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3307 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3308 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3309 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3311 *(cp1++) = '.'; /* Simulate trailing '/' */
3312 cp2 += 2; /* for loop will incr this to == dirend */
3314 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3316 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3319 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3320 if (*cp2 == '.') *(cp1++) = '_';
3321 else *(cp1++) = *cp2;
3325 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3326 if (hasdir) *(cp1++) = ']';
3327 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3328 while (*cp2) *(cp1++) = *(cp2++);
3333 } /* end of do_tovmsspec() */
3335 /* External entry points */
3336 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3337 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3339 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3340 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3341 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3343 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3345 if (path == NULL) return NULL;
3346 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3347 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3348 if (buf) return buf;
3350 vmslen = strlen(vmsified);
3351 New(1317,cp,vmslen+1,char);
3352 memcpy(cp,vmsified,vmslen);
3357 strcpy(__tovmspath_retbuf,vmsified);
3358 return __tovmspath_retbuf;
3361 } /* end of do_tovmspath() */
3363 /* External entry points */
3364 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3365 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3368 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3369 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3370 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3372 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3374 if (path == NULL) return NULL;
3375 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3376 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3377 if (buf) return buf;
3379 unixlen = strlen(unixified);
3380 New(1317,cp,unixlen+1,char);
3381 memcpy(cp,unixified,unixlen);
3386 strcpy(__tounixpath_retbuf,unixified);
3387 return __tounixpath_retbuf;
3390 } /* end of do_tounixpath() */
3392 /* External entry points */
3393 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3394 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3397 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3399 *****************************************************************************
3401 * Copyright (C) 1989-1994 by *
3402 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3404 * Permission is hereby granted for the reproduction of this software, *
3405 * on condition that this copyright notice is included in the reproduction, *
3406 * and that such reproduction is not for purposes of profit or material *
3409 * 27-Aug-1994 Modified for inclusion in perl5 *
3410 * by Charles Bailey bailey@newman.upenn.edu *
3411 *****************************************************************************
3415 * getredirection() is intended to aid in porting C programs
3416 * to VMS (Vax-11 C). The native VMS environment does not support
3417 * '>' and '<' I/O redirection, or command line wild card expansion,
3418 * or a command line pipe mechanism using the '|' AND background
3419 * command execution '&'. All of these capabilities are provided to any
3420 * C program which calls this procedure as the first thing in the
3422 * The piping mechanism will probably work with almost any 'filter' type
3423 * of program. With suitable modification, it may useful for other
3424 * portability problems as well.
3426 * Author: Mark Pizzolato mark@infocomm.com
3430 struct list_item *next;
3434 static void add_item(struct list_item **head,
3435 struct list_item **tail,
3439 static void mp_expand_wild_cards(pTHX_ char *item,
3440 struct list_item **head,
3441 struct list_item **tail,
3444 static int background_process(int argc, char **argv);
3446 static void pipe_and_fork(pTHX_ char **cmargv);
3448 /*{{{ void getredirection(int *ac, char ***av)*/
3450 mp_getredirection(pTHX_ int *ac, char ***av)
3452 * Process vms redirection arg's. Exit if any error is seen.
3453 * If getredirection() processes an argument, it is erased
3454 * from the vector. getredirection() returns a new argc and argv value.
3455 * In the event that a background command is requested (by a trailing "&"),
3456 * this routine creates a background subprocess, and simply exits the program.
3458 * Warning: do not try to simplify the code for vms. The code
3459 * presupposes that getredirection() is called before any data is
3460 * read from stdin or written to stdout.
3462 * Normal usage is as follows:
3468 * getredirection(&argc, &argv);
3472 int argc = *ac; /* Argument Count */
3473 char **argv = *av; /* Argument Vector */
3474 char *ap; /* Argument pointer */
3475 int j; /* argv[] index */
3476 int item_count = 0; /* Count of Items in List */
3477 struct list_item *list_head = 0; /* First Item in List */
3478 struct list_item *list_tail; /* Last Item in List */
3479 char *in = NULL; /* Input File Name */
3480 char *out = NULL; /* Output File Name */
3481 char *outmode = "w"; /* Mode to Open Output File */
3482 char *err = NULL; /* Error File Name */
3483 char *errmode = "w"; /* Mode to Open Error File */
3484 int cmargc = 0; /* Piped Command Arg Count */
3485 char **cmargv = NULL;/* Piped Command Arg Vector */
3488 * First handle the case where the last thing on the line ends with
3489 * a '&'. This indicates the desire for the command to be run in a
3490 * subprocess, so we satisfy that desire.
3493 if (0 == strcmp("&", ap))
3494 exit(background_process(--argc, argv));
3495 if (*ap && '&' == ap[strlen(ap)-1])
3497 ap[strlen(ap)-1] = '\0';
3498 exit(background_process(argc, argv));
3501 * Now we handle the general redirection cases that involve '>', '>>',
3502 * '<', and pipes '|'.
3504 for (j = 0; j < argc; ++j)
3506 if (0 == strcmp("<", argv[j]))
3510 PerlIO_printf(Perl_debug_log,"No input file after < on command line");
3511 exit(LIB$_WRONUMARG);
3516 if ('<' == *(ap = argv[j]))
3521 if (0 == strcmp(">", ap))
3525 PerlIO_printf(Perl_debug_log,"No output file after > on command line");
3526 exit(LIB$_WRONUMARG);
3545 PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
3546 exit(LIB$_WRONUMARG);
3550 if (('2' == *ap) && ('>' == ap[1]))
3567 PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
3568 exit(LIB$_WRONUMARG);
3572 if (0 == strcmp("|", argv[j]))
3576 PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
3577 exit(LIB$_WRONUMARG);
3579 cmargc = argc-(j+1);
3580 cmargv = &argv[j+1];
3584 if ('|' == *(ap = argv[j]))
3592 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3595 * Allocate and fill in the new argument vector, Some Unix's terminate
3596 * the list with an extra null pointer.
3598 New(1302, argv, item_count+1, char *);
3600 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3601 argv[j] = list_head->value;
3607 PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
3608 exit(LIB$_INVARGORD);
3610 pipe_and_fork(aTHX_ cmargv);
3613 /* Check for input from a pipe (mailbox) */
3615 if (in == NULL && 1 == isapipe(0))
3617 char mbxname[L_tmpnam];
3619 long int dvi_item = DVI$_DEVBUFSIZ;
3620 $DESCRIPTOR(mbxnam, "");
3621 $DESCRIPTOR(mbxdevnam, "");
3623 /* Input from a pipe, reopen it in binary mode to disable */
3624 /* carriage control processing. */
3626 fgetname(stdin, mbxname);
3627 mbxnam.dsc$a_pointer = mbxname;
3628 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3629 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3630 mbxdevnam.dsc$a_pointer = mbxname;
3631 mbxdevnam.dsc$w_length = sizeof(mbxname);
3632 dvi_item = DVI$_DEVNAM;
3633 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3634 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3637 freopen(mbxname, "rb", stdin);
3640 PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3644 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3646 PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
3649 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3651 PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
3654 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3657 if (strcmp(err,"&1") == 0) {
3658 dup2(fileno(stdout), fileno(stderr));
3659 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3662 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3664 PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
3668 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3672 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3675 #ifdef ARGPROC_DEBUG
3676 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3677 for (j = 0; j < *ac; ++j)
3678 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3680 /* Clear errors we may have hit expanding wildcards, so they don't
3681 show up in Perl's $! later */
3682 set_errno(0); set_vaxc_errno(1);
3683 } /* end of getredirection() */
3686 static void add_item(struct list_item **head,
3687 struct list_item **tail,
3693 New(1303,*head,1,struct list_item);
3697 New(1304,(*tail)->next,1,struct list_item);
3698 *tail = (*tail)->next;
3700 (*tail)->value = value;
3704 static void mp_expand_wild_cards(pTHX_ char *item,
3705 struct list_item **head,
3706 struct list_item **tail,
3710 unsigned long int context = 0;
3716 char vmsspec[NAM$C_MAXRSS+1];
3717 $DESCRIPTOR(filespec, "");
3718 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3719 $DESCRIPTOR(resultspec, "");
3720 unsigned long int zero = 0, sts;
3722 for (cp = item; *cp; cp++) {
3723 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3724 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3726 if (!*cp || isspace(*cp))
3728 add_item(head, tail, item, count);
3731 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3732 resultspec.dsc$b_class = DSC$K_CLASS_D;
3733 resultspec.dsc$a_pointer = NULL;
3734 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3735 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3736 if (!isunix || !filespec.dsc$a_pointer)
3737 filespec.dsc$a_pointer = item;
3738 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3740 * Only return version specs, if the caller specified a version
3742 had_version = strchr(item, ';');
3744 * Only return device and directory specs, if the caller specifed either.
3746 had_device = strchr(item, ':');
3747 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3749 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3750 &defaultspec, 0, 0, &zero))))
3755 New(1305,string,resultspec.dsc$w_length+1,char);
3756 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3757 string[resultspec.dsc$w_length] = '\0';
3758 if (NULL == had_version)
3759 *((char *)strrchr(string, ';')) = '\0';
3760 if ((!had_directory) && (had_device == NULL))
3762 if (NULL == (devdir = strrchr(string, ']')))
3763 devdir = strrchr(string, '>');
3764 strcpy(string, devdir + 1);
3767 * Be consistent with what the C RTL has already done to the rest of
3768 * the argv items and lowercase all of these names.
3770 for (c = string; *c; ++c)
3773 if (isunix) trim_unixpath(string,item,1);
3774 add_item(head, tail, string, count);
3777 if (sts != RMS$_NMF)
3779 set_vaxc_errno(sts);
3782 case RMS$_FNF: case RMS$_DNF:
3783 set_errno(ENOENT); break;
3785 set_errno(ENOTDIR); break;
3787 set_errno(ENODEV); break;
3788 case RMS$_FNM: case RMS$_SYN:
3789 set_errno(EINVAL); break;
3791 set_errno(EACCES); break;
3793 _ckvmssts_noperl(sts);
3797 add_item(head, tail, item, count);
3798 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3799 _ckvmssts_noperl(lib$find_file_end(&context));
3802 static int child_st[2];/* Event Flag set when child process completes */
3804 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3806 static unsigned long int exit_handler(int *status)
3810 if (0 == child_st[0])
3812 #ifdef ARGPROC_DEBUG
3813 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3815 fflush(stdout); /* Have to flush pipe for binary data to */
3816 /* terminate properly -- <tp@mccall.com> */
3817 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3818 sys$dassgn(child_chan);
3820 sys$synch(0, child_st);
3825 static void sig_child(int chan)
3827 #ifdef ARGPROC_DEBUG
3828 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3830 if (child_st[0] == 0)
3834 static struct exit_control_block exit_block =
3839 &exit_block.exit_status,
3843 static void pipe_and_fork(pTHX_ char **cmargv)
3846 $DESCRIPTOR(cmddsc, "");
3847 static char mbxname[64];
3848 $DESCRIPTOR(mbxdsc, mbxname);
3850 unsigned long int zero = 0, one = 1;
3852 strcpy(subcmd, cmargv[0]);
3853 for (j = 1; NULL != cmargv[j]; ++j)
3855 strcat(subcmd, " \"");
3856 strcat(subcmd, cmargv[j]);
3857 strcat(subcmd, "\"");
3859 cmddsc.dsc$a_pointer = subcmd;
3860 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3862 create_mbx(aTHX_ &child_chan,&mbxdsc);
3863 #ifdef ARGPROC_DEBUG
3864 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3865 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3867 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3868 0, &pid, child_st, &zero, sig_child,
3870 #ifdef ARGPROC_DEBUG
3871 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3873 sys$dclexh(&exit_block);
3874 if (NULL == freopen(mbxname, "wb", stdout))
3876 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3880 static int background_process(int argc, char **argv)
3882 char command[2048] = "$";
3883 $DESCRIPTOR(value, "");
3884 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3885 static $DESCRIPTOR(null, "NLA0:");
3886 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3888 $DESCRIPTOR(pidstr, "");
3890 unsigned long int flags = 17, one = 1, retsts;
3892 strcat(command, argv[0]);
3895 strcat(command, " \"");
3896 strcat(command, *(++argv));
3897 strcat(command, "\"");
3899 value.dsc$a_pointer = command;
3900 value.dsc$w_length = strlen(value.dsc$a_pointer);
3901 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3902 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3903 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3904 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3907 _ckvmssts_noperl(retsts);
3909 #ifdef ARGPROC_DEBUG
3910 PerlIO_printf(Perl_debug_log, "%s\n", command);
3912 sprintf(pidstring, "%08X", pid);
3913 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3914 pidstr.dsc$a_pointer = pidstring;
3915 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3916 lib$set_symbol(&pidsymbol, &pidstr);
3920 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3923 /* OS-specific initialization at image activation (not thread startup) */
3924 /* Older VAXC header files lack these constants */
3925 #ifndef JPI$_RIGHTS_SIZE
3926 # define JPI$_RIGHTS_SIZE 817
3928 #ifndef KGB$M_SUBSYSTEM
3929 # define KGB$M_SUBSYSTEM 0x8
3932 /*{{{void vms_image_init(int *, char ***)*/
3934 vms_image_init(int *argcp, char ***argvp)
3936 char eqv[LNM$C_NAMLENGTH+1] = "";
3937 unsigned int len, tabct = 8, tabidx = 0;
3938 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3939 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3940 unsigned short int dummy, rlen;
3941 struct dsc$descriptor_s **tabvec;
3942 #if defined(PERL_IMPLICIT_CONTEXT)
3945 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3946 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3947 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3950 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3951 _ckvmssts_noperl(iosb[0]);
3952 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3953 if (iprv[i]) { /* Running image installed with privs? */
3954 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3959 /* Rights identifiers might trigger tainting as well. */
3960 if (!will_taint && (rlen || rsz)) {
3961 while (rlen < rsz) {
3962 /* We didn't get all the identifiers on the first pass. Allocate a
3963 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3964 * were needed to hold all identifiers at time of last call; we'll
3965 * allocate that many unsigned long ints), and go back and get 'em.
3966 * If it gave us less than it wanted to despite ample buffer space,
3967 * something's broken. Is your system missing a system identifier?
3969 if (rsz <= jpilist[1].buflen) {
3970 /* Perl_croak accvios when used this early in startup. */
3971 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3972 rsz, (unsigned long) jpilist[1].buflen,
3973 "Check your rights database for corruption.\n");
3976 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3977 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3978 jpilist[1].buflen = rsz * sizeof(unsigned long int);
3979 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
3980 _ckvmssts_noperl(iosb[0]);
3982 mask = jpilist[1].bufadr;
3983 /* Check attribute flags for each identifier (2nd longword); protected
3984 * subsystem identifiers trigger tainting.
3986 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
3987 if (mask[i] & KGB$M_SUBSYSTEM) {
3992 if (mask != rlst) Safefree(mask);
3994 /* We need to use this hack to tell Perl it should run with tainting,
3995 * since its tainting flag may be part of the PL_curinterp struct, which
3996 * hasn't been allocated when vms_image_init() is called.
4000 New(1320,newap,*argcp+2,char **);
4001 newap[0] = argvp[0];
4003 Copy(argvp[1],newap[2],*argcp-1,char **);
4004 /* We orphan the old argv, since we don't know where it's come from,
4005 * so we don't know how to free it.
4007 *argcp++; argvp = newap;
4009 else { /* Did user explicitly request tainting? */
4011 char *cp, **av = *argvp;
4012 for (i = 1; i < *argcp; i++) {
4013 if (*av[i] != '-') break;
4014 for (cp = av[i]+1; *cp; cp++) {
4015 if (*cp == 'T') { will_taint = 1; break; }
4016 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4017 strchr("DFIiMmx",*cp)) break;
4019 if (will_taint) break;
4024 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4026 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4027 else if (tabidx >= tabct) {
4029 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4031 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4032 tabvec[tabidx]->dsc$w_length = 0;
4033 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4034 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4035 tabvec[tabidx]->dsc$a_pointer = NULL;
4036 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4038 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4040 getredirection(argcp,argvp);
4041 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4043 # include <reentrancy.h>
4044 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4053 * Trim Unix-style prefix off filespec, so it looks like what a shell
4054 * glob expansion would return (i.e. from specified prefix on, not
4055 * full path). Note that returned filespec is Unix-style, regardless
4056 * of whether input filespec was VMS-style or Unix-style.
4058 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4059 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4060 * vector of options; at present, only bit 0 is used, and if set tells
4061 * trim unixpath to try the current default directory as a prefix when
4062 * presented with a possibly ambiguous ... wildcard.
4064 * Returns !=0 on success, with trimmed filespec replacing contents of
4065 * fspec, and 0 on failure, with contents of fpsec unchanged.
4067 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4069 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4071 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4072 *template, *base, *end, *cp1, *cp2;
4073 register int tmplen, reslen = 0, dirs = 0;
4075 if (!wildspec || !fspec) return 0;
4076 if (strpbrk(wildspec,"]>:") != NULL) {
4077 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4078 else template = unixwild;
4080 else template = wildspec;
4081 if (strpbrk(fspec,"]>:") != NULL) {
4082 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4083 else base = unixified;
4084 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4085 * check to see that final result fits into (isn't longer than) fspec */
4086 reslen = strlen(fspec);
4090 /* No prefix or absolute path on wildcard, so nothing to remove */
4091 if (!*template || *template == '/') {
4092 if (base == fspec) return 1;
4093 tmplen = strlen(unixified);
4094 if (tmplen > reslen) return 0; /* not enough space */
4095 /* Copy unixified resultant, including trailing NUL */
4096 memmove(fspec,unixified,tmplen+1);
4100 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4101 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4102 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4103 for (cp1 = end ;cp1 >= base; cp1--)
4104 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4106 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4110 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4111 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4112 int ells = 1, totells, segdirs, match;
4113 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4114 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4116 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4118 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4119 if (ellipsis == template && opts & 1) {
4120 /* Template begins with an ellipsis. Since we can't tell how many
4121 * directory names at the front of the resultant to keep for an
4122 * arbitrary starting point, we arbitrarily choose the current
4123 * default directory as a starting point. If it's there as a prefix,
4124 * clip it off. If not, fall through and act as if the leading
4125 * ellipsis weren't there (i.e. return shortest possible path that
4126 * could match template).
4128 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4129 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4130 if (_tolower(*cp1) != _tolower(*cp2)) break;
4131 segdirs = dirs - totells; /* Min # of dirs we must have left */
4132 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4133 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4134 memcpy(fspec,cp2+1,end - cp2);
4138 /* First off, back up over constant elements at end of path */
4140 for (front = end ; front >= base; front--)
4141 if (*front == '/' && !dirs--) { front++; break; }
4143 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4144 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4145 if (cp1 != '\0') return 0; /* Path too long. */
4147 *cp2 = '\0'; /* Pick up with memcpy later */
4148 lcfront = lcres + (front - base);
4149 /* Now skip over each ellipsis and try to match the path in front of it. */
4151 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4152 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4153 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4154 if (cp1 < template) break; /* template started with an ellipsis */
4155 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4156 ellipsis = cp1; continue;
4158 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4160 for (segdirs = 0, cp2 = tpl;
4161 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4163 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4164 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4165 if (*cp2 == '/') segdirs++;
4167 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4168 /* Back up at least as many dirs as in template before matching */
4169 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4170 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4171 for (match = 0; cp1 > lcres;) {
4172 resdsc.dsc$a_pointer = cp1;
4173 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4175 if (match == 1) lcfront = cp1;
4177 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4179 if (!match) return 0; /* Can't find prefix ??? */
4180 if (match > 1 && opts & 1) {
4181 /* This ... wildcard could cover more than one set of dirs (i.e.
4182 * a set of similar dir names is repeated). If the template
4183 * contains more than 1 ..., upstream elements could resolve the
4184 * ambiguity, but it's not worth a full backtracking setup here.
4185 * As a quick heuristic, clip off the current default directory
4186 * if it's present to find the trimmed spec, else use the
4187 * shortest string that this ... could cover.
4189 char def[NAM$C_MAXRSS+1], *st;
4191 if (getcwd(def, sizeof def,0) == NULL) return 0;
4192 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4193 if (_tolower(*cp1) != _tolower(*cp2)) break;
4194 segdirs = dirs - totells; /* Min # of dirs we must have left */
4195 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4196 if (*cp1 == '\0' && *cp2 == '/') {
4197 memcpy(fspec,cp2+1,end - cp2);
4200 /* Nope -- stick with lcfront from above and keep going. */
4203 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4208 } /* end of trim_unixpath() */
4213 * VMS readdir() routines.
4214 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4216 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4217 * Minor modifications to original routines.
4220 /* Number of elements in vms_versions array */
4221 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4224 * Open a directory, return a handle for later use.
4226 /*{{{ DIR *opendir(char*name) */
4228 Perl_opendir(pTHX_ char *name)
4231 char dir[NAM$C_MAXRSS+1];
4234 if (do_tovmspath(name,dir,0) == NULL) {
4237 if (flex_stat(dir,&sb) == -1) return NULL;
4238 if (!S_ISDIR(sb.st_mode)) {
4239 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4242 if (!cando_by_name(S_IRUSR,0,dir)) {
4243 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4246 /* Get memory for the handle, and the pattern. */
4248 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4250 /* Fill in the fields; mainly playing with the descriptor. */
4251 (void)sprintf(dd->pattern, "%s*.*",dir);
4254 dd->vms_wantversions = 0;
4255 dd->pat.dsc$a_pointer = dd->pattern;
4256 dd->pat.dsc$w_length = strlen(dd->pattern);
4257 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4258 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4261 } /* end of opendir() */
4265 * Set the flag to indicate we want versions or not.
4267 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4269 vmsreaddirversions(DIR *dd, int flag)
4271 dd->vms_wantversions = flag;
4276 * Free up an opened directory.
4278 /*{{{ void closedir(DIR *dd)*/
4282 (void)lib$find_file_end(&dd->context);
4283 Safefree(dd->pattern);
4284 Safefree((char *)dd);
4289 * Collect all the version numbers for the current file.
4292 collectversions(pTHX_ DIR *dd)
4294 struct dsc$descriptor_s pat;
4295 struct dsc$descriptor_s res;
4297 char *p, *text, buff[sizeof dd->entry.d_name];
4299 unsigned long context, tmpsts;
4301 /* Convenient shorthand. */
4304 /* Add the version wildcard, ignoring the "*.*" put on before */
4305 i = strlen(dd->pattern);
4306 New(1308,text,i + e->d_namlen + 3,char);
4307 (void)strcpy(text, dd->pattern);
4308 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4310 /* Set up the pattern descriptor. */
4311 pat.dsc$a_pointer = text;
4312 pat.dsc$w_length = i + e->d_namlen - 1;
4313 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4314 pat.dsc$b_class = DSC$K_CLASS_S;
4316 /* Set up result descriptor. */
4317 res.dsc$a_pointer = buff;
4318 res.dsc$w_length = sizeof buff - 2;
4319 res.dsc$b_dtype = DSC$K_DTYPE_T;
4320 res.dsc$b_class = DSC$K_CLASS_S;
4322 /* Read files, collecting versions. */
4323 for (context = 0, e->vms_verscount = 0;
4324 e->vms_verscount < VERSIZE(e);
4325 e->vms_verscount++) {
4326 tmpsts = lib$find_file(&pat, &res, &context);
4327 if (tmpsts == RMS$_NMF || context == 0) break;
4329 buff[sizeof buff - 1] = '\0';
4330 if ((p = strchr(buff, ';')))
4331 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4333 e->vms_versions[e->vms_verscount] = -1;
4336 _ckvmssts(lib$find_file_end(&context));
4339 } /* end of collectversions() */
4342 * Read the next entry from the directory.
4344 /*{{{ struct dirent *readdir(DIR *dd)*/
4346 Perl_readdir(pTHX_ DIR *dd)
4348 struct dsc$descriptor_s res;
4349 char *p, buff[sizeof dd->entry.d_name];
4350 unsigned long int tmpsts;
4352 /* Set up result descriptor, and get next file. */
4353 res.dsc$a_pointer = buff;
4354 res.dsc$w_length = sizeof buff - 2;
4355 res.dsc$b_dtype = DSC$K_DTYPE_T;
4356 res.dsc$b_class = DSC$K_CLASS_S;
4357 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4358 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4359 if (!(tmpsts & 1)) {
4360 set_vaxc_errno(tmpsts);
4363 set_errno(EACCES); break;
4365 set_errno(ENODEV); break;
4367 set_errno(ENOTDIR); break;
4368 case RMS$_FNF: case RMS$_DNF:
4369 set_errno(ENOENT); break;
4376 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4377 buff[sizeof buff - 1] = '\0';
4378 for (p = buff; *p; p++) *p = _tolower(*p);
4379 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4382 /* Skip any directory component and just copy the name. */
4383 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4384 else (void)strcpy(dd->entry.d_name, buff);
4386 /* Clobber the version. */
4387 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4389 dd->entry.d_namlen = strlen(dd->entry.d_name);
4390 dd->entry.vms_verscount = 0;
4391 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4394 } /* end of readdir() */
4398 * Return something that can be used in a seekdir later.
4400 /*{{{ long telldir(DIR *dd)*/
4409 * Return to a spot where we used to be. Brute force.
4411 /*{{{ void seekdir(DIR *dd,long count)*/
4413 Perl_seekdir(pTHX_ DIR *dd, long count)
4415 int vms_wantversions;
4417 /* If we haven't done anything yet... */
4421 /* Remember some state, and clear it. */
4422 vms_wantversions = dd->vms_wantversions;
4423 dd->vms_wantversions = 0;
4424 _ckvmssts(lib$find_file_end(&dd->context));
4427 /* The increment is in readdir(). */
4428 for (dd->count = 0; dd->count < count; )
4431 dd->vms_wantversions = vms_wantversions;
4433 } /* end of seekdir() */
4436 /* VMS subprocess management
4438 * my_vfork() - just a vfork(), after setting a flag to record that
4439 * the current script is trying a Unix-style fork/exec.
4441 * vms_do_aexec() and vms_do_exec() are called in response to the
4442 * perl 'exec' function. If this follows a vfork call, then they
4443 * call out the the regular perl routines in doio.c which do an
4444 * execvp (for those who really want to try this under VMS).
4445 * Otherwise, they do exactly what the perl docs say exec should
4446 * do - terminate the current script and invoke a new command
4447 * (See below for notes on command syntax.)
4449 * do_aspawn() and do_spawn() implement the VMS side of the perl
4450 * 'system' function.
4452 * Note on command arguments to perl 'exec' and 'system': When handled
4453 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4454 * are concatenated to form a DCL command string. If the first arg
4455 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4456 * the the command string is handed off to DCL directly. Otherwise,
4457 * the first token of the command is taken as the filespec of an image
4458 * to run. The filespec is expanded using a default type of '.EXE' and
4459 * the process defaults for device, directory, etc., and if found, the resultant
4460 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4461 * the command string as parameters. This is perhaps a bit complicated,
4462 * but I hope it will form a happy medium between what VMS folks expect
4463 * from lib$spawn and what Unix folks expect from exec.
4466 static int vfork_called;
4468 /*{{{int my_vfork()*/
4479 vms_execfree(pTHX) {
4481 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4484 if (VMScmd.dsc$a_pointer) {
4485 Safefree(VMScmd.dsc$a_pointer);
4486 VMScmd.dsc$w_length = 0;
4487 VMScmd.dsc$a_pointer = Nullch;
4492 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4494 char *junk, *tmps = Nullch;
4495 register size_t cmdlen = 0;
4502 tmps = SvPV(really,rlen);
4509 for (idx++; idx <= sp; idx++) {
4511 junk = SvPVx(*idx,rlen);
4512 cmdlen += rlen ? rlen + 1 : 0;
4515 New(401,PL_Cmd,cmdlen+1,char);
4517 if (tmps && *tmps) {
4518 strcpy(PL_Cmd,tmps);
4521 else *PL_Cmd = '\0';
4522 while (++mark <= sp) {
4524 char *s = SvPVx(*mark,n_a);
4526 if (*PL_Cmd) strcat(PL_Cmd," ");
4532 } /* end of setup_argstr() */
4535 static unsigned long int
4536 setup_cmddsc(pTHX_ char *cmd, int check_img)
4538 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4539 $DESCRIPTOR(defdsc,".EXE");
4540 $DESCRIPTOR(defdsc2,".");
4541 $DESCRIPTOR(resdsc,resspec);
4542 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4543 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4544 register char *s, *rest, *cp, *wordbreak;
4548 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4551 while (*s && isspace(*s)) s++;
4553 if (*s == '@' || *s == '$') {
4554 vmsspec[0] = *s; rest = s + 1;
4555 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4557 else { cp = vmsspec; rest = s; }
4558 if (*rest == '.' || *rest == '/') {
4561 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4562 rest++, cp2++) *cp2 = *rest;
4564 if (do_tovmsspec(resspec,cp,0)) {
4567 for (cp2 = vmsspec + strlen(vmsspec);
4568 *rest && cp2 - vmsspec < sizeof vmsspec;
4569 rest++, cp2++) *cp2 = *rest;
4574 /* Intuit whether verb (first word of cmd) is a DCL command:
4575 * - if first nonspace char is '@', it's a DCL indirection
4577 * - if verb contains a filespec separator, it's not a DCL command
4578 * - if it doesn't, caller tells us whether to default to a DCL
4579 * command, or to a local image unless told it's DCL (by leading '$')
4581 if (*s == '@') isdcl = 1;
4583 register char *filespec = strpbrk(s,":<[.;");
4584 rest = wordbreak = strpbrk(s," \"\t/");
4585 if (!wordbreak) wordbreak = s + strlen(s);
4586 if (*s == '$') check_img = 0;
4587 if (filespec && (filespec < wordbreak)) isdcl = 0;
4588 else isdcl = !check_img;
4592 imgdsc.dsc$a_pointer = s;
4593 imgdsc.dsc$w_length = wordbreak - s;
4594 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4596 _ckvmssts(lib$find_file_end(&cxt));
4597 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4598 if (!(retsts & 1) && *s == '$') {
4599 _ckvmssts(lib$find_file_end(&cxt));
4600 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4601 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4603 _ckvmssts(lib$find_file_end(&cxt));
4604 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4608 _ckvmssts(lib$find_file_end(&cxt));
4613 while (*s && !isspace(*s)) s++;
4616 /* check that it's really not DCL with no file extension */
4617 fp = fopen(resspec,"r","ctx=bin,shr=get");
4619 char b[4] = {0,0,0,0};
4620 read(fileno(fp),b,4);
4621 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4624 if (check_img && isdcl) return RMS$_FNF;
4626 if (cando_by_name(S_IXUSR,0,resspec)) {
4627 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4629 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4631 strcpy(VMScmd.dsc$a_pointer,"@");
4633 strcat(VMScmd.dsc$a_pointer,resspec);
4634 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4635 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4638 else retsts = RMS$_PRV;
4641 /* It's either a DCL command or we couldn't find a suitable image */
4642 VMScmd.dsc$w_length = strlen(cmd);
4643 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4644 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4645 if (!(retsts & 1)) {
4646 /* just hand off status values likely to be due to user error */
4647 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4648 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4649 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4650 else { _ckvmssts(retsts); }
4653 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4655 } /* end of setup_cmddsc() */
4658 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4660 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4663 if (vfork_called) { /* this follows a vfork - act Unixish */
4665 if (vfork_called < 0) {
4666 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4669 else return do_aexec(really,mark,sp);
4671 /* no vfork - act VMSish */
4672 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4677 } /* end of vms_do_aexec() */
4680 /* {{{bool vms_do_exec(char *cmd) */
4682 Perl_vms_do_exec(pTHX_ char *cmd)
4685 if (vfork_called) { /* this follows a vfork - act Unixish */
4687 if (vfork_called < 0) {
4688 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4691 else return do_exec(cmd);
4694 { /* no vfork - act VMSish */
4695 unsigned long int retsts;
4698 TAINT_PROPER("exec");
4699 if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4700 retsts = lib$do_command(&VMScmd);
4703 case RMS$_FNF: case RMS$_DNF:
4704 set_errno(ENOENT); break;
4706 set_errno(ENOTDIR); break;
4708 set_errno(ENODEV); break;
4710 set_errno(EACCES); break;
4712 set_errno(EINVAL); break;
4714 set_errno(E2BIG); break;
4715 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4716 _ckvmssts(retsts); /* fall through */
4717 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4720 set_vaxc_errno(retsts);
4721 if (ckWARN(WARN_EXEC)) {
4722 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4723 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4730 } /* end of vms_do_exec() */
4733 unsigned long int Perl_do_spawn(pTHX_ char *);
4735 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4737 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4739 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4742 } /* end of do_aspawn() */
4745 /* {{{unsigned long int do_spawn(char *cmd) */
4747 Perl_do_spawn(pTHX_ char *cmd)
4749 unsigned long int sts, substs, hadcmd = 1;
4752 TAINT_PROPER("spawn");
4753 if (!cmd || !*cmd) {
4755 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4757 else if ((sts = setup_cmddsc(aTHX_ cmd,0)) & 1) {
4758 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4763 case RMS$_FNF: case RMS$_DNF:
4764 set_errno(ENOENT); break;
4766 set_errno(ENOTDIR); break;
4768 set_errno(ENODEV); break;
4770 set_errno(EACCES); break;
4772 set_errno(EINVAL); break;
4774 set_errno(E2BIG); break;
4775 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4776 _ckvmssts(sts); /* fall through */
4777 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4780 set_vaxc_errno(sts);
4781 if (ckWARN(WARN_EXEC)) {
4782 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4783 hadcmd ? VMScmd.dsc$w_length : 0,
4784 hadcmd ? VMScmd.dsc$a_pointer : "",
4791 } /* end of do_spawn() */
4795 static unsigned int *sockflags, sockflagsize;
4798 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4799 * routines found in some versions of the CRTL can't deal with sockets.
4800 * We don't shim the other file open routines since a socket isn't
4801 * likely to be opened by a name.
4803 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4804 FILE *my_fdopen(int fd, const char *mode)
4806 FILE *fp = fdopen(fd, (char *) mode);
4809 unsigned int fdoff = fd / sizeof(unsigned int);
4810 struct stat sbuf; /* native stat; we don't need flex_stat */
4811 if (!sockflagsize || fdoff > sockflagsize) {
4812 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4813 else New (1324,sockflags,fdoff+2,unsigned int);
4814 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4815 sockflagsize = fdoff + 2;
4817 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4818 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4827 * Clear the corresponding bit when the (possibly) socket stream is closed.
4828 * There still a small hole: we miss an implicit close which might occur
4829 * via freopen(). >> Todo
4831 /*{{{ int my_fclose(FILE *fp)*/
4832 int my_fclose(FILE *fp) {
4834 unsigned int fd = fileno(fp);
4835 unsigned int fdoff = fd / sizeof(unsigned int);
4837 if (sockflagsize && fdoff <= sockflagsize)
4838 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4846 * A simple fwrite replacement which outputs itmsz*nitm chars without
4847 * introducing record boundaries every itmsz chars.
4848 * We are using fputs, which depends on a terminating null. We may
4849 * well be writing binary data, so we need to accommodate not only
4850 * data with nulls sprinkled in the middle but also data with no null
4853 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4855 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
4857 register char *cp, *end, *cpd, *data;
4858 register unsigned int fd = fileno(dest);
4859 register unsigned int fdoff = fd / sizeof(unsigned int);
4861 int bufsize = itmsz * nitm + 1;
4863 if (fdoff < sockflagsize &&
4864 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4865 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4869 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4870 memcpy( data, src, itmsz*nitm );
4871 data[itmsz*nitm] = '\0';
4873 end = data + itmsz * nitm;
4874 retval = (int) nitm; /* on success return # items written */
4877 while (cpd <= end) {
4878 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4879 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4881 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4885 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4888 } /* end of my_fwrite() */
4891 /*{{{ int my_flush(FILE *fp)*/
4893 Perl_my_flush(pTHX_ FILE *fp)
4896 if ((res = fflush(fp)) == 0 && fp) {
4897 #ifdef VMS_DO_SOCKETS
4899 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4901 res = fsync(fileno(fp));
4904 * If the flush succeeded but set end-of-file, we need to clear
4905 * the error because our caller may check ferror(). BTW, this
4906 * probably means we just flushed an empty file.
4908 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4915 * Here are replacements for the following Unix routines in the VMS environment:
4916 * getpwuid Get information for a particular UIC or UID
4917 * getpwnam Get information for a named user
4918 * getpwent Get information for each user in the rights database
4919 * setpwent Reset search to the start of the rights database
4920 * endpwent Finish searching for users in the rights database
4922 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4923 * (defined in pwd.h), which contains the following fields:-
4925 * char *pw_name; Username (in lower case)
4926 * char *pw_passwd; Hashed password
4927 * unsigned int pw_uid; UIC
4928 * unsigned int pw_gid; UIC group number
4929 * char *pw_unixdir; Default device/directory (VMS-style)
4930 * char *pw_gecos; Owner name
4931 * char *pw_dir; Default device/directory (Unix-style)
4932 * char *pw_shell; Default CLI name (eg. DCL)
4934 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4936 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4937 * not the UIC member number (eg. what's returned by getuid()),
4938 * getpwuid() can accept either as input (if uid is specified, the caller's
4939 * UIC group is used), though it won't recognise gid=0.
4941 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4942 * information about other users in your group or in other groups, respectively.
4943 * If the required privilege is not available, then these routines fill only
4944 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4947 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4950 /* sizes of various UAF record fields */
4951 #define UAI$S_USERNAME 12
4952 #define UAI$S_IDENT 31
4953 #define UAI$S_OWNER 31
4954 #define UAI$S_DEFDEV 31
4955 #define UAI$S_DEFDIR 63
4956 #define UAI$S_DEFCLI 31
4959 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4960 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4961 (uic).uic$v_group != UIC$K_WILD_GROUP)
4963 static char __empty[]= "";
4964 static struct passwd __passwd_empty=
4965 {(char *) __empty, (char *) __empty, 0, 0,
4966 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4967 static int contxt= 0;
4968 static struct passwd __pwdcache;
4969 static char __pw_namecache[UAI$S_IDENT+1];
4972 * This routine does most of the work extracting the user information.
4974 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
4977 unsigned char length;
4978 char pw_gecos[UAI$S_OWNER+1];
4980 static union uicdef uic;
4982 unsigned char length;
4983 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
4986 unsigned char length;
4987 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
4990 unsigned char length;
4991 char pw_shell[UAI$S_DEFCLI+1];
4993 static char pw_passwd[UAI$S_PWD+1];
4995 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
4996 struct dsc$descriptor_s name_desc;
4997 unsigned long int sts;
4999 static struct itmlst_3 itmlst[]= {
5000 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5001 {sizeof(uic), UAI$_UIC, &uic, &luic},
5002 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5003 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5004 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5005 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5006 {0, 0, NULL, NULL}};
5008 name_desc.dsc$w_length= strlen(name);
5009 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5010 name_desc.dsc$b_class= DSC$K_CLASS_S;
5011 name_desc.dsc$a_pointer= (char *) name;
5013 /* Note that sys$getuai returns many fields as counted strings. */
5014 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5015 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5016 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5018 else { _ckvmssts(sts); }
5019 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5021 if ((int) owner.length < lowner) lowner= (int) owner.length;
5022 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5023 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5024 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5025 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5026 owner.pw_gecos[lowner]= '\0';
5027 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5028 defcli.pw_shell[ldefcli]= '\0';
5029 if (valid_uic(uic)) {
5030 pwd->pw_uid= uic.uic$l_uic;
5031 pwd->pw_gid= uic.uic$v_group;
5034 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5035 pwd->pw_passwd= pw_passwd;
5036 pwd->pw_gecos= owner.pw_gecos;
5037 pwd->pw_dir= defdev.pw_dir;
5038 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5039 pwd->pw_shell= defcli.pw_shell;
5040 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5042 ldir= strlen(pwd->pw_unixdir) - 1;
5043 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5046 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5047 __mystrtolower(pwd->pw_unixdir);
5052 * Get information for a named user.
5054 /*{{{struct passwd *getpwnam(char *name)*/
5055 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5057 struct dsc$descriptor_s name_desc;
5059 unsigned long int status, sts;
5061 __pwdcache = __passwd_empty;
5062 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5063 /* We still may be able to determine pw_uid and pw_gid */
5064 name_desc.dsc$w_length= strlen(name);
5065 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5066 name_desc.dsc$b_class= DSC$K_CLASS_S;
5067 name_desc.dsc$a_pointer= (char *) name;
5068 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5069 __pwdcache.pw_uid= uic.uic$l_uic;
5070 __pwdcache.pw_gid= uic.uic$v_group;
5073 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5074 set_vaxc_errno(sts);
5075 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5078 else { _ckvmssts(sts); }
5081 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5082 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5083 __pwdcache.pw_name= __pw_namecache;
5085 } /* end of my_getpwnam() */
5089 * Get information for a particular UIC or UID.
5090 * Called by my_getpwent with uid=-1 to list all users.
5092 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5093 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5095 const $DESCRIPTOR(name_desc,__pw_namecache);
5096 unsigned short lname;
5098 unsigned long int status;
5100 if (uid == (unsigned int) -1) {
5102 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5103 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5104 set_vaxc_errno(status);
5105 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5109 else { _ckvmssts(status); }
5110 } while (!valid_uic (uic));
5114 if (!uic.uic$v_group)
5115 uic.uic$v_group= PerlProc_getgid();
5117 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5118 else status = SS$_IVIDENT;
5119 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5120 status == RMS$_PRV) {
5121 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5124 else { _ckvmssts(status); }
5126 __pw_namecache[lname]= '\0';
5127 __mystrtolower(__pw_namecache);
5129 __pwdcache = __passwd_empty;
5130 __pwdcache.pw_name = __pw_namecache;
5132 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5133 The identifier's value is usually the UIC, but it doesn't have to be,
5134 so if we can, we let fillpasswd update this. */
5135 __pwdcache.pw_uid = uic.uic$l_uic;
5136 __pwdcache.pw_gid = uic.uic$v_group;
5138 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5141 } /* end of my_getpwuid() */
5145 * Get information for next user.
5147 /*{{{struct passwd *my_getpwent()*/
5148 struct passwd *Perl_my_getpwent(pTHX)
5150 return (my_getpwuid((unsigned int) -1));
5155 * Finish searching rights database for users.
5157 /*{{{void my_endpwent()*/
5158 void Perl_my_endpwent(pTHX)
5161 _ckvmssts(sys$finish_rdb(&contxt));
5167 #ifdef HOMEGROWN_POSIX_SIGNALS
5168 /* Signal handling routines, pulled into the core from POSIX.xs.
5170 * We need these for threads, so they've been rolled into the core,
5171 * rather than left in POSIX.xs.
5173 * (DRS, Oct 23, 1997)
5176 /* sigset_t is atomic under VMS, so these routines are easy */
5177 /*{{{int my_sigemptyset(sigset_t *) */
5178 int my_sigemptyset(sigset_t *set) {
5179 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5185 /*{{{int my_sigfillset(sigset_t *)*/
5186 int my_sigfillset(sigset_t *set) {
5188 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5189 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5195 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5196 int my_sigaddset(sigset_t *set, int sig) {
5197 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5198 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5199 *set |= (1 << (sig - 1));
5205 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5206 int my_sigdelset(sigset_t *set, int sig) {
5207 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5208 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5209 *set &= ~(1 << (sig - 1));
5215 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5216 int my_sigismember(sigset_t *set, int sig) {
5217 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5218 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5219 *set & (1 << (sig - 1));
5224 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5225 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5228 /* If set and oset are both null, then things are badly wrong. Bail out. */
5229 if ((oset == NULL) && (set == NULL)) {
5230 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5234 /* If set's null, then we're just handling a fetch. */
5236 tempmask = sigblock(0);
5241 tempmask = sigsetmask(*set);
5244 tempmask = sigblock(*set);
5247 tempmask = sigblock(0);
5248 sigsetmask(*oset & ~tempmask);
5251 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5256 /* Did they pass us an oset? If so, stick our holding mask into it */
5263 #endif /* HOMEGROWN_POSIX_SIGNALS */
5266 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5267 * my_utime(), and flex_stat(), all of which operate on UTC unless
5268 * VMSISH_TIMES is true.
5270 /* method used to handle UTC conversions:
5271 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5273 static int gmtime_emulation_type;
5274 /* number of secs to add to UTC POSIX-style time to get local time */
5275 static long int utc_offset_secs;
5277 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5278 * in vmsish.h. #undef them here so we can call the CRTL routines
5287 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5288 * qualifier with the extern prefix pragma. This provisional
5289 * hack circumvents this prefix pragma problem in previous
5292 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5293 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5294 # pragma __extern_prefix save
5295 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5296 # define gmtime decc$__utctz_gmtime
5297 # define localtime decc$__utctz_localtime
5298 # define time decc$__utc_time
5299 # pragma __extern_prefix restore
5301 struct tm *gmtime(), *localtime();
5307 static time_t toutc_dst(time_t loc) {
5310 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5311 loc -= utc_offset_secs;
5312 if (rsltmp->tm_isdst) loc -= 3600;
5315 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5316 ((gmtime_emulation_type || my_time(NULL)), \
5317 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5318 ((secs) - utc_offset_secs))))
5320 static time_t toloc_dst(time_t utc) {
5323 utc += utc_offset_secs;
5324 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5325 if (rsltmp->tm_isdst) utc += 3600;
5328 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5329 ((gmtime_emulation_type || my_time(NULL)), \
5330 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5331 ((secs) + utc_offset_secs))))
5333 #ifndef RTL_USES_UTC
5336 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5337 DST starts on 1st sun of april at 02:00 std time
5338 ends on last sun of october at 02:00 dst time
5339 see the UCX management command reference, SET CONFIG TIMEZONE
5340 for formatting info.
5342 No, it's not as general as it should be, but then again, NOTHING
5343 will handle UK times in a sensible way.
5348 parse the DST start/end info:
5349 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5353 tz_parse_startend(char *s, struct tm *w, int *past)
5355 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5356 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5361 if (!past) return 0;
5364 if (w->tm_year % 4 == 0) ly = 1;
5365 if (w->tm_year % 100 == 0) ly = 0;
5366 if (w->tm_year+1900 % 400 == 0) ly = 1;
5369 dozjd = isdigit(*s);
5370 if (*s == 'J' || *s == 'j' || dozjd) {
5371 if (!dozjd && !isdigit(*++s)) return 0;
5374 d = d*10 + *s++ - '0';
5376 d = d*10 + *s++ - '0';
5379 if (d == 0) return 0;
5380 if (d > 366) return 0;
5382 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5385 } else if (*s == 'M' || *s == 'm') {
5386 if (!isdigit(*++s)) return 0;
5388 if (isdigit(*s)) m = 10*m + *s++ - '0';
5389 if (*s != '.') return 0;
5390 if (!isdigit(*++s)) return 0;
5392 if (n < 1 || n > 5) return 0;
5393 if (*s != '.') return 0;
5394 if (!isdigit(*++s)) return 0;
5396 if (d > 6) return 0;
5400 if (!isdigit(*++s)) return 0;
5402 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5404 if (!isdigit(*++s)) return 0;
5406 if (isdigit(*s)) min = 10*min + *s++ - '0';
5408 if (!isdigit(*++s)) return 0;
5410 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5420 if (w->tm_yday < d) goto before;
5421 if (w->tm_yday > d) goto after;
5423 if (w->tm_mon+1 < m) goto before;
5424 if (w->tm_mon+1 > m) goto after;
5426 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5427 k = d - j; /* mday of first d */
5429 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5430 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5431 if (w->tm_mday < k) goto before;
5432 if (w->tm_mday > k) goto after;
5435 if (w->tm_hour < hour) goto before;
5436 if (w->tm_hour > hour) goto after;
5437 if (w->tm_min < min) goto before;
5438 if (w->tm_min > min) goto after;
5439 if (w->tm_sec < sec) goto before;
5453 /* parse the offset: (+|-)hh[:mm[:ss]] */
5456 tz_parse_offset(char *s, int *offset)
5458 int hour = 0, min = 0, sec = 0;
5461 if (!offset) return 0;
5463 if (*s == '-') {neg++; s++;}
5465 if (!isdigit(*s)) return 0;
5467 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5468 if (hour > 24) return 0;
5470 if (!isdigit(*++s)) return 0;
5472 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5473 if (min > 59) return 0;
5475 if (!isdigit(*++s)) return 0;
5477 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5478 if (sec > 59) return 0;
5482 *offset = (hour*60+min)*60 + sec;
5483 if (neg) *offset = -*offset;
5488 input time is w, whatever type of time the CRTL localtime() uses.
5489 sets dst, the zone, and the gmtoff (seconds)
5491 caches the value of TZ and UCX$TZ env variables; note that
5492 my_setenv looks for these and sets a flag if they're changed
5495 We have to watch out for the "australian" case (dst starts in
5496 october, ends in april)...flagged by "reverse" and checked by
5497 scanning through the months of the previous year.
5502 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5507 char *dstzone, *tz, *s_start, *s_end;
5508 int std_off, dst_off, isdst;
5509 int y, dststart, dstend;
5510 static char envtz[1025]; /* longer than any logical, symbol, ... */
5511 static char ucxtz[1025];
5512 static char reversed = 0;
5518 reversed = -1; /* flag need to check */
5519 envtz[0] = ucxtz[0] = '\0';
5520 tz = my_getenv("TZ",0);
5521 if (tz) strcpy(envtz, tz);
5522 tz = my_getenv("UCX$TZ",0);
5523 if (tz) strcpy(ucxtz, tz);
5524 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5527 if (!*tz) tz = ucxtz;
5530 while (isalpha(*s)) s++;
5531 s = tz_parse_offset(s, &std_off);
5533 if (!*s) { /* no DST, hurray we're done! */
5539 while (isalpha(*s)) s++;
5540 s2 = tz_parse_offset(s, &dst_off);
5544 dst_off = std_off - 3600;
5547 if (!*s) { /* default dst start/end?? */
5548 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5549 s = strchr(ucxtz,',');
5551 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5553 if (*s != ',') return 0;
5556 when = _toutc(when); /* convert to utc */
5557 when = when - std_off; /* convert to pseudolocal time*/
5559 w2 = localtime(&when);
5562 s = tz_parse_startend(s_start,w2,&dststart);
5564 if (*s != ',') return 0;
5567 when = _toutc(when); /* convert to utc */
5568 when = when - dst_off; /* convert to pseudolocal time*/
5569 w2 = localtime(&when);
5570 if (w2->tm_year != y) { /* spans a year, just check one time */
5571 when += dst_off - std_off;
5572 w2 = localtime(&when);
5575 s = tz_parse_startend(s_end,w2,&dstend);
5578 if (reversed == -1) { /* need to check if start later than end */
5582 if (when < 2*365*86400) {
5583 when += 2*365*86400;
5587 w2 =localtime(&when);
5588 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5590 for (j = 0; j < 12; j++) {
5591 w2 =localtime(&when);
5592 (void) tz_parse_startend(s_start,w2,&ds);
5593 (void) tz_parse_startend(s_end,w2,&de);
5594 if (ds != de) break;
5598 if (de && !ds) reversed = 1;
5601 isdst = dststart && !dstend;
5602 if (reversed) isdst = dststart || !dstend;
5605 if (dst) *dst = isdst;
5606 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5607 if (isdst) tz = dstzone;
5609 while(isalpha(*tz)) *zone++ = *tz++;
5615 #endif /* !RTL_USES_UTC */
5617 /* my_time(), my_localtime(), my_gmtime()
5618 * By default traffic in UTC time values, using CRTL gmtime() or
5619 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5620 * Note: We need to use these functions even when the CRTL has working
5621 * UTC support, since they also handle C<use vmsish qw(times);>
5623 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5624 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5627 /*{{{time_t my_time(time_t *timep)*/
5628 time_t Perl_my_time(pTHX_ time_t *timep)
5633 if (gmtime_emulation_type == 0) {
5635 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5636 /* results of calls to gmtime() and localtime() */
5637 /* for same &base */
5639 gmtime_emulation_type++;
5640 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5641 char off[LNM$C_NAMLENGTH+1];;
5643 gmtime_emulation_type++;
5644 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5645 gmtime_emulation_type++;
5646 utc_offset_secs = 0;
5647 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5649 else { utc_offset_secs = atol(off); }
5651 else { /* We've got a working gmtime() */
5652 struct tm gmt, local;
5655 tm_p = localtime(&base);
5657 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5658 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5659 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5660 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5666 # ifdef RTL_USES_UTC
5667 if (VMSISH_TIME) when = _toloc(when);
5669 if (!VMSISH_TIME) when = _toutc(when);
5672 if (timep != NULL) *timep = when;
5675 } /* end of my_time() */
5679 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5681 Perl_my_gmtime(pTHX_ const time_t *timep)
5687 if (timep == NULL) {
5688 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5691 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5695 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5697 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5698 return gmtime(&when);
5700 /* CRTL localtime() wants local time as input, so does no tz correction */
5701 rsltmp = localtime(&when);
5702 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5705 } /* end of my_gmtime() */
5709 /*{{{struct tm *my_localtime(const time_t *timep)*/
5711 Perl_my_localtime(pTHX_ const time_t *timep)
5713 time_t when, whenutc;
5717 if (timep == NULL) {
5718 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5721 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5722 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5725 # ifdef RTL_USES_UTC
5727 if (VMSISH_TIME) when = _toutc(when);
5729 /* CRTL localtime() wants UTC as input, does tz correction itself */
5730 return localtime(&when);
5732 # else /* !RTL_USES_UTC */
5735 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5736 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5739 #ifndef RTL_USES_UTC
5740 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5741 when = whenutc - offset; /* pseudolocal time*/
5744 /* CRTL localtime() wants local time as input, so does no tz correction */
5745 rsltmp = localtime(&when);
5746 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5750 } /* end of my_localtime() */
5753 /* Reset definitions for later calls */
5754 #define gmtime(t) my_gmtime(t)
5755 #define localtime(t) my_localtime(t)
5756 #define time(t) my_time(t)
5759 /* my_utime - update modification time of a file
5760 * calling sequence is identical to POSIX utime(), but under
5761 * VMS only the modification time is changed; ODS-2 does not
5762 * maintain access times. Restrictions differ from the POSIX
5763 * definition in that the time can be changed as long as the
5764 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5765 * no separate checks are made to insure that the caller is the
5766 * owner of the file or has special privs enabled.
5767 * Code here is based on Joe Meadows' FILE utility.
5770 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5771 * to VMS epoch (01-JAN-1858 00:00:00.00)
5772 * in 100 ns intervals.
5774 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5776 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5777 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5780 long int bintime[2], len = 2, lowbit, unixtime,
5781 secscale = 10000000; /* seconds --> 100 ns intervals */
5782 unsigned long int chan, iosb[2], retsts;
5783 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5784 struct FAB myfab = cc$rms_fab;
5785 struct NAM mynam = cc$rms_nam;
5786 #if defined (__DECC) && defined (__VAX)
5787 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5788 * at least through VMS V6.1, which causes a type-conversion warning.
5790 # pragma message save
5791 # pragma message disable cvtdiftypes
5793 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5794 struct fibdef myfib;
5795 #if defined (__DECC) && defined (__VAX)
5796 /* This should be right after the declaration of myatr, but due
5797 * to a bug in VAX DEC C, this takes effect a statement early.
5799 # pragma message restore
5801 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5802 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5803 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5805 if (file == NULL || *file == '\0') {
5807 set_vaxc_errno(LIB$_INVARG);
5810 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5812 if (utimes != NULL) {
5813 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5814 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5815 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5816 * as input, we force the sign bit to be clear by shifting unixtime right
5817 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5819 lowbit = (utimes->modtime & 1) ? secscale : 0;
5820 unixtime = (long int) utimes->modtime;
5822 /* If input was UTC; convert to local for sys svc */
5823 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5825 unixtime >>= 1; secscale <<= 1;
5826 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5827 if (!(retsts & 1)) {
5829 set_vaxc_errno(retsts);
5832 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5833 if (!(retsts & 1)) {
5835 set_vaxc_errno(retsts);
5840 /* Just get the current time in VMS format directly */
5841 retsts = sys$gettim(bintime);
5842 if (!(retsts & 1)) {
5844 set_vaxc_errno(retsts);
5849 myfab.fab$l_fna = vmsspec;
5850 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5851 myfab.fab$l_nam = &mynam;
5852 mynam.nam$l_esa = esa;
5853 mynam.nam$b_ess = (unsigned char) sizeof esa;
5854 mynam.nam$l_rsa = rsa;
5855 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5857 /* Look for the file to be affected, letting RMS parse the file
5858 * specification for us as well. I have set errno using only
5859 * values documented in the utime() man page for VMS POSIX.
5861 retsts = sys$parse(&myfab,0,0);
5862 if (!(retsts & 1)) {
5863 set_vaxc_errno(retsts);
5864 if (retsts == RMS$_PRV) set_errno(EACCES);
5865 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5866 else set_errno(EVMSERR);
5869 retsts = sys$search(&myfab,0,0);
5870 if (!(retsts & 1)) {
5871 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5872 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5873 set_vaxc_errno(retsts);
5874 if (retsts == RMS$_PRV) set_errno(EACCES);
5875 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5876 else set_errno(EVMSERR);
5880 devdsc.dsc$w_length = mynam.nam$b_dev;
5881 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5883 retsts = sys$assign(&devdsc,&chan,0,0);
5884 if (!(retsts & 1)) {
5885 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5886 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5887 set_vaxc_errno(retsts);
5888 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5889 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5890 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5891 else set_errno(EVMSERR);
5895 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5896 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5898 memset((void *) &myfib, 0, sizeof myfib);
5899 #if defined(__DECC) || defined(__DECCXX)
5900 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5901 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5902 /* This prevents the revision time of the file being reset to the current
5903 * time as a result of our IO$_MODIFY $QIO. */
5904 myfib.fib$l_acctl = FIB$M_NORECORD;
5906 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5907 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5908 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5910 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5911 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5912 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5913 _ckvmssts(sys$dassgn(chan));
5914 if (retsts & 1) retsts = iosb[0];
5915 if (!(retsts & 1)) {
5916 set_vaxc_errno(retsts);
5917 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5918 else set_errno(EVMSERR);
5923 } /* end of my_utime() */
5927 * flex_stat, flex_fstat
5928 * basic stat, but gets it right when asked to stat
5929 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5932 /* encode_dev packs a VMS device name string into an integer to allow
5933 * simple comparisons. This can be used, for example, to check whether two
5934 * files are located on the same device, by comparing their encoded device
5935 * names. Even a string comparison would not do, because stat() reuses the
5936 * device name buffer for each call; so without encode_dev, it would be
5937 * necessary to save the buffer and use strcmp (this would mean a number of
5938 * changes to the standard Perl code, to say nothing of what a Perl script
5941 * The device lock id, if it exists, should be unique (unless perhaps compared
5942 * with lock ids transferred from other nodes). We have a lock id if the disk is
5943 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5944 * device names. Thus we use the lock id in preference, and only if that isn't
5945 * available, do we try to pack the device name into an integer (flagged by
5946 * the sign bit (LOCKID_MASK) being set).
5948 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5949 * name and its encoded form, but it seems very unlikely that we will find
5950 * two files on different disks that share the same encoded device names,
5951 * and even more remote that they will share the same file id (if the test
5952 * is to check for the same file).
5954 * A better method might be to use sys$device_scan on the first call, and to
5955 * search for the device, returning an index into the cached array.
5956 * The number returned would be more intelligable.
5957 * This is probably not worth it, and anyway would take quite a bit longer
5958 * on the first call.
5960 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5961 static mydev_t encode_dev (pTHX_ const char *dev)
5964 unsigned long int f;
5969 if (!dev || !dev[0]) return 0;
5973 struct dsc$descriptor_s dev_desc;
5974 unsigned long int status, lockid, item = DVI$_LOCKID;
5976 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5977 can try that first. */
5978 dev_desc.dsc$w_length = strlen (dev);
5979 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
5980 dev_desc.dsc$b_class = DSC$K_CLASS_S;
5981 dev_desc.dsc$a_pointer = (char *) dev;
5982 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
5983 if (lockid) return (lockid & ~LOCKID_MASK);
5987 /* Otherwise we try to encode the device name */
5991 for (q = dev + strlen(dev); q--; q >= dev) {
5994 else if (isalpha (toupper (*q)))
5995 c= toupper (*q) - 'A' + (char)10;
5997 continue; /* Skip '$'s */
5999 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6001 enc += f * (unsigned long int) c;
6003 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6005 } /* end of encode_dev() */
6007 static char namecache[NAM$C_MAXRSS+1];
6010 is_null_device(name)
6013 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6014 The underscore prefix, controller letter, and unit number are
6015 independently optional; for our purposes, the colon punctuation
6016 is not. The colon can be trailed by optional directory and/or
6017 filename, but two consecutive colons indicates a nodename rather
6018 than a device. [pr] */
6019 if (*name == '_') ++name;
6020 if (tolower(*name++) != 'n') return 0;
6021 if (tolower(*name++) != 'l') return 0;
6022 if (tolower(*name) == 'a') ++name;
6023 if (*name == '0') ++name;
6024 return (*name++ == ':') && (*name != ':');
6027 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6028 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6029 * subset of the applicable information.
6032 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6034 char fname_phdev[NAM$C_MAXRSS+1];
6035 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6037 char fname[NAM$C_MAXRSS+1];
6038 unsigned long int retsts;
6039 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6040 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6042 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6043 device name on successive calls */
6044 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6045 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6046 namdsc.dsc$a_pointer = fname;
6047 namdsc.dsc$w_length = sizeof fname - 1;
6049 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6050 &namdsc,&namdsc.dsc$w_length,0,0);
6052 fname[namdsc.dsc$w_length] = '\0';
6054 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6055 * but if someone has redefined that logical, Perl gets very lost. Since
6056 * we have the physical device name from the stat buffer, just paste it on.
6058 strcpy( fname_phdev, statbufp->st_devnam );
6059 strcat( fname_phdev, strrchr(fname, ':') );
6061 return cando_by_name(bit,effective,fname_phdev);
6063 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6064 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6068 return FALSE; /* Should never get to here */
6070 } /* end of cando() */
6074 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6076 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6078 static char usrname[L_cuserid];
6079 static struct dsc$descriptor_s usrdsc =
6080 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6081 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6082 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6083 unsigned short int retlen;
6084 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6085 union prvdef curprv;
6086 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6087 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6088 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6091 if (!fname || !*fname) return FALSE;
6092 /* Make sure we expand logical names, since sys$check_access doesn't */
6093 if (!strpbrk(fname,"/]>:")) {
6094 strcpy(fileified,fname);
6095 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6098 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6099 retlen = namdsc.dsc$w_length = strlen(vmsname);
6100 namdsc.dsc$a_pointer = vmsname;
6101 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6102 vmsname[retlen-1] == ':') {
6103 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6104 namdsc.dsc$w_length = strlen(fileified);
6105 namdsc.dsc$a_pointer = fileified;
6108 if (!usrdsc.dsc$w_length) {
6110 usrdsc.dsc$w_length = strlen(usrname);
6114 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6115 access = ARM$M_EXECUTE; break;
6116 case S_IRUSR: case S_IRGRP: case S_IROTH:
6117 access = ARM$M_READ; break;
6118 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6119 access = ARM$M_WRITE; break;
6120 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6121 access = ARM$M_DELETE; break;
6126 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6127 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6128 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6129 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6130 set_vaxc_errno(retsts);
6131 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6132 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6133 else set_errno(ENOENT);
6136 if (retsts == SS$_NORMAL) {
6137 if (!privused) return TRUE;
6138 /* We can get access, but only by using privs. Do we have the
6139 necessary privs currently enabled? */
6140 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6141 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6142 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6143 !curprv.prv$v_bypass) return FALSE;
6144 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6145 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6146 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6149 if (retsts == SS$_ACCONFLICT) {
6154 return FALSE; /* Should never get here */
6156 } /* end of cando_by_name() */
6160 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6162 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6164 if (!fstat(fd,(stat_t *) statbufp)) {
6165 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6166 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6167 # ifdef RTL_USES_UTC
6170 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6171 statbufp->st_atime = _toloc(statbufp->st_atime);
6172 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6177 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6181 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6182 statbufp->st_atime = _toutc(statbufp->st_atime);
6183 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6190 } /* end of flex_fstat() */
6193 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6195 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6197 char fileified[NAM$C_MAXRSS+1];
6198 char temp_fspec[NAM$C_MAXRSS+300];
6201 strcpy(temp_fspec, fspec);
6202 if (statbufp == (Stat_t *) &PL_statcache)
6203 do_tovmsspec(temp_fspec,namecache,0);
6204 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6205 memset(statbufp,0,sizeof *statbufp);
6206 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6207 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6208 statbufp->st_uid = 0x00010001;
6209 statbufp->st_gid = 0x0001;
6210 time((time_t *)&statbufp->st_mtime);
6211 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6215 /* Try for a directory name first. If fspec contains a filename without
6216 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6217 * and sea:[wine.dark]water. exist, we prefer the directory here.
6218 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6219 * not sea:[wine.dark]., if the latter exists. If the intended target is
6220 * the file with null type, specify this by calling flex_stat() with
6221 * a '.' at the end of fspec.
6223 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6224 retval = stat(fileified,(stat_t *) statbufp);
6225 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6226 strcpy(namecache,fileified);
6228 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6230 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6231 # ifdef RTL_USES_UTC
6234 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6235 statbufp->st_atime = _toloc(statbufp->st_atime);
6236 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6241 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6245 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6246 statbufp->st_atime = _toutc(statbufp->st_atime);
6247 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6253 } /* end of flex_stat() */
6257 /*{{{char *my_getlogin()*/
6258 /* VMS cuserid == Unix getlogin, except calling sequence */
6262 static char user[L_cuserid];
6263 return cuserid(user);
6268 /* rmscopy - copy a file using VMS RMS routines
6270 * Copies contents and attributes of spec_in to spec_out, except owner
6271 * and protection information. Name and type of spec_in are used as
6272 * defaults for spec_out. The third parameter specifies whether rmscopy()
6273 * should try to propagate timestamps from the input file to the output file.
6274 * If it is less than 0, no timestamps are preserved. If it is 0, then
6275 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6276 * propagated to the output file at creation iff the output file specification
6277 * did not contain an explicit name or type, and the revision date is always
6278 * updated at the end of the copy operation. If it is greater than 0, then
6279 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6280 * other than the revision date should be propagated, and bit 1 indicates
6281 * that the revision date should be propagated.
6283 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6285 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6286 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6287 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6288 * as part of the Perl standard distribution under the terms of the
6289 * GNU General Public License or the Perl Artistic License. Copies
6290 * of each may be found in the Perl standard distribution.
6292 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6294 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6296 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6297 rsa[NAM$C_MAXRSS], ubf[32256];
6298 unsigned long int i, sts, sts2;
6299 struct FAB fab_in, fab_out;
6300 struct RAB rab_in, rab_out;
6302 struct XABDAT xabdat;
6303 struct XABFHC xabfhc;
6304 struct XABRDT xabrdt;
6305 struct XABSUM xabsum;
6307 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6308 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6309 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6313 fab_in = cc$rms_fab;
6314 fab_in.fab$l_fna = vmsin;
6315 fab_in.fab$b_fns = strlen(vmsin);
6316 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6317 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6318 fab_in.fab$l_fop = FAB$M_SQO;
6319 fab_in.fab$l_nam = &nam;
6320 fab_in.fab$l_xab = (void *) &xabdat;
6323 nam.nam$l_rsa = rsa;
6324 nam.nam$b_rss = sizeof(rsa);
6325 nam.nam$l_esa = esa;
6326 nam.nam$b_ess = sizeof (esa);
6327 nam.nam$b_esl = nam.nam$b_rsl = 0;
6329 xabdat = cc$rms_xabdat; /* To get creation date */
6330 xabdat.xab$l_nxt = (void *) &xabfhc;
6332 xabfhc = cc$rms_xabfhc; /* To get record length */
6333 xabfhc.xab$l_nxt = (void *) &xabsum;
6335 xabsum = cc$rms_xabsum; /* To get key and area information */
6337 if (!((sts = sys$open(&fab_in)) & 1)) {
6338 set_vaxc_errno(sts);
6340 case RMS$_FNF: case RMS$_DNF:
6341 set_errno(ENOENT); break;
6343 set_errno(ENOTDIR); break;
6345 set_errno(ENODEV); break;
6347 set_errno(EINVAL); break;
6349 set_errno(EACCES); break;
6357 fab_out.fab$w_ifi = 0;
6358 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6359 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6360 fab_out.fab$l_fop = FAB$M_SQO;
6361 fab_out.fab$l_fna = vmsout;
6362 fab_out.fab$b_fns = strlen(vmsout);
6363 fab_out.fab$l_dna = nam.nam$l_name;
6364 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6366 if (preserve_dates == 0) { /* Act like DCL COPY */
6367 nam.nam$b_nop = NAM$M_SYNCHK;
6368 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6369 if (!((sts = sys$parse(&fab_out)) & 1)) {
6370 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6371 set_vaxc_errno(sts);
6374 fab_out.fab$l_xab = (void *) &xabdat;
6375 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6377 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6378 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6379 preserve_dates =0; /* bitmask from this point forward */
6381 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6382 if (!((sts = sys$create(&fab_out)) & 1)) {
6383 set_vaxc_errno(sts);
6386 set_errno(ENOENT); break;
6388 set_errno(ENOTDIR); break;
6390 set_errno(ENODEV); break;
6392 set_errno(EINVAL); break;
6394 set_errno(EACCES); break;
6400 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6401 if (preserve_dates & 2) {
6402 /* sys$close() will process xabrdt, not xabdat */
6403 xabrdt = cc$rms_xabrdt;
6405 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6407 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6408 * is unsigned long[2], while DECC & VAXC use a struct */
6409 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6411 fab_out.fab$l_xab = (void *) &xabrdt;
6414 rab_in = cc$rms_rab;
6415 rab_in.rab$l_fab = &fab_in;
6416 rab_in.rab$l_rop = RAB$M_BIO;
6417 rab_in.rab$l_ubf = ubf;
6418 rab_in.rab$w_usz = sizeof ubf;
6419 if (!((sts = sys$connect(&rab_in)) & 1)) {
6420 sys$close(&fab_in); sys$close(&fab_out);
6421 set_errno(EVMSERR); set_vaxc_errno(sts);
6425 rab_out = cc$rms_rab;
6426 rab_out.rab$l_fab = &fab_out;
6427 rab_out.rab$l_rbf = ubf;
6428 if (!((sts = sys$connect(&rab_out)) & 1)) {
6429 sys$close(&fab_in); sys$close(&fab_out);
6430 set_errno(EVMSERR); set_vaxc_errno(sts);
6434 while ((sts = sys$read(&rab_in))) { /* always true */
6435 if (sts == RMS$_EOF) break;
6436 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6437 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6438 sys$close(&fab_in); sys$close(&fab_out);
6439 set_errno(EVMSERR); set_vaxc_errno(sts);
6444 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6445 sys$close(&fab_in); sys$close(&fab_out);
6446 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6448 set_errno(EVMSERR); set_vaxc_errno(sts);
6454 } /* end of rmscopy() */
6458 /*** The following glue provides 'hooks' to make some of the routines
6459 * from this file available from Perl. These routines are sufficiently
6460 * basic, and are required sufficiently early in the build process,
6461 * that's it's nice to have them available to miniperl as well as the
6462 * full Perl, so they're set up here instead of in an extension. The
6463 * Perl code which handles importation of these names into a given
6464 * package lives in [.VMS]Filespec.pm in @INC.
6468 rmsexpand_fromperl(pTHX_ CV *cv)
6471 char *fspec, *defspec = NULL, *rslt;
6474 if (!items || items > 2)
6475 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6476 fspec = SvPV(ST(0),n_a);
6477 if (!fspec || !*fspec) XSRETURN_UNDEF;
6478 if (items == 2) defspec = SvPV(ST(1),n_a);
6480 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6481 ST(0) = sv_newmortal();
6482 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6487 vmsify_fromperl(pTHX_ CV *cv)
6493 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6494 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6495 ST(0) = sv_newmortal();
6496 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6501 unixify_fromperl(pTHX_ CV *cv)
6507 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6508 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6509 ST(0) = sv_newmortal();
6510 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6515 fileify_fromperl(pTHX_ CV *cv)
6521 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6522 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6523 ST(0) = sv_newmortal();
6524 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6529 pathify_fromperl(pTHX_ CV *cv)
6535 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6536 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6537 ST(0) = sv_newmortal();
6538 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6543 vmspath_fromperl(pTHX_ CV *cv)
6549 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6550 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6551 ST(0) = sv_newmortal();
6552 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6557 unixpath_fromperl(pTHX_ CV *cv)
6563 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6564 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6565 ST(0) = sv_newmortal();
6566 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6571 candelete_fromperl(pTHX_ CV *cv)
6574 char fspec[NAM$C_MAXRSS+1], *fsp;
6579 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6581 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6582 if (SvTYPE(mysv) == SVt_PVGV) {
6583 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6584 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6591 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6592 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6598 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6603 rmscopy_fromperl(pTHX_ CV *cv)
6606 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6608 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6609 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6610 unsigned long int sts;
6615 if (items < 2 || items > 3)
6616 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6618 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6619 if (SvTYPE(mysv) == SVt_PVGV) {
6620 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6621 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6628 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6629 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6634 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6635 if (SvTYPE(mysv) == SVt_PVGV) {
6636 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6637 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6644 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6645 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6650 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6652 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6658 mod2fname(pTHX_ CV *cv)
6661 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6662 workbuff[NAM$C_MAXRSS*1 + 1];
6663 int total_namelen = 3, counter, num_entries;
6664 /* ODS-5 ups this, but we want to be consistent, so... */
6665 int max_name_len = 39;
6666 AV *in_array = (AV *)SvRV(ST(0));
6668 num_entries = av_len(in_array);
6670 /* All the names start with PL_. */
6671 strcpy(ultimate_name, "PL_");
6673 /* Clean up our working buffer */
6674 Zero(work_name, sizeof(work_name), char);
6676 /* Run through the entries and build up a working name */
6677 for(counter = 0; counter <= num_entries; counter++) {
6678 /* If it's not the first name then tack on a __ */
6680 strcat(work_name, "__");
6682 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6686 /* Check to see if we actually have to bother...*/
6687 if (strlen(work_name) + 3 <= max_name_len) {
6688 strcat(ultimate_name, work_name);
6690 /* It's too darned big, so we need to go strip. We use the same */
6691 /* algorithm as xsubpp does. First, strip out doubled __ */
6692 char *source, *dest, last;
6695 for (source = work_name; *source; source++) {
6696 if (last == *source && last == '_') {
6702 /* Go put it back */
6703 strcpy(work_name, workbuff);
6704 /* Is it still too big? */
6705 if (strlen(work_name) + 3 > max_name_len) {
6706 /* Strip duplicate letters */
6709 for (source = work_name; *source; source++) {
6710 if (last == toupper(*source)) {
6714 last = toupper(*source);
6716 strcpy(work_name, workbuff);
6719 /* Is it *still* too big? */
6720 if (strlen(work_name) + 3 > max_name_len) {
6721 /* Too bad, we truncate */
6722 work_name[max_name_len - 2] = 0;
6724 strcat(ultimate_name, work_name);
6727 /* Okay, return it */
6728 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6736 char* file = __FILE__;
6737 char temp_buff[512];
6738 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6739 no_translate_barewords = TRUE;
6741 no_translate_barewords = FALSE;
6744 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6745 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6746 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6747 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6748 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6749 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6750 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6751 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6752 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6753 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6755 store_pipelocs(aTHX);