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");
1068 #ifndef HOMEGROWN_POSIX_SIGNALS
1070 * The C RTL's sigaction fails to check for invalid signal numbers so we
1071 * help it out a bit. The docs are correct, but the actual routine doesn't
1072 * do what the docs say it will.
1074 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1076 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1077 struct sigaction* oact)
1079 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1080 SETERRNO(EINVAL, SS$_INVARG);
1083 return sigaction(sig, act, oact);
1088 /* default piping mailbox size */
1089 #define PERL_BUFSIZ 512
1093 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1095 unsigned long int mbxbufsiz;
1096 static unsigned long int syssize = 0;
1097 unsigned long int dviitm = DVI$_DEVNAM;
1098 char csize[LNM$C_NAMLENGTH+1];
1101 unsigned long syiitm = SYI$_MAXBUF;
1103 * Get the SYSGEN parameter MAXBUF
1105 * If the logical 'PERL_MBX_SIZE' is defined
1106 * use the value of the logical instead of PERL_BUFSIZ, but
1107 * keep the size between 128 and MAXBUF.
1110 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1113 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1114 mbxbufsiz = atoi(csize);
1116 mbxbufsiz = PERL_BUFSIZ;
1118 if (mbxbufsiz < 128) mbxbufsiz = 128;
1119 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1121 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1123 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1124 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1126 } /* end of create_mbx() */
1129 /*{{{ my_popen and my_pclose*/
1131 typedef struct _iosb IOSB;
1132 typedef struct _iosb* pIOSB;
1133 typedef struct _pipe Pipe;
1134 typedef struct _pipe* pPipe;
1135 typedef struct pipe_details Info;
1136 typedef struct pipe_details* pInfo;
1137 typedef struct _srqp RQE;
1138 typedef struct _srqp* pRQE;
1139 typedef struct _tochildbuf CBuf;
1140 typedef struct _tochildbuf* pCBuf;
1143 unsigned short status;
1144 unsigned short count;
1145 unsigned long dvispec;
1148 #pragma member_alignment save
1149 #pragma nomember_alignment quadword
1150 struct _srqp { /* VMS self-relative queue entry */
1151 unsigned long qptr[2];
1153 #pragma member_alignment restore
1154 static RQE RQE_ZERO = {0,0};
1156 struct _tochildbuf {
1159 unsigned short size;
1167 unsigned short chan_in;
1168 unsigned short chan_out;
1170 unsigned int bufsize;
1182 #if defined(PERL_IMPLICIT_CONTEXT)
1183 void *thx; /* Either a thread or an interpreter */
1184 /* pointer, depending on how we're built */
1192 PerlIO *fp; /* stdio file pointer to pipe mailbox */
1193 int pid; /* PID of subprocess */
1194 int mode; /* == 'r' if pipe open for reading */
1195 int done; /* subprocess has completed */
1196 int closing; /* my_pclose is closing this pipe */
1197 unsigned long completion; /* termination status of subprocess */
1198 pPipe in; /* pipe in to sub */
1199 pPipe out; /* pipe out of sub */
1200 pPipe err; /* pipe of sub's sys$error */
1201 int in_done; /* true when in pipe finished */
1206 struct exit_control_block
1208 struct exit_control_block *flink;
1209 unsigned long int (*exit_routine)();
1210 unsigned long int arg_count;
1211 unsigned long int *status_address;
1212 unsigned long int exit_status;
1215 #define RETRY_DELAY "0 ::0.20"
1216 #define MAX_RETRY 50
1218 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1219 static unsigned long mypid;
1220 static unsigned long delaytime[2];
1222 static pInfo open_pipes = NULL;
1223 static $DESCRIPTOR(nl_desc, "NL:");
1226 static unsigned long int
1227 pipe_exit_routine(pTHX)
1230 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1231 int sts, did_stuff, need_eof;
1234 first we try sending an EOF...ignore if doesn't work, make sure we
1242 _ckvmssts(sys$setast(0));
1243 if (info->in && !info->in->shut_on_empty) {
1244 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1248 _ckvmssts(sys$setast(1));
1251 if (did_stuff) sleep(1); /* wait for EOF to have an effect */
1256 _ckvmssts(sys$setast(0));
1257 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1258 sts = sys$forcex(&info->pid,0,&abort);
1259 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1262 _ckvmssts(sys$setast(1));
1265 if (did_stuff) sleep(1); /* wait for them to respond */
1269 _ckvmssts(sys$setast(0));
1270 if (!info->done) { /* We tried to be nice . . . */
1271 sts = sys$delprc(&info->pid,0);
1272 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1274 _ckvmssts(sys$setast(1));
1279 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1280 else if (!(sts & 1)) retsts = sts;
1285 static struct exit_control_block pipe_exitblock =
1286 {(struct exit_control_block *) 0,
1287 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1289 static void pipe_mbxtofd_ast(pPipe p);
1290 static void pipe_tochild1_ast(pPipe p);
1291 static void pipe_tochild2_ast(pPipe p);
1294 popen_completion_ast(pInfo info)
1296 pInfo i = open_pipes;
1300 if (i == info) break;
1303 if (!i) return; /* unlinked, probably freed too */
1305 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1309 Writing to subprocess ...
1310 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1312 chan_out may be waiting for "done" flag, or hung waiting
1313 for i/o completion to child...cancel the i/o. This will
1314 put it into "snarf mode" (done but no EOF yet) that discards
1317 Output from subprocess (stdout, stderr) needs to be flushed and
1318 shut down. We try sending an EOF, but if the mbx is full the pipe
1319 routine should still catch the "shut_on_empty" flag, telling it to
1320 use immediate-style reads so that "mbx empty" -> EOF.
1324 if (info->in && !info->in_done) { /* only for mode=w */
1325 if (info->in->shut_on_empty && info->in->need_wake) {
1326 info->in->need_wake = FALSE;
1327 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1329 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1333 if (info->out && !info->out_done) { /* were we also piping output? */
1334 info->out->shut_on_empty = TRUE;
1335 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1336 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1337 _ckvmssts_noperl(iss);
1340 if (info->err && !info->err_done) { /* we were piping stderr */
1341 info->err->shut_on_empty = TRUE;
1342 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1343 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1344 _ckvmssts_noperl(iss);
1346 _ckvmssts_noperl(sys$setef(pipe_ef));
1350 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img);
1351 static void vms_execfree(pTHX);
1354 we actually differ from vmstrnenv since we use this to
1355 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1356 are pointing to the same thing
1359 static unsigned short
1360 popen_translate(pTHX_ char *logical, char *result)
1363 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1364 $DESCRIPTOR(d_log,"");
1366 unsigned short length;
1367 unsigned short code;
1369 unsigned short *retlenaddr;
1371 unsigned short l, ifi;
1373 d_log.dsc$a_pointer = logical;
1374 d_log.dsc$w_length = strlen(logical);
1376 itmlst[0].code = LNM$_STRING;
1377 itmlst[0].length = 255;
1378 itmlst[0].buffer_addr = result;
1379 itmlst[0].retlenaddr = &l;
1382 itmlst[1].length = 0;
1383 itmlst[1].buffer_addr = 0;
1384 itmlst[1].retlenaddr = 0;
1386 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1387 if (iss == SS$_NOLOGNAM) {
1391 if (!(iss&1)) lib$signal(iss);
1394 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1395 strip it off and return the ifi, if any
1398 if (result[0] == 0x1b && result[1] == 0x00) {
1399 memcpy(&ifi,result+2,2);
1400 strcpy(result,result+4);
1402 return ifi; /* this is the RMS internal file id */
1405 #define MAX_DCL_SYMBOL 255
1406 static void pipe_infromchild_ast(pPipe p);
1409 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1410 inside an AST routine without worrying about reentrancy and which Perl
1411 memory allocator is being used.
1413 We read data and queue up the buffers, then spit them out one at a
1414 time to the output mailbox when the output mailbox is ready for one.
1417 #define INITIAL_TOCHILDQUEUE 2
1420 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1424 char mbx1[64], mbx2[64];
1425 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1426 DSC$K_CLASS_S, mbx1},
1427 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1428 DSC$K_CLASS_S, mbx2};
1429 unsigned int dviitm = DVI$_DEVBUFSIZ;
1432 New(1368, p, 1, Pipe);
1434 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1435 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1436 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1439 p->shut_on_empty = FALSE;
1440 p->need_wake = FALSE;
1443 p->iosb.status = SS$_NORMAL;
1444 p->iosb2.status = SS$_NORMAL;
1450 #ifdef PERL_IMPLICIT_CONTEXT
1454 n = sizeof(CBuf) + p->bufsize;
1456 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1457 _ckvmssts(lib$get_vm(&n, &b));
1458 b->buf = (char *) b + sizeof(CBuf);
1459 _ckvmssts(lib$insqhi(b, &p->free));
1462 pipe_tochild2_ast(p);
1463 pipe_tochild1_ast(p);
1469 /* reads the MBX Perl is writing, and queues */
1472 pipe_tochild1_ast(pPipe p)
1475 int iss = p->iosb.status;
1476 int eof = (iss == SS$_ENDOFFILE);
1477 #ifdef PERL_IMPLICIT_CONTEXT
1483 p->shut_on_empty = TRUE;
1485 _ckvmssts(sys$dassgn(p->chan_in));
1491 b->size = p->iosb.count;
1492 _ckvmssts(lib$insqhi(b, &p->wait));
1494 p->need_wake = FALSE;
1495 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1498 p->retry = 1; /* initial call */
1501 if (eof) { /* flush the free queue, return when done */
1502 int n = sizeof(CBuf) + p->bufsize;
1504 iss = lib$remqti(&p->free, &b);
1505 if (iss == LIB$_QUEWASEMP) return;
1507 _ckvmssts(lib$free_vm(&n, &b));
1511 iss = lib$remqti(&p->free, &b);
1512 if (iss == LIB$_QUEWASEMP) {
1513 int n = sizeof(CBuf) + p->bufsize;
1514 _ckvmssts(lib$get_vm(&n, &b));
1515 b->buf = (char *) b + sizeof(CBuf);
1521 iss = sys$qio(0,p->chan_in,
1522 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1524 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1525 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1530 /* writes queued buffers to output, waits for each to complete before
1534 pipe_tochild2_ast(pPipe p)
1537 int iss = p->iosb2.status;
1538 int n = sizeof(CBuf) + p->bufsize;
1539 int done = (p->info && p->info->done) ||
1540 iss == SS$_CANCEL || iss == SS$_ABORT;
1541 #if defined(PERL_IMPLICIT_CONTEXT)
1546 if (p->type) { /* type=1 has old buffer, dispose */
1547 if (p->shut_on_empty) {
1548 _ckvmssts(lib$free_vm(&n, &b));
1550 _ckvmssts(lib$insqhi(b, &p->free));
1555 iss = lib$remqti(&p->wait, &b);
1556 if (iss == LIB$_QUEWASEMP) {
1557 if (p->shut_on_empty) {
1559 _ckvmssts(sys$dassgn(p->chan_out));
1560 *p->pipe_done = TRUE;
1561 _ckvmssts(sys$setef(pipe_ef));
1563 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1564 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1568 p->need_wake = TRUE;
1578 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1579 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1581 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1582 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1591 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1594 char mbx1[64], mbx2[64];
1595 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1596 DSC$K_CLASS_S, mbx1},
1597 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1598 DSC$K_CLASS_S, mbx2};
1599 unsigned int dviitm = DVI$_DEVBUFSIZ;
1601 New(1367, p, 1, Pipe);
1602 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1603 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1605 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1606 New(1367, p->buf, p->bufsize, char);
1607 p->shut_on_empty = FALSE;
1610 p->iosb.status = SS$_NORMAL;
1611 #if defined(PERL_IMPLICIT_CONTEXT)
1614 pipe_infromchild_ast(p);
1622 pipe_infromchild_ast(pPipe p)
1624 int iss = p->iosb.status;
1625 int eof = (iss == SS$_ENDOFFILE);
1626 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1627 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1628 #if defined(PERL_IMPLICIT_CONTEXT)
1632 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1633 _ckvmssts(sys$dassgn(p->chan_out));
1638 input shutdown if EOF from self (done or shut_on_empty)
1639 output shutdown if closing flag set (my_pclose)
1640 send data/eof from child or eof from self
1641 otherwise, re-read (snarf of data from child)
1646 if (myeof && p->chan_in) { /* input shutdown */
1647 _ckvmssts(sys$dassgn(p->chan_in));
1652 if (myeof || kideof) { /* pass EOF to parent */
1653 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1654 pipe_infromchild_ast, p,
1657 } else if (eof) { /* eat EOF --- fall through to read*/
1659 } else { /* transmit data */
1660 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1661 pipe_infromchild_ast,p,
1662 p->buf, p->iosb.count, 0, 0, 0, 0));
1668 /* everything shut? flag as done */
1670 if (!p->chan_in && !p->chan_out) {
1671 *p->pipe_done = TRUE;
1672 _ckvmssts(sys$setef(pipe_ef));
1676 /* write completed (or read, if snarfing from child)
1677 if still have input active,
1678 queue read...immediate mode if shut_on_empty so we get EOF if empty
1680 check if Perl reading, generate EOFs as needed
1686 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1687 pipe_infromchild_ast,p,
1688 p->buf, p->bufsize, 0, 0, 0, 0);
1689 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1691 } else { /* send EOFs for extra reads */
1692 p->iosb.status = SS$_ENDOFFILE;
1693 p->iosb.dvispec = 0;
1694 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1696 pipe_infromchild_ast, p, 0, 0, 0, 0));
1702 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1706 unsigned long dviitm = DVI$_DEVBUFSIZ;
1708 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1709 DSC$K_CLASS_S, mbx};
1711 /* things like terminals and mbx's don't need this filter */
1712 if (fd && fstat(fd,&s) == 0) {
1713 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1714 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1715 DSC$K_CLASS_S, s.st_dev};
1717 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1718 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1719 strcpy(out, s.st_dev);
1724 New(1366, p, 1, Pipe);
1725 p->fd_out = dup(fd);
1726 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1727 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1728 New(1366, p->buf, p->bufsize+1, char);
1729 p->shut_on_empty = FALSE;
1734 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1735 pipe_mbxtofd_ast, p,
1736 p->buf, p->bufsize, 0, 0, 0, 0));
1742 pipe_mbxtofd_ast(pPipe p)
1744 int iss = p->iosb.status;
1745 int done = p->info->done;
1747 int eof = (iss == SS$_ENDOFFILE);
1748 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1749 int err = !(iss&1) && !eof;
1750 #if defined(PERL_IMPLICIT_CONTEXT)
1754 if (done && myeof) { /* end piping */
1756 sys$dassgn(p->chan_in);
1757 *p->pipe_done = TRUE;
1758 _ckvmssts(sys$setef(pipe_ef));
1762 if (!err && !eof) { /* good data to send to file */
1763 p->buf[p->iosb.count] = '\n';
1764 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1767 if (p->retry < MAX_RETRY) {
1768 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1778 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1779 pipe_mbxtofd_ast, p,
1780 p->buf, p->bufsize, 0, 0, 0, 0);
1781 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1786 typedef struct _pipeloc PLOC;
1787 typedef struct _pipeloc* pPLOC;
1791 char dir[NAM$C_MAXRSS+1];
1793 static pPLOC head_PLOC = 0;
1796 free_pipelocs(pTHX_ void *head)
1809 store_pipelocs(pTHX)
1813 AV *av = GvAVn(PL_incgv);
1818 char temp[NAM$C_MAXRSS+1];
1821 /* the . directory from @INC comes last */
1824 p->next = head_PLOC;
1826 strcpy(p->dir,"./");
1828 /* get the directory from $^X */
1830 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
1831 strcpy(temp, PL_origargv[0]);
1832 x = strrchr(temp,']');
1835 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
1837 p->next = head_PLOC;
1839 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1840 p->dir[NAM$C_MAXRSS] = '\0';
1844 /* reverse order of @INC entries, skip "." since entered above */
1846 for (i = 0; i <= AvFILL(av); i++) {
1847 dirsv = *av_fetch(av,i,TRUE);
1849 if (SvROK(dirsv)) continue;
1850 dir = SvPVx(dirsv,n_a);
1851 if (strcmp(dir,".") == 0) continue;
1852 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
1856 p->next = head_PLOC;
1858 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1859 p->dir[NAM$C_MAXRSS] = '\0';
1862 /* most likely spot (ARCHLIB) put first in the list */
1865 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
1867 p->next = head_PLOC;
1869 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
1870 p->dir[NAM$C_MAXRSS] = '\0';
1873 Perl_call_atexit(aTHX_ &free_pipelocs, head_PLOC);
1880 static int vmspipe_file_status = 0;
1881 static char vmspipe_file[NAM$C_MAXRSS+1];
1883 /* already found? Check and use ... need read+execute permission */
1885 if (vmspipe_file_status == 1) {
1886 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1887 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1888 return vmspipe_file;
1890 vmspipe_file_status = 0;
1893 /* scan through stored @INC, $^X */
1895 if (vmspipe_file_status == 0) {
1896 char file[NAM$C_MAXRSS+1];
1897 pPLOC p = head_PLOC;
1900 strcpy(file, p->dir);
1901 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
1902 file[NAM$C_MAXRSS] = '\0';
1905 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
1907 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
1908 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
1909 vmspipe_file_status = 1;
1910 return vmspipe_file;
1913 vmspipe_file_status = -1; /* failed, use tempfiles */
1920 vmspipe_tempfile(pTHX)
1922 char file[NAM$C_MAXRSS+1];
1924 static int index = 0;
1927 /* create a tempfile */
1929 /* we can't go from W, shr=get to R, shr=get without
1930 an intermediate vulnerable state, so don't bother trying...
1932 and lib$spawn doesn't shr=put, so have to close the write
1934 So... match up the creation date/time and the FID to
1935 make sure we're dealing with the same file
1940 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
1941 fp = fopen(file,"w");
1943 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
1944 fp = fopen(file,"w");
1946 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
1947 fp = fopen(file,"w");
1950 if (!fp) return 0; /* we're hosed */
1952 fprintf(fp,"$! 'f$verify(0)\n");
1953 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
1954 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
1955 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
1956 fprintf(fp,"$ perl_on = \"set noon\"\n");
1957 fprintf(fp,"$ perl_exit = \"exit\"\n");
1958 fprintf(fp,"$ perl_del = \"delete\"\n");
1959 fprintf(fp,"$ pif = \"if\"\n");
1960 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1961 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
1962 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
1963 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
1964 fprintf(fp,"$ cmd = perl_popen_cmd\n");
1965 fprintf(fp,"$! --- get rid of global symbols\n");
1966 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
1967 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
1968 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
1969 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
1970 fprintf(fp,"$ perl_on\n");
1971 fprintf(fp,"$ 'cmd\n");
1972 fprintf(fp,"$ perl_status = $STATUS\n");
1973 fprintf(fp,"$ perl_del 'perl_cfile'\n");
1974 fprintf(fp,"$ perl_exit 'perl_status'\n");
1977 fgetname(fp, file, 1);
1978 fstat(fileno(fp), &s0);
1981 fp = fopen(file,"r","shr=get");
1983 fstat(fileno(fp), &s1);
1985 if (s0.st_ino[0] != s1.st_ino[0] ||
1986 s0.st_ino[1] != s1.st_ino[1] ||
1987 s0.st_ino[2] != s1.st_ino[2] ||
1988 s0.st_ctime != s1.st_ctime ) {
1999 safe_popen(pTHX_ char *cmd, char *mode)
2001 static int handler_set_up = FALSE;
2002 unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
2003 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2004 char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2005 char in[512], out[512], err[512], mbx[512];
2007 char tfilebuf[NAM$C_MAXRSS+1];
2009 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2010 DSC$K_CLASS_S, symbol};
2011 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2014 $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
2015 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2016 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2017 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2019 /* once-per-program initialization...
2020 note that the SETAST calls and the dual test of pipe_ef
2021 makes sure that only the FIRST thread through here does
2022 the initialization...all other threads wait until it's
2025 Yeah, uglier than a pthread call, it's got all the stuff inline
2026 rather than in a separate routine.
2030 _ckvmssts(sys$setast(0));
2032 unsigned long int pidcode = JPI$_PID;
2033 $DESCRIPTOR(d_delay, RETRY_DELAY);
2034 _ckvmssts(lib$get_ef(&pipe_ef));
2035 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2036 _ckvmssts(sys$bintim(&d_delay, delaytime));
2038 if (!handler_set_up) {
2039 _ckvmssts(sys$dclexh(&pipe_exitblock));
2040 handler_set_up = TRUE;
2042 _ckvmssts(sys$setast(1));
2045 /* see if we can find a VMSPIPE.COM */
2048 vmspipe = find_vmspipe(aTHX);
2050 strcpy(tfilebuf+1,vmspipe);
2051 } else { /* uh, oh...we're in tempfile hell */
2052 tpipe = vmspipe_tempfile(aTHX);
2053 if (!tpipe) { /* a fish popular in Boston */
2054 if (ckWARN(WARN_PIPE)) {
2055 Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping");
2059 fgetname(tpipe,tfilebuf+1,1);
2061 vmspipedsc.dsc$a_pointer = tfilebuf;
2062 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2064 if (!(setup_cmddsc(aTHX_ cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; }
2065 New(1301,info,1,Info);
2069 info->completion = 0;
2070 info->closing = FALSE;
2074 info->in_done = TRUE;
2075 info->out_done = TRUE;
2076 info->err_done = TRUE;
2077 in[0] = out[0] = err[0] = '\0';
2079 if (*mode == 'r') { /* piping from subroutine */
2081 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2083 info->out->pipe_done = &info->out_done;
2084 info->out_done = FALSE;
2085 info->out->info = info;
2087 info->fp = PerlIO_open(mbx, mode);
2088 if (!info->fp && info->out) {
2089 sys$cancel(info->out->chan_out);
2091 while (!info->out_done) {
2093 _ckvmssts(sys$setast(0));
2094 done = info->out_done;
2095 if (!done) _ckvmssts(sys$clref(pipe_ef));
2096 _ckvmssts(sys$setast(1));
2097 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2100 if (info->out->buf) Safefree(info->out->buf);
2101 Safefree(info->out);
2106 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2108 info->err->pipe_done = &info->err_done;
2109 info->err_done = FALSE;
2110 info->err->info = info;
2113 } else { /* piping to subroutine , mode=w*/
2115 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2116 info->fp = PerlIO_open(mbx, mode);
2118 info->in->pipe_done = &info->in_done;
2119 info->in_done = FALSE;
2120 info->in->info = info;
2124 if (!info->fp && info->in) {
2126 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2127 0, 0, 0, 0, 0, 0, 0, 0));
2129 while (!info->in_done) {
2131 _ckvmssts(sys$setast(0));
2132 done = info->in_done;
2133 if (!done) _ckvmssts(sys$clref(pipe_ef));
2134 _ckvmssts(sys$setast(1));
2135 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2138 if (info->in->buf) Safefree(info->in->buf);
2145 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2147 info->out->pipe_done = &info->out_done;
2148 info->out_done = FALSE;
2149 info->out->info = info;
2152 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2154 info->err->pipe_done = &info->err_done;
2155 info->err_done = FALSE;
2156 info->err->info = info;
2160 symbol[MAX_DCL_SYMBOL] = '\0';
2162 strncpy(symbol, in, MAX_DCL_SYMBOL);
2163 d_symbol.dsc$w_length = strlen(symbol);
2164 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2166 strncpy(symbol, err, MAX_DCL_SYMBOL);
2167 d_symbol.dsc$w_length = strlen(symbol);
2168 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2170 strncpy(symbol, out, MAX_DCL_SYMBOL);
2171 d_symbol.dsc$w_length = strlen(symbol);
2172 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2174 p = VMScmd.dsc$a_pointer;
2175 while (*p && *p != '\n') p++;
2176 *p = '\0'; /* truncate on \n */
2177 p = VMScmd.dsc$a_pointer;
2178 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2179 if (*p == '$') p++; /* remove leading $ */
2180 while (*p == ' ' || *p == '\t') p++;
2181 strncpy(symbol, p, MAX_DCL_SYMBOL);
2182 d_symbol.dsc$w_length = strlen(symbol);
2183 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2185 _ckvmssts(sys$setast(0));
2186 info->next=open_pipes; /* prepend to list */
2188 _ckvmssts(sys$setast(1));
2189 _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
2190 0, &info->pid, &info->completion,
2191 0, popen_completion_ast,info,0,0,0));
2193 /* if we were using a tempfile, close it now */
2195 if (tpipe) fclose(tpipe);
2197 /* once the subprocess is spawned, its copied the symbols and
2198 we can get rid of ours */
2200 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2201 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2202 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2203 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2206 PL_forkprocess = info->pid;
2208 } /* end of safe_popen */
2211 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2213 Perl_my_popen(pTHX_ char *cmd, char *mode)
2216 TAINT_PROPER("popen");
2217 PERL_FLUSHALL_FOR_CHILD;
2218 return safe_popen(aTHX_ cmd,mode);
2223 /*{{{ I32 my_pclose(PerlIO *fp)*/
2224 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2226 pInfo info, last = NULL;
2227 unsigned long int retsts;
2230 for (info = open_pipes; info != NULL; last = info, info = info->next)
2231 if (info->fp == fp) break;
2233 if (info == NULL) { /* no such pipe open */
2234 set_errno(ECHILD); /* quoth POSIX */
2235 set_vaxc_errno(SS$_NONEXPR);
2239 /* If we were writing to a subprocess, insure that someone reading from
2240 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2241 * produce an EOF record in the mailbox.
2243 * well, at least sometimes it *does*, so we have to watch out for
2244 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2247 PerlIO_flush(info->fp); /* first, flush data */
2249 _ckvmssts(sys$setast(0));
2250 info->closing = TRUE;
2251 done = info->done && info->in_done && info->out_done && info->err_done;
2252 /* hanging on write to Perl's input? cancel it */
2253 if (info->mode == 'r' && info->out && !info->out_done) {
2254 if (info->out->chan_out) {
2255 _ckvmssts(sys$cancel(info->out->chan_out));
2256 if (!info->out->chan_in) { /* EOF generation, need AST */
2257 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2261 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2262 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2264 _ckvmssts(sys$setast(1));
2265 PerlIO_close(info->fp);
2268 we have to wait until subprocess completes, but ALSO wait until all
2269 the i/o completes...otherwise we'll be freeing the "info" structure
2270 that the i/o ASTs could still be using...
2274 _ckvmssts(sys$setast(0));
2275 done = info->done && info->in_done && info->out_done && info->err_done;
2276 if (!done) _ckvmssts(sys$clref(pipe_ef));
2277 _ckvmssts(sys$setast(1));
2278 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2280 retsts = info->completion;
2282 /* remove from list of open pipes */
2283 _ckvmssts(sys$setast(0));
2284 if (last) last->next = info->next;
2285 else open_pipes = info->next;
2286 _ckvmssts(sys$setast(1));
2288 /* free buffers and structures */
2291 if (info->in->buf) Safefree(info->in->buf);
2295 if (info->out->buf) Safefree(info->out->buf);
2296 Safefree(info->out);
2299 if (info->err->buf) Safefree(info->err->buf);
2300 Safefree(info->err);
2306 } /* end of my_pclose() */
2308 /* sort-of waitpid; use only with popen() */
2309 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2311 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2316 for (info = open_pipes; info != NULL; info = info->next)
2317 if (info->pid == pid) break;
2319 if (info != NULL) { /* we know about this child */
2320 while (!info->done) {
2321 _ckvmssts(sys$setast(0));
2323 if (!done) _ckvmssts(sys$clref(pipe_ef));
2324 _ckvmssts(sys$setast(1));
2325 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2328 *statusp = info->completion;
2331 else { /* we haven't heard of this child */
2332 $DESCRIPTOR(intdsc,"0 00:00:01");
2333 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
2334 unsigned long int interval[2],sts;
2336 if (ckWARN(WARN_EXEC)) {
2337 _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
2338 _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
2339 if (ownerpid != mypid)
2340 Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
2343 _ckvmssts(sys$bintim(&intdsc,interval));
2344 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2345 _ckvmssts(sys$schdwk(0,0,interval,0));
2346 _ckvmssts(sys$hiber());
2348 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2351 /* There's no easy way to find the termination status a child we're
2352 * not aware of beforehand. If we're really interested in the future,
2353 * we can go looking for a termination mailbox, or chase after the
2354 * accounting record for the process.
2360 } /* end of waitpid() */
2365 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2367 my_gconvert(double val, int ndig, int trail, char *buf)
2369 static char __gcvtbuf[DBL_DIG+1];
2372 loc = buf ? buf : __gcvtbuf;
2374 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2376 sprintf(loc,"%.*g",ndig,val);
2382 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2383 return gcvt(val,ndig,loc);
2386 loc[0] = '0'; loc[1] = '\0';
2394 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2395 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2396 * to expand file specification. Allows for a single default file
2397 * specification and a simple mask of options. If outbuf is non-NULL,
2398 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2399 * the resultant file specification is placed. If outbuf is NULL, the
2400 * resultant file specification is placed into a static buffer.
2401 * The third argument, if non-NULL, is taken to be a default file
2402 * specification string. The fourth argument is unused at present.
2403 * rmesexpand() returns the address of the resultant string if
2404 * successful, and NULL on error.
2406 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2409 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2411 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2412 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2413 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2414 struct FAB myfab = cc$rms_fab;
2415 struct NAM mynam = cc$rms_nam;
2417 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2419 if (!filespec || !*filespec) {
2420 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2424 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2425 else outbuf = __rmsexpand_retbuf;
2427 if ((isunix = (strchr(filespec,'/') != NULL))) {
2428 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2429 filespec = vmsfspec;
2432 myfab.fab$l_fna = filespec;
2433 myfab.fab$b_fns = strlen(filespec);
2434 myfab.fab$l_nam = &mynam;
2436 if (defspec && *defspec) {
2437 if (strchr(defspec,'/') != NULL) {
2438 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2441 myfab.fab$l_dna = defspec;
2442 myfab.fab$b_dns = strlen(defspec);
2445 mynam.nam$l_esa = esa;
2446 mynam.nam$b_ess = sizeof esa;
2447 mynam.nam$l_rsa = outbuf;
2448 mynam.nam$b_rss = NAM$C_MAXRSS;
2450 retsts = sys$parse(&myfab,0,0);
2451 if (!(retsts & 1)) {
2452 mynam.nam$b_nop |= NAM$M_SYNCHK;
2453 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2454 retsts = sys$parse(&myfab,0,0);
2455 if (retsts & 1) goto expanded;
2457 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2458 (void) sys$parse(&myfab,0,0); /* Free search context */
2459 if (out) Safefree(out);
2460 set_vaxc_errno(retsts);
2461 if (retsts == RMS$_PRV) set_errno(EACCES);
2462 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2463 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2464 else set_errno(EVMSERR);
2467 retsts = sys$search(&myfab,0,0);
2468 if (!(retsts & 1) && retsts != RMS$_FNF) {
2469 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2470 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2471 if (out) Safefree(out);
2472 set_vaxc_errno(retsts);
2473 if (retsts == RMS$_PRV) set_errno(EACCES);
2474 else set_errno(EVMSERR);
2478 /* If the input filespec contained any lowercase characters,
2479 * downcase the result for compatibility with Unix-minded code. */
2481 for (out = myfab.fab$l_fna; *out; out++)
2482 if (islower(*out)) { haslower = 1; break; }
2483 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2484 else { out = esa; speclen = mynam.nam$b_esl; }
2485 /* Trim off null fields added by $PARSE
2486 * If type > 1 char, must have been specified in original or default spec
2487 * (not true for version; $SEARCH may have added version of existing file).
2489 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2490 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2491 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2492 if (trimver || trimtype) {
2493 if (defspec && *defspec) {
2494 char defesa[NAM$C_MAXRSS];
2495 struct FAB deffab = cc$rms_fab;
2496 struct NAM defnam = cc$rms_nam;
2498 deffab.fab$l_nam = &defnam;
2499 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2500 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2501 defnam.nam$b_nop = NAM$M_SYNCHK;
2502 if (sys$parse(&deffab,0,0) & 1) {
2503 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2504 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2507 if (trimver) speclen = mynam.nam$l_ver - out;
2509 /* If we didn't already trim version, copy down */
2510 if (speclen > mynam.nam$l_ver - out)
2511 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2512 speclen - (mynam.nam$l_ver - out));
2513 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2516 /* If we just had a directory spec on input, $PARSE "helpfully"
2517 * adds an empty name and type for us */
2518 if (mynam.nam$l_name == mynam.nam$l_type &&
2519 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2520 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2521 speclen = mynam.nam$l_name - out;
2522 out[speclen] = '\0';
2523 if (haslower) __mystrtolower(out);
2525 /* Have we been working with an expanded, but not resultant, spec? */
2526 /* Also, convert back to Unix syntax if necessary. */
2527 if (!mynam.nam$b_rsl) {
2529 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2531 else strcpy(outbuf,esa);
2534 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2535 strcpy(outbuf,tmpfspec);
2537 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2538 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2539 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2543 /* External entry points */
2544 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2545 { return do_rmsexpand(spec,buf,0,def,opt); }
2546 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2547 { return do_rmsexpand(spec,buf,1,def,opt); }
2551 ** The following routines are provided to make life easier when
2552 ** converting among VMS-style and Unix-style directory specifications.
2553 ** All will take input specifications in either VMS or Unix syntax. On
2554 ** failure, all return NULL. If successful, the routines listed below
2555 ** return a pointer to a buffer containing the appropriately
2556 ** reformatted spec (and, therefore, subsequent calls to that routine
2557 ** will clobber the result), while the routines of the same names with
2558 ** a _ts suffix appended will return a pointer to a mallocd string
2559 ** containing the appropriately reformatted spec.
2560 ** In all cases, only explicit syntax is altered; no check is made that
2561 ** the resulting string is valid or that the directory in question
2564 ** fileify_dirspec() - convert a directory spec into the name of the
2565 ** directory file (i.e. what you can stat() to see if it's a dir).
2566 ** The style (VMS or Unix) of the result is the same as the style
2567 ** of the parameter passed in.
2568 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2569 ** what you prepend to a filename to indicate what directory it's in).
2570 ** The style (VMS or Unix) of the result is the same as the style
2571 ** of the parameter passed in.
2572 ** tounixpath() - convert a directory spec into a Unix-style path.
2573 ** tovmspath() - convert a directory spec into a VMS-style path.
2574 ** tounixspec() - convert any file spec into a Unix-style file spec.
2575 ** tovmsspec() - convert any file spec into a VMS-style spec.
2577 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2578 ** Permission is given to distribute this code as part of the Perl
2579 ** standard distribution under the terms of the GNU General Public
2580 ** License or the Perl Artistic License. Copies of each may be
2581 ** found in the Perl standard distribution.
2584 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
2585 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
2587 static char __fileify_retbuf[NAM$C_MAXRSS+1];
2588 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
2589 char *retspec, *cp1, *cp2, *lastdir;
2590 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
2592 if (!dir || !*dir) {
2593 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2595 dirlen = strlen(dir);
2596 while (dirlen && dir[dirlen-1] == '/') --dirlen;
2597 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
2598 strcpy(trndir,"/sys$disk/000000");
2602 if (dirlen > NAM$C_MAXRSS) {
2603 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
2605 if (!strpbrk(dir+1,"/]>:")) {
2606 strcpy(trndir,*dir == '/' ? dir + 1: dir);
2607 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
2609 dirlen = strlen(dir);
2612 strncpy(trndir,dir,dirlen);
2613 trndir[dirlen] = '\0';
2616 /* If we were handed a rooted logical name or spec, treat it like a
2617 * simple directory, so that
2618 * $ Define myroot dev:[dir.]
2619 * ... do_fileify_dirspec("myroot",buf,1) ...
2620 * does something useful.
2622 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
2623 dir[--dirlen] = '\0';
2624 dir[dirlen-1] = ']';
2627 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
2628 /* If we've got an explicit filename, we can just shuffle the string. */
2629 if (*(cp1+1)) hasfilename = 1;
2630 /* Similarly, we can just back up a level if we've got multiple levels
2631 of explicit directories in a VMS spec which ends with directories. */
2633 for (cp2 = cp1; cp2 > dir; cp2--) {
2635 *cp2 = *cp1; *cp1 = '\0';
2639 if (*cp2 == '[' || *cp2 == '<') break;
2644 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
2645 if (dir[0] == '.') {
2646 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
2647 return do_fileify_dirspec("[]",buf,ts);
2648 else if (dir[1] == '.' &&
2649 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
2650 return do_fileify_dirspec("[-]",buf,ts);
2652 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
2653 dirlen -= 1; /* to last element */
2654 lastdir = strrchr(dir,'/');
2656 else if ((cp1 = strstr(dir,"/.")) != NULL) {
2657 /* If we have "/." or "/..", VMSify it and let the VMS code
2658 * below expand it, rather than repeating the code to handle
2659 * relative components of a filespec here */
2661 if (*(cp1+2) == '.') cp1++;
2662 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
2663 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2664 if (strchr(vmsdir,'/') != NULL) {
2665 /* If do_tovmsspec() returned it, it must have VMS syntax
2666 * delimiters in it, so it's a mixed VMS/Unix spec. We take
2667 * the time to check this here only so we avoid a recursion
2668 * loop; otherwise, gigo.
2670 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
2672 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2673 return do_tounixspec(trndir,buf,ts);
2676 } while ((cp1 = strstr(cp1,"/.")) != NULL);
2677 lastdir = strrchr(dir,'/');
2679 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
2680 /* Ditto for specs that end in an MFD -- let the VMS code
2681 * figure out whether it's a real device or a rooted logical. */
2682 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
2683 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
2684 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
2685 return do_tounixspec(trndir,buf,ts);
2688 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
2689 !(lastdir = cp1 = strrchr(dir,']')) &&
2690 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
2691 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
2693 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2694 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2695 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2696 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2697 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2698 (ver || *cp3)))))) {
2700 set_vaxc_errno(RMS$_DIR);
2706 /* If we lead off with a device or rooted logical, add the MFD
2707 if we're specifying a top-level directory. */
2708 if (lastdir && *dir == '/') {
2710 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
2717 retlen = dirlen + (addmfd ? 13 : 6);
2718 if (buf) retspec = buf;
2719 else if (ts) New(1309,retspec,retlen+1,char);
2720 else retspec = __fileify_retbuf;
2722 dirlen = lastdir - dir;
2723 memcpy(retspec,dir,dirlen);
2724 strcpy(&retspec[dirlen],"/000000");
2725 strcpy(&retspec[dirlen+7],lastdir);
2728 memcpy(retspec,dir,dirlen);
2729 retspec[dirlen] = '\0';
2731 /* We've picked up everything up to the directory file name.
2732 Now just add the type and version, and we're set. */
2733 strcat(retspec,".dir;1");
2736 else { /* VMS-style directory spec */
2737 char esa[NAM$C_MAXRSS+1], term, *cp;
2738 unsigned long int sts, cmplen, haslower = 0;
2739 struct FAB dirfab = cc$rms_fab;
2740 struct NAM savnam, dirnam = cc$rms_nam;
2742 dirfab.fab$b_fns = strlen(dir);
2743 dirfab.fab$l_fna = dir;
2744 dirfab.fab$l_nam = &dirnam;
2745 dirfab.fab$l_dna = ".DIR;1";
2746 dirfab.fab$b_dns = 6;
2747 dirnam.nam$b_ess = NAM$C_MAXRSS;
2748 dirnam.nam$l_esa = esa;
2750 for (cp = dir; *cp; cp++)
2751 if (islower(*cp)) { haslower = 1; break; }
2752 if (!((sts = sys$parse(&dirfab))&1)) {
2753 if (dirfab.fab$l_sts == RMS$_DIR) {
2754 dirnam.nam$b_nop |= NAM$M_SYNCHK;
2755 sts = sys$parse(&dirfab) & 1;
2759 set_vaxc_errno(dirfab.fab$l_sts);
2765 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
2766 /* Yes; fake the fnb bits so we'll check type below */
2767 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
2769 else { /* No; just work with potential name */
2770 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
2772 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
2773 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2774 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2779 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
2780 cp1 = strchr(esa,']');
2781 if (!cp1) cp1 = strchr(esa,'>');
2782 if (cp1) { /* Should always be true */
2783 dirnam.nam$b_esl -= cp1 - esa - 1;
2784 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
2787 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
2788 /* Yep; check version while we're at it, if it's there. */
2789 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
2790 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
2791 /* Something other than .DIR[;1]. Bzzt. */
2792 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2793 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2795 set_vaxc_errno(RMS$_DIR);
2799 esa[dirnam.nam$b_esl] = '\0';
2800 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
2801 /* They provided at least the name; we added the type, if necessary, */
2802 if (buf) retspec = buf; /* in sys$parse() */
2803 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
2804 else retspec = __fileify_retbuf;
2805 strcpy(retspec,esa);
2806 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2807 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2810 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
2811 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
2813 dirnam.nam$b_esl -= 9;
2815 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
2816 if (cp1 == NULL) { /* should never happen */
2817 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2818 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2823 retlen = strlen(esa);
2824 if ((cp1 = strrchr(esa,'.')) != NULL) {
2825 /* There's more than one directory in the path. Just roll back. */
2827 if (buf) retspec = buf;
2828 else if (ts) New(1311,retspec,retlen+7,char);
2829 else retspec = __fileify_retbuf;
2830 strcpy(retspec,esa);
2833 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
2834 /* Go back and expand rooted logical name */
2835 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
2836 if (!(sys$parse(&dirfab) & 1)) {
2837 dirnam.nam$l_rlf = NULL;
2838 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2840 set_vaxc_errno(dirfab.fab$l_sts);
2843 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
2844 if (buf) retspec = buf;
2845 else if (ts) New(1312,retspec,retlen+16,char);
2846 else retspec = __fileify_retbuf;
2847 cp1 = strstr(esa,"][");
2849 memcpy(retspec,esa,dirlen);
2850 if (!strncmp(cp1+2,"000000]",7)) {
2851 retspec[dirlen-1] = '\0';
2852 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2853 if (*cp1 == '.') *cp1 = ']';
2855 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2856 memcpy(cp1+1,"000000]",7);
2860 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
2861 retspec[retlen] = '\0';
2862 /* Convert last '.' to ']' */
2863 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
2864 if (*cp1 == '.') *cp1 = ']';
2866 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
2867 memcpy(cp1+1,"000000]",7);
2871 else { /* This is a top-level dir. Add the MFD to the path. */
2872 if (buf) retspec = buf;
2873 else if (ts) New(1312,retspec,retlen+16,char);
2874 else retspec = __fileify_retbuf;
2877 while (*cp1 != ':') *(cp2++) = *(cp1++);
2878 strcpy(cp2,":[000000]");
2883 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
2884 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
2885 /* We've set up the string up through the filename. Add the
2886 type and version, and we're done. */
2887 strcat(retspec,".DIR;1");
2889 /* $PARSE may have upcased filespec, so convert output to lower
2890 * case if input contained any lowercase characters. */
2891 if (haslower) __mystrtolower(retspec);
2894 } /* end of do_fileify_dirspec() */
2896 /* External entry points */
2897 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
2898 { return do_fileify_dirspec(dir,buf,0); }
2899 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
2900 { return do_fileify_dirspec(dir,buf,1); }
2902 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
2903 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
2905 static char __pathify_retbuf[NAM$C_MAXRSS+1];
2906 unsigned long int retlen;
2907 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
2909 if (!dir || !*dir) {
2910 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
2913 if (*dir) strcpy(trndir,dir);
2914 else getcwd(trndir,sizeof trndir - 1);
2916 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
2917 && my_trnlnm(trndir,trndir,0)) {
2918 STRLEN trnlen = strlen(trndir);
2920 /* Trap simple rooted lnms, and return lnm:[000000] */
2921 if (!strcmp(trndir+trnlen-2,".]")) {
2922 if (buf) retpath = buf;
2923 else if (ts) New(1318,retpath,strlen(dir)+10,char);
2924 else retpath = __pathify_retbuf;
2925 strcpy(retpath,dir);
2926 strcat(retpath,":[000000]");
2932 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
2933 if (*dir == '.' && (*(dir+1) == '\0' ||
2934 (*(dir+1) == '.' && *(dir+2) == '\0')))
2935 retlen = 2 + (*(dir+1) != '\0');
2937 if ( !(cp1 = strrchr(dir,'/')) &&
2938 !(cp1 = strrchr(dir,']')) &&
2939 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
2940 if ((cp2 = strchr(cp1,'.')) != NULL &&
2941 (*(cp2-1) != '/' || /* Trailing '.', '..', */
2942 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
2943 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
2944 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
2946 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2947 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2948 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2949 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2950 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2951 (ver || *cp3)))))) {
2953 set_vaxc_errno(RMS$_DIR);
2956 retlen = cp2 - dir + 1;
2958 else { /* No file type present. Treat the filename as a directory. */
2959 retlen = strlen(dir) + 1;
2962 if (buf) retpath = buf;
2963 else if (ts) New(1313,retpath,retlen+1,char);
2964 else retpath = __pathify_retbuf;
2965 strncpy(retpath,dir,retlen-1);
2966 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
2967 retpath[retlen-1] = '/'; /* with '/', add it. */
2968 retpath[retlen] = '\0';
2970 else retpath[retlen-1] = '\0';
2972 else { /* VMS-style directory spec */
2973 char esa[NAM$C_MAXRSS+1], *cp;
2974 unsigned long int sts, cmplen, haslower;
2975 struct FAB dirfab = cc$rms_fab;
2976 struct NAM savnam, dirnam = cc$rms_nam;
2978 /* If we've got an explicit filename, we can just shuffle the string. */
2979 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
2980 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
2981 if ((cp2 = strchr(cp1,'.')) != NULL) {
2983 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
2984 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
2985 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
2986 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
2987 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
2988 (ver || *cp3)))))) {
2990 set_vaxc_errno(RMS$_DIR);
2994 else { /* No file type, so just draw name into directory part */
2995 for (cp2 = cp1; *cp2; cp2++) ;
2998 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3000 /* We've now got a VMS 'path'; fall through */
3002 dirfab.fab$b_fns = strlen(dir);
3003 dirfab.fab$l_fna = dir;
3004 if (dir[dirfab.fab$b_fns-1] == ']' ||
3005 dir[dirfab.fab$b_fns-1] == '>' ||
3006 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3007 if (buf) retpath = buf;
3008 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3009 else retpath = __pathify_retbuf;
3010 strcpy(retpath,dir);
3013 dirfab.fab$l_dna = ".DIR;1";
3014 dirfab.fab$b_dns = 6;
3015 dirfab.fab$l_nam = &dirnam;
3016 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3017 dirnam.nam$l_esa = esa;
3019 for (cp = dir; *cp; cp++)
3020 if (islower(*cp)) { haslower = 1; break; }
3022 if (!(sts = (sys$parse(&dirfab)&1))) {
3023 if (dirfab.fab$l_sts == RMS$_DIR) {
3024 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3025 sts = sys$parse(&dirfab) & 1;
3029 set_vaxc_errno(dirfab.fab$l_sts);
3035 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3036 if (dirfab.fab$l_sts != RMS$_FNF) {
3037 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3038 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3040 set_vaxc_errno(dirfab.fab$l_sts);
3043 dirnam = savnam; /* No; just work with potential name */
3046 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3047 /* Yep; check version while we're at it, if it's there. */
3048 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3049 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3050 /* Something other than .DIR[;1]. Bzzt. */
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);
3054 set_vaxc_errno(RMS$_DIR);
3058 /* OK, the type was fine. Now pull any file name into the
3060 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3062 cp1 = strrchr(esa,'>');
3063 *dirnam.nam$l_type = '>';
3066 *(dirnam.nam$l_type + 1) = '\0';
3067 retlen = dirnam.nam$l_type - esa + 2;
3068 if (buf) retpath = buf;
3069 else if (ts) New(1314,retpath,retlen,char);
3070 else retpath = __pathify_retbuf;
3071 strcpy(retpath,esa);
3072 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3073 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3074 /* $PARSE may have upcased filespec, so convert output to lower
3075 * case if input contained any lowercase characters. */
3076 if (haslower) __mystrtolower(retpath);
3080 } /* end of do_pathify_dirspec() */
3082 /* External entry points */
3083 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3084 { return do_pathify_dirspec(dir,buf,0); }
3085 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3086 { return do_pathify_dirspec(dir,buf,1); }
3088 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3089 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3091 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3092 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3093 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3095 if (spec == NULL) return NULL;
3096 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3097 if (buf) rslt = buf;
3099 retlen = strlen(spec);
3100 cp1 = strchr(spec,'[');
3101 if (!cp1) cp1 = strchr(spec,'<');
3103 for (cp1++; *cp1; cp1++) {
3104 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3105 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3106 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3109 New(1315,rslt,retlen+2+2*expand,char);
3111 else rslt = __tounixspec_retbuf;
3112 if (strchr(spec,'/') != NULL) {
3119 dirend = strrchr(spec,']');
3120 if (dirend == NULL) dirend = strrchr(spec,'>');
3121 if (dirend == NULL) dirend = strchr(spec,':');
3122 if (dirend == NULL) {
3126 if (*cp2 != '[' && *cp2 != '<') {
3129 else { /* the VMS spec begins with directories */
3131 if (*cp2 == ']' || *cp2 == '>') {
3132 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3135 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3136 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3137 if (ts) Safefree(rslt);
3142 while (*cp3 != ':' && *cp3) cp3++;
3144 if (strchr(cp3,']') != NULL) break;
3145 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3147 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3148 retlen = devlen + dirlen;
3149 Renew(rslt,retlen+1+2*expand,char);
3155 *(cp1++) = *(cp3++);
3156 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3160 else if ( *cp2 == '.') {
3161 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3162 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3168 for (; cp2 <= dirend; cp2++) {
3171 if (*(cp2+1) == '[') cp2++;
3173 else if (*cp2 == ']' || *cp2 == '>') {
3174 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3176 else if (*cp2 == '.') {
3178 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3179 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3180 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3181 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3182 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3184 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3185 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3189 else if (*cp2 == '-') {
3190 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3191 while (*cp2 == '-') {
3193 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3195 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3196 if (ts) Safefree(rslt); /* filespecs like */
3197 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3201 else *(cp1++) = *cp2;
3203 else *(cp1++) = *cp2;
3205 while (*cp2) *(cp1++) = *(cp2++);
3210 } /* end of do_tounixspec() */
3212 /* External entry points */
3213 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3214 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3216 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3217 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3218 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3219 char *rslt, *dirend;
3220 register char *cp1, *cp2;
3221 unsigned long int infront = 0, hasdir = 1;
3223 if (path == NULL) return NULL;
3224 if (buf) rslt = buf;
3225 else if (ts) New(1316,rslt,strlen(path)+9,char);
3226 else rslt = __tovmsspec_retbuf;
3227 if (strpbrk(path,"]:>") ||
3228 (dirend = strrchr(path,'/')) == NULL) {
3229 if (path[0] == '.') {
3230 if (path[1] == '\0') strcpy(rslt,"[]");
3231 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3232 else strcpy(rslt,path); /* probably garbage */
3234 else strcpy(rslt,path);
3237 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3238 if (!*(dirend+2)) dirend +=2;
3239 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3240 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3245 char trndev[NAM$C_MAXRSS+1];
3249 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3251 if (!buf & ts) Renew(rslt,18,char);
3252 strcpy(rslt,"sys$disk:[000000]");
3255 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3257 islnm = my_trnlnm(rslt,trndev,0);
3258 trnend = islnm ? strlen(trndev) - 1 : 0;
3259 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3260 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3261 /* If the first element of the path is a logical name, determine
3262 * whether it has to be translated so we can add more directories. */
3263 if (!islnm || rooted) {
3266 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3270 if (cp2 != dirend) {
3271 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3272 strcpy(rslt,trndev);
3273 cp1 = rslt + trnend;
3286 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3287 cp2 += 2; /* skip over "./" - it's redundant */
3288 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3290 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3291 *(cp1++) = '-'; /* "../" --> "-" */
3294 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3295 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3296 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3297 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3300 if (cp2 > dirend) cp2 = dirend;
3302 else *(cp1++) = '.';
3304 for (; cp2 < dirend; cp2++) {
3306 if (*(cp2-1) == '/') continue;
3307 if (*(cp1-1) != '.') *(cp1++) = '.';
3310 else if (!infront && *cp2 == '.') {
3311 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3312 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3313 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3314 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3315 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3316 else { /* back up over previous directory name */
3318 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3319 if (*(cp1-1) == '[') {
3320 memcpy(cp1,"000000.",7);
3325 if (cp2 == dirend) break;
3327 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3328 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3329 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3330 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3332 *(cp1++) = '.'; /* Simulate trailing '/' */
3333 cp2 += 2; /* for loop will incr this to == dirend */
3335 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3337 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3340 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3341 if (*cp2 == '.') *(cp1++) = '_';
3342 else *(cp1++) = *cp2;
3346 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3347 if (hasdir) *(cp1++) = ']';
3348 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3349 while (*cp2) *(cp1++) = *(cp2++);
3354 } /* end of do_tovmsspec() */
3356 /* External entry points */
3357 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3358 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3360 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3361 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3362 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3364 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3366 if (path == NULL) return NULL;
3367 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3368 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3369 if (buf) return buf;
3371 vmslen = strlen(vmsified);
3372 New(1317,cp,vmslen+1,char);
3373 memcpy(cp,vmsified,vmslen);
3378 strcpy(__tovmspath_retbuf,vmsified);
3379 return __tovmspath_retbuf;
3382 } /* end of do_tovmspath() */
3384 /* External entry points */
3385 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3386 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3389 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3390 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3391 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3393 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3395 if (path == NULL) return NULL;
3396 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3397 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3398 if (buf) return buf;
3400 unixlen = strlen(unixified);
3401 New(1317,cp,unixlen+1,char);
3402 memcpy(cp,unixified,unixlen);
3407 strcpy(__tounixpath_retbuf,unixified);
3408 return __tounixpath_retbuf;
3411 } /* end of do_tounixpath() */
3413 /* External entry points */
3414 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3415 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3418 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3420 *****************************************************************************
3422 * Copyright (C) 1989-1994 by *
3423 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3425 * Permission is hereby granted for the reproduction of this software, *
3426 * on condition that this copyright notice is included in the reproduction, *
3427 * and that such reproduction is not for purposes of profit or material *
3430 * 27-Aug-1994 Modified for inclusion in perl5 *
3431 * by Charles Bailey bailey@newman.upenn.edu *
3432 *****************************************************************************
3436 * getredirection() is intended to aid in porting C programs
3437 * to VMS (Vax-11 C). The native VMS environment does not support
3438 * '>' and '<' I/O redirection, or command line wild card expansion,
3439 * or a command line pipe mechanism using the '|' AND background
3440 * command execution '&'. All of these capabilities are provided to any
3441 * C program which calls this procedure as the first thing in the
3443 * The piping mechanism will probably work with almost any 'filter' type
3444 * of program. With suitable modification, it may useful for other
3445 * portability problems as well.
3447 * Author: Mark Pizzolato mark@infocomm.com
3451 struct list_item *next;
3455 static void add_item(struct list_item **head,
3456 struct list_item **tail,
3460 static void mp_expand_wild_cards(pTHX_ char *item,
3461 struct list_item **head,
3462 struct list_item **tail,
3465 static int background_process(int argc, char **argv);
3467 static void pipe_and_fork(pTHX_ char **cmargv);
3469 /*{{{ void getredirection(int *ac, char ***av)*/
3471 mp_getredirection(pTHX_ int *ac, char ***av)
3473 * Process vms redirection arg's. Exit if any error is seen.
3474 * If getredirection() processes an argument, it is erased
3475 * from the vector. getredirection() returns a new argc and argv value.
3476 * In the event that a background command is requested (by a trailing "&"),
3477 * this routine creates a background subprocess, and simply exits the program.
3479 * Warning: do not try to simplify the code for vms. The code
3480 * presupposes that getredirection() is called before any data is
3481 * read from stdin or written to stdout.
3483 * Normal usage is as follows:
3489 * getredirection(&argc, &argv);
3493 int argc = *ac; /* Argument Count */
3494 char **argv = *av; /* Argument Vector */
3495 char *ap; /* Argument pointer */
3496 int j; /* argv[] index */
3497 int item_count = 0; /* Count of Items in List */
3498 struct list_item *list_head = 0; /* First Item in List */
3499 struct list_item *list_tail; /* Last Item in List */
3500 char *in = NULL; /* Input File Name */
3501 char *out = NULL; /* Output File Name */
3502 char *outmode = "w"; /* Mode to Open Output File */
3503 char *err = NULL; /* Error File Name */
3504 char *errmode = "w"; /* Mode to Open Error File */
3505 int cmargc = 0; /* Piped Command Arg Count */
3506 char **cmargv = NULL;/* Piped Command Arg Vector */
3509 * First handle the case where the last thing on the line ends with
3510 * a '&'. This indicates the desire for the command to be run in a
3511 * subprocess, so we satisfy that desire.
3514 if (0 == strcmp("&", ap))
3515 exit(background_process(--argc, argv));
3516 if (*ap && '&' == ap[strlen(ap)-1])
3518 ap[strlen(ap)-1] = '\0';
3519 exit(background_process(argc, argv));
3522 * Now we handle the general redirection cases that involve '>', '>>',
3523 * '<', and pipes '|'.
3525 for (j = 0; j < argc; ++j)
3527 if (0 == strcmp("<", argv[j]))
3531 fprintf(stderr,"No input file after < on command line");
3532 exit(LIB$_WRONUMARG);
3537 if ('<' == *(ap = argv[j]))
3542 if (0 == strcmp(">", ap))
3546 fprintf(stderr,"No output file after > on command line");
3547 exit(LIB$_WRONUMARG);
3566 fprintf(stderr,"No output file after > or >> on command line");
3567 exit(LIB$_WRONUMARG);
3571 if (('2' == *ap) && ('>' == ap[1]))
3588 fprintf(stderr,"No output file after 2> or 2>> on command line");
3589 exit(LIB$_WRONUMARG);
3593 if (0 == strcmp("|", argv[j]))
3597 fprintf(stderr,"No command into which to pipe on command line");
3598 exit(LIB$_WRONUMARG);
3600 cmargc = argc-(j+1);
3601 cmargv = &argv[j+1];
3605 if ('|' == *(ap = argv[j]))
3613 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
3616 * Allocate and fill in the new argument vector, Some Unix's terminate
3617 * the list with an extra null pointer.
3619 New(1302, argv, item_count+1, char *);
3621 for (j = 0; j < item_count; ++j, list_head = list_head->next)
3622 argv[j] = list_head->value;
3628 fprintf(stderr,"'|' and '>' may not both be specified on command line");
3629 exit(LIB$_INVARGORD);
3631 pipe_and_fork(aTHX_ cmargv);
3634 /* Check for input from a pipe (mailbox) */
3636 if (in == NULL && 1 == isapipe(0))
3638 char mbxname[L_tmpnam];
3640 long int dvi_item = DVI$_DEVBUFSIZ;
3641 $DESCRIPTOR(mbxnam, "");
3642 $DESCRIPTOR(mbxdevnam, "");
3644 /* Input from a pipe, reopen it in binary mode to disable */
3645 /* carriage control processing. */
3647 fgetname(stdin, mbxname);
3648 mbxnam.dsc$a_pointer = mbxname;
3649 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
3650 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
3651 mbxdevnam.dsc$a_pointer = mbxname;
3652 mbxdevnam.dsc$w_length = sizeof(mbxname);
3653 dvi_item = DVI$_DEVNAM;
3654 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
3655 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
3658 freopen(mbxname, "rb", stdin);
3661 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
3665 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
3667 fprintf(stderr,"Can't open input file %s as stdin",in);
3670 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
3672 fprintf(stderr,"Can't open output file %s as stdout",out);
3675 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
3678 if (strcmp(err,"&1") == 0) {
3679 dup2(fileno(stdout), fileno(stderr));
3680 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
3683 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
3685 fprintf(stderr,"Can't open error file %s as stderr",err);
3689 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
3693 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
3696 #ifdef ARGPROC_DEBUG
3697 PerlIO_printf(Perl_debug_log, "Arglist:\n");
3698 for (j = 0; j < *ac; ++j)
3699 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
3701 /* Clear errors we may have hit expanding wildcards, so they don't
3702 show up in Perl's $! later */
3703 set_errno(0); set_vaxc_errno(1);
3704 } /* end of getredirection() */
3707 static void add_item(struct list_item **head,
3708 struct list_item **tail,
3714 New(1303,*head,1,struct list_item);
3718 New(1304,(*tail)->next,1,struct list_item);
3719 *tail = (*tail)->next;
3721 (*tail)->value = value;
3725 static void mp_expand_wild_cards(pTHX_ char *item,
3726 struct list_item **head,
3727 struct list_item **tail,
3731 unsigned long int context = 0;
3737 char vmsspec[NAM$C_MAXRSS+1];
3738 $DESCRIPTOR(filespec, "");
3739 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
3740 $DESCRIPTOR(resultspec, "");
3741 unsigned long int zero = 0, sts;
3743 for (cp = item; *cp; cp++) {
3744 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
3745 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
3747 if (!*cp || isspace(*cp))
3749 add_item(head, tail, item, count);
3752 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
3753 resultspec.dsc$b_class = DSC$K_CLASS_D;
3754 resultspec.dsc$a_pointer = NULL;
3755 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
3756 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
3757 if (!isunix || !filespec.dsc$a_pointer)
3758 filespec.dsc$a_pointer = item;
3759 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
3761 * Only return version specs, if the caller specified a version
3763 had_version = strchr(item, ';');
3765 * Only return device and directory specs, if the caller specifed either.
3767 had_device = strchr(item, ':');
3768 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
3770 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
3771 &defaultspec, 0, 0, &zero))))
3776 New(1305,string,resultspec.dsc$w_length+1,char);
3777 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
3778 string[resultspec.dsc$w_length] = '\0';
3779 if (NULL == had_version)
3780 *((char *)strrchr(string, ';')) = '\0';
3781 if ((!had_directory) && (had_device == NULL))
3783 if (NULL == (devdir = strrchr(string, ']')))
3784 devdir = strrchr(string, '>');
3785 strcpy(string, devdir + 1);
3788 * Be consistent with what the C RTL has already done to the rest of
3789 * the argv items and lowercase all of these names.
3791 for (c = string; *c; ++c)
3794 if (isunix) trim_unixpath(string,item,1);
3795 add_item(head, tail, string, count);
3798 if (sts != RMS$_NMF)
3800 set_vaxc_errno(sts);
3803 case RMS$_FNF: case RMS$_DNF:
3804 set_errno(ENOENT); break;
3806 set_errno(ENOTDIR); break;
3808 set_errno(ENODEV); break;
3809 case RMS$_FNM: case RMS$_SYN:
3810 set_errno(EINVAL); break;
3812 set_errno(EACCES); break;
3814 _ckvmssts_noperl(sts);
3818 add_item(head, tail, item, count);
3819 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
3820 _ckvmssts_noperl(lib$find_file_end(&context));
3823 static int child_st[2];/* Event Flag set when child process completes */
3825 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
3827 static unsigned long int exit_handler(int *status)
3831 if (0 == child_st[0])
3833 #ifdef ARGPROC_DEBUG
3834 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
3836 fflush(stdout); /* Have to flush pipe for binary data to */
3837 /* terminate properly -- <tp@mccall.com> */
3838 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
3839 sys$dassgn(child_chan);
3841 sys$synch(0, child_st);
3846 static void sig_child(int chan)
3848 #ifdef ARGPROC_DEBUG
3849 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
3851 if (child_st[0] == 0)
3855 static struct exit_control_block exit_block =
3860 &exit_block.exit_status,
3864 static void pipe_and_fork(pTHX_ char **cmargv)
3867 $DESCRIPTOR(cmddsc, "");
3868 static char mbxname[64];
3869 $DESCRIPTOR(mbxdsc, mbxname);
3871 unsigned long int zero = 0, one = 1;
3873 strcpy(subcmd, cmargv[0]);
3874 for (j = 1; NULL != cmargv[j]; ++j)
3876 strcat(subcmd, " \"");
3877 strcat(subcmd, cmargv[j]);
3878 strcat(subcmd, "\"");
3880 cmddsc.dsc$a_pointer = subcmd;
3881 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
3883 create_mbx(aTHX_ &child_chan,&mbxdsc);
3884 #ifdef ARGPROC_DEBUG
3885 PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
3886 PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
3888 _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
3889 0, &pid, child_st, &zero, sig_child,
3891 #ifdef ARGPROC_DEBUG
3892 PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
3894 sys$dclexh(&exit_block);
3895 if (NULL == freopen(mbxname, "wb", stdout))
3897 PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
3901 static int background_process(int argc, char **argv)
3903 char command[2048] = "$";
3904 $DESCRIPTOR(value, "");
3905 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
3906 static $DESCRIPTOR(null, "NLA0:");
3907 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
3909 $DESCRIPTOR(pidstr, "");
3911 unsigned long int flags = 17, one = 1, retsts;
3913 strcat(command, argv[0]);
3916 strcat(command, " \"");
3917 strcat(command, *(++argv));
3918 strcat(command, "\"");
3920 value.dsc$a_pointer = command;
3921 value.dsc$w_length = strlen(value.dsc$a_pointer);
3922 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
3923 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
3924 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
3925 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
3928 _ckvmssts_noperl(retsts);
3930 #ifdef ARGPROC_DEBUG
3931 PerlIO_printf(Perl_debug_log, "%s\n", command);
3933 sprintf(pidstring, "%08X", pid);
3934 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
3935 pidstr.dsc$a_pointer = pidstring;
3936 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
3937 lib$set_symbol(&pidsymbol, &pidstr);
3941 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
3944 /* OS-specific initialization at image activation (not thread startup) */
3945 /* Older VAXC header files lack these constants */
3946 #ifndef JPI$_RIGHTS_SIZE
3947 # define JPI$_RIGHTS_SIZE 817
3949 #ifndef KGB$M_SUBSYSTEM
3950 # define KGB$M_SUBSYSTEM 0x8
3953 /*{{{void vms_image_init(int *, char ***)*/
3955 vms_image_init(int *argcp, char ***argvp)
3957 char eqv[LNM$C_NAMLENGTH+1] = "";
3958 unsigned int len, tabct = 8, tabidx = 0;
3959 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
3960 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
3961 unsigned short int dummy, rlen;
3962 struct dsc$descriptor_s **tabvec;
3963 #if defined(PERL_IMPLICIT_CONTEXT)
3966 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
3967 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
3968 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
3971 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
3972 _ckvmssts_noperl(iosb[0]);
3973 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
3974 if (iprv[i]) { /* Running image installed with privs? */
3975 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
3980 /* Rights identifiers might trigger tainting as well. */
3981 if (!will_taint && (rlen || rsz)) {
3982 while (rlen < rsz) {
3983 /* We didn't get all the identifiers on the first pass. Allocate a
3984 * buffer much larger than $GETJPI wants (rsz is size in bytes that
3985 * were needed to hold all identifiers at time of last call; we'll
3986 * allocate that many unsigned long ints), and go back and get 'em.
3987 * If it gave us less than it wanted to despite ample buffer space,
3988 * something's broken. Is your system missing a system identifier?
3990 if (rsz <= jpilist[1].buflen) {
3991 /* Perl_croak accvios when used this early in startup. */
3992 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
3993 rsz, (unsigned long) jpilist[1].buflen,
3994 "Check your rights database for corruption.\n");
3997 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
3998 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
3999 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4000 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4001 _ckvmssts_noperl(iosb[0]);
4003 mask = jpilist[1].bufadr;
4004 /* Check attribute flags for each identifier (2nd longword); protected
4005 * subsystem identifiers trigger tainting.
4007 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4008 if (mask[i] & KGB$M_SUBSYSTEM) {
4013 if (mask != rlst) Safefree(mask);
4015 /* We need to use this hack to tell Perl it should run with tainting,
4016 * since its tainting flag may be part of the PL_curinterp struct, which
4017 * hasn't been allocated when vms_image_init() is called.
4021 New(1320,newap,*argcp+2,char **);
4022 newap[0] = argvp[0];
4024 Copy(argvp[1],newap[2],*argcp-1,char **);
4025 /* We orphan the old argv, since we don't know where it's come from,
4026 * so we don't know how to free it.
4028 *argcp++; argvp = newap;
4030 else { /* Did user explicitly request tainting? */
4032 char *cp, **av = *argvp;
4033 for (i = 1; i < *argcp; i++) {
4034 if (*av[i] != '-') break;
4035 for (cp = av[i]+1; *cp; cp++) {
4036 if (*cp == 'T') { will_taint = 1; break; }
4037 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4038 strchr("DFIiMmx",*cp)) break;
4040 if (will_taint) break;
4045 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4047 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4048 else if (tabidx >= tabct) {
4050 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4052 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4053 tabvec[tabidx]->dsc$w_length = 0;
4054 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4055 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4056 tabvec[tabidx]->dsc$a_pointer = NULL;
4057 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4059 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4061 getredirection(argcp,argvp);
4062 #if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4064 # include <reentrancy.h>
4065 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4074 * Trim Unix-style prefix off filespec, so it looks like what a shell
4075 * glob expansion would return (i.e. from specified prefix on, not
4076 * full path). Note that returned filespec is Unix-style, regardless
4077 * of whether input filespec was VMS-style or Unix-style.
4079 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4080 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4081 * vector of options; at present, only bit 0 is used, and if set tells
4082 * trim unixpath to try the current default directory as a prefix when
4083 * presented with a possibly ambiguous ... wildcard.
4085 * Returns !=0 on success, with trimmed filespec replacing contents of
4086 * fspec, and 0 on failure, with contents of fpsec unchanged.
4088 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4090 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4092 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4093 *template, *base, *end, *cp1, *cp2;
4094 register int tmplen, reslen = 0, dirs = 0;
4096 if (!wildspec || !fspec) return 0;
4097 if (strpbrk(wildspec,"]>:") != NULL) {
4098 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4099 else template = unixwild;
4101 else template = wildspec;
4102 if (strpbrk(fspec,"]>:") != NULL) {
4103 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4104 else base = unixified;
4105 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4106 * check to see that final result fits into (isn't longer than) fspec */
4107 reslen = strlen(fspec);
4111 /* No prefix or absolute path on wildcard, so nothing to remove */
4112 if (!*template || *template == '/') {
4113 if (base == fspec) return 1;
4114 tmplen = strlen(unixified);
4115 if (tmplen > reslen) return 0; /* not enough space */
4116 /* Copy unixified resultant, including trailing NUL */
4117 memmove(fspec,unixified,tmplen+1);
4121 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4122 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4123 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4124 for (cp1 = end ;cp1 >= base; cp1--)
4125 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4127 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4131 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4132 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4133 int ells = 1, totells, segdirs, match;
4134 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4135 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4137 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4139 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4140 if (ellipsis == template && opts & 1) {
4141 /* Template begins with an ellipsis. Since we can't tell how many
4142 * directory names at the front of the resultant to keep for an
4143 * arbitrary starting point, we arbitrarily choose the current
4144 * default directory as a starting point. If it's there as a prefix,
4145 * clip it off. If not, fall through and act as if the leading
4146 * ellipsis weren't there (i.e. return shortest possible path that
4147 * could match template).
4149 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4150 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4151 if (_tolower(*cp1) != _tolower(*cp2)) break;
4152 segdirs = dirs - totells; /* Min # of dirs we must have left */
4153 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4154 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4155 memcpy(fspec,cp2+1,end - cp2);
4159 /* First off, back up over constant elements at end of path */
4161 for (front = end ; front >= base; front--)
4162 if (*front == '/' && !dirs--) { front++; break; }
4164 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4165 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4166 if (cp1 != '\0') return 0; /* Path too long. */
4168 *cp2 = '\0'; /* Pick up with memcpy later */
4169 lcfront = lcres + (front - base);
4170 /* Now skip over each ellipsis and try to match the path in front of it. */
4172 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4173 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4174 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4175 if (cp1 < template) break; /* template started with an ellipsis */
4176 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4177 ellipsis = cp1; continue;
4179 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4181 for (segdirs = 0, cp2 = tpl;
4182 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4184 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4185 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4186 if (*cp2 == '/') segdirs++;
4188 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4189 /* Back up at least as many dirs as in template before matching */
4190 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4191 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4192 for (match = 0; cp1 > lcres;) {
4193 resdsc.dsc$a_pointer = cp1;
4194 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4196 if (match == 1) lcfront = cp1;
4198 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4200 if (!match) return 0; /* Can't find prefix ??? */
4201 if (match > 1 && opts & 1) {
4202 /* This ... wildcard could cover more than one set of dirs (i.e.
4203 * a set of similar dir names is repeated). If the template
4204 * contains more than 1 ..., upstream elements could resolve the
4205 * ambiguity, but it's not worth a full backtracking setup here.
4206 * As a quick heuristic, clip off the current default directory
4207 * if it's present to find the trimmed spec, else use the
4208 * shortest string that this ... could cover.
4210 char def[NAM$C_MAXRSS+1], *st;
4212 if (getcwd(def, sizeof def,0) == NULL) return 0;
4213 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4214 if (_tolower(*cp1) != _tolower(*cp2)) break;
4215 segdirs = dirs - totells; /* Min # of dirs we must have left */
4216 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4217 if (*cp1 == '\0' && *cp2 == '/') {
4218 memcpy(fspec,cp2+1,end - cp2);
4221 /* Nope -- stick with lcfront from above and keep going. */
4224 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4229 } /* end of trim_unixpath() */
4234 * VMS readdir() routines.
4235 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4237 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4238 * Minor modifications to original routines.
4241 /* Number of elements in vms_versions array */
4242 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4245 * Open a directory, return a handle for later use.
4247 /*{{{ DIR *opendir(char*name) */
4249 Perl_opendir(pTHX_ char *name)
4252 char dir[NAM$C_MAXRSS+1];
4255 if (do_tovmspath(name,dir,0) == NULL) {
4258 if (flex_stat(dir,&sb) == -1) return NULL;
4259 if (!S_ISDIR(sb.st_mode)) {
4260 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4263 if (!cando_by_name(S_IRUSR,0,dir)) {
4264 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4267 /* Get memory for the handle, and the pattern. */
4269 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4271 /* Fill in the fields; mainly playing with the descriptor. */
4272 (void)sprintf(dd->pattern, "%s*.*",dir);
4275 dd->vms_wantversions = 0;
4276 dd->pat.dsc$a_pointer = dd->pattern;
4277 dd->pat.dsc$w_length = strlen(dd->pattern);
4278 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4279 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4282 } /* end of opendir() */
4286 * Set the flag to indicate we want versions or not.
4288 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4290 vmsreaddirversions(DIR *dd, int flag)
4292 dd->vms_wantversions = flag;
4297 * Free up an opened directory.
4299 /*{{{ void closedir(DIR *dd)*/
4303 (void)lib$find_file_end(&dd->context);
4304 Safefree(dd->pattern);
4305 Safefree((char *)dd);
4310 * Collect all the version numbers for the current file.
4313 collectversions(pTHX_ DIR *dd)
4315 struct dsc$descriptor_s pat;
4316 struct dsc$descriptor_s res;
4318 char *p, *text, buff[sizeof dd->entry.d_name];
4320 unsigned long context, tmpsts;
4322 /* Convenient shorthand. */
4325 /* Add the version wildcard, ignoring the "*.*" put on before */
4326 i = strlen(dd->pattern);
4327 New(1308,text,i + e->d_namlen + 3,char);
4328 (void)strcpy(text, dd->pattern);
4329 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4331 /* Set up the pattern descriptor. */
4332 pat.dsc$a_pointer = text;
4333 pat.dsc$w_length = i + e->d_namlen - 1;
4334 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4335 pat.dsc$b_class = DSC$K_CLASS_S;
4337 /* Set up result descriptor. */
4338 res.dsc$a_pointer = buff;
4339 res.dsc$w_length = sizeof buff - 2;
4340 res.dsc$b_dtype = DSC$K_DTYPE_T;
4341 res.dsc$b_class = DSC$K_CLASS_S;
4343 /* Read files, collecting versions. */
4344 for (context = 0, e->vms_verscount = 0;
4345 e->vms_verscount < VERSIZE(e);
4346 e->vms_verscount++) {
4347 tmpsts = lib$find_file(&pat, &res, &context);
4348 if (tmpsts == RMS$_NMF || context == 0) break;
4350 buff[sizeof buff - 1] = '\0';
4351 if ((p = strchr(buff, ';')))
4352 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4354 e->vms_versions[e->vms_verscount] = -1;
4357 _ckvmssts(lib$find_file_end(&context));
4360 } /* end of collectversions() */
4363 * Read the next entry from the directory.
4365 /*{{{ struct dirent *readdir(DIR *dd)*/
4367 Perl_readdir(pTHX_ DIR *dd)
4369 struct dsc$descriptor_s res;
4370 char *p, buff[sizeof dd->entry.d_name];
4371 unsigned long int tmpsts;
4373 /* Set up result descriptor, and get next file. */
4374 res.dsc$a_pointer = buff;
4375 res.dsc$w_length = sizeof buff - 2;
4376 res.dsc$b_dtype = DSC$K_DTYPE_T;
4377 res.dsc$b_class = DSC$K_CLASS_S;
4378 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4379 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4380 if (!(tmpsts & 1)) {
4381 set_vaxc_errno(tmpsts);
4384 set_errno(EACCES); break;
4386 set_errno(ENODEV); break;
4388 set_errno(ENOTDIR); break;
4389 case RMS$_FNF: case RMS$_DNF:
4390 set_errno(ENOENT); break;
4397 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4398 buff[sizeof buff - 1] = '\0';
4399 for (p = buff; *p; p++) *p = _tolower(*p);
4400 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4403 /* Skip any directory component and just copy the name. */
4404 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4405 else (void)strcpy(dd->entry.d_name, buff);
4407 /* Clobber the version. */
4408 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4410 dd->entry.d_namlen = strlen(dd->entry.d_name);
4411 dd->entry.vms_verscount = 0;
4412 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4415 } /* end of readdir() */
4419 * Return something that can be used in a seekdir later.
4421 /*{{{ long telldir(DIR *dd)*/
4430 * Return to a spot where we used to be. Brute force.
4432 /*{{{ void seekdir(DIR *dd,long count)*/
4434 Perl_seekdir(pTHX_ DIR *dd, long count)
4436 int vms_wantversions;
4438 /* If we haven't done anything yet... */
4442 /* Remember some state, and clear it. */
4443 vms_wantversions = dd->vms_wantversions;
4444 dd->vms_wantversions = 0;
4445 _ckvmssts(lib$find_file_end(&dd->context));
4448 /* The increment is in readdir(). */
4449 for (dd->count = 0; dd->count < count; )
4452 dd->vms_wantversions = vms_wantversions;
4454 } /* end of seekdir() */
4457 /* VMS subprocess management
4459 * my_vfork() - just a vfork(), after setting a flag to record that
4460 * the current script is trying a Unix-style fork/exec.
4462 * vms_do_aexec() and vms_do_exec() are called in response to the
4463 * perl 'exec' function. If this follows a vfork call, then they
4464 * call out the the regular perl routines in doio.c which do an
4465 * execvp (for those who really want to try this under VMS).
4466 * Otherwise, they do exactly what the perl docs say exec should
4467 * do - terminate the current script and invoke a new command
4468 * (See below for notes on command syntax.)
4470 * do_aspawn() and do_spawn() implement the VMS side of the perl
4471 * 'system' function.
4473 * Note on command arguments to perl 'exec' and 'system': When handled
4474 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4475 * are concatenated to form a DCL command string. If the first arg
4476 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4477 * the the command string is handed off to DCL directly. Otherwise,
4478 * the first token of the command is taken as the filespec of an image
4479 * to run. The filespec is expanded using a default type of '.EXE' and
4480 * the process defaults for device, directory, etc., and if found, the resultant
4481 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4482 * the command string as parameters. This is perhaps a bit complicated,
4483 * but I hope it will form a happy medium between what VMS folks expect
4484 * from lib$spawn and what Unix folks expect from exec.
4487 static int vfork_called;
4489 /*{{{int my_vfork()*/
4500 vms_execfree(pTHX) {
4502 if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd);
4505 if (VMScmd.dsc$a_pointer) {
4506 Safefree(VMScmd.dsc$a_pointer);
4507 VMScmd.dsc$w_length = 0;
4508 VMScmd.dsc$a_pointer = Nullch;
4513 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4515 char *junk, *tmps = Nullch;
4516 register size_t cmdlen = 0;
4523 tmps = SvPV(really,rlen);
4530 for (idx++; idx <= sp; idx++) {
4532 junk = SvPVx(*idx,rlen);
4533 cmdlen += rlen ? rlen + 1 : 0;
4536 New(401,PL_Cmd,cmdlen+1,char);
4538 if (tmps && *tmps) {
4539 strcpy(PL_Cmd,tmps);
4542 else *PL_Cmd = '\0';
4543 while (++mark <= sp) {
4545 char *s = SvPVx(*mark,n_a);
4547 if (*PL_Cmd) strcat(PL_Cmd," ");
4553 } /* end of setup_argstr() */
4556 static unsigned long int
4557 setup_cmddsc(pTHX_ char *cmd, int check_img)
4559 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
4560 $DESCRIPTOR(defdsc,".EXE");
4561 $DESCRIPTOR(defdsc2,".");
4562 $DESCRIPTOR(resdsc,resspec);
4563 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4564 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
4565 register char *s, *rest, *cp, *wordbreak;
4569 (sizeof(vmsspec) > sizeof(resspec) ? sizeof(resspec) : sizeof(vmsspec)))
4572 while (*s && isspace(*s)) s++;
4574 if (*s == '@' || *s == '$') {
4575 vmsspec[0] = *s; rest = s + 1;
4576 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
4578 else { cp = vmsspec; rest = s; }
4579 if (*rest == '.' || *rest == '/') {
4582 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
4583 rest++, cp2++) *cp2 = *rest;
4585 if (do_tovmsspec(resspec,cp,0)) {
4588 for (cp2 = vmsspec + strlen(vmsspec);
4589 *rest && cp2 - vmsspec < sizeof vmsspec;
4590 rest++, cp2++) *cp2 = *rest;
4595 /* Intuit whether verb (first word of cmd) is a DCL command:
4596 * - if first nonspace char is '@', it's a DCL indirection
4598 * - if verb contains a filespec separator, it's not a DCL command
4599 * - if it doesn't, caller tells us whether to default to a DCL
4600 * command, or to a local image unless told it's DCL (by leading '$')
4602 if (*s == '@') isdcl = 1;
4604 register char *filespec = strpbrk(s,":<[.;");
4605 rest = wordbreak = strpbrk(s," \"\t/");
4606 if (!wordbreak) wordbreak = s + strlen(s);
4607 if (*s == '$') check_img = 0;
4608 if (filespec && (filespec < wordbreak)) isdcl = 0;
4609 else isdcl = !check_img;
4613 imgdsc.dsc$a_pointer = s;
4614 imgdsc.dsc$w_length = wordbreak - s;
4615 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4617 _ckvmssts(lib$find_file_end(&cxt));
4618 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4619 if (!(retsts & 1) && *s == '$') {
4620 _ckvmssts(lib$find_file_end(&cxt));
4621 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
4622 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
4624 _ckvmssts(lib$find_file_end(&cxt));
4625 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
4629 _ckvmssts(lib$find_file_end(&cxt));
4634 while (*s && !isspace(*s)) s++;
4637 /* check that it's really not DCL with no file extension */
4638 fp = fopen(resspec,"r","ctx=bin,shr=get");
4640 char b[4] = {0,0,0,0};
4641 read(fileno(fp),b,4);
4642 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
4645 if (check_img && isdcl) return RMS$_FNF;
4647 if (cando_by_name(S_IXUSR,0,resspec)) {
4648 New(402,VMScmd.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
4650 strcpy(VMScmd.dsc$a_pointer,"$ MCR ");
4652 strcpy(VMScmd.dsc$a_pointer,"@");
4654 strcat(VMScmd.dsc$a_pointer,resspec);
4655 if (rest) strcat(VMScmd.dsc$a_pointer,rest);
4656 VMScmd.dsc$w_length = strlen(VMScmd.dsc$a_pointer);
4659 else retsts = RMS$_PRV;
4662 /* It's either a DCL command or we couldn't find a suitable image */
4663 VMScmd.dsc$w_length = strlen(cmd);
4664 if (cmd == PL_Cmd) VMScmd.dsc$a_pointer = PL_Cmd;
4665 else VMScmd.dsc$a_pointer = savepvn(cmd,VMScmd.dsc$w_length);
4666 if (!(retsts & 1)) {
4667 /* just hand off status values likely to be due to user error */
4668 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
4669 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
4670 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
4671 else { _ckvmssts(retsts); }
4674 return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : retsts);
4676 } /* end of setup_cmddsc() */
4679 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
4681 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
4684 if (vfork_called) { /* this follows a vfork - act Unixish */
4686 if (vfork_called < 0) {
4687 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4690 else return do_aexec(really,mark,sp);
4692 /* no vfork - act VMSish */
4693 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
4698 } /* end of vms_do_aexec() */
4701 /* {{{bool vms_do_exec(char *cmd) */
4703 Perl_vms_do_exec(pTHX_ char *cmd)
4706 if (vfork_called) { /* this follows a vfork - act Unixish */
4708 if (vfork_called < 0) {
4709 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
4712 else return do_exec(cmd);
4715 { /* no vfork - act VMSish */
4716 unsigned long int retsts;
4719 TAINT_PROPER("exec");
4720 if ((retsts = setup_cmddsc(aTHX_ cmd,1)) & 1)
4721 retsts = lib$do_command(&VMScmd);
4724 case RMS$_FNF: case RMS$_DNF:
4725 set_errno(ENOENT); break;
4727 set_errno(ENOTDIR); break;
4729 set_errno(ENODEV); break;
4731 set_errno(EACCES); break;
4733 set_errno(EINVAL); break;
4735 set_errno(E2BIG); break;
4736 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4737 _ckvmssts(retsts); /* fall through */
4738 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4741 set_vaxc_errno(retsts);
4742 if (ckWARN(WARN_EXEC)) {
4743 Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
4744 VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
4751 } /* end of vms_do_exec() */
4754 unsigned long int Perl_do_spawn(pTHX_ char *);
4756 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
4758 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
4760 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
4763 } /* end of do_aspawn() */
4766 /* {{{unsigned long int do_spawn(char *cmd) */
4768 Perl_do_spawn(pTHX_ char *cmd)
4770 unsigned long int sts, substs, hadcmd = 1;
4773 TAINT_PROPER("spawn");
4774 if (!cmd || !*cmd) {
4776 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
4778 else if ((sts = setup_cmddsc(aTHX_ cmd,0)) & 1) {
4779 sts = lib$spawn(&VMScmd,0,0,0,0,0,&substs,0,0,0,0,0,0);
4784 case RMS$_FNF: case RMS$_DNF:
4785 set_errno(ENOENT); break;
4787 set_errno(ENOTDIR); break;
4789 set_errno(ENODEV); break;
4791 set_errno(EACCES); break;
4793 set_errno(EINVAL); break;
4795 set_errno(E2BIG); break;
4796 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4797 _ckvmssts(sts); /* fall through */
4798 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4801 set_vaxc_errno(sts);
4802 if (ckWARN(WARN_EXEC)) {
4803 Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
4804 hadcmd ? VMScmd.dsc$w_length : 0,
4805 hadcmd ? VMScmd.dsc$a_pointer : "",
4812 } /* end of do_spawn() */
4816 static unsigned int *sockflags, sockflagsize;
4819 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
4820 * routines found in some versions of the CRTL can't deal with sockets.
4821 * We don't shim the other file open routines since a socket isn't
4822 * likely to be opened by a name.
4824 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
4825 FILE *my_fdopen(int fd, const char *mode)
4827 FILE *fp = fdopen(fd, (char *) mode);
4830 unsigned int fdoff = fd / sizeof(unsigned int);
4831 struct stat sbuf; /* native stat; we don't need flex_stat */
4832 if (!sockflagsize || fdoff > sockflagsize) {
4833 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
4834 else New (1324,sockflags,fdoff+2,unsigned int);
4835 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
4836 sockflagsize = fdoff + 2;
4838 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
4839 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
4848 * Clear the corresponding bit when the (possibly) socket stream is closed.
4849 * There still a small hole: we miss an implicit close which might occur
4850 * via freopen(). >> Todo
4852 /*{{{ int my_fclose(FILE *fp)*/
4853 int my_fclose(FILE *fp) {
4855 unsigned int fd = fileno(fp);
4856 unsigned int fdoff = fd / sizeof(unsigned int);
4858 if (sockflagsize && fdoff <= sockflagsize)
4859 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
4867 * A simple fwrite replacement which outputs itmsz*nitm chars without
4868 * introducing record boundaries every itmsz chars.
4869 * We are using fputs, which depends on a terminating null. We may
4870 * well be writing binary data, so we need to accommodate not only
4871 * data with nulls sprinkled in the middle but also data with no null
4874 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
4876 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
4878 register char *cp, *end, *cpd, *data;
4879 register unsigned int fd = fileno(dest);
4880 register unsigned int fdoff = fd / sizeof(unsigned int);
4882 int bufsize = itmsz * nitm + 1;
4884 if (fdoff < sockflagsize &&
4885 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
4886 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
4890 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
4891 memcpy( data, src, itmsz*nitm );
4892 data[itmsz*nitm] = '\0';
4894 end = data + itmsz * nitm;
4895 retval = (int) nitm; /* on success return # items written */
4898 while (cpd <= end) {
4899 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
4900 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
4902 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
4906 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
4909 } /* end of my_fwrite() */
4912 /*{{{ int my_flush(FILE *fp)*/
4914 Perl_my_flush(pTHX_ FILE *fp)
4917 if ((res = fflush(fp)) == 0 && fp) {
4918 #ifdef VMS_DO_SOCKETS
4920 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
4922 res = fsync(fileno(fp));
4925 * If the flush succeeded but set end-of-file, we need to clear
4926 * the error because our caller may check ferror(). BTW, this
4927 * probably means we just flushed an empty file.
4929 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
4936 * Here are replacements for the following Unix routines in the VMS environment:
4937 * getpwuid Get information for a particular UIC or UID
4938 * getpwnam Get information for a named user
4939 * getpwent Get information for each user in the rights database
4940 * setpwent Reset search to the start of the rights database
4941 * endpwent Finish searching for users in the rights database
4943 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
4944 * (defined in pwd.h), which contains the following fields:-
4946 * char *pw_name; Username (in lower case)
4947 * char *pw_passwd; Hashed password
4948 * unsigned int pw_uid; UIC
4949 * unsigned int pw_gid; UIC group number
4950 * char *pw_unixdir; Default device/directory (VMS-style)
4951 * char *pw_gecos; Owner name
4952 * char *pw_dir; Default device/directory (Unix-style)
4953 * char *pw_shell; Default CLI name (eg. DCL)
4955 * If the specified user does not exist, getpwuid and getpwnam return NULL.
4957 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
4958 * not the UIC member number (eg. what's returned by getuid()),
4959 * getpwuid() can accept either as input (if uid is specified, the caller's
4960 * UIC group is used), though it won't recognise gid=0.
4962 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
4963 * information about other users in your group or in other groups, respectively.
4964 * If the required privilege is not available, then these routines fill only
4965 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
4968 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
4971 /* sizes of various UAF record fields */
4972 #define UAI$S_USERNAME 12
4973 #define UAI$S_IDENT 31
4974 #define UAI$S_OWNER 31
4975 #define UAI$S_DEFDEV 31
4976 #define UAI$S_DEFDIR 63
4977 #define UAI$S_DEFCLI 31
4980 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
4981 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
4982 (uic).uic$v_group != UIC$K_WILD_GROUP)
4984 static char __empty[]= "";
4985 static struct passwd __passwd_empty=
4986 {(char *) __empty, (char *) __empty, 0, 0,
4987 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
4988 static int contxt= 0;
4989 static struct passwd __pwdcache;
4990 static char __pw_namecache[UAI$S_IDENT+1];
4993 * This routine does most of the work extracting the user information.
4995 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
4998 unsigned char length;
4999 char pw_gecos[UAI$S_OWNER+1];
5001 static union uicdef uic;
5003 unsigned char length;
5004 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5007 unsigned char length;
5008 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5011 unsigned char length;
5012 char pw_shell[UAI$S_DEFCLI+1];
5014 static char pw_passwd[UAI$S_PWD+1];
5016 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5017 struct dsc$descriptor_s name_desc;
5018 unsigned long int sts;
5020 static struct itmlst_3 itmlst[]= {
5021 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5022 {sizeof(uic), UAI$_UIC, &uic, &luic},
5023 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5024 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5025 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5026 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5027 {0, 0, NULL, NULL}};
5029 name_desc.dsc$w_length= strlen(name);
5030 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5031 name_desc.dsc$b_class= DSC$K_CLASS_S;
5032 name_desc.dsc$a_pointer= (char *) name;
5034 /* Note that sys$getuai returns many fields as counted strings. */
5035 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5036 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5037 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5039 else { _ckvmssts(sts); }
5040 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5042 if ((int) owner.length < lowner) lowner= (int) owner.length;
5043 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5044 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5045 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5046 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5047 owner.pw_gecos[lowner]= '\0';
5048 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5049 defcli.pw_shell[ldefcli]= '\0';
5050 if (valid_uic(uic)) {
5051 pwd->pw_uid= uic.uic$l_uic;
5052 pwd->pw_gid= uic.uic$v_group;
5055 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5056 pwd->pw_passwd= pw_passwd;
5057 pwd->pw_gecos= owner.pw_gecos;
5058 pwd->pw_dir= defdev.pw_dir;
5059 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5060 pwd->pw_shell= defcli.pw_shell;
5061 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5063 ldir= strlen(pwd->pw_unixdir) - 1;
5064 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5067 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5068 __mystrtolower(pwd->pw_unixdir);
5073 * Get information for a named user.
5075 /*{{{struct passwd *getpwnam(char *name)*/
5076 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5078 struct dsc$descriptor_s name_desc;
5080 unsigned long int status, sts;
5082 __pwdcache = __passwd_empty;
5083 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5084 /* We still may be able to determine pw_uid and pw_gid */
5085 name_desc.dsc$w_length= strlen(name);
5086 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5087 name_desc.dsc$b_class= DSC$K_CLASS_S;
5088 name_desc.dsc$a_pointer= (char *) name;
5089 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5090 __pwdcache.pw_uid= uic.uic$l_uic;
5091 __pwdcache.pw_gid= uic.uic$v_group;
5094 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5095 set_vaxc_errno(sts);
5096 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5099 else { _ckvmssts(sts); }
5102 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5103 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5104 __pwdcache.pw_name= __pw_namecache;
5106 } /* end of my_getpwnam() */
5110 * Get information for a particular UIC or UID.
5111 * Called by my_getpwent with uid=-1 to list all users.
5113 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5114 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5116 const $DESCRIPTOR(name_desc,__pw_namecache);
5117 unsigned short lname;
5119 unsigned long int status;
5121 if (uid == (unsigned int) -1) {
5123 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5124 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5125 set_vaxc_errno(status);
5126 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5130 else { _ckvmssts(status); }
5131 } while (!valid_uic (uic));
5135 if (!uic.uic$v_group)
5136 uic.uic$v_group= PerlProc_getgid();
5138 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5139 else status = SS$_IVIDENT;
5140 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5141 status == RMS$_PRV) {
5142 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5145 else { _ckvmssts(status); }
5147 __pw_namecache[lname]= '\0';
5148 __mystrtolower(__pw_namecache);
5150 __pwdcache = __passwd_empty;
5151 __pwdcache.pw_name = __pw_namecache;
5153 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5154 The identifier's value is usually the UIC, but it doesn't have to be,
5155 so if we can, we let fillpasswd update this. */
5156 __pwdcache.pw_uid = uic.uic$l_uic;
5157 __pwdcache.pw_gid = uic.uic$v_group;
5159 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5162 } /* end of my_getpwuid() */
5166 * Get information for next user.
5168 /*{{{struct passwd *my_getpwent()*/
5169 struct passwd *Perl_my_getpwent(pTHX)
5171 return (my_getpwuid((unsigned int) -1));
5176 * Finish searching rights database for users.
5178 /*{{{void my_endpwent()*/
5179 void Perl_my_endpwent(pTHX)
5182 _ckvmssts(sys$finish_rdb(&contxt));
5188 #ifdef HOMEGROWN_POSIX_SIGNALS
5189 /* Signal handling routines, pulled into the core from POSIX.xs.
5191 * We need these for threads, so they've been rolled into the core,
5192 * rather than left in POSIX.xs.
5194 * (DRS, Oct 23, 1997)
5197 /* sigset_t is atomic under VMS, so these routines are easy */
5198 /*{{{int my_sigemptyset(sigset_t *) */
5199 int my_sigemptyset(sigset_t *set) {
5200 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5206 /*{{{int my_sigfillset(sigset_t *)*/
5207 int my_sigfillset(sigset_t *set) {
5209 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5210 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5216 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5217 int my_sigaddset(sigset_t *set, int sig) {
5218 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5219 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5220 *set |= (1 << (sig - 1));
5226 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5227 int my_sigdelset(sigset_t *set, int sig) {
5228 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5229 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5230 *set &= ~(1 << (sig - 1));
5236 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5237 int my_sigismember(sigset_t *set, int sig) {
5238 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5239 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5240 *set & (1 << (sig - 1));
5245 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5246 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5249 /* If set and oset are both null, then things are badly wrong. Bail out. */
5250 if ((oset == NULL) && (set == NULL)) {
5251 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5255 /* If set's null, then we're just handling a fetch. */
5257 tempmask = sigblock(0);
5262 tempmask = sigsetmask(*set);
5265 tempmask = sigblock(*set);
5268 tempmask = sigblock(0);
5269 sigsetmask(*oset & ~tempmask);
5272 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5277 /* Did they pass us an oset? If so, stick our holding mask into it */
5284 #endif /* HOMEGROWN_POSIX_SIGNALS */
5287 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5288 * my_utime(), and flex_stat(), all of which operate on UTC unless
5289 * VMSISH_TIMES is true.
5291 /* method used to handle UTC conversions:
5292 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5294 static int gmtime_emulation_type;
5295 /* number of secs to add to UTC POSIX-style time to get local time */
5296 static long int utc_offset_secs;
5298 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5299 * in vmsish.h. #undef them here so we can call the CRTL routines
5308 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5309 * qualifier with the extern prefix pragma. This provisional
5310 * hack circumvents this prefix pragma problem in previous
5313 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5314 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5315 # pragma __extern_prefix save
5316 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5317 # define gmtime decc$__utctz_gmtime
5318 # define localtime decc$__utctz_localtime
5319 # define time decc$__utc_time
5320 # pragma __extern_prefix restore
5322 struct tm *gmtime(), *localtime();
5328 static time_t toutc_dst(time_t loc) {
5331 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5332 loc -= utc_offset_secs;
5333 if (rsltmp->tm_isdst) loc -= 3600;
5336 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5337 ((gmtime_emulation_type || my_time(NULL)), \
5338 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5339 ((secs) - utc_offset_secs))))
5341 static time_t toloc_dst(time_t utc) {
5344 utc += utc_offset_secs;
5345 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5346 if (rsltmp->tm_isdst) utc += 3600;
5349 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5350 ((gmtime_emulation_type || my_time(NULL)), \
5351 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5352 ((secs) + utc_offset_secs))))
5354 #ifndef RTL_USES_UTC
5357 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5358 DST starts on 1st sun of april at 02:00 std time
5359 ends on last sun of october at 02:00 dst time
5360 see the UCX management command reference, SET CONFIG TIMEZONE
5361 for formatting info.
5363 No, it's not as general as it should be, but then again, NOTHING
5364 will handle UK times in a sensible way.
5369 parse the DST start/end info:
5370 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5374 tz_parse_startend(char *s, struct tm *w, int *past)
5376 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5377 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5382 if (!past) return 0;
5385 if (w->tm_year % 4 == 0) ly = 1;
5386 if (w->tm_year % 100 == 0) ly = 0;
5387 if (w->tm_year+1900 % 400 == 0) ly = 1;
5390 dozjd = isdigit(*s);
5391 if (*s == 'J' || *s == 'j' || dozjd) {
5392 if (!dozjd && !isdigit(*++s)) return 0;
5395 d = d*10 + *s++ - '0';
5397 d = d*10 + *s++ - '0';
5400 if (d == 0) return 0;
5401 if (d > 366) return 0;
5403 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5406 } else if (*s == 'M' || *s == 'm') {
5407 if (!isdigit(*++s)) return 0;
5409 if (isdigit(*s)) m = 10*m + *s++ - '0';
5410 if (*s != '.') return 0;
5411 if (!isdigit(*++s)) return 0;
5413 if (n < 1 || n > 5) return 0;
5414 if (*s != '.') return 0;
5415 if (!isdigit(*++s)) return 0;
5417 if (d > 6) return 0;
5421 if (!isdigit(*++s)) return 0;
5423 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5425 if (!isdigit(*++s)) return 0;
5427 if (isdigit(*s)) min = 10*min + *s++ - '0';
5429 if (!isdigit(*++s)) return 0;
5431 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5441 if (w->tm_yday < d) goto before;
5442 if (w->tm_yday > d) goto after;
5444 if (w->tm_mon+1 < m) goto before;
5445 if (w->tm_mon+1 > m) goto after;
5447 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5448 k = d - j; /* mday of first d */
5450 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5451 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5452 if (w->tm_mday < k) goto before;
5453 if (w->tm_mday > k) goto after;
5456 if (w->tm_hour < hour) goto before;
5457 if (w->tm_hour > hour) goto after;
5458 if (w->tm_min < min) goto before;
5459 if (w->tm_min > min) goto after;
5460 if (w->tm_sec < sec) goto before;
5474 /* parse the offset: (+|-)hh[:mm[:ss]] */
5477 tz_parse_offset(char *s, int *offset)
5479 int hour = 0, min = 0, sec = 0;
5482 if (!offset) return 0;
5484 if (*s == '-') {neg++; s++;}
5486 if (!isdigit(*s)) return 0;
5488 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5489 if (hour > 24) return 0;
5491 if (!isdigit(*++s)) return 0;
5493 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5494 if (min > 59) return 0;
5496 if (!isdigit(*++s)) return 0;
5498 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5499 if (sec > 59) return 0;
5503 *offset = (hour*60+min)*60 + sec;
5504 if (neg) *offset = -*offset;
5509 input time is w, whatever type of time the CRTL localtime() uses.
5510 sets dst, the zone, and the gmtoff (seconds)
5512 caches the value of TZ and UCX$TZ env variables; note that
5513 my_setenv looks for these and sets a flag if they're changed
5516 We have to watch out for the "australian" case (dst starts in
5517 october, ends in april)...flagged by "reverse" and checked by
5518 scanning through the months of the previous year.
5523 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5528 char *dstzone, *tz, *s_start, *s_end;
5529 int std_off, dst_off, isdst;
5530 int y, dststart, dstend;
5531 static char envtz[1025]; /* longer than any logical, symbol, ... */
5532 static char ucxtz[1025];
5533 static char reversed = 0;
5539 reversed = -1; /* flag need to check */
5540 envtz[0] = ucxtz[0] = '\0';
5541 tz = my_getenv("TZ",0);
5542 if (tz) strcpy(envtz, tz);
5543 tz = my_getenv("UCX$TZ",0);
5544 if (tz) strcpy(ucxtz, tz);
5545 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
5548 if (!*tz) tz = ucxtz;
5551 while (isalpha(*s)) s++;
5552 s = tz_parse_offset(s, &std_off);
5554 if (!*s) { /* no DST, hurray we're done! */
5560 while (isalpha(*s)) s++;
5561 s2 = tz_parse_offset(s, &dst_off);
5565 dst_off = std_off - 3600;
5568 if (!*s) { /* default dst start/end?? */
5569 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
5570 s = strchr(ucxtz,',');
5572 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
5574 if (*s != ',') return 0;
5577 when = _toutc(when); /* convert to utc */
5578 when = when - std_off; /* convert to pseudolocal time*/
5580 w2 = localtime(&when);
5583 s = tz_parse_startend(s_start,w2,&dststart);
5585 if (*s != ',') return 0;
5588 when = _toutc(when); /* convert to utc */
5589 when = when - dst_off; /* convert to pseudolocal time*/
5590 w2 = localtime(&when);
5591 if (w2->tm_year != y) { /* spans a year, just check one time */
5592 when += dst_off - std_off;
5593 w2 = localtime(&when);
5596 s = tz_parse_startend(s_end,w2,&dstend);
5599 if (reversed == -1) { /* need to check if start later than end */
5603 if (when < 2*365*86400) {
5604 when += 2*365*86400;
5608 w2 =localtime(&when);
5609 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
5611 for (j = 0; j < 12; j++) {
5612 w2 =localtime(&when);
5613 (void) tz_parse_startend(s_start,w2,&ds);
5614 (void) tz_parse_startend(s_end,w2,&de);
5615 if (ds != de) break;
5619 if (de && !ds) reversed = 1;
5622 isdst = dststart && !dstend;
5623 if (reversed) isdst = dststart || !dstend;
5626 if (dst) *dst = isdst;
5627 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
5628 if (isdst) tz = dstzone;
5630 while(isalpha(*tz)) *zone++ = *tz++;
5636 #endif /* !RTL_USES_UTC */
5638 /* my_time(), my_localtime(), my_gmtime()
5639 * By default traffic in UTC time values, using CRTL gmtime() or
5640 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
5641 * Note: We need to use these functions even when the CRTL has working
5642 * UTC support, since they also handle C<use vmsish qw(times);>
5644 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
5645 * Modified by Charles Bailey <bailey@newman.upenn.edu>
5648 /*{{{time_t my_time(time_t *timep)*/
5649 time_t Perl_my_time(pTHX_ time_t *timep)
5654 if (gmtime_emulation_type == 0) {
5656 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
5657 /* results of calls to gmtime() and localtime() */
5658 /* for same &base */
5660 gmtime_emulation_type++;
5661 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
5662 char off[LNM$C_NAMLENGTH+1];;
5664 gmtime_emulation_type++;
5665 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
5666 gmtime_emulation_type++;
5667 utc_offset_secs = 0;
5668 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
5670 else { utc_offset_secs = atol(off); }
5672 else { /* We've got a working gmtime() */
5673 struct tm gmt, local;
5676 tm_p = localtime(&base);
5678 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
5679 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
5680 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
5681 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
5687 # ifdef RTL_USES_UTC
5688 if (VMSISH_TIME) when = _toloc(when);
5690 if (!VMSISH_TIME) when = _toutc(when);
5693 if (timep != NULL) *timep = when;
5696 } /* end of my_time() */
5700 /*{{{struct tm *my_gmtime(const time_t *timep)*/
5702 Perl_my_gmtime(pTHX_ const time_t *timep)
5708 if (timep == NULL) {
5709 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5712 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5716 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
5718 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
5719 return gmtime(&when);
5721 /* CRTL localtime() wants local time as input, so does no tz correction */
5722 rsltmp = localtime(&when);
5723 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
5726 } /* end of my_gmtime() */
5730 /*{{{struct tm *my_localtime(const time_t *timep)*/
5732 Perl_my_localtime(pTHX_ const time_t *timep)
5734 time_t when, whenutc;
5738 if (timep == NULL) {
5739 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5742 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
5743 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
5746 # ifdef RTL_USES_UTC
5748 if (VMSISH_TIME) when = _toutc(when);
5750 /* CRTL localtime() wants UTC as input, does tz correction itself */
5751 return localtime(&when);
5753 # else /* !RTL_USES_UTC */
5756 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
5757 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
5760 #ifndef RTL_USES_UTC
5761 if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/
5762 when = whenutc - offset; /* pseudolocal time*/
5765 /* CRTL localtime() wants local time as input, so does no tz correction */
5766 rsltmp = localtime(&when);
5767 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
5771 } /* end of my_localtime() */
5774 /* Reset definitions for later calls */
5775 #define gmtime(t) my_gmtime(t)
5776 #define localtime(t) my_localtime(t)
5777 #define time(t) my_time(t)
5780 /* my_utime - update modification time of a file
5781 * calling sequence is identical to POSIX utime(), but under
5782 * VMS only the modification time is changed; ODS-2 does not
5783 * maintain access times. Restrictions differ from the POSIX
5784 * definition in that the time can be changed as long as the
5785 * caller has permission to execute the necessary IO$_MODIFY $QIO;
5786 * no separate checks are made to insure that the caller is the
5787 * owner of the file or has special privs enabled.
5788 * Code here is based on Joe Meadows' FILE utility.
5791 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
5792 * to VMS epoch (01-JAN-1858 00:00:00.00)
5793 * in 100 ns intervals.
5795 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
5797 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
5798 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
5801 long int bintime[2], len = 2, lowbit, unixtime,
5802 secscale = 10000000; /* seconds --> 100 ns intervals */
5803 unsigned long int chan, iosb[2], retsts;
5804 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
5805 struct FAB myfab = cc$rms_fab;
5806 struct NAM mynam = cc$rms_nam;
5807 #if defined (__DECC) && defined (__VAX)
5808 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
5809 * at least through VMS V6.1, which causes a type-conversion warning.
5811 # pragma message save
5812 # pragma message disable cvtdiftypes
5814 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
5815 struct fibdef myfib;
5816 #if defined (__DECC) && defined (__VAX)
5817 /* This should be right after the declaration of myatr, but due
5818 * to a bug in VAX DEC C, this takes effect a statement early.
5820 # pragma message restore
5822 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
5823 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
5824 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
5826 if (file == NULL || *file == '\0') {
5828 set_vaxc_errno(LIB$_INVARG);
5831 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
5833 if (utimes != NULL) {
5834 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
5835 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
5836 * Since time_t is unsigned long int, and lib$emul takes a signed long int
5837 * as input, we force the sign bit to be clear by shifting unixtime right
5838 * one bit, then multiplying by an extra factor of 2 in lib$emul().
5840 lowbit = (utimes->modtime & 1) ? secscale : 0;
5841 unixtime = (long int) utimes->modtime;
5843 /* If input was UTC; convert to local for sys svc */
5844 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
5846 unixtime >>= 1; secscale <<= 1;
5847 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
5848 if (!(retsts & 1)) {
5850 set_vaxc_errno(retsts);
5853 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
5854 if (!(retsts & 1)) {
5856 set_vaxc_errno(retsts);
5861 /* Just get the current time in VMS format directly */
5862 retsts = sys$gettim(bintime);
5863 if (!(retsts & 1)) {
5865 set_vaxc_errno(retsts);
5870 myfab.fab$l_fna = vmsspec;
5871 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
5872 myfab.fab$l_nam = &mynam;
5873 mynam.nam$l_esa = esa;
5874 mynam.nam$b_ess = (unsigned char) sizeof esa;
5875 mynam.nam$l_rsa = rsa;
5876 mynam.nam$b_rss = (unsigned char) sizeof rsa;
5878 /* Look for the file to be affected, letting RMS parse the file
5879 * specification for us as well. I have set errno using only
5880 * values documented in the utime() man page for VMS POSIX.
5882 retsts = sys$parse(&myfab,0,0);
5883 if (!(retsts & 1)) {
5884 set_vaxc_errno(retsts);
5885 if (retsts == RMS$_PRV) set_errno(EACCES);
5886 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5887 else set_errno(EVMSERR);
5890 retsts = sys$search(&myfab,0,0);
5891 if (!(retsts & 1)) {
5892 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5893 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5894 set_vaxc_errno(retsts);
5895 if (retsts == RMS$_PRV) set_errno(EACCES);
5896 else if (retsts == RMS$_FNF) set_errno(ENOENT);
5897 else set_errno(EVMSERR);
5901 devdsc.dsc$w_length = mynam.nam$b_dev;
5902 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
5904 retsts = sys$assign(&devdsc,&chan,0,0);
5905 if (!(retsts & 1)) {
5906 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5907 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5908 set_vaxc_errno(retsts);
5909 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
5910 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
5911 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
5912 else set_errno(EVMSERR);
5916 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
5917 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
5919 memset((void *) &myfib, 0, sizeof myfib);
5920 #if defined(__DECC) || defined(__DECCXX)
5921 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
5922 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
5923 /* This prevents the revision time of the file being reset to the current
5924 * time as a result of our IO$_MODIFY $QIO. */
5925 myfib.fib$l_acctl = FIB$M_NORECORD;
5927 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
5928 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
5929 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
5931 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
5932 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
5933 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
5934 _ckvmssts(sys$dassgn(chan));
5935 if (retsts & 1) retsts = iosb[0];
5936 if (!(retsts & 1)) {
5937 set_vaxc_errno(retsts);
5938 if (retsts == SS$_NOPRIV) set_errno(EACCES);
5939 else set_errno(EVMSERR);
5944 } /* end of my_utime() */
5948 * flex_stat, flex_fstat
5949 * basic stat, but gets it right when asked to stat
5950 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
5953 /* encode_dev packs a VMS device name string into an integer to allow
5954 * simple comparisons. This can be used, for example, to check whether two
5955 * files are located on the same device, by comparing their encoded device
5956 * names. Even a string comparison would not do, because stat() reuses the
5957 * device name buffer for each call; so without encode_dev, it would be
5958 * necessary to save the buffer and use strcmp (this would mean a number of
5959 * changes to the standard Perl code, to say nothing of what a Perl script
5962 * The device lock id, if it exists, should be unique (unless perhaps compared
5963 * with lock ids transferred from other nodes). We have a lock id if the disk is
5964 * mounted cluster-wide, which is when we tend to get long (host-qualified)
5965 * device names. Thus we use the lock id in preference, and only if that isn't
5966 * available, do we try to pack the device name into an integer (flagged by
5967 * the sign bit (LOCKID_MASK) being set).
5969 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
5970 * name and its encoded form, but it seems very unlikely that we will find
5971 * two files on different disks that share the same encoded device names,
5972 * and even more remote that they will share the same file id (if the test
5973 * is to check for the same file).
5975 * A better method might be to use sys$device_scan on the first call, and to
5976 * search for the device, returning an index into the cached array.
5977 * The number returned would be more intelligable.
5978 * This is probably not worth it, and anyway would take quite a bit longer
5979 * on the first call.
5981 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
5982 static mydev_t encode_dev (pTHX_ const char *dev)
5985 unsigned long int f;
5990 if (!dev || !dev[0]) return 0;
5994 struct dsc$descriptor_s dev_desc;
5995 unsigned long int status, lockid, item = DVI$_LOCKID;
5997 /* For cluster-mounted disks, the disk lock identifier is unique, so we
5998 can try that first. */
5999 dev_desc.dsc$w_length = strlen (dev);
6000 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6001 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6002 dev_desc.dsc$a_pointer = (char *) dev;
6003 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6004 if (lockid) return (lockid & ~LOCKID_MASK);
6008 /* Otherwise we try to encode the device name */
6012 for (q = dev + strlen(dev); q--; q >= dev) {
6015 else if (isalpha (toupper (*q)))
6016 c= toupper (*q) - 'A' + (char)10;
6018 continue; /* Skip '$'s */
6020 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6022 enc += f * (unsigned long int) c;
6024 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6026 } /* end of encode_dev() */
6028 static char namecache[NAM$C_MAXRSS+1];
6031 is_null_device(name)
6034 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6035 The underscore prefix, controller letter, and unit number are
6036 independently optional; for our purposes, the colon punctuation
6037 is not. The colon can be trailed by optional directory and/or
6038 filename, but two consecutive colons indicates a nodename rather
6039 than a device. [pr] */
6040 if (*name == '_') ++name;
6041 if (tolower(*name++) != 'n') return 0;
6042 if (tolower(*name++) != 'l') return 0;
6043 if (tolower(*name) == 'a') ++name;
6044 if (*name == '0') ++name;
6045 return (*name++ == ':') && (*name != ':');
6048 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6049 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6050 * subset of the applicable information.
6053 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6055 char fname_phdev[NAM$C_MAXRSS+1];
6056 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6058 char fname[NAM$C_MAXRSS+1];
6059 unsigned long int retsts;
6060 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6061 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6063 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6064 device name on successive calls */
6065 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6066 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6067 namdsc.dsc$a_pointer = fname;
6068 namdsc.dsc$w_length = sizeof fname - 1;
6070 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6071 &namdsc,&namdsc.dsc$w_length,0,0);
6073 fname[namdsc.dsc$w_length] = '\0';
6075 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6076 * but if someone has redefined that logical, Perl gets very lost. Since
6077 * we have the physical device name from the stat buffer, just paste it on.
6079 strcpy( fname_phdev, statbufp->st_devnam );
6080 strcat( fname_phdev, strrchr(fname, ':') );
6082 return cando_by_name(bit,effective,fname_phdev);
6084 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6085 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6089 return FALSE; /* Should never get to here */
6091 } /* end of cando() */
6095 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6097 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6099 static char usrname[L_cuserid];
6100 static struct dsc$descriptor_s usrdsc =
6101 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6102 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6103 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6104 unsigned short int retlen;
6105 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6106 union prvdef curprv;
6107 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6108 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6109 struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6112 if (!fname || !*fname) return FALSE;
6113 /* Make sure we expand logical names, since sys$check_access doesn't */
6114 if (!strpbrk(fname,"/]>:")) {
6115 strcpy(fileified,fname);
6116 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6119 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6120 retlen = namdsc.dsc$w_length = strlen(vmsname);
6121 namdsc.dsc$a_pointer = vmsname;
6122 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6123 vmsname[retlen-1] == ':') {
6124 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6125 namdsc.dsc$w_length = strlen(fileified);
6126 namdsc.dsc$a_pointer = fileified;
6129 if (!usrdsc.dsc$w_length) {
6131 usrdsc.dsc$w_length = strlen(usrname);
6135 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6136 access = ARM$M_EXECUTE; break;
6137 case S_IRUSR: case S_IRGRP: case S_IROTH:
6138 access = ARM$M_READ; break;
6139 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6140 access = ARM$M_WRITE; break;
6141 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6142 access = ARM$M_DELETE; break;
6147 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
6148 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6149 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6150 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6151 set_vaxc_errno(retsts);
6152 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6153 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6154 else set_errno(ENOENT);
6157 if (retsts == SS$_NORMAL) {
6158 if (!privused) return TRUE;
6159 /* We can get access, but only by using privs. Do we have the
6160 necessary privs currently enabled? */
6161 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6162 if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
6163 if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv &&
6164 !curprv.prv$v_bypass) return FALSE;
6165 if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv &&
6166 !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
6167 if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
6170 if (retsts == SS$_ACCONFLICT) {
6175 return FALSE; /* Should never get here */
6177 } /* end of cando_by_name() */
6181 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6183 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6185 if (!fstat(fd,(stat_t *) statbufp)) {
6186 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6187 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6188 # ifdef RTL_USES_UTC
6191 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6192 statbufp->st_atime = _toloc(statbufp->st_atime);
6193 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6198 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6202 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6203 statbufp->st_atime = _toutc(statbufp->st_atime);
6204 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6211 } /* end of flex_fstat() */
6214 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6216 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6218 char fileified[NAM$C_MAXRSS+1];
6219 char temp_fspec[NAM$C_MAXRSS+300];
6222 strcpy(temp_fspec, fspec);
6223 if (statbufp == (Stat_t *) &PL_statcache)
6224 do_tovmsspec(temp_fspec,namecache,0);
6225 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6226 memset(statbufp,0,sizeof *statbufp);
6227 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6228 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6229 statbufp->st_uid = 0x00010001;
6230 statbufp->st_gid = 0x0001;
6231 time((time_t *)&statbufp->st_mtime);
6232 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6236 /* Try for a directory name first. If fspec contains a filename without
6237 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6238 * and sea:[wine.dark]water. exist, we prefer the directory here.
6239 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6240 * not sea:[wine.dark]., if the latter exists. If the intended target is
6241 * the file with null type, specify this by calling flex_stat() with
6242 * a '.' at the end of fspec.
6244 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6245 retval = stat(fileified,(stat_t *) statbufp);
6246 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6247 strcpy(namecache,fileified);
6249 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6251 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6252 # ifdef RTL_USES_UTC
6255 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6256 statbufp->st_atime = _toloc(statbufp->st_atime);
6257 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6262 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6266 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6267 statbufp->st_atime = _toutc(statbufp->st_atime);
6268 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6274 } /* end of flex_stat() */
6278 /*{{{char *my_getlogin()*/
6279 /* VMS cuserid == Unix getlogin, except calling sequence */
6283 static char user[L_cuserid];
6284 return cuserid(user);
6289 /* rmscopy - copy a file using VMS RMS routines
6291 * Copies contents and attributes of spec_in to spec_out, except owner
6292 * and protection information. Name and type of spec_in are used as
6293 * defaults for spec_out. The third parameter specifies whether rmscopy()
6294 * should try to propagate timestamps from the input file to the output file.
6295 * If it is less than 0, no timestamps are preserved. If it is 0, then
6296 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6297 * propagated to the output file at creation iff the output file specification
6298 * did not contain an explicit name or type, and the revision date is always
6299 * updated at the end of the copy operation. If it is greater than 0, then
6300 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6301 * other than the revision date should be propagated, and bit 1 indicates
6302 * that the revision date should be propagated.
6304 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6306 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6307 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6308 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6309 * as part of the Perl standard distribution under the terms of the
6310 * GNU General Public License or the Perl Artistic License. Copies
6311 * of each may be found in the Perl standard distribution.
6313 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6315 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6317 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6318 rsa[NAM$C_MAXRSS], ubf[32256];
6319 unsigned long int i, sts, sts2;
6320 struct FAB fab_in, fab_out;
6321 struct RAB rab_in, rab_out;
6323 struct XABDAT xabdat;
6324 struct XABFHC xabfhc;
6325 struct XABRDT xabrdt;
6326 struct XABSUM xabsum;
6328 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6329 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6330 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6334 fab_in = cc$rms_fab;
6335 fab_in.fab$l_fna = vmsin;
6336 fab_in.fab$b_fns = strlen(vmsin);
6337 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6338 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6339 fab_in.fab$l_fop = FAB$M_SQO;
6340 fab_in.fab$l_nam = &nam;
6341 fab_in.fab$l_xab = (void *) &xabdat;
6344 nam.nam$l_rsa = rsa;
6345 nam.nam$b_rss = sizeof(rsa);
6346 nam.nam$l_esa = esa;
6347 nam.nam$b_ess = sizeof (esa);
6348 nam.nam$b_esl = nam.nam$b_rsl = 0;
6350 xabdat = cc$rms_xabdat; /* To get creation date */
6351 xabdat.xab$l_nxt = (void *) &xabfhc;
6353 xabfhc = cc$rms_xabfhc; /* To get record length */
6354 xabfhc.xab$l_nxt = (void *) &xabsum;
6356 xabsum = cc$rms_xabsum; /* To get key and area information */
6358 if (!((sts = sys$open(&fab_in)) & 1)) {
6359 set_vaxc_errno(sts);
6361 case RMS$_FNF: case RMS$_DNF:
6362 set_errno(ENOENT); break;
6364 set_errno(ENOTDIR); break;
6366 set_errno(ENODEV); break;
6368 set_errno(EINVAL); break;
6370 set_errno(EACCES); break;
6378 fab_out.fab$w_ifi = 0;
6379 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6380 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6381 fab_out.fab$l_fop = FAB$M_SQO;
6382 fab_out.fab$l_fna = vmsout;
6383 fab_out.fab$b_fns = strlen(vmsout);
6384 fab_out.fab$l_dna = nam.nam$l_name;
6385 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6387 if (preserve_dates == 0) { /* Act like DCL COPY */
6388 nam.nam$b_nop = NAM$M_SYNCHK;
6389 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6390 if (!((sts = sys$parse(&fab_out)) & 1)) {
6391 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6392 set_vaxc_errno(sts);
6395 fab_out.fab$l_xab = (void *) &xabdat;
6396 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6398 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6399 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6400 preserve_dates =0; /* bitmask from this point forward */
6402 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6403 if (!((sts = sys$create(&fab_out)) & 1)) {
6404 set_vaxc_errno(sts);
6407 set_errno(ENOENT); break;
6409 set_errno(ENOTDIR); break;
6411 set_errno(ENODEV); break;
6413 set_errno(EINVAL); break;
6415 set_errno(EACCES); break;
6421 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6422 if (preserve_dates & 2) {
6423 /* sys$close() will process xabrdt, not xabdat */
6424 xabrdt = cc$rms_xabrdt;
6426 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6428 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6429 * is unsigned long[2], while DECC & VAXC use a struct */
6430 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6432 fab_out.fab$l_xab = (void *) &xabrdt;
6435 rab_in = cc$rms_rab;
6436 rab_in.rab$l_fab = &fab_in;
6437 rab_in.rab$l_rop = RAB$M_BIO;
6438 rab_in.rab$l_ubf = ubf;
6439 rab_in.rab$w_usz = sizeof ubf;
6440 if (!((sts = sys$connect(&rab_in)) & 1)) {
6441 sys$close(&fab_in); sys$close(&fab_out);
6442 set_errno(EVMSERR); set_vaxc_errno(sts);
6446 rab_out = cc$rms_rab;
6447 rab_out.rab$l_fab = &fab_out;
6448 rab_out.rab$l_rbf = ubf;
6449 if (!((sts = sys$connect(&rab_out)) & 1)) {
6450 sys$close(&fab_in); sys$close(&fab_out);
6451 set_errno(EVMSERR); set_vaxc_errno(sts);
6455 while ((sts = sys$read(&rab_in))) { /* always true */
6456 if (sts == RMS$_EOF) break;
6457 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6458 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6459 sys$close(&fab_in); sys$close(&fab_out);
6460 set_errno(EVMSERR); set_vaxc_errno(sts);
6465 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6466 sys$close(&fab_in); sys$close(&fab_out);
6467 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6469 set_errno(EVMSERR); set_vaxc_errno(sts);
6475 } /* end of rmscopy() */
6479 /*** The following glue provides 'hooks' to make some of the routines
6480 * from this file available from Perl. These routines are sufficiently
6481 * basic, and are required sufficiently early in the build process,
6482 * that's it's nice to have them available to miniperl as well as the
6483 * full Perl, so they're set up here instead of in an extension. The
6484 * Perl code which handles importation of these names into a given
6485 * package lives in [.VMS]Filespec.pm in @INC.
6489 rmsexpand_fromperl(pTHX_ CV *cv)
6492 char *fspec, *defspec = NULL, *rslt;
6495 if (!items || items > 2)
6496 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6497 fspec = SvPV(ST(0),n_a);
6498 if (!fspec || !*fspec) XSRETURN_UNDEF;
6499 if (items == 2) defspec = SvPV(ST(1),n_a);
6501 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6502 ST(0) = sv_newmortal();
6503 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6508 vmsify_fromperl(pTHX_ CV *cv)
6514 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6515 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6516 ST(0) = sv_newmortal();
6517 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
6522 unixify_fromperl(pTHX_ CV *cv)
6528 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
6529 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
6530 ST(0) = sv_newmortal();
6531 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
6536 fileify_fromperl(pTHX_ CV *cv)
6542 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
6543 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
6544 ST(0) = sv_newmortal();
6545 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
6550 pathify_fromperl(pTHX_ CV *cv)
6556 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
6557 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
6558 ST(0) = sv_newmortal();
6559 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
6564 vmspath_fromperl(pTHX_ CV *cv)
6570 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
6571 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
6572 ST(0) = sv_newmortal();
6573 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
6578 unixpath_fromperl(pTHX_ CV *cv)
6584 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
6585 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
6586 ST(0) = sv_newmortal();
6587 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
6592 candelete_fromperl(pTHX_ CV *cv)
6595 char fspec[NAM$C_MAXRSS+1], *fsp;
6600 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
6602 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6603 if (SvTYPE(mysv) == SVt_PVGV) {
6604 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
6605 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6612 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
6613 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6619 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
6624 rmscopy_fromperl(pTHX_ CV *cv)
6627 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
6629 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6630 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6631 unsigned long int sts;
6636 if (items < 2 || items > 3)
6637 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
6639 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
6640 if (SvTYPE(mysv) == SVt_PVGV) {
6641 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
6642 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6649 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
6650 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6655 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
6656 if (SvTYPE(mysv) == SVt_PVGV) {
6657 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
6658 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6665 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
6666 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6671 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
6673 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
6679 mod2fname(pTHX_ CV *cv)
6682 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
6683 workbuff[NAM$C_MAXRSS*1 + 1];
6684 int total_namelen = 3, counter, num_entries;
6685 /* ODS-5 ups this, but we want to be consistent, so... */
6686 int max_name_len = 39;
6687 AV *in_array = (AV *)SvRV(ST(0));
6689 num_entries = av_len(in_array);
6691 /* All the names start with PL_. */
6692 strcpy(ultimate_name, "PL_");
6694 /* Clean up our working buffer */
6695 Zero(work_name, sizeof(work_name), char);
6697 /* Run through the entries and build up a working name */
6698 for(counter = 0; counter <= num_entries; counter++) {
6699 /* If it's not the first name then tack on a __ */
6701 strcat(work_name, "__");
6703 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
6707 /* Check to see if we actually have to bother...*/
6708 if (strlen(work_name) + 3 <= max_name_len) {
6709 strcat(ultimate_name, work_name);
6711 /* It's too darned big, so we need to go strip. We use the same */
6712 /* algorithm as xsubpp does. First, strip out doubled __ */
6713 char *source, *dest, last;
6716 for (source = work_name; *source; source++) {
6717 if (last == *source && last == '_') {
6723 /* Go put it back */
6724 strcpy(work_name, workbuff);
6725 /* Is it still too big? */
6726 if (strlen(work_name) + 3 > max_name_len) {
6727 /* Strip duplicate letters */
6730 for (source = work_name; *source; source++) {
6731 if (last == toupper(*source)) {
6735 last = toupper(*source);
6737 strcpy(work_name, workbuff);
6740 /* Is it *still* too big? */
6741 if (strlen(work_name) + 3 > max_name_len) {
6742 /* Too bad, we truncate */
6743 work_name[max_name_len - 2] = 0;
6745 strcat(ultimate_name, work_name);
6748 /* Okay, return it */
6749 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
6757 char* file = __FILE__;
6758 char temp_buff[512];
6759 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
6760 no_translate_barewords = TRUE;
6762 no_translate_barewords = FALSE;
6765 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
6766 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
6767 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
6768 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
6769 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
6770 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
6771 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
6772 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
6773 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
6774 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
6776 store_pipelocs(aTHX);